[Rt-commit] r3833 - in HTTP-Server-Simple: . lib/HTTP/Server lib/HTTP/Server/Simple lib/HTTP/Server/Simple/CGI

jesse at bestpractical.com jesse at bestpractical.com
Mon Sep 5 14:11:26 EDT 2005


Author: jesse
Date: Mon Sep  5 14:11:26 2005
New Revision: 3833

Modified:
   HTTP-Server-Simple/   (props changed)
   HTTP-Server-Simple/lib/HTTP/Server/Simple.pm
   HTTP-Server-Simple/lib/HTTP/Server/Simple/CGI.pm
   HTTP-Server-Simple/lib/HTTP/Server/Simple/CGI/Environment.pm
Log:
 r15372 at hualien:  jesse | 2005-09-04 17:52:12 -0400
 * Reformat all the code to break submitted patches


Modified: HTTP-Server-Simple/lib/HTTP/Server/Simple.pm
==============================================================================
--- HTTP-Server-Simple/lib/HTTP/Server/Simple.pm	(original)
+++ HTTP-Server-Simple/lib/HTTP/Server/Simple.pm	Mon Sep  5 14:11:26 2005
@@ -60,39 +60,38 @@
 
 # Handle SIGHUP
 
-                             
-                             
-local $SIG{CHLD} = 'IGNORE'; # reap child processes
+local $SIG{CHLD} = 'IGNORE';    # reap child processes
 local $SIG{HUP} = sub {
     close HTTPDaemon;
+
     # and then, on systems implementing fork(), we make sure
     # we are running with a new pid, so another -HUP will still
     # work on the new process.
     require Config;
-    if ($Config::Config{d_fork} and my $pid = fork()) {
+    if ( $Config::Config{d_fork} and my $pid = fork() ) {
+
         # finally, allow ^C on the parent process to terminate
         # the children.
-        waitpid($pid, 0); exit;
+        waitpid( $pid, 0 );
+        exit;
     }
 
     # do the exec. if $0 is not executable, try running it with $^X.
-    exec { $0 } ( ((-x $0) ? () : ($^X)), $0, @ARGV );
+    exec {$0}( ( ( -x $0 ) ? () : ($^X) ), $0, @ARGV );
 };
 
-
-
 sub new {
-    my ($proto,$port) = @_;
+    my ( $proto, $port ) = @_;
     my $class = ref($proto) || $proto;
 
     if ( $class eq __PACKAGE__ ) {
-	require HTTP::Server::Simple::CGI;
-	return HTTP::Server::Simple::CGI->new(@_[1..$#_]);
+        require HTTP::Server::Simple::CGI;
+        return HTTP::Server::Simple::CGI->new( @_[ 1 .. $#_ ] );
     }
 
-    my $self  = {};
+    my $self = {};
     bless( $self, $class );
-    $self->port( $port || '8080');
+    $self->port( $port || '8080' );
     return $self;
 }
 
@@ -142,12 +141,11 @@
 
     if ( $^O !~ /MSWin32/ ) {
         POSIX::setsid()
-          or die "Can't start a new session: $!";
+            or die "Can't start a new session: $!";
     }
     $self->run();
 }
 
-
 =head2 run
 
 Run the server.  If all goes well, this won't ever return, but it will
@@ -156,20 +154,21 @@
 =cut
 
 my $server_class_id = 0;
+
 sub run {
-    my $self    = shift;
-    my $server  = $self->net_server;
+    my $self   = shift;
+    my $server = $self->net_server;
 
     # $pkg is generated anew for each invocation to "run"
     # Just so we can use different net_server() implementations
     # in different runs.
-    my $pkg     = join '::', ref($self), "NetServer".$server_class_id++;
+    my $pkg = join '::', ref($self), "NetServer" . $server_class_id++;
 
     no strict 'refs';
     *{"$pkg\::process_request"} = $self->_process_request;
 
     if ($server) {
-        require join('/', split /::/, $server).'.pm';
+        require join( '/', split /::/, $server ) . '.pm';
         *{"$pkg\::ISA"} = [$server];
         $self->print_banner;
     }
@@ -178,7 +177,7 @@
         *{"$pkg\::run"} = $self->_default_run;
     }
 
-    $pkg->run(port => $self->port);
+    $pkg->run( port => $self->port );
 }
 
 =head2 net_server
@@ -189,34 +188,34 @@
 
 =cut
 
-sub net_server { undef }
+sub net_server {undef}
 
 sub _default_run {
     my $self = shift;
 
     # Default "run" closure method for a stub, minimal Net::Server instance.
-    sub {
+    return sub {
         my $pkg = shift;
 
         $self->print_banner;
 
         while (1) {
-            local $SIG{PIPE} = 'IGNORE'; # If we don't ignore SIGPIPE, a 
-                                      # client closing the connection before we 
-                                      # finish sending will cause the server to exit
-            while ( accept( my $remote, HTTPDaemon )) {
+            local $SIG{PIPE} = 'IGNORE';    # If we don't ignore SIGPIPE, a
+                 # client closing the connection before we
+                 # finish sending will cause the server to exit
+            while ( accept( my $remote, HTTPDaemon ) ) {
                 $self->stdio_handle($remote);
                 $self->accept_hook if $self->can("accept_hook");
 
                 *STDIN  = $self->stdin_handle();
                 *STDOUT = $self->stdout_handle();
-		select STDOUT; # required for HTTP::Server::Simple::Recorder
-                               # XXX TODO glasser: why?
+                select STDOUT;   # required for HTTP::Server::Simple::Recorder
+                                 # XXX TODO glasser: why?
                 $pkg->process_request;
                 close $remote;
             }
-        }    
-    }
+        }
+    };
 }
 
 sub _process_request {
@@ -228,31 +227,30 @@
 
         $self->stdio_handle(*STDIN) unless $self->stdio_handle;
 
-        # Default to unencoded, raw data out.
-        # if you're sending utf8 and latin1 data mixed, you may need to override this
-        binmode STDIN, ':raw';
+ # Default to unencoded, raw data out.
+ # if you're sending utf8 and latin1 data mixed, you may need to override this
+        binmode STDIN,  ':raw';
         binmode STDOUT, ':raw';
 
-        my $remote_sockaddr = getpeername($self->stdio_handle);
+        my $remote_sockaddr = getpeername( $self->stdio_handle );
         my ( undef, $iaddr ) = sockaddr_in($remote_sockaddr);
         my $peername = gethostbyaddr( $iaddr, AF_INET ) || "localhost";
 
         my $peeraddr = inet_ntoa($iaddr) || "127.0.0.1";
 
-        my $local_sockaddr = getsockname($self->stdio_handle);
+        my $local_sockaddr = getsockname( $self->stdio_handle );
         my ( undef, $localiaddr ) = sockaddr_in($local_sockaddr);
         my $localname = gethostbyaddr( $localiaddr, AF_INET )
             || "localhost";
         my $localaddr = inet_ntoa($localiaddr) || "127.0.0.1";
 
-        my ( $method, $request_uri, $proto ) =
-            $self->parse_request
-                or do {$self->bad_request; return};
+        my ( $method, $request_uri, $proto ) = $self->parse_request
+            or do { $self->bad_request; return };
 
         $proto ||= "HTTP/0.9";
 
-        my ( $file, $query_string ) =
-            ( $request_uri =~ /([^?]*)(?:\?(.*))?/ );    # split at ?
+        my ( $file, $query_string )
+            = ( $request_uri =~ /([^?]*)(?:\?(.*))?/ );    # split at ?
 
         if ( $method !~ /^(?:GET|POST|HEAD)$/ ) {
             $self->bad_request;
@@ -275,20 +273,18 @@
         if ( $proto =~ m{HTTP/(\d(\.\d)?)$} and $1 >= 1 ) {
 
             my $headers = $self->parse_headers
-                or do{$self->bad_request; return};
+                or do { $self->bad_request; return };
 
-            $self->headers( $headers) ;
+            $self->headers($headers);
 
         }
 
         $self->post_setup_hook if $self->can("post_setup_hook");
 
-
         $self->handler;
-    }
+        }
 }
 
-
 =head2 stdio_handle [FILEHANDLE]
 
 When called with an argument, sets the socket to the server to that arg.
@@ -317,7 +313,7 @@
 sub stdin_handle {
     my $self = shift;
     return $self->stdio_handle;
-} 
+}
 
 =head2 stdout_handle
 
@@ -330,8 +326,7 @@
 sub stdout_handle {
     my $self = shift;
     return $self->stdio_handle;
-} 
-
+}
 
 =head1 IMPORTANT SUB-CLASS METHODS
 
