[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