From: Guillermo Roditi Date: Mon, 23 Jun 2008 21:17:23 +0000 (+0000) Subject: converting the engines. i had to add use NEXT to some of the test files to make it... X-Git-Tag: 5.8000_03~108 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FCatalyst-Runtime.git;a=commitdiff_plain;h=7fa2c9c1b85c98786655ad5169708d8dc84e8353 converting the engines. i had to add use NEXT to some of the test files to make it work. hope thats not a bad thing r17077@martha (orig r7534): groditi | 2008-03-29 20:51:46 -0400 --- diff --git a/lib/Catalyst.pm b/lib/Catalyst.pm index b9d43a5..7c151db 100644 --- a/lib/Catalyst.pm +++ b/lib/Catalyst.pm @@ -13,7 +13,6 @@ use Catalyst::Controller; use Devel::InnerPackage (); use File::stat; use Module::Pluggable::Object (); -use NEXT; use Text::SimpleTable (); use Path::Class::Dir (); use Path::Class::File (); diff --git a/lib/Catalyst/Engine.pm b/lib/Catalyst/Engine.pm index 6935c37..1f22735 100644 --- a/lib/Catalyst/Engine.pm +++ b/lib/Catalyst/Engine.pm @@ -1,7 +1,8 @@ package Catalyst::Engine; -use strict; -use base 'Class::Accessor::Fast'; +use Moose; +with 'MooseX::Emulate::Class::Accessor::Fast'; + use CGI::Simple::Cookie; use Data::Dump qw/dump/; use Errno 'EWOULDBLOCK'; @@ -12,7 +13,8 @@ use URI::QueryParam; use Scalar::Util (); # input position and length -__PACKAGE__->mk_accessors(qw/read_position read_length/); +has read_length => (is => 'rw'); +has read_position => (is => 'rw'); # Stringify to class use overload '""' => sub { return ref shift }, fallback => 1; @@ -66,10 +68,9 @@ sub finalize_cookies { my ( $self, $c ) = @_; my @cookies; + my $response = $c->response; - foreach my $name ( keys %{ $c->response->cookies } ) { - - my $val = $c->response->cookies->{$name}; + while( my($name, $val) = each %{ $response->cookies } ) { my $cookie = ( Scalar::Util::blessed($val) @@ -88,7 +89,7 @@ sub finalize_cookies { } for my $cookie (@cookies) { - $c->res->headers->push_header( 'Set-Cookie' => $cookie ); + $response->headers->push_header( 'Set-Cookie' => $cookie ); } } @@ -242,7 +243,7 @@ EOF } /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */ /* Browser specific (not valid) styles to make preformatted text wrap */ - pre { + pre { white-space: pre-wrap; /* css-3 */ white-space: -moz-pre-wrap; /* Mozilla, since 1999 */ white-space: -pre-wrap; /* Opera 4-6 */ @@ -291,14 +292,12 @@ Clean up after uploads, deleting temp files. sub finalize_uploads { my ( $self, $c ) = @_; - if ( keys %{ $c->request->uploads } ) { - for my $key ( keys %{ $c->request->uploads } ) { - my $upload = $c->request->uploads->{$key}; - unlink map { $_->tempname } - grep { -e $_->tempname } - ref $upload eq 'ARRAY' ? @{$upload} : ($upload); - } + my $request = $c->request; + while( my($key,$upload) = each %{ $request->uploads } ) { + unlink grep { -e $_ } map { $_->tempname } + (ref $upload eq 'ARRAY' ? @{$upload} : ($upload)); } + } =head2 $self->prepare_body($c) @@ -311,13 +310,14 @@ sub prepare_body { my ( $self, $c ) = @_; if ( my $length = $self->read_length ) { - unless ( $c->request->{_body} ) { - my $type = $c->request->header('Content-Type'); - $c->request->{_body} = HTTP::Body->new( $type, $length ); - $c->request->{_body}->{tmpdir} = $c->config->{uploadtmp} + my $request = $c->request; + unless ( $request->{_body} ) { + my $type = $request->header('Content-Type'); + $request->{_body} = HTTP::Body->new( $type, $length ); + $request->{_body}->{tmpdir} = $c->config->{uploadtmp} if exists $c->config->{uploadtmp}; } - + while ( my $buffer = $self->read($c) ) { $c->prepare_body_chunk($buffer); } @@ -350,15 +350,15 @@ sub prepare_body_chunk { =head2 $self->prepare_body_parameters($c) -Sets up parameters from body. +Sets up parameters from body. =cut sub prepare_body_parameters { my ( $self, $c ) = @_; - + return unless $c->request->{_body}; - + $c->request->body_parameters( $c->request->{_body}->param ); } @@ -399,25 +399,22 @@ sets up parameters from query and post parameters. sub prepare_parameters { my ( $self, $c ) = @_; + my $request = $c->request; + my $parameters = $request->parameters; + my $body_parameters = $request->body_parameters; + my $query_parameters = $request->query_parameters; # We copy, no references - foreach my $name ( keys %{ $c->request->query_parameters } ) { - my $param = $c->request->query_parameters->{$name}; - $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param; - $c->request->parameters->{$name} = $param; + while( my($name, $param) = each(%$query_parameters) ) { + $parameters->{$name} = ref $param eq 'ARRAY' ? [ @$param ] : $param; } # Merge query and body parameters - foreach my $name ( keys %{ $c->request->body_parameters } ) { - my $param = $c->request->body_parameters->{$name}; - $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param; - if ( my $old_param = $c->request->parameters->{$name} ) { - if ( ref $old_param eq 'ARRAY' ) { - push @{ $c->request->parameters->{$name} }, - ref $param eq 'ARRAY' ? @$param : $param; - } - else { $c->request->parameters->{$name} = [ $old_param, $param ] } + while( my($name, $param) = each(%$body_parameters) ) { + my @values = ref $param eq 'ARRAY' ? @$param : ($param); + if ( my $existing = $parameters->{$name} ) { + unshift(@values, (ref $existing eq 'ARRAY' ? @$existing : $existing)); } - else { $c->request->parameters->{$name} = $param } + $parameters->{$name} = @values > 1 ? \@values : $values[0]; } } @@ -439,7 +436,7 @@ process the query string and extract query parameters. sub prepare_query_parameters { my ( $self, $c, $query_string ) = @_; - + # Check for keywords (no = signs) # (yes, index() is faster than a regex :)) if ( index( $query_string, '=' ) < 0 ) { @@ -451,17 +448,17 @@ sub prepare_query_parameters { # replace semi-colons $query_string =~ s/;/&/g; - + my @params = split /&/, $query_string; for my $item ( @params ) { - - my ($param, $value) + + my ($param, $value) = map { $self->unescape_uri($_) } split( /=/, $item, 2 ); - + $param = $self->unescape_uri($item) unless defined $param; - + if ( exists $query{$param} ) { if ( ref $query{$param} ) { push @{ $query{$param} }, $value; @@ -489,7 +486,7 @@ sub prepare_read { # Initialize the read position $self->read_position(0); - + # Initialize the amount of data we think we need to read $self->read_length( $c->request->header('Content-Length') || 0 ); } @@ -508,40 +505,41 @@ sub prepare_request { } sub prepare_uploads { my ( $self, $c ) = @_; - - return unless $c->request->{_body}; - - my $uploads = $c->request->{_body}->upload; - for my $name ( keys %$uploads ) { - my $files = $uploads->{$name}; - $files = ref $files eq 'ARRAY' ? $files : [$files]; + + my $request = $c->request; + return unless $request->{_body}; + + my $uploads = $request->{_body}->upload; + my $parameters = $request->parameters; + while(my($name,$files) = each(%$uploads) ) { my @uploads; - for my $upload (@$files) { - my $u = Catalyst::Request::Upload->new; - $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) ); - $u->type( $u->headers->content_type ); - $u->tempname( $upload->{tempname} ); - $u->size( $upload->{size} ); - $u->filename( $upload->{filename} ); + for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) { + my $headers = HTTP::Headers->new( %{ $upload->{headers} } ); + my $u = Catalyst::Request::Upload->new + ( + size => $upload->{size}, + type => $headers->content_type, + headers => $headers, + tempname => $upload->{tempname}, + filename => $upload->{filename}, + ); push @uploads, $u; } - $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0]; + $request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0]; # support access to the filename as a normal param my @filenames = map { $_->{filename} } @uploads; # append, if there's already params with this name - if (exists $c->request->parameters->{$name}) { - if (ref $c->request->parameters->{$name} eq 'ARRAY') { - push @{ $c->request->parameters->{$name} }, @filenames; + if (exists $parameters->{$name}) { + if (ref $parameters->{$name} eq 'ARRAY') { + push @{ $parameters->{$name} }, @filenames; } else { - $c->request->parameters->{$name} = - [ $c->request->parameters->{$name}, @filenames ]; + $parameters->{$name} = [ $parameters->{$name}, @filenames ]; } } else { - $c->request->parameters->{$name} = - @filenames > 1 ? \@filenames : $filenames[0]; + $parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0]; } } } @@ -621,15 +619,15 @@ sub write { $self->prepare_write($c); $self->{_prepared_write} = 1; } - + my $len = length($buffer); my $wrote = syswrite STDOUT, $buffer; - + if ( !defined $wrote && $! == EWOULDBLOCK ) { # Unable to write on the first try, will retry in the loop below $wrote = 0; } - + if ( defined $wrote && $wrote < $len ) { # We didn't write the whole buffer while (1) { @@ -641,11 +639,11 @@ sub write { next if $! == EWOULDBLOCK; return; } - + last if $wrote >= $len; } } - + return $wrote; } diff --git a/lib/Catalyst/Engine/CGI.pm b/lib/Catalyst/Engine/CGI.pm index 4b699d3..75b8fba 100644 --- a/lib/Catalyst/Engine/CGI.pm +++ b/lib/Catalyst/Engine/CGI.pm @@ -1,10 +1,9 @@ package Catalyst::Engine::CGI; -use strict; -use base 'Catalyst::Engine'; -use NEXT; +use Moose; +extends 'Catalyst::Engine'; -__PACKAGE__->mk_accessors('env'); +has env => (is => 'rw'); =head1 NAME @@ -42,7 +41,7 @@ sub finalize_headers { $c->response->header( Status => $c->response->status ); - $self->{_header_buf} + $self->{_header_buf} = $c->response->headers->as_string("\015\012") . "\015\012"; } @@ -54,7 +53,8 @@ sub prepare_connection { my ( $self, $c ) = @_; local (*ENV) = $self->env || \%ENV; - $c->request->address( $ENV{REMOTE_ADDR} ); + my $request = $c->request; + $request->address( $ENV{REMOTE_ADDR} ); PROXY_CHECK: { @@ -67,20 +67,20 @@ sub prepare_connection { # If we are running as a backend server, the user will always appear # as 127.0.0.1. Select the most recent upstream IP (last in the list) my ($ip) = $ENV{HTTP_X_FORWARDED_FOR} =~ /([^,\s]+)$/; - $c->request->address($ip); + $request->address($ip); } - $c->request->hostname( $ENV{REMOTE_HOST} ); - $c->request->protocol( $ENV{SERVER_PROTOCOL} ); - $c->request->user( $ENV{REMOTE_USER} ); - $c->request->method( $ENV{REQUEST_METHOD} ); + $request->hostname( $ENV{REMOTE_HOST} ); + $request->protocol( $ENV{SERVER_PROTOCOL} ); + $request->user( $ENV{REMOTE_USER} ); + $request->method( $ENV{REQUEST_METHOD} ); if ( $ENV{HTTPS} && uc( $ENV{HTTPS} ) eq 'ON' ) { - $c->request->secure(1); + $request->secure(1); } if ( $ENV{SERVER_PORT} == 443 ) { - $c->request->secure(1); + $request->secure(1); } } @@ -91,12 +91,12 @@ sub prepare_connection { sub prepare_headers { my ( $self, $c ) = @_; local (*ENV) = $self->env || \%ENV; - + my $headers = $c->request->headers; # Read headers from %ENV foreach my $header ( keys %ENV ) { next unless $header =~ /^(?:HTTP|CONTENT|COOKIE)/i; ( my $field = $header ) =~ s/^HTTPS?_//; - $c->req->headers->header( $field => $ENV{$header} ); + $headers->header( $field => $ENV{$header} ); } } @@ -139,21 +139,21 @@ sub prepare_path { # set the request URI my $path = $base_path . ( $ENV{PATH_INFO} || '' ); $path =~ s{^/+}{}; - + # Using URI directly is way too slow, so we construct the URLs manually my $uri_class = "URI::$scheme"; - + # HTTP_HOST will include the port even if it's 80/443 $host =~ s/:(?:80|443)$//; - + if ( $port !~ /^(?:80|443)$/ && $host !~ /:/ ) { $host .= ":$port"; } - + # Escape the path $path =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go; $path =~ s/\?/%3F/g; # STUPID STUPID SPECIAL CASE - + my $query = $ENV{QUERY_STRING} ? '?' . $ENV{QUERY_STRING} : ''; my $uri = $scheme . '://' . $host . '/' . $path . $query; @@ -162,7 +162,7 @@ sub prepare_path { # set the base URI # base must end in a slash $base_path .= '/' unless $base_path =~ m{/$}; - + my $base_uri = $scheme . '://' . $host . $base_path; $c->request->base( bless \$base_uri, $uri_class ); @@ -172,14 +172,15 @@ sub prepare_path { =cut -sub prepare_query_parameters { +around prepare_query_parameters => sub { + my $orig = shift; my ( $self, $c ) = @_; local (*ENV) = $self->env || \%ENV; if ( $ENV{QUERY_STRING} ) { - $self->SUPER::prepare_query_parameters( $c, $ENV{QUERY_STRING} ); + $self->$orig( $c, $ENV{QUERY_STRING} ); } -} +}; =head2 $self->prepare_request($c, (env => \%env)) @@ -199,14 +200,9 @@ Enable autoflush on the output handle for CGI-based engines. =cut -sub prepare_write { - my ( $self, $c ) = @_; - - # Set the output handle to autoflush +before prepare_write => sub { *STDOUT->autoflush(1); - - $self->NEXT::prepare_write($c); -} +}; =head2 $self->write($c, $buffer) @@ -214,16 +210,17 @@ Writes the buffer to the client. =cut -sub write { +around write => sub { + my $orig = shift; my ( $self, $c, $buffer ) = @_; # Prepend the headers if they have not yet been sent if ( my $headers = delete $self->{_header_buf} ) { $buffer = $headers . $buffer; } - - return $self->NEXT::write( $c, $buffer ); -} + + return $self->$orig( $c, $buffer ); +}; =head2 $self->read_chunk($c, $buffer, $length) diff --git a/lib/Catalyst/Engine/FastCGI.pm b/lib/Catalyst/Engine/FastCGI.pm index bd272a1..8e59958 100644 --- a/lib/Catalyst/Engine/FastCGI.pm +++ b/lib/Catalyst/Engine/FastCGI.pm @@ -1,7 +1,8 @@ package Catalyst::Engine::FastCGI; -use strict; -use base 'Catalyst::Engine::CGI'; +use Moose; +extends 'Catalyst::Engine::CGI'; + eval "use FCGI"; die "Unable to load the FCGI module, you may need to install it:\n$@\n" if $@; @@ -18,7 +19,7 @@ This is the FastCGI engine. This class overloads some methods from C. =head2 $self->run($c, $listen, { option => value, ... }) - + Starts the FastCGI server. If C<$listen> is set, then it specifies a location to listen for FastCGI requests; @@ -60,7 +61,7 @@ Specify a filename for the pid file Specify a FCGI::ProcManager sub-class -=item detach +=item detach Detach from console @@ -98,7 +99,7 @@ sub run { my $error = \*STDERR; # send STDERR to the web server $error = \*STDOUT # send STDERR to stdout (a logfile) if $options->{keep_stderr}; # (if asked to) - + my $request = FCGI::Request( \*STDIN, \*STDOUT, $error, \%env, $sock, ( $options->{nointr} ? 0 : &FCGI::FAIL_ACCEPT_ON_INTR ), @@ -134,16 +135,16 @@ sub run { while ( $request->Accept >= 0 ) { $proc_manager && $proc_manager->pm_pre_dispatch(); - + # If we're running under Lighttpd, swap PATH_INFO and SCRIPT_NAME # http://lists.rawmode.org/pipermail/catalyst/2006-June/008361.html # Thanks to Mark Blythe for this fix if ( $env{SERVER_SOFTWARE} && $env{SERVER_SOFTWARE} =~ /lighttpd/ ) { $env{PATH_INFO} ||= delete $env{SCRIPT_NAME}; } - + $class->handle_request( env => \%env ); - + $proc_manager && $proc_manager->pm_post_dispatch(); } } @@ -159,11 +160,11 @@ sub write { $self->prepare_write($c); $self->{_prepared_write} = 1; } - + # XXX: We can't use Engine's write() method because syswrite # appears to return bogus values instead of the number of bytes # written: http://www.fastcgi.com/om_archive/mail-archive/0128.html - + # Prepend the headers if they have not yet been sent if ( my $headers = delete $self->{_header_buf} ) { $buffer = $headers . $buffer; @@ -214,7 +215,7 @@ __END__ =head2 Standalone FastCGI Server -In server mode the application runs as a standalone server and accepts +In server mode the application runs as a standalone server and accepts connections from a web server. The application can be on the same machine as the web server, on a remote machine, or even on multiple remote machines. Advantages of this method include running the Catalyst application as a @@ -225,14 +226,14 @@ To start your application in server mode, install the FCGI::ProcManager module and then use the included fastcgi.pl script. $ script/myapp_fastcgi.pl -l /tmp/myapp.socket -n 5 - + Command line options for fastcgi.pl include: -d -daemon Daemonize the server. -p -pidfile Write a pidfile with the pid of the process manager. -l -listen Listen on a socket path, hostname:port, or :port. -n -nproc The number of processes started to handle requests. - + See below for the specific web server configurations for using the external server. @@ -241,20 +242,20 @@ server. Apache requires the mod_fastcgi module. The same module supports both Apache 1 and 2. -There are three ways to run your application under FastCGI on Apache: server, +There are three ways to run your application under FastCGI on Apache: server, static, and dynamic. =head3 Standalone server mode FastCgiExternalServer /tmp/myapp.fcgi -socket /tmp/myapp.socket Alias /myapp/ /tmp/myapp/myapp.fcgi/ - + # Or, run at the root Alias / /tmp/myapp.fcgi/ - + # Optionally, rewrite the path when accessed without a trailing slash RewriteRule ^/myapp$ myapp/ [R] - + The FastCgiExternalServer directive tells Apache that when serving /tmp/myapp to use the FastCGI application listenting on the socket @@ -263,7 +264,7 @@ it's a virtual file name. With some versions of C or C, you can use any name you like, but most require that the virtual filename end in C<.fcgi>. -It's likely that Apache is not configured to serve files in /tmp, so the +It's likely that Apache is not configured to serve files in /tmp, so the Alias directive maps the url path /myapp/ to the (virtual) file that runs the FastCGI application. The trailing slashes are important as their use will correctly set the PATH_INFO environment variable used by Catalyst to @@ -281,14 +282,14 @@ FastCGI script to run your application. FastCgiServer /path/to/myapp/script/myapp_fastcgi.pl -processes 3 Alias /myapp/ /path/to/myapp/script/myapp_fastcgi.pl/ - + FastCgiServer tells Apache to start three processes of your application at startup. The Alias command maps a path to the FastCGI application. Again, the trailing slashes are important. - + =head3 Dynamic mode -In FastCGI dynamic mode, Apache will run your application on demand, +In FastCGI dynamic mode, Apache will run your application on demand, typically by requesting a file with a specific extension (e.g. .fcgi). ISPs often use this type of setup to provide FastCGI support to many customers. @@ -320,7 +321,7 @@ Here is a complete example: Then a request for /script/myapp_fastcgi.pl will run the application. - + For more information on using FastCGI under Apache, visit L @@ -354,7 +355,7 @@ These configurations were tested with Lighttpd 1.4.7. =head3 Static mode server.document-root = "/var/www/MyApp/root" - + fastcgi.server = ( "" => ( "MyApp" => ( @@ -367,12 +368,12 @@ These configurations were tested with Lighttpd 1.4.7. ) ) ) - + Note that in newer versions of lighttpd, the min-procs and idle-timeout values are disabled. The above example would start 5 processes. =head3 Non-root configuration - + You can also run your application at any non-root location with either of the above modes. diff --git a/lib/Catalyst/Engine/HTTP.pm b/lib/Catalyst/Engine/HTTP.pm index 85ab25f..30c5201 100644 --- a/lib/Catalyst/Engine/HTTP.pm +++ b/lib/Catalyst/Engine/HTTP.pm @@ -1,13 +1,12 @@ package Catalyst::Engine::HTTP; -use strict; -use base 'Catalyst::Engine::CGI'; +use Moose; +extends 'Catalyst::Engine::CGI'; use Data::Dump qw(dump); use Errno 'EWOULDBLOCK'; use HTTP::Date (); use HTTP::Headers; use HTTP::Status; -use NEXT; use Socket; use IO::Socket::INET (); use IO::Select (); @@ -52,28 +51,29 @@ sub finalize_headers { my $protocol = $c->request->protocol; my $status = $c->response->status; my $message = status_message($status); - + my $res_headers = $c->response->headers; + my @headers; push @headers, "$protocol $status $message"; - - $c->response->headers->header( Date => HTTP::Date::time2str(time) ); - $c->response->headers->header( Status => $status ); - + + $res_headers->header( Date => HTTP::Date::time2str(time) ); + $res_headers->header( Status => $status ); + # Should we keep the connection open? my $connection = $c->request->header('Connection'); - if ( $self->{options}->{keepalive} - && $connection + if ( $self->{options}->{keepalive} + && $connection && $connection =~ /^keep-alive$/i ) { - $c->response->headers->header( Connection => 'keep-alive' ); + $res_headers->header( Connection => 'keep-alive' ); $self->{_keepalive} = 1; } else { - $c->response->headers->header( Connection => 'close' ); + $res_headers->header( Connection => 'close' ); } - - push @headers, $c->response->headers->as_string("\x0D\x0A"); - + + push @headers, $res_headers->as_string("\x0D\x0A"); + # Buffer the headers so they are sent with the first write() call # This reduces the number of TCP packets we are sending $self->{_header_buf} = join("\x0D\x0A", @headers, ''); @@ -83,28 +83,20 @@ sub finalize_headers { =cut -sub finalize_read { - my ( $self, $c ) = @_; - +before finalize_read => sub { # Never ever remove this, it would result in random length output # streams if STDIN eq STDOUT (like in the HTTP engine) *STDIN->blocking(1); - - return $self->NEXT::finalize_read($c); -} +}; =head2 $self->prepare_read($c) =cut -sub prepare_read { - my ( $self, $c ) = @_; - +befpre prepare_read => sub { # Set the input handle to non-blocking *STDIN->blocking(0); - - return $self->NEXT::prepare_read($c); -} +}; =head2 $self->read_chunk($c, $buffer, $length) @@ -113,7 +105,7 @@ sub prepare_read { sub read_chunk { my $self = shift; my $c = shift; - + # If we have any remaining data in the input buffer, send it back first if ( $_[0] = delete $self->{inputbuf} ) { my $read = length( $_[0] ); @@ -146,9 +138,10 @@ Writes the buffer to the client. =cut -sub write { +around write => sub { + my $orig = shift; my ( $self, $c, $buffer ) = @_; - + # Avoid 'print() on closed filehandle Remote' warnings when using IE return unless *STDOUT->opened(); @@ -156,9 +149,9 @@ sub write { if ( my $headers = delete $self->{_header_buf} ) { $buffer = $headers . $buffer; } - - my $ret = $self->NEXT::write( $c, $buffer ); - + + my $ret = $self->$orig( $c, $buffer ); + if ( !defined $ret ) { $self->{_write_error} = $!; DEBUG && warn "write: Failed to write response ($!)\n"; @@ -166,9 +159,9 @@ sub write { else { DEBUG && warn "write: Wrote response ($ret bytes)\n"; } - + return $ret; -} +}; =head2 run @@ -179,7 +172,7 @@ sub run { my ( $self, $class, $port, $host, $options ) = @_; $options ||= {}; - + $self->{options} = $options; if ($options->{background}) { @@ -239,28 +232,28 @@ sub run { } my $pid = undef; - + # Ignore broken pipes as an HTTP server should local $SIG{PIPE} = 'IGNORE'; - + # Restart on HUP - local $SIG{HUP} = sub { + local $SIG{HUP} = sub { $restart = 1; warn "Restarting server on SIGHUP...\n"; }; - + LISTEN: while ( !$restart ) { - while ( accept( Remote, $daemon ) ) { + while ( accept( Remote, $daemon ) ) { DEBUG && warn "New connection\n"; select Remote; Remote->blocking(1); - + # Read until we see all headers $self->{inputbuf} = ''; - + if ( !$self->_read_headers ) { # Error reading, give up close Remote; @@ -268,15 +261,14 @@ sub run { } my ( $method, $uri, $protocol ) = $self->_parse_request_line; - - next unless $method; - + DEBUG && warn "Parsed request: $method $uri $protocol\n"; + next unless $method; unless ( uc($method) eq 'RESTART' ) { # Fork - if ( $options->{fork} ) { + if ( $options->{fork} ) { if ( $pid = fork ) { DEBUG && warn "Forked child $pid\n"; next; @@ -284,10 +276,10 @@ sub run { } $self->_handler( $class, $port, $method, $uri, $protocol ); - + if ( my $error = delete $self->{_write_error} ) { close Remote; - + if ( !defined $pid ) { next LISTEN; } @@ -319,9 +311,9 @@ sub run { close Remote; } } - + $daemon->close; - + DEBUG && warn "Shutting down\n"; if ($restart) { @@ -332,8 +324,8 @@ sub run { ### those include dirs upon re-exec. So add them to PERL5LIB, so they ### are available again for the exec'ed process --kane use Config; - $ENV{PERL5LIB} .= join $Config{path_sep}, @INC; - + $ENV{PERL5LIB} .= join $Config{path_sep}, @INC; + exec $^X, $0, @{ $options->{argv} }; } @@ -354,11 +346,11 @@ sub _handler { my $sel = IO::Select->new; $sel->add( \*STDIN ); - + REQUEST: while (1) { my ( $path, $query_string ) = split /\?/, $uri, 2; - + # Initialize CGI environment local %ENV = ( PATH_INFO => $path || '', @@ -379,37 +371,37 @@ sub _handler { # Pass flow control to Catalyst $class->handle_request; - + DEBUG && warn "Request done\n"; - + # Allow keepalive requests, this is a hack but we'll support it until # the next major release. if ( delete $self->{_keepalive} ) { - + DEBUG && warn "Reusing previous connection for keep-alive request\n"; - - if ( $sel->can_read(1) ) { + + if ( $sel->can_read(1) ) { if ( !$self->_read_headers ) { # Error reading, give up last REQUEST; } ( $method, $uri, $protocol ) = $self->_parse_request_line; - + DEBUG && warn "Parsed request: $method $uri $protocol\n"; - + # Force HTTP/1.0 $protocol = '1.0'; - + next REQUEST; } - + DEBUG && warn "No keep-alive request within 1 second\n"; } - + last REQUEST; } - + DEBUG && warn "Closing connection\n"; close Remote; @@ -417,51 +409,50 @@ sub _handler { sub _read_headers { my $self = shift; - + while (1) { my $read = sysread Remote, my $buf, CHUNKSIZE; - + if ( !defined $read ) { next if $! == EWOULDBLOCK; DEBUG && warn "Error reading headers: $!\n"; return; - } - elsif ( $read == 0 ) { + } elsif ( $read == 0 ) { DEBUG && warn "EOF\n"; return; } - + DEBUG && warn "Read $read bytes\n"; $self->{inputbuf} .= $buf; last if $self->{inputbuf} =~ /(\x0D\x0A?\x0D\x0A?|\x0A\x0D?\x0A\x0D?)/s; } - + return 1; } sub _parse_request_line { my $self = shift; - # Parse request line + # Parse request line if ( $self->{inputbuf} !~ s/^(\w+)[ \t]+(\S+)(?:[ \t]+(HTTP\/\d+\.\d+))?[^\012]*\012// ) { return (); } - + my $method = $1; my $uri = $2; my $proto = $3 || 'HTTP/0.9'; - + return ( $method, $uri, $proto ); } sub _parse_headers { my $self = shift; - + # Copy the buffer for header parsing, and remove the header block # from the content buffer. my $buf = $self->{inputbuf}; $self->{inputbuf} =~ s/.*?(\x0D\x0A?\x0D\x0A?|\x0A\x0D?\x0A\x0D?)//s; - + # Parse headers my $headers = HTTP::Headers->new; my ($key, $val); @@ -481,19 +472,19 @@ sub _parse_headers { } } $headers->push_header( $key, $val ) if $key; - + DEBUG && warn "Parsed headers: " . dump($headers) . "\n"; # Convert headers into ENV vars $headers->scan( sub { my ( $key, $val ) = @_; - + $key = uc $key; $key = 'COOKIE' if $key eq 'COOKIES'; $key =~ tr/-/_/; $key = 'HTTP_' . $key unless $key =~ m/\A(?:CONTENT_(?:LENGTH|TYPE)|COOKIE)\z/; - + if ( exists $ENV{$key} ) { $ENV{$key} .= ", $val"; } @@ -507,19 +498,19 @@ sub _socket_data { my ( $self, $handle ) = @_; my $remote_sockaddr = getpeername($handle); - my ( undef, $iaddr ) = $remote_sockaddr - ? sockaddr_in($remote_sockaddr) + my ( undef, $iaddr ) = $remote_sockaddr + ? sockaddr_in($remote_sockaddr) : (undef, undef); - + my $local_sockaddr = getsockname($handle); my ( undef, $localiaddr ) = sockaddr_in($local_sockaddr); # This mess is necessary to keep IE from crashing the server my $data = { - peername => $iaddr + peername => $iaddr ? ( gethostbyaddr( $iaddr, AF_INET ) || 'localhost' ) : 'localhost', - peeraddr => $iaddr + peeraddr => $iaddr ? ( inet_ntoa($iaddr) || '127.0.0.1' ) : '127.0.0.1', localname => gethostbyaddr( $localiaddr, AF_INET ) || 'localhost', diff --git a/lib/Catalyst/Engine/HTTP/Restarter.pm b/lib/Catalyst/Engine/HTTP/Restarter.pm index 02c58ba..8e5c8c0 100644 --- a/lib/Catalyst/Engine/HTTP/Restarter.pm +++ b/lib/Catalyst/Engine/HTTP/Restarter.pm @@ -1,12 +1,11 @@ package Catalyst::Engine::HTTP::Restarter; -use strict; -use warnings; -use base 'Catalyst::Engine::HTTP'; +use Moose; +extends 'Catalyst::Engine::HTTP'; use Catalyst::Engine::HTTP::Restarter::Watcher; -use NEXT; -sub run { +around run => sub { + my $orig = shift; my ( $self, $class, $port, $host, $options ) = @_; $options ||= {}; @@ -19,8 +18,8 @@ sub run { close STDOUT; my $watcher = Catalyst::Engine::HTTP::Restarter::Watcher->new( - directory => ( - $options->{restart_directory} || + directory => ( + $options->{restart_directory} || File::Spec->catdir( $FindBin::Bin, '..' ) ), follow_symlinks => $options->{follow_symlinks}, @@ -67,8 +66,8 @@ sub run { } } - return $self->NEXT::run( $class, $port, $host, $options ); -} + return $self->$orig( $class, $port, $host, $options ); +}; 1; __END__ diff --git a/lib/Catalyst/Engine/HTTP/Restarter/Watcher.pm b/lib/Catalyst/Engine/HTTP/Restarter/Watcher.pm index b45c3da..b1ae9b7 100644 --- a/lib/Catalyst/Engine/HTTP/Restarter/Watcher.pm +++ b/lib/Catalyst/Engine/HTTP/Restarter/Watcher.pm @@ -1,21 +1,17 @@ package Catalyst::Engine::HTTP::Restarter::Watcher; -use strict; -use warnings; -use base 'Class::Accessor::Fast'; +use Moose; use File::Find; use File::Modified; use File::Spec; use Time::HiRes qw/sleep/; -__PACKAGE__->mk_accessors( - qw/delay - directory - modified - regex - follow_symlinks - watch_list/ -); +has delay => (is => 'rw'); +has regex => (is => 'rw'); +has modified => (is => 'rw'); +has directory => (is => 'rw'); +has watch_list => (is => 'rw'); +has follow_simlinks => (is => 'rw'); sub new { my ( $class, %args ) = @_; @@ -48,7 +44,7 @@ sub watch { my @changes; my @changed_files; - + my $delay = ( defined $self->delay ) ? $self->delay : 1; sleep $delay if $delay > 0; @@ -160,7 +156,7 @@ files regex => '\.yml$|\.yaml$|\.pm$', delay => 1, ); - + while (1) { my @changed_files = $watcher->watch(); } diff --git a/t/lib/Catalyst/Plugin/Test/Errors.pm b/t/lib/Catalyst/Plugin/Test/Errors.pm index 92fa63c..f5212e3 100644 --- a/t/lib/Catalyst/Plugin/Test/Errors.pm +++ b/t/lib/Catalyst/Plugin/Test/Errors.pm @@ -1,6 +1,7 @@ package Catalyst::Plugin::Test::Errors; use strict; +use NEXT; sub error { my $c = shift; @@ -12,10 +13,10 @@ sub error { if ( $_[0] =~ /^(Unknown resource|No default action defined)/ ) { $c->response->status(404); } - + if ( $_[0] =~ /^Couldn\'t forward/ ) { $c->response->status(404); - } + } if ( $_[0] =~ /^Caught exception/ ) { $c->response->status(500); diff --git a/t/lib/Catalyst/Plugin/Test/Headers.pm b/t/lib/Catalyst/Plugin/Test/Headers.pm index ac47209..5bb07a5 100644 --- a/t/lib/Catalyst/Plugin/Test/Headers.pm +++ b/t/lib/Catalyst/Plugin/Test/Headers.pm @@ -1,6 +1,7 @@ package Catalyst::Plugin::Test::Headers; use strict; +use NEXT; sub prepare { my $class = shift; @@ -9,7 +10,7 @@ sub prepare { $c->response->header( 'X-Catalyst-Engine' => $c->engine ); $c->response->header( 'X-Catalyst-Debug' => $c->debug ? 1 : 0 ); - + { my $components = join( ', ', sort keys %{ $c->components } ); $c->response->header( 'X-Catalyst-Components' => $components ); diff --git a/t/lib/Catalyst/Plugin/Test/Plugin.pm b/t/lib/Catalyst/Plugin/Test/Plugin.pm index 62b2cad..cc6178d 100644 --- a/t/lib/Catalyst/Plugin/Test/Plugin.pm +++ b/t/lib/Catalyst/Plugin/Test/Plugin.pm @@ -1,6 +1,7 @@ package Catalyst::Plugin::Test::Plugin; use strict; +use NEXT; use base qw/Catalyst::Base Class::Data::Inheritable/; diff --git a/t/unit_core_component_loading.t b/t/unit_core_component_loading.t index 5b6a4a7..bae3c5e 100644 --- a/t/unit_core_component_loading.t +++ b/t/unit_core_component_loading.t @@ -40,7 +40,7 @@ my @components = ( { type => 'View', prefix => 'View', name => 'Foo' }, ); -sub write_component_file { +sub write_component_file { my ($dir_list, $module_name, $content) = @_; my $dir = File::Spec->catdir(@$dir_list); @@ -63,6 +63,7 @@ sub make_component_file { write_component_file(\@dir_list, $name_final, <NEXT::COMPONENT(\@_); @@ -164,7 +165,7 @@ write_component_file([$libdir, $appclass, 'Model'], 'TopLevel', <NEXT::COMPONENT(\@_); no strict 'refs'; *{\__PACKAGE__ . "::whoami"} = sub { return \__PACKAGE__; };