@@ -347,11 +342,12 @@
 =cut
 
 sub handler {
-    my ( $self ) = @_;
-    if ( ref ($self) ne __PACKAGE__ ) {
-	croak "do not call ".ref($self)."::SUPER->handler";
-    } else {
-	die "handler called out of context";
+    my ($self) = @_;
+    if ( ref($self) ne __PACKAGE__ ) {
+        croak "do not call " . ref($self) . "::SUPER->handler";
+    }
+    else {
+        die "handler called out of context";
     }
 }
 
@@ -378,9 +374,9 @@
 =cut
 
 sub setup {
-    my ( $self ) = @_;
-    while ( my ($item, $value) = splice @_, 0, 2 ) {
-	$self->$item($value) if $self->can($item);
+    my ($self) = @_;
+    while ( my ( $item, $value ) = splice @_, 0, 2 ) {
+        $self->$item($value) if $self->can($item);
     }
 }
 
@@ -412,14 +408,14 @@
 =cut
 
 sub headers {
-    my $self = shift;
+    my $self    = shift;
     my $headers = shift;
 
     my $can_header = $self->can("header");
-    while ( my ($header, $value) = splice @$headers, 0, 2 ) {
-	if ( $can_header ) {
-	    $self->header($header => $value)
-	}
+    while ( my ( $header, $value ) = splice @$headers, 0, 2 ) {
+        if ($can_header) {
+            $self->header( $header => $value );
+        }
     }
 }
 
@@ -446,9 +442,11 @@
 sub print_banner {
     my $self = shift;
 
-    print(  __PACKAGE__.": You can connect to your server at "
-	    ."http://localhost:" . $self->port
-          . "/\n" );
+    print(    __PACKAGE__
+            . ": You can connect to your server at "
+            . "http://localhost:"
+            . $self->port
+            . "/\n" );
 
 }
 
@@ -473,11 +471,11 @@
     $_ = $chunk;
 
     m/^(\w+)\s+(\S+)(?:\s+(\S+))?\r?$/;
-    my $method = $1 || '';
-    my $uri = $2 || '';
+    my $method   = $1 || '';
+    my $uri      = $2 || '';
     my $protocol = $3 || '';
 
-    return($method, $uri, $protocol);
+    return ( $method, $uri, $protocol );
 }
 
 =head2 parse_headers
@@ -510,10 +508,9 @@
         else { $chunk .= $buff }
     }
 
-    return(\@headers);
+    return ( \@headers );
 }
 
