use Devel::InnerPackage ();
use File::stat;
use Module::Pluggable::Object ();
-use NEXT;
use Text::SimpleTable ();
use Path::Class::Dir ();
use Path::Class::File ();
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';
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;
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)
}
for my $cookie (@cookies) {
- $c->res->headers->push_header( 'Set-Cookie' => $cookie );
+ $response->headers->push_header( 'Set-Cookie' => $cookie );
}
}
}
/* 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 */
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)
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);
}
=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 );
}
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];
}
}
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 ) {
# 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;
# 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 );
}
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];
}
}
}
$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) {
next if $! == EWOULDBLOCK;
return;
}
-
+
last if $wrote >= $len;
}
}
-
+
return $wrote;
}
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
$c->response->header( Status => $c->response->status );
- $self->{_header_buf}
+ $self->{_header_buf}
= $c->response->headers->as_string("\015\012") . "\015\012";
}
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:
{
# 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);
}
}
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} );
}
}
# 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;
# 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 );
=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))
=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)
=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)
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 $@;
This class overloads some methods from C<Catalyst::Engine::CGI>.
=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;
Specify a FCGI::ProcManager sub-class
-=item detach
+=item detach
Detach from console
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 ),
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();
}
}
$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;
=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
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.
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
C<mod_fcgid>, 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
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.
Then a request for /script/myapp_fastcgi.pl will run the
application.
-
+
For more information on using FastCGI under Apache, visit
L<http://www.fastcgi.com/mod_fastcgi/docs/mod_fastcgi.html>
=head3 Static mode
server.document-root = "/var/www/MyApp/root"
-
+
fastcgi.server = (
"" => (
"MyApp" => (
)
)
)
-
+
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.
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 ();
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, '');
=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)
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] );
=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();
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";
else {
DEBUG && warn "write: Wrote response ($ret bytes)\n";
}
-
+
return $ret;
-}
+};
=head2 run
my ( $self, $class, $port, $host, $options ) = @_;
$options ||= {};
-
+
$self->{options} = $options;
if ($options->{background}) {
}
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;
}
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;
}
$self->_handler( $class, $port, $method, $uri, $protocol );
-
+
if ( my $error = delete $self->{_write_error} ) {
close Remote;
-
+
if ( !defined $pid ) {
next LISTEN;
}
close Remote;
}
}
-
+
$daemon->close;
-
+
DEBUG && warn "Shutting down\n";
if ($restart) {
### 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} };
}
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 || '',
# 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;
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);
}
}
$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";
}
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',
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 ||= {};
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},
}
}
- return $self->NEXT::run( $class, $port, $host, $options );
-}
+ return $self->$orig( $class, $port, $host, $options );
+};
1;
__END__
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 ) = @_;
my @changes;
my @changed_files;
-
+
my $delay = ( defined $self->delay ) ? $self->delay : 1;
sleep $delay if $delay > 0;
regex => '\.yml$|\.yaml$|\.pm$',
delay => 1,
);
-
+
while (1) {
my @changed_files = $watcher->watch();
}
package Catalyst::Plugin::Test::Errors;
use strict;
+use NEXT;
sub error {
my $c = shift;
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);
package Catalyst::Plugin::Test::Headers;
use strict;
+use NEXT;
sub prepare {
my $class = shift;
$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 );
package Catalyst::Plugin::Test::Plugin;
use strict;
+use NEXT;
use base qw/Catalyst::Base Class::Data::Inheritable/;
{ 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);
write_component_file(\@dir_list, $name_final, <<EOF);
package $fullname;
+use NEXT;
use base '$compbase';
sub COMPONENT {
my \$self = shift->NEXT::COMPONENT(\@_);
package ${appclass}::Model::TopLevel;
use base 'Catalyst::Model';
sub COMPONENT {
-
+
my \$self = shift->NEXT::COMPONENT(\@_);
no strict 'refs';
*{\__PACKAGE__ . "::whoami"} = sub { return \__PACKAGE__; };
projects / catagits/Catalyst-Runtime.git / commitdiff