HTTP-Server-Simple-0.50HEAD HTTP-Server-Simple-0.50 master

author: Lorry Tar Creator <lorry-tar-importer@lorry> 2015-02-02 15:36:39 +0000
committer: Lorry Tar Creator <lorry-tar-importer@lorry> 2015-02-02 15:36:39 +0000
commit: e2d680ac7c6f0bb36808aa45e1453c8b585d2717 (patch)
tree: 97944a18c68e27f1472b7c2221ead889b13de107 /lib/HTTP/Server/Simple
download: HTTP-Server-Simple-tarball-master.tar.gz
2 files changed, 293 insertions, 0 deletions
diff --git a/lib/HTTP/Server/Simple/CGI.pm b/lib/HTTP/Server/Simple/CGI.pm
new file mode 100644
index 0000000..b11fc12
--- /dev/null
+++ b/lib/HTTP/Server/Simple/CGI.pm
@@ -0,0 +1,178 @@
+
+package HTTP::Server::Simple::CGI;
+
+use base qw(HTTP::Server::Simple HTTP::Server::Simple::CGI::Environment);
+use strict;
+use warnings;
+
+use vars qw($default_doc $DEFAULT_CGI_INIT $DEFAULT_CGI_CLASS);
+
+$DEFAULT_CGI_CLASS = "CGI";
+$DEFAULT_CGI_INIT = sub { require CGI; CGI::initialize_globals()};
+
+
+=head1 NAME
+
+HTTP::Server::Simple::CGI - CGI.pm-style version of HTTP::Server::Simple
+
+=head1 DESCRIPTION
+
+HTTP::Server::Simple was already simple, but some smart-ass pointed
+out that there is no CGI in HTTP, and so this module was born to
+isolate the CGI.pm-related parts of this handler.
+
+
+=head2 accept_hook
+
+The accept_hook in this sub-class clears the environment to the
+start-up state.
+
+=cut
+
+sub accept_hook {
+    my $self = shift;
+    $self->setup_environment(@_);
+}
+
+=head2 post_setup_hook
+
+Initializes the global L<CGI> object, as well as other environment
+settings.
+
+=cut
+
+sub post_setup_hook {
+    my $self = shift;
+    $self->setup_server_url;
+    if ( my $init = $self->cgi_init ) {
+        $init->();
+    }
+}
+
+=head2 cgi_class [Classname]
+
+Gets or sets the class to use for creating the C<$cgi> object passed to
+C<handle_request>.
+
+Called with a single argument, it sets the coderef. Called with no arguments, 
+it returns this field's current value.
+
+To provide an initialization subroutine to be run in the post_setup_hook, 
+see L</cgi_init>.
+
+e.g.
+
+    $server->cgi_class('CGI');
+
+    $server->cgi_init(sub {
+        require CGI;
+        CGI::initialize_globals();
+    });
+
+or, if you want to use L<CGI::Simple>,
+
+    $server->cgi_class('CGI::Simple');
+    $server->cgi_init(sub {
+        require CGI::Simple;
+    });
+
+=cut
+
+sub cgi_class {
+    my $self = shift;
+    if (@_) {
+        $self->{cgi_class} = shift;
+    }
+    return $self->{cgi_class} || $DEFAULT_CGI_CLASS;
+}
+
+=head2 cgi_init [CODEREF]
+
+A coderef to run in the post_setup_hook.
+
+Called with a single argument, it sets the coderef. Called with no arguments, 
+it returns this field's current value.
+
+=cut
+
+sub cgi_init {
+    my $self = shift;
+    if (@_) {
+        $self->{cgi_init} = shift;
+    }
+    return $self->{cgi_init} || $DEFAULT_CGI_INIT;
+    
+}
+
+
+=head2 setup
+
+This method sets up CGI environment variables based on various
+meta-headers, like the protocol, remote host name, request path, etc.
+
+See the docs in L<HTTP::Server::Simple> for more detail.
+
+=cut
+
+sub setup {
+    my $self = shift;
+    $self->setup_environment_from_metadata(@_);
+}
+
+=head2 handle_request CGI
+
+This routine is called whenever your server gets a request it can
+handle.
+
+It's called with a CGI object that's been pre-initialized.
+You want to override this method in your subclass
+
+
+=cut
+
+$default_doc = ( join "", <DATA> );
+
+sub handle_request {
+    my ( $self, $cgi ) = @_;
+
+    print "HTTP/1.0 200 OK\r\n";    # probably OK by now
+    print "Content-Type: text/html\r\nContent-Length: ", length($default_doc),
+        "\r\n\r\n", $default_doc;
+}
+
+=head2 handler
+
+Handler implemented as part of HTTP::Server::Simple API
+
+=cut
+
+sub handler {
+    my $self = shift;
+    my $cgi;
+    $cgi = $self->cgi_class->new;
+    eval { $self->handle_request($cgi) };
+    if ($@) {
+        my $error = $@;
+        warn $error;
+    }
+}
+
+1;
+
+__DATA__
+<html>
+  <head>
+    <title>Hello!</title>
+  </head>
+  <body>
+    <h1>Congratulations!</h1>
+
+    <p>You now have a functional HTTP::Server::Simple::CGI running.
+      </p>
+
+    <p><i>(If you're seeing this page, it means you haven't subclassed
+      HTTP::Server::Simple::CGI, which you'll need to do to make it
+      useful.)</i>
+      </p>
+  </body>
+</html>
diff --git a/lib/HTTP/Server/Simple/CGI/Environment.pm b/lib/HTTP/Server/Simple/CGI/Environment.pm
new file mode 100644
index 0000000..4b2c895
--- /dev/null
+++ b/lib/HTTP/Server/Simple/CGI/Environment.pm
@@ -0,0 +1,115 @@
+
+package HTTP::Server::Simple::CGI::Environment;
+
+use strict;
+use warnings;
+use HTTP::Server::Simple;
+
+use vars qw(%ENV_MAPPING);
+
+my %clean_env = %ENV;
+
+=head1 NAME
+
+HTTP::Server::Simple::CGI::Environment - a HTTP::Server::Simple mixin to provide the CGI protocol
+
+=head1 DESCRIPTION
+
+This mixin abstracts the CGI protocol out from
+L<HTTP::Server::Simple::CGI> so that it's easier to provide your own
+CGI handlers with L<HTTP::Server::Simple> which B<don't> use CGI.pm
+
+=head2 setup_environment
+
+C<setup_environemnt> is usually called in the superclass's accept_hook
+
+This routine in this sub-class clears the environment to the
+start-up state.
+
+=cut
+
+sub setup_environment {
+    %ENV = (
+        %clean_env,
+        SERVER_SOFTWARE   => "HTTP::Server::Simple/$HTTP::Server::Simple::VERSION",
+        GATEWAY_INTERFACE => 'CGI/1.1'
+    );
+}
+
+=head2 setup_server_url
+
+Sets up the C<SERVER_URL> environment variable
+
+=cut
+
+sub setup_server_url {
+    $ENV{SERVER_URL}
+        ||= ( "http://" . ($ENV{SERVER_NAME} || 'localhost') . ":" . ( $ENV{SERVER_PORT}||80) . "/" );
+}
+
+=head2 setup_environment_from_metadata
+
+This method sets up CGI environment variables based on various
+meta-headers, like the protocol, remote host name, request path, etc.
+
+See the docs in L<HTTP::Server::Simple> for more detail.
+
+=cut
+
+%ENV_MAPPING = (
+    protocol     => "SERVER_PROTOCOL",
+    localport    => "SERVER_PORT",
+    localname    => "SERVER_NAME",
+    path         => "PATH_INFO",
+    request_uri  => "REQUEST_URI",
+    method       => "REQUEST_METHOD",
+    peeraddr     => "REMOTE_ADDR",
+    peername     => "REMOTE_HOST",
+    peerport     => "REMOTE_PORT",
+    query_string => "QUERY_STRING",
+);
+
+sub setup_environment_from_metadata {
+    no warnings 'uninitialized';
+    my $self = shift;
+
+    # XXX TODO: rather than clone functionality from the base class,
+    # we should call super
+    #
+    while ( my ( $item, $value ) = splice @_, 0, 2 ) {
+        if ( my $k = $ENV_MAPPING{$item} ) {
+            $ENV{$k} = $value;
+        }
+    }
+
+    # Apache and lighttpd both do one layer of unescaping on
+    # path_info; we should duplicate that.
+    $ENV{PATH_INFO} =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
+}
+
+=head2  header
+
+C<header> turns a single HTTP headers into CGI environment variables.
+
+=cut
+
+sub header {
+    my $self  = shift;
+    my $tag   = shift;
+    my $value = shift;
+
+    $tag = uc($tag);
+    $tag =~ s/^COOKIES$/COOKIE/;
+    $tag =~ s/-/_/g;
+    $tag = "HTTP_" . $tag
+        unless $tag =~ m/^CONTENT_(?:LENGTH|TYPE)$/;
+
+    if ( exists $ENV{$tag} ) {
+        $ENV{$tag} .= ", $value";
+    }
+    else {
+        $ENV{$tag} = $value;
+    }
+}
+
+1;
author	Lorry Tar Creator <lorry-tar-importer@lorry>	2015-02-02 15:36:39 +0000
committer	Lorry Tar Creator <lorry-tar-importer@lorry>	2015-02-02 15:36:39 +0000
commit	e2d680ac7c6f0bb36808aa45e1453c8b585d2717 (patch)
tree	97944a18c68e27f1472b7c2221ead889b13de107 /lib/HTTP/Server/Simple
download	HTTP-Server-Simple-tarball-master.tar.gz