-
 =head2 setup_listener
 
 This routine binds the server to a port and interface.
@@ -527,18 +524,17 @@
 
     socket( HTTPDaemon, PF_INET, SOCK_STREAM, $tcp ) or die "socket: $!";
     setsockopt( HTTPDaemon, SOL_SOCKET, SO_REUSEADDR, pack( "l", 1 ) )
-      or warn "setsockopt: $!";
+        or warn "setsockopt: $!";
     bind( HTTPDaemon,
         sockaddr_in(
             $self->port(),
-            (
-                $self->host
+            (   $self->host
                 ? inet_aton( $self->host )
                 : INADDR_ANY
             )
         )
-      )
-      or die "bind: $!";
+        )
+        or die "bind: $!";
     listen( HTTPDaemon, SOMAXCONN ) or die "listen: $!";
 
 }
@@ -557,7 +553,7 @@
 
     print "HTTP/1.0 400 Bad request\r\n";    # probably OK by now
     print "Content-Type: text/html\r\nContent-Length: ",
-	length($bad_request_doc), "\r\n\r\n", $bad_request_doc;
+        length($bad_request_doc), "\r\n\r\n", $bad_request_doc;
 }
 
 =head1 AUTHOR

Modified: HTTP-Server-Simple/lib/HTTP/Server/Simple/CGI.pm
==============================================================================
--- HTTP-Server-Simple/lib/HTTP/Server/Simple/CGI.pm	(original)
+++ HTTP-Server-Simple/lib/HTTP/Server/Simple/CGI.pm	Mon Sep  5 14:11:26 2005
@@ -58,7 +58,6 @@
     $self->setup_environment_from_metadata(@_);
 }
 
-
 =head2 handle_request CGI
 
 This routine is called whenever your server gets a request it can
@@ -71,14 +70,14 @@
 =cut
 
 our $default_doc;
-$default_doc = (join "", <DATA>);
+$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;
+    print "Content-Type: text/html\r\nContent-Length: ", length($default_doc),
+        "\r\n\r\n", $default_doc;
 }
 
 =head2 handler
@@ -89,15 +88,14 @@
 
 sub handler {
     my $self = shift;
-    my $cgi = new CGI();
-    eval {$self->handle_request($cgi) };
-    if ($@) { 
+    my $cgi  = new CGI();
+    eval { $self->handle_request($cgi) };
+    if ($@) {
         my $error = $@;
         warn $error;
     }
 }
 
-
 1;
 
 __DATA__

Modified: HTTP-Server-Simple/lib/HTTP/Server/Simple/CGI/Environment.pm
==============================================================================
--- HTTP-Server-Simple/lib/HTTP/Server/Simple/CGI/Environment.pm	(original)
+++ HTTP-Server-Simple/lib/HTTP/Server/Simple/CGI/Environment.pm	Mon Sep  5 14:11:26 2005
@@ -6,7 +6,7 @@
 
 our $VERSION = $HTTP::Server::Simple::VERSION;
 
-my %clean_env=%ENV;
+my %clean_env = %ENV;
 
 =head1 NAME
 
@@ -28,10 +28,11 @@
 =cut
 
 sub setup_environment {
-    %ENV= ( %clean_env,
-	    SERVER_SOFTWARE => "HTTP::Server::Simple/$VERSION",
-            GATEWAY_INTERFACE => 'CGI/1.1'
-	  );
+    %ENV = (
+        %clean_env,
+        SERVER_SOFTWARE   => "HTTP::Server::Simple/$VERSION",
+        GATEWAY_INTERFACE => 'CGI/1.1'
+    );
 }
 
 =head2 setup_server_url
@@ -40,8 +41,9 @@
 
 =cut
 
-sub setup_server_url  {
-    $ENV{SERVER_URL} ||= ("http://".$ENV{SERVER_NAME}.":".$ENV{SERVER_PORT}."/");
+sub setup_server_url {
+    $ENV{SERVER_URL}
+        ||= ( "http://" . $ENV{SERVER_NAME} . ":" . $ENV{SERVER_PORT} . "/" );
 }
 
 =head2 setup_environment_from_metadata
@@ -53,17 +55,17 @@
 
 =cut
 
-our %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",
-      query_string => "QUERY_STRING",
-    );
+our %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",
+    query_string => "QUERY_STRING",
+);
 
 sub setup_environment_from_metadata {
     no warnings 'uninitialized';
@@ -72,10 +74,10 @@
     # XXX TODO: rather than clone functionality from the base class,
     # we should call super
     #
-    while ( my ($item, $value) = splice @_, 0, 2 ) {
+    while ( my ( $item, $value ) = splice @_, 0, 2 ) {
         if ( my $k = $ENV_MAPPING{$item} ) {
-	    $ENV{$k} = $value;
-	}
+            $ENV{$k} = $value;
+        }
     }
 
 }
@@ -87,22 +89,22 @@
 =cut
 
 sub header {
-    my $self = shift;
-    my $tag = shift;
+    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)|COOKIE)$/;
-
-	if ( exists $ENV{$tag} ) {
-	    $ENV{$tag} .= "; $value";
-	} else {
-	    $ENV{$tag} = $value;
-	}
-}
+    $tag = uc($tag);
+    $tag =~ s/^COOKIES$/COOKIE/;
+    $tag =~ s/-/_/g;
+    $tag = "HTTP_" . $tag
+        unless $tag =~ m/^(?:CONTENT_(?:LENGTH|TYPE)|COOKIE)$/;
 
+    if ( exists $ENV{$tag} ) {
+        $ENV{$tag} .= "; $value";
+    }
+    else {
+        $ENV{$tag} = $value;
+    }
+}
 
 1;


More information about the Rt-commit mailing list