Container-Builder
view release on metacpan or search on metacpan
examples/fatpacked.plackup view on Meta::CPAN
our @EXPORT = qw( req_to_psgi res_from_psgi );
use Carp ();
use HTTP::Status qw(status_message);
use URI::Escape ();
use Plack::Util;
use Try::Tiny;
my $TRUE = (1 == 1);
my $FALSE = !$TRUE;
sub req_to_psgi {
my $req = shift;
unless (try { $req->isa('HTTP::Request') }) {
Carp::croak("Request is not HTTP::Request: $req");
}
# from HTTP::Request::AsCGI
my $host = $req->header('Host');
my $uri = $req->uri->clone;
$uri->scheme('http') unless $uri->scheme;
$uri->host('localhost') unless $uri->host;
$uri->port(80) unless $uri->port;
$uri->host_port($host) unless !$host || ( $host eq $uri->host_port );
my $input;
my $content = $req->content;
if (ref $content eq 'CODE') {
if (defined $req->content_length) {
$input = HTTP::Message::PSGI::ChunkedInput->new($content);
} else {
$req->header("Transfer-Encoding" => "chunked");
$input = HTTP::Message::PSGI::ChunkedInput->new($content, 1);
}
} else {
open $input, "<", \$content;
$req->content_length(length $content)
unless defined $req->content_length;
}
my $env = {
PATH_INFO => URI::Escape::uri_unescape($uri->path || '/'),
QUERY_STRING => $uri->query || '',
SCRIPT_NAME => '',
SERVER_NAME => $uri->host,
SERVER_PORT => $uri->port,
SERVER_PROTOCOL => $req->protocol || 'HTTP/1.1',
REMOTE_ADDR => '127.0.0.1',
REMOTE_HOST => 'localhost',
REMOTE_PORT => int( rand(64000) + 1000 ), # not in RFC 3875
REQUEST_URI => $uri->path_query || '/', # not in RFC 3875
REQUEST_METHOD => $req->method,
'psgi.version' => [ 1, 1 ],
'psgi.url_scheme' => $uri->scheme eq 'https' ? 'https' : 'http',
'psgi.input' => $input,
'psgi.errors' => *STDERR,
'psgi.multithread' => $FALSE,
'psgi.multiprocess' => $FALSE,
'psgi.run_once' => $TRUE,
'psgi.streaming' => $TRUE,
'psgi.nonblocking' => $FALSE,
@_,
};
for my $field ( $req->headers->header_field_names ) {
my $key = uc("HTTP_$field");
$key =~ tr/-/_/;
$key =~ s/^HTTP_// if $field =~ /^Content-(Length|Type)$/;
unless ( exists $env->{$key} ) {
$env->{$key} = $req->headers->header($field);
}
}
if ($env->{SCRIPT_NAME}) {
$env->{PATH_INFO} =~ s/^\Q$env->{SCRIPT_NAME}\E/\//;
$env->{PATH_INFO} =~ s/^\/+/\//;
}
if (!defined($env->{HTTP_HOST}) && $req->uri->can('host')) {
$env->{HTTP_HOST} = $req->uri->host;
$env->{HTTP_HOST} .= ':' . $req->uri->port
if $req->uri->port ne $req->uri->default_port;
}
return $env;
}
sub res_from_psgi {
my ($psgi_res) = @_;
require HTTP::Response;
my $res;
if (ref $psgi_res eq 'ARRAY') {
_res_from_psgi($psgi_res, \$res);
} elsif (ref $psgi_res eq 'CODE') {
$psgi_res->(sub {
_res_from_psgi($_[0], \$res);
});
} else {
Carp::croak("Bad response: ", defined $psgi_res ? $psgi_res : 'undef');
}
return $res;
}
sub _res_from_psgi {
my ($status, $headers, $body) = @{+shift};
my $res_ref = shift;
my $convert_resp = sub {
my $res = HTTP::Response->new($status);
$res->message(status_message($status));
$res->headers->header(@$headers) if @$headers;
if (ref $body eq 'ARRAY') {
$res->content(join '', grep defined, @$body);
} else {
local $/ = \4096;
examples/fatpacked.plackup view on Meta::CPAN
eval { require IO::Socket::SSL; 1 }
or Carp::croak("SSL suport requires IO::Socket::SSL");
$args->{SSL_key_file} = $self->{ssl_key_file};
$args->{SSL_cert_file} = $self->{ssl_cert_file};
return "IO::Socket::SSL";
} elsif ($self->{ipv6}) {
eval { require IO::Socket::IP; 1 }
or Carp::croak("IPv6 support requires IO::Socket::IP");
$self->{host} ||= '::';
$args->{LocalAddr} ||= '::';
return "IO::Socket::IP";
}
return "IO::Socket::INET";
}
sub setup_listener {
my $self = shift;
$self->{listen_sock} ||= do {
my %args = (
Listen => SOMAXCONN,
LocalPort => $self->{port},
LocalAddr => $self->{host},
Proto => 'tcp',
ReuseAddr => 1,
);
my $class = $self->prepare_socket_class(\%args);
$class->new(%args)
or die "failed to listen to port $self->{port}: $!";
};
$self->{server_ready}->({ %$self, proto => $self->{ssl} ? 'https' : 'http' });
}
sub accept_loop {
my($self, $app) = @_;
$app = Plack::Middleware::ContentLength->wrap($app);
while (1) {
local $SIG{PIPE} = 'IGNORE';
if (my $conn = $self->{listen_sock}->accept) {
if (defined TCP_NODELAY) {
$conn->setsockopt(IPPROTO_TCP, TCP_NODELAY, 1)
or die "setsockopt(TCP_NODELAY) failed:$!";
}
my $env = {
SERVER_PORT => $self->{port},
SERVER_NAME => $self->{host},
SCRIPT_NAME => '',
REMOTE_ADDR => $conn->peerhost,
REMOTE_PORT => $conn->peerport || 0,
'psgi.version' => [ 1, 1 ],
'psgi.errors' => *STDERR,
'psgi.url_scheme' => $self->{ssl} ? 'https' : 'http',
'psgi.run_once' => Plack::Util::FALSE,
'psgi.multithread' => Plack::Util::FALSE,
'psgi.multiprocess' => Plack::Util::FALSE,
'psgi.streaming' => Plack::Util::TRUE,
'psgi.nonblocking' => Plack::Util::FALSE,
'psgix.harakiri' => Plack::Util::TRUE,
'psgix.input.buffered' => Plack::Util::TRUE,
'psgix.io' => $conn,
};
$self->handle_connection($env, $conn, $app);
$conn->close;
last if $env->{'psgix.harakiri.commit'};
}
}
}
sub handle_connection {
my($self, $env, $conn, $app) = @_;
my $buf = '';
my $res = [ 400, [ 'Content-Type' => 'text/plain' ], [ 'Bad Request' ] ];
while (1) {
my $rlen = $self->read_timeout(
$conn, \$buf, MAX_REQUEST_SIZE - length($buf), length($buf),
$self->{timeout},
) or return;
my $reqlen = parse_http_request($buf, $env);
if ($reqlen >= 0) {
$buf = substr $buf, $reqlen;
if (my $cl = $env->{CONTENT_LENGTH}) {
my $buffer = Stream::Buffered->new($cl);
while ($cl > 0) {
my $chunk;
if (length $buf) {
$chunk = $buf;
$buf = '';
} else {
$self->read_timeout($conn, \$chunk, $cl, 0, $self->{timeout})
or return;
}
$buffer->print($chunk);
$cl -= length $chunk;
}
$env->{'psgi.input'} = $buffer->rewind;
} else {
open my $input, "<", \$buf;
$env->{'psgi.input'} = $input;
}
$res = Plack::Util::run_app $app, $env;
last;
}
if ($reqlen == -2) {
# request is incomplete, do nothing
} elsif ($reqlen == -1) {
# error, close conn
last;
}
}
if (ref $res eq 'ARRAY') {
$self->_handle_response($res, $conn);
examples/fatpacked.plackup view on Meta::CPAN
$fatpacked{"Plack/Handler/Apache1.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_HANDLER_APACHE1';
package Plack::Handler::Apache1;
use strict;
use Apache::Request;
use Apache::Constants qw(:common :response);
use Plack::Util;
use Scalar::Util;
my %apps; # psgi file to $app mapping
sub new { bless {}, shift }
sub preload {
my $class = shift;
for my $app (@_) {
$class->load_app($app);
}
}
sub load_app {
my($class, $app) = @_;
return $apps{$app} ||= do {
# Trick Catalyst, CGI.pm, CGI::Cookie and others that check
# for $ENV{MOD_PERL}.
#
# Note that we delete it instead of just localizing
# $ENV{MOD_PERL} because some users may check if the key
# exists, and we do it this way because "delete local" is new
# in 5.12:
# http://perldoc.perl.org/5.12.0/perldelta.html#delete-local
local $ENV{MOD_PERL};
delete $ENV{MOD_PERL};
Plack::Util::load_psgi $app;
};
}
sub handler {
my $class = __PACKAGE__;
my $r = shift;
my $psgi = $r->dir_config('psgi_app');
$class->call_app($r, $class->load_app($psgi));
}
sub call_app {
my ($class, $r, $app) = @_;
$r->subprocess_env; # let Apache create %ENV for us :)
my $env = {
%ENV,
'psgi.version' => [ 1, 1 ],
'psgi.url_scheme' => ($ENV{HTTPS}||'off') =~ /^(?:on|1)$/i ? 'https' : 'http',
'psgi.input' => $r,
'psgi.errors' => *STDERR,
'psgi.multithread' => Plack::Util::FALSE,
'psgi.multiprocess' => Plack::Util::TRUE,
'psgi.run_once' => Plack::Util::FALSE,
'psgi.streaming' => Plack::Util::TRUE,
'psgi.nonblocking' => Plack::Util::FALSE,
'psgix.harakiri' => Plack::Util::TRUE,
};
if (defined(my $HTTP_AUTHORIZATION = $r->headers_in->{Authorization})) {
$env->{HTTP_AUTHORIZATION} = $HTTP_AUTHORIZATION;
}
my $vpath = $env->{SCRIPT_NAME} . ($env->{PATH_INFO} || '');
my $location = $r->location || "/";
$location =~ s{/$}{};
(my $path_info = $vpath) =~ s/^\Q$location\E//;
$env->{SCRIPT_NAME} = $location;
$env->{PATH_INFO} = $path_info;
my $res = $app->($env);
if (ref $res eq 'ARRAY') {
_handle_response($r, $res);
}
elsif (ref $res eq 'CODE') {
$res->(sub {
_handle_response($r, $_[0]);
});
}
else {
die "Bad response $res";
}
if ($env->{'psgix.harakiri.commit'}) {
$r->child_terminate;
}
return OK;
}
sub _handle_response {
my ($r, $res) = @_;
my ($status, $headers, $body) = @{ $res };
my $hdrs = ($status >= 200 && $status < 300)
? $r->headers_out : $r->err_headers_out;
Plack::Util::header_iter($headers, sub {
my($h, $v) = @_;
if (lc $h eq 'content-type') {
$r->content_type($v);
} else {
$hdrs->add($h => $v);
}
});
$r->status($status);
$r->send_http_header;
if (defined $body) {
if (Plack::Util::is_real_fh($body)) {
$r->send_fd($body);
examples/fatpacked.plackup view on Meta::CPAN
$fatpacked{"Plack/Handler/Apache2.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_HANDLER_APACHE2';
package Plack::Handler::Apache2;
use strict;
use warnings;
use Apache2::RequestRec;
use Apache2::RequestIO;
use Apache2::RequestUtil;
use Apache2::Response;
use Apache2::Const -compile => qw(OK);
use Apache2::Log;
use APR::Table;
use IO::Handle;
use Plack::Util;
use Scalar::Util;
use URI;
use URI::Escape;
my %apps; # psgi file to $app mapping
sub new { bless {}, shift }
sub preload {
my $class = shift;
for my $app (@_) {
$class->load_app($app);
}
}
sub load_app {
my($class, $app) = @_;
return $apps{$app} ||= do {
# Trick Catalyst, CGI.pm, CGI::Cookie and others that check
# for $ENV{MOD_PERL}.
#
# Note that we delete it instead of just localizing
# $ENV{MOD_PERL} because some users may check if the key
# exists, and we do it this way because "delete local" is new
# in 5.12:
# http://perldoc.perl.org/5.12.0/perldelta.html#delete-local
local $ENV{MOD_PERL};
delete $ENV{MOD_PERL};
Plack::Util::load_psgi $app;
};
}
sub call_app {
my ($class, $r, $app) = @_;
$r->subprocess_env; # let Apache create %ENV for us :)
my $env = {
%ENV,
'psgi.version' => [ 1, 1 ],
'psgi.url_scheme' => ($ENV{HTTPS}||'off') =~ /^(?:on|1)$/i ? 'https' : 'http',
'psgi.input' => $r,
'psgi.errors' => *STDERR,
'psgi.multithread' => Plack::Util::FALSE,
'psgi.multiprocess' => Plack::Util::TRUE,
'psgi.run_once' => Plack::Util::FALSE,
'psgi.streaming' => Plack::Util::TRUE,
'psgi.nonblocking' => Plack::Util::FALSE,
'psgix.harakiri' => Plack::Util::TRUE,
'psgix.cleanup' => Plack::Util::TRUE,
'psgix.cleanup.handlers' => [],
};
if (defined(my $HTTP_AUTHORIZATION = $r->headers_in->{Authorization})) {
$env->{HTTP_AUTHORIZATION} = $HTTP_AUTHORIZATION;
}
# If you supply more than one Content-Length header Apache will
# happily concat the values with ", ", e.g. "72, 72". This
# violates the PSGI spec so fix this up and just take the first
# one.
if (exists $env->{CONTENT_LENGTH} && $env->{CONTENT_LENGTH} =~ /,/) {
no warnings qw(numeric);
$env->{CONTENT_LENGTH} = int $env->{CONTENT_LENGTH};
}
# Actually, we can not trust PATH_INFO from mod_perl because mod_perl squeezes multiple slashes into one slash.
my $uri = URI->new("http://".$r->hostname.$r->unparsed_uri);
$env->{PATH_INFO} = uri_unescape($uri->path);
$class->fixup_path($r, $env);
my $res = $app->($env);
if (ref $res eq 'ARRAY') {
_handle_response($r, $res);
}
elsif (ref $res eq 'CODE') {
$res->(sub {
_handle_response($r, $_[0]);
});
}
else {
die "Bad response $res";
}
if (@{ $env->{'psgix.cleanup.handlers'} }) {
$r->push_handlers(
PerlCleanupHandler => sub {
for my $cleanup_handler (@{ $env->{'psgix.cleanup.handlers'} }) {
$cleanup_handler->($env);
}
if ($env->{'psgix.harakiri.commit'}) {
$r->child_terminate;
}
},
);
} else {
if ($env->{'psgix.harakiri.commit'}) {
$r->child_terminate;
}
}
return Apache2::Const::OK;
}
examples/fatpacked.plackup view on Meta::CPAN
414 => 'Request-URI Too Large',
415 => 'Unsupported Media Type',
416 => 'Request Range Not Satisfiable',
417 => 'Expectation Failed',
422 => 'Unprocessable Entity', # RFC 2518 (WebDAV)
423 => 'Locked', # RFC 2518 (WebDAV)
424 => 'Failed Dependency', # RFC 2518 (WebDAV)
425 => 'No code', # WebDAV Advanced Collections
426 => 'Upgrade Required', # RFC 2817
449 => 'Retry with', # unofficial Microsoft
500 => 'Internal Server Error',
501 => 'Not Implemented',
502 => 'Bad Gateway',
503 => 'Service Unavailable',
504 => 'Gateway Timeout',
505 => 'HTTP Version Not Supported',
506 => 'Variant Also Negotiates', # RFC 2295
507 => 'Insufficient Storage', # RFC 2518 (WebDAV)
509 => 'Bandwidth Limit Exceeded', # unofficial
510 => 'Not Extended', # RFC 2774
);
sub new { bless {}, shift }
sub run {
my ($self, $app) = @_;
my $env = $self->setup_env();
my $res = $app->($env);
if (ref $res eq 'ARRAY') {
$self->_handle_response($res);
}
elsif (ref $res eq 'CODE') {
$res->(sub {
$self->_handle_response($_[0]);
});
}
else {
die "Bad response $res";
}
}
sub setup_env {
my ( $self, $override_env ) = @_;
$override_env ||= {};
binmode STDIN;
binmode STDERR;
my $env = {
%ENV,
'psgi.version' => [ 1, 1 ],
'psgi.url_scheme' => ($ENV{HTTPS}||'off') =~ /^(?:on|1)$/i ? 'https' : 'http',
'psgi.input' => *STDIN,
'psgi.errors' => *STDERR,
'psgi.multithread' => 0,
'psgi.multiprocess' => 1,
'psgi.run_once' => 1,
'psgi.streaming' => 1,
'psgi.nonblocking' => 1,
%{ $override_env },
};
delete $env->{HTTP_CONTENT_TYPE};
delete $env->{HTTP_CONTENT_LENGTH};
$env->{'HTTP_COOKIE'} ||= $ENV{COOKIE}; # O'Reilly server bug
if (!exists $env->{PATH_INFO}) {
$env->{PATH_INFO} = '';
}
if ($env->{SCRIPT_NAME} eq '/') {
$env->{SCRIPT_NAME} = '';
$env->{PATH_INFO} = '/' . $env->{PATH_INFO};
}
return $env;
}
sub _handle_response {
my ($self, $res) = @_;
*STDOUT->autoflush(1);
binmode STDOUT;
my $hdrs;
my $message = $StatusCode{$res->[0]};
$hdrs = "Status: $res->[0] $message\015\012";
my $headers = $res->[1];
while (my ($k, $v) = splice(@$headers, 0, 2)) {
$hdrs .= "$k: $v\015\012";
}
$hdrs .= "\015\012";
print STDOUT $hdrs;
my $body = $res->[2];
my $cb = sub { print STDOUT $_[0] };
# inline Plack::Util::foreach here
if (ref $body eq 'ARRAY') {
for my $line (@$body) {
$cb->($line) if length $line;
}
}
elsif (defined $body) {
local $/ = \65536 unless ref $/;
while (defined(my $line = $body->getline)) {
$cb->($line) if length $line;
}
$body->close;
}
else {
return Plack::Handler::CGI::Writer->new;
}
}
examples/fatpacked.plackup view on Meta::CPAN
die "STDIN is not a socket: specify a listen location";
}
@{$self}{qw(stdin stdout stderr)}
= (IO::Handle->new, IO::Handle->new, IO::Handle->new);
my %env;
my $request = FCGI::Request(
$self->{stdin}, $self->{stdout}, $self->{stderr},
\%env, $sock,
($self->{nointr} ? 0 : &FCGI::FAIL_ACCEPT_ON_INTR),
);
my $proc_manager;
if ($self->{listen} or $running_on_server_starter) {
$self->daemon_fork if $self->{daemonize};
if ($self->{manager}) {
if (blessed $self->{manager}) {
for (qw(nproc pid proc_title)) {
die "Don't use '$_' when passing in a 'manager' object"
if $self->{$_};
}
$proc_manager = $self->{manager};
} else {
Plack::Util::load_class($self->{manager});
$proc_manager = $self->{manager}->new({
n_processes => $self->{nproc},
pid_fname => $self->{pid},
(exists $self->{proc_title}
? (pm_title => $self->{proc_title}) : ()),
});
}
# detach *before* the ProcManager inits
$self->daemon_detach if $self->{daemonize};
}
elsif ($self->{daemonize}) {
$self->daemon_detach;
}
} elsif (blessed $self->{manager}) {
$proc_manager = $self->{manager};
}
$proc_manager && $proc_manager->pm_manage;
while ($request->Accept >= 0) {
$proc_manager && $proc_manager->pm_pre_dispatch;
my $env = {
%env,
'psgi.version' => [1,1],
'psgi.url_scheme' => ($env{HTTPS}||'off') =~ /^(?:on|1)$/i ? 'https' : 'http',
'psgi.input' => $self->{stdin},
'psgi.errors' =>
($self->{keep_stderr} ? \*STDERR : $self->{stderr}),
'psgi.multithread' => Plack::Util::FALSE,
'psgi.multiprocess' => defined $proc_manager,
'psgi.run_once' => Plack::Util::FALSE,
'psgi.streaming' => Plack::Util::TRUE,
'psgi.nonblocking' => Plack::Util::FALSE,
'psgix.harakiri' => defined $proc_manager,
'psgix.cleanup' => 1,
'psgix.cleanup.handlers' => [],
};
delete $env->{HTTP_CONTENT_TYPE};
delete $env->{HTTP_CONTENT_LENGTH};
# lighttpd munges multiple slashes in PATH_INFO into one. Try recovering it
my $uri = URI->new("http://localhost" . $env->{REQUEST_URI});
$env->{PATH_INFO} = uri_unescape($uri->path);
$env->{PATH_INFO} =~ s/^\Q$env->{SCRIPT_NAME}\E//;
# root access for mod_fastcgi
if (!exists $env->{PATH_INFO}) {
$env->{PATH_INFO} = '';
}
# typical fastcgi_param from nginx might get empty values
for my $key (qw(CONTENT_TYPE CONTENT_LENGTH)) {
no warnings;
delete $env->{$key} if exists $env->{$key} && $env->{$key} eq '';
}
if (defined(my $HTTP_AUTHORIZATION = $env->{Authorization})) {
$env->{HTTP_AUTHORIZATION} = $HTTP_AUTHORIZATION;
}
my $res = Plack::Util::run_app $app, $env;
if (ref $res eq 'ARRAY') {
$self->_handle_response($res);
}
elsif (ref $res eq 'CODE') {
$res->(sub {
$self->_handle_response($_[0]);
});
}
else {
die "Bad response $res";
}
# give pm_post_dispatch the chance to do things after the client thinks
# the request is done
$request->Finish;
$proc_manager && $proc_manager->pm_post_dispatch();
# When the fcgi-manager exits it sends a TERM signal to the workers.
# However, if we're busy processing the cleanup handlers, testing
# shows that the worker doesn't actually exit in that case.
# Trapping the TERM signal and finshing up fixes that.
my $exit_due_to_signal = 0;
if ( @{ $env->{'psgix.cleanup.handlers'} || [] } ) {
local $SIG{TERM} = sub { $exit_due_to_signal = 1 };
for my $handler ( @{ $env->{'psgix.cleanup.handlers'} } ) {
$handler->($env);
}
}
examples/fatpacked.plackup view on Meta::CPAN
Plack::Loader::Restarter is a loader backend that implements C<-r> and
C<-R> option for the L<plackup> script. It forks the server as a child
process and the parent watches the directories for file updates, and
whenever it receives the notification, kills the child server and
restart.
=head1 SEE ALSO
L<Plack::Runner>, L<Catalyst::Restarter>
=cut
PLACK_LOADER_RESTARTER
$fatpacked{"Plack/Loader/Shotgun.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_LOADER_SHOTGUN';
package Plack::Loader::Shotgun;
use strict;
use parent qw(Plack::Loader);
use Storable;
use Try::Tiny;
use Plack::Middleware::BufferedStreaming;
die <<DIE if $^O eq 'MSWin32' && !$ENV{PLACK_SHOTGUN_MEMORY_LEAK};
Shotgun loader uses fork(2) system call to create a fresh Perl interpreter, that is known to not work
properly in a fork-emulation layer on Windows and cause huge memory leaks.
If you're aware of this and still want to run the loader, run it with the environment variable
PLACK_SHOTGUN_MEMORY_LEAK on.
DIE
sub preload_app {
my($self, $builder) = @_;
$self->{builder} = sub { Plack::Middleware::BufferedStreaming->wrap($builder->()) };
}
sub run {
my($self, $server) = @_;
my $app = sub {
my $env = shift;
pipe my $read, my $write;
my $pid = fork;
if ($pid) {
# parent
close $write;
my $res = Storable::thaw(join '', <$read>);
close $read;
waitpid($pid, 0);
return $res;
} else {
# child
close $read;
my $res;
try {
$env->{'psgi.streaming'} = 0;
$res = $self->{builder}->()->($env);
my @body;
Plack::Util::foreach($res->[2], sub { push @body, $_[0] });
$res->[2] = \@body;
} catch {
$env->{'psgi.errors'}->print($_);
$res = [ 500, [ "Content-Type", "text/plain" ], [ "Internal Server Error" ] ];
};
print {$write} Storable::freeze($res);
close $write;
exit;
}
};
$server->run($app);
}
1;
__END__
=head1 NAME
Plack::Loader::Shotgun - forking implementation of plackup
=head1 SYNOPSIS
plackup -L Shotgun
=head1 DESCRIPTION
Shotgun loader delays the compilation and execution of your
application until the runtime. When a new request comes in, this forks
a new child, compiles your code and runs the application.
This should be an ultimate alternative solution when reloading with
L<Plack::Middleware::Refresh> doesn't work, or plackup's default C<-r>
filesystem watcher causes problems. I can imagine this is useful for
applications which expects their application is only evaluated once
(like in-file templates) or on operating systems with broken fork
implementation, etc.
This is much like good old CGI's fork and run but you don't need a web
server, and there's a benefit of preloading modules that are not
likely to change. For instance if you develop a web application using
Moose and DBIx::Class,
plackup -MMoose -MDBIx::Class -L Shotgun yourapp.psgi
would preload those modules and only re-evaluates your code in every
request.
=head1 AUTHOR
Tatsuhiko Miyagawa with an inspiration from L<http://github.com/rtomayko/shotgun>
=head1 SEE ALSO
L<plackup>
examples/fatpacked.plackup view on Meta::CPAN
# $self->app is the original app
my $res = $self->app->($env);
# Do something with $res
return $res;
}
# then in app.psgi
use Plack::Builder;
my $app = sub { ... } # as usual
builder {
enable "Plack::Middleware::Foo";
enable "Plack::Middleware::Bar", %options;
$app;
};
=head1 DESCRIPTION
Plack::Middleware is a utility base class to write PSGI
middleware. All you have to do is to inherit from Plack::Middleware
and then implement the callback C<call> method (or the C<to_app> method
that would return the PSGI code reference) to do the actual work. You
can use C<< $self->app >> to call the original (wrapped) application.
Your middleware object is created at the PSGI application compile time
and is persistent during the web server life cycle (unless it is a
non-persistent environment such as CGI), so you should never set or
cache per-request data like C<$env> in your middleware object. See
also L<Plack::Component/"OBJECT LIFECYCLE">.
See L<Plack::Builder> how to actually enable middleware in your
I<.psgi> application file using the DSL. If you do not like our
builder DSL, you can also use the C<wrap> method to wrap your application
with a middleware:
use Plack::Middleware::Foo;
my $app = sub { ... };
$app = Plack::Middleware::Foo->wrap($app, %options);
$app = Plack::Middleware::Bar->wrap($app, %options);
=head1 RESPONSE CALLBACK
The typical middleware is written like this:
package Plack::Middleware::Something;
use parent qw(Plack::Middleware);
sub call {
my($self, $env) = @_;
# pre-processing $env
my $res = $self->app->($env);
# post-processing $res
return $res;
}
The tricky thing about post-processing the response is that it could
either be an immediate 3 element array ref, or a code reference that
implements the delayed (streaming) interface.
Dealing with these two types of response in each piece of middleware
is pointless, so you're recommended to use the C<response_cb> wrapper
function in L<Plack::Util> when implementing a post processing
middleware.
sub call {
my($self, $env) = @_;
# pre-processing $env
my $res = $self->app->($env);
return Plack::Util::response_cb($res, sub {
my $res = shift;
# do something with $res;
});
}
The callback function gets a response as an array reference, and you can
update the reference to implement the post-processing. In the normal
case, this arrayref will have three elements (as described by the PSGI
spec), but will have only two elements when using a C<$writer> as
described below.
package Plack::Middleware::Always500;
use parent qw(Plack::Middleware);
use Plack::Util;
sub call {
my($self, $env) = @_;
my $res = $self->app->($env);
return Plack::Util::response_cb($res, sub {
my $res = shift;
$res->[0] = 500;
return;
});
}
In this example, the callback gets the C<$res> and updates its first
element (status code) to 500. Using C<response_cb> makes sure that
this works with the delayed response too.
You're not required (and not recommended either) to return a new array
reference - they will be simply ignored. You're suggested to
explicitly return, unless you fiddle with the content filter callback
(see below).
Similarly, note that you have to keep the C<$res> reference when you
swap the entire response.
Plack::Util::response_cb($res, sub {
my $res = shift;
$res = [ $new_status, $new_headers, $new_body ]; # THIS DOES NOT WORK
return;
});
This does not work, since assigning a new anonymous array to C<$res>
doesn't update the original PSGI response value. You should instead
do:
Plack::Util::response_cb($res, sub {
my $res = shift;
@$res = ($new_status, $new_headers, $new_body); # THIS WORKS
return;
});
The third element of the response array ref is a body, and it could
be either an arrayref or L<IO::Handle>-ish object. The application could
also make use of the C<$writer> object if C<psgi.streaming> is in
effect, and in this case, the third element will not exist
(C<@$res == 2>). Dealing with these variants is again really painful,
and C<response_cb> can take care of that too, by allowing you to return
a content filter as a code reference.
# replace all "Foo" in content body with "Bar"
Plack::Util::response_cb($res, sub {
my $res = shift;
return sub {
my $chunk = shift;
return unless defined $chunk;
$chunk =~ s/Foo/Bar/g;
return $chunk;
}
});
The callback takes one argument C<$chunk> and your callback is
expected to return the updated chunk. If the given C<$chunk> is undef,
it means the stream has reached the end, so your callback should also
return undef, or return the final chunk and return undef when called
next time.
=head1 SEE ALSO
L<Plack> L<Plack::Builder> L<Plack::Component>
=cut
PLACK_MIDDLEWARE
$fatpacked{"Plack/Middleware/AccessLog.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE_ACCESSLOG';
package Plack::Middleware::AccessLog;
use strict;
use warnings;
use parent qw( Plack::Middleware );
use Plack::Util::Accessor qw( logger format compiled_format char_handlers block_handlers );
use Apache::LogFormat::Compiler;
my %formats = (
common => '%h %l %u %t "%r" %>s %b',
combined => '%h %l %u %t "%r" %>s %b "%{Referer}i" "%{User-agent}i"',
);
sub prepare_app {
my $self = shift;
my $fmt = $self->format || "combined";
$fmt = $formats{$fmt} if exists $formats{$fmt};
$self->compiled_format(Apache::LogFormat::Compiler->new($fmt,
char_handlers => $self->char_handlers || {},
block_handlers => $self->block_handlers || {},
));
}
sub call {
my $self = shift;
my($env) = @_;
my $res = $self->app->($env);
if ( ref($res) && ref($res) eq 'ARRAY' ) {
my $content_length = Plack::Util::content_length($res->[2]);
examples/fatpacked.plackup view on Meta::CPAN
supplied and returns whether the authentication succeeds. Required.
Authenticator can also be an object that responds to C<authenticate>
method that takes username and password and returns boolean, so
backends for L<Authen::Simple> is perfect to use:
use Authen::Simple::LDAP;
enable "Auth::Basic", authenticator => Authen::Simple::LDAP->new(...);
=item realm
Realm name to display in the basic authentication dialog. Defaults to I<restricted area>.
=back
=head1 LIMITATIONS
This middleware expects that the application has a full access to the
headers sent by clients in PSGI environment. That is normally the case
with standalone Perl PSGI web servers such as L<Starman> or
L<HTTP::Server::Simple::PSGI>.
However, in a web server configuration where you can't achieve this
(i.e. using your application via Apache's mod_cgi), this middleware
does not work since your application can't know the value of
C<Authorization:> header.
If you use Apache as a web server and CGI to run your PSGI
application, you can either a) compile Apache with
C<-DSECURITY_HOLE_PASS_AUTHORIZATION> option, or b) use mod_rewrite to
pass the Authorization header to the application with the rewrite rule
like following.
RewriteEngine on
RewriteRule .* - [E=HTTP_AUTHORIZATION:%{HTTP:Authorization},L]
=head1 AUTHOR
Tatsuhiko Miyagawa
=head1 SEE ALSO
L<Plack>
=cut
PLACK_MIDDLEWARE_AUTH_BASIC
$fatpacked{"Plack/Middleware/BufferedStreaming.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE_BUFFEREDSTREAMING';
package Plack::Middleware::BufferedStreaming;
use strict;
no warnings;
use Carp;
use Plack::Util;
use Plack::Util::Accessor qw(force);
use Scalar::Util qw(weaken);
use parent qw(Plack::Middleware);
sub call {
my ( $self, $env ) = @_;
my $caller_supports_streaming = $env->{'psgi.streaming'};
$env->{'psgi.streaming'} = Plack::Util::TRUE;
my $res = $self->app->($env);
return $res if $caller_supports_streaming && !$self->force;
if ( ref($res) eq 'CODE' ) {
my $ret;
$res->(sub {
my $write = shift;
if ( @$write == 2 ) {
my @body;
$ret = [ @$write, \@body ];
return Plack::Util::inline_object(
write => sub { push @body, $_[0] },
close => sub { },
);
} else {
$ret = $write;
return;
}
});
return $ret;
} else {
return $res;
}
}
1;
__END__
=head1 NAME
Plack::Middleware::BufferedStreaming - Enable buffering for non-streaming aware servers
=head1 SYNOPSIS
enable "BufferedStreaming";
=head1 DESCRIPTION
Plack::Middleware::BufferedStreaming is a PSGI middleware component
that wraps the application that uses C<psgi.streaming> interface to
run on the servers that do not support the interface, by buffering the
writer output to a temporary buffer.
This middleware doesn't do anything and bypass the application if the
server supports C<psgi.streaming> interface, unless you set C<force>
option (see below).
=head1 OPTIONS
=over 4
=item force
Force enable this middleware only if the container supports C<psgi.streaming>.
=back
=head1 AUTHOR
Yuval Kogman
Tatsuhiko Miyagawa
=cut
PLACK_MIDDLEWARE_BUFFEREDSTREAMING
$fatpacked{"Plack/Middleware/Chunked.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE_CHUNKED';
package Plack::Middleware::Chunked;
use strict;
use parent qw(Plack::Middleware);
use Plack::Util;
sub call {
my($self, $env) = @_;
my $res = $self->app->($env);
$self->response_cb($res, sub {
my $res = shift;
my $h = Plack::Util::headers($res->[1]);
if ($env->{'SERVER_PROTOCOL'} ne 'HTTP/1.0' and
! Plack::Util::status_with_no_entity_body($res->[0]) and
! $h->exists('Content-Length') and
! $h->exists('Transfer-Encoding')
) {
$h->set('Transfer-Encoding' => 'chunked');
my $done;
return sub {
my $chunk = shift;
return if $done;
unless (defined $chunk) {
$done = 1;
return "0\015\012\015\012";
}
return '' unless length $chunk;
return sprintf('%x', length $chunk) . "\015\012$chunk\015\012";
};
}
});
}
1;
__END__
=head1 NAME
Plack::Middleware::Chunked - Applies chunked encoding to the response body
=head1 SYNOPSIS
# Mostly from server implementations
$app = Plack::Middleware::Chunked->wrap($app);
=head1 DESCRIPTION
examples/fatpacked.plackup view on Meta::CPAN
$fatpacked{"Plack/Middleware/JSONP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE_JSONP';
package Plack::Middleware::JSONP;
use strict;
use parent qw(Plack::Middleware);
use Plack::Util;
use URI::Escape ();
use Plack::Util::Accessor qw/callback_key/;
sub prepare_app {
my $self = shift;
unless (defined $self->callback_key) {
$self->callback_key('callback');
}
}
sub call {
my($self, $env) = @_;
my $res = $self->app->($env);
$self->response_cb($res, sub {
my $res = shift;
if (defined $res->[2]) {
my $h = Plack::Util::headers($res->[1]);
my $callback_key = $self->callback_key;
if ($h->get('Content-Type') =~ m!/(?:json|javascript)! &&
$env->{QUERY_STRING} =~ /(?:^|&)$callback_key=([^&]+)/) {
my $cb = URI::Escape::uri_unescape($1);
if ($cb =~ /^[\w\.\[\]]+$/) {
my $body;
Plack::Util::foreach($res->[2], sub { $body .= $_[0] });
my $jsonp = "/**/$cb($body)";
$res->[2] = [ $jsonp ];
$h->set('Content-Length', length $jsonp);
$h->set('Content-Type', 'text/javascript');
}
}
}
});
}
1;
__END__
=head1 NAME
Plack::Middleware::JSONP - Wraps JSON response in JSONP if callback parameter is specified
=head1 SYNOPSIS
enable "JSONP", callback_key => 'jsonp';
=head1 DESCRIPTION
Plack::Middleware::JSONP wraps JSON response, which has Content-Type
value either C<text/javascript> or C<application/json> as a JSONP
response which is specified with the C<callback> query parameter. The
name of the parameter can be set while enabling the middleware.
This middleware only works with a non-streaming response, and doesn't
touch the response otherwise.
=head1 AUTHOR
Tatsuhiko Miyagawa
=head1 SEE ALSO
L<Plack>
=cut
PLACK_MIDDLEWARE_JSONP
$fatpacked{"Plack/Middleware/LighttpdScriptNameFix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE_LIGHTTPDSCRIPTNAMEFIX';
package Plack::Middleware::LighttpdScriptNameFix;
use strict;
use parent qw/Plack::Middleware/;
use Plack::Util::Accessor qw(script_name);
sub prepare_app {
my $self = shift;
my $script_name = $self->script_name;
$script_name = '' unless defined($script_name);
$script_name =~ s!/$!!;
$self->script_name($script_name);
}
sub call {
my($self, $env) = @_;
if ($env->{SERVER_SOFTWARE} && $env->{SERVER_SOFTWARE} =~ /lighttpd/) {
$env->{PATH_INFO} = $env->{SCRIPT_NAME} . $env->{PATH_INFO};
$env->{SCRIPT_NAME} = $self->script_name;
$env->{PATH_INFO} =~ s/^\Q$env->{SCRIPT_NAME}\E//;
}
return $self->app->($env);
}
1;
__END__
=head1 NAME
Plack::Middleware::LighttpdScriptNameFix - fixes wrong SCRIPT_NAME and PATH_INFO that lighttpd sets
=head1 SYNOPSIS
# in your app.psgi
use Plack::Builder;
builder {
enable "LighttpdScriptNameFix";
$app;
};
# Or from the command line
examples/fatpacked.plackup view on Meta::CPAN
sub call {
my $self = shift;
my $env = shift;
$self->validate_env($env);
my $res = $self->app->($env);
return $self->validate_res($res);
}
sub validate_env {
my ($self, $env) = @_;
unless ($env->{REQUEST_METHOD}) {
die('Missing env param: REQUEST_METHOD');
}
unless ($env->{REQUEST_METHOD} =~ /^[A-Z]+$/) {
die("Invalid env param: REQUEST_METHOD($env->{REQUEST_METHOD})");
}
unless (defined($env->{SCRIPT_NAME})) { # allows empty string
die('Missing mandatory env param: SCRIPT_NAME');
}
if ($env->{SCRIPT_NAME} eq '/') {
die('SCRIPT_NAME must not be /');
}
unless (defined($env->{PATH_INFO})) { # allows empty string
die('Missing mandatory env param: PATH_INFO');
}
if ($env->{PATH_INFO} ne '' && $env->{PATH_INFO} !~ m!^/!) {
die('PATH_INFO must begin with / ($env->{PATH_INFO})');
}
unless (defined($env->{SERVER_NAME})) {
die('Missing mandatory env param: SERVER_NAME');
}
if ($env->{SERVER_NAME} eq '') {
die('SERVER_NAME must not be empty string');
}
unless (defined($env->{SERVER_PORT})) {
die('Missing mandatory env param: SERVER_PORT');
}
if ($env->{SERVER_PORT} eq '') {
die('SERVER_PORT must not be empty string');
}
if (defined($env->{SERVER_PROTOCOL}) and $env->{SERVER_PROTOCOL} !~ m{^HTTP/\d}) {
die("Invalid SERVER_PROTOCOL: $env->{SERVER_PROTOCOL}");
}
for my $param (qw/version url_scheme input errors multithread multiprocess/) {
unless (exists $env->{"psgi.$param"}) {
die("Missing psgi.$param");
}
}
unless (ref($env->{'psgi.version'}) eq 'ARRAY') {
die("psgi.version should be ArrayRef: $env->{'psgi.version'}");
}
unless (scalar(@{$env->{'psgi.version'}}) == 2) {
die('psgi.version should contain 2 elements, not ', scalar(@{$env->{'psgi.version'}}));
}
unless ($env->{'psgi.url_scheme'} =~ /^https?$/) {
die("psgi.url_scheme should be 'http' or 'https': ", $env->{'psgi.url_scheme'});
}
if ($env->{"psgi.version"}->[1] == 1) { # 1.1
for my $param (qw(streaming nonblocking run_once)) {
unless (exists $env->{"psgi.$param"}) {
die("Missing psgi.$param");
}
}
}
if ($env->{HTTP_CONTENT_TYPE}) {
die('HTTP_CONTENT_TYPE should not exist');
}
if ($env->{HTTP_CONTENT_LENGTH}) {
die('HTTP_CONTENT_LENGTH should not exist');
}
}
sub is_possibly_fh {
my $fh = shift;
ref $fh eq 'GLOB' &&
*{$fh}{IO} &&
*{$fh}{IO}->can('getline');
}
sub validate_res {
my ($self, $res, $streaming) = @_;
unless (ref($res) eq 'ARRAY' or ref($res) eq 'CODE') {
die("Response should be array ref or code ref: $res");
}
if (ref $res eq 'CODE') {
return $self->response_cb($res, sub { $self->validate_res(@_, 1) });
}
unless (@$res == 3 || ($streaming && @$res == 2)) {
die('Response needs to be 3 element array, or 2 element in streaming');
}
unless ($res->[0] =~ /^\d+$/ && $res->[0] >= 100) {
die("Status code needs to be an integer greater than or equal to 100: $res->[0]");
}
unless (ref $res->[1] eq 'ARRAY') {
die("Headers needs to be an array ref: $res->[1]");
}
my @copy = @{$res->[1]};
unless (@copy % 2 == 0) {
die('The number of response headers needs to be even, not odd(', scalar(@copy), ')');
}
while(my($key, $val) = splice(@copy, 0, 2)) {
if (lc $key eq 'status') {
die('Response headers MUST NOT contain a key named Status');
}
if ($key =~ /[:\r\n]|[-_]$/) {
die("Response headers MUST NOT contain a key with : or newlines, or that end in - or _. Header: $key");
}
unless ($key =~ /^[a-zA-Z][0-9a-zA-Z\-_]*$/) {
die("Response headers MUST consist only of letters, digits, _ or - and MUST start with a letter. Header: $key");
}
if ($val =~ /[\000-\037]/) {
die("Response headers MUST NOT contain characters below octal \037. Header: $key. Value: $val");
}
unless (defined $val) {
die("Response headers MUST be a defined string. Header: $key");
}
}
# @$res == 2 is only right in psgi.streaming, and it's already checked.
unless (@$res == 2 ||
ref $res->[2] eq 'ARRAY' ||
Plack::Util::is_real_fh($res->[2]) ||
is_possibly_fh($res->[2]) ||
(blessed($res->[2]) && $res->[2]->can('getline'))) {
die("Body should be an array ref or filehandle: $res->[2]");
}
if (ref $res->[2] eq 'ARRAY' && grep _has_wide_char($_), @{$res->[2]}) {
die("Body must be bytes and should not contain wide characters (UTF-8 strings)");
}
return $res;
}
# NOTE: Some modules like HTML:: or XML:: could possibly generate
# ASCII/Latin-1 strings with utf8 flags on. They're actually safe to
# print, so there's no need to give warnings about it.
sub _has_wide_char {
my $str = shift;
utf8::is_utf8($str) && $str =~ /[^\x00-\xff]/;
}
1;
__END__
=head1 NAME
Plack::Middleware::Lint - Validate request and response
=head1 SYNOPSIS
use Plack::Middleware::Lint;
my $app = sub { ... }; # your app or middleware
$app = Plack::Middleware::Lint->wrap($app);
# Or from plackup
plackup -e 'enable "Lint"' myapp.psgi
=head1 DESCRIPTION
Plack::Middleware::Lint is a middleware component to validate request
and response environment formats. You are strongly suggested to use
this middleware when you develop a new framework adapter or a new PSGI
web server that implements the PSGI interface.
This middleware is enabled by default when you run plackup or other
launcher tools with the default environment I<development> value.
=head1 DEBUGGING
Because of how this middleware works, it may not be easy to debug Lint
errors when you encounter one, unless you're writing a PSGI web server
or a framework.
For example, when you're an application developer (user of some
framework) and see errors like:
Body should be an array ref or filehandle at lib/Plack/Middleware/Lint.pm line XXXX
examples/fatpacked.plackup view on Meta::CPAN
return $err if ref $err;
# Ugly hack to remove " at ... line ..." automatically appended by perl
# If there's a proper way to do this, please let me know.
$err =~ s/ at \Q$caller->[1]\E line $caller->[2]\.\n$//;
return $err;
}
sub utf8_safe {
my $str = shift;
# NOTE: I know messing with utf8:: in the code is WRONG, but
# because we're running someone else's code that we can't
# guarantee which encoding an exception is encoded, there's no
# better way than doing this. The latest Devel::StackTrace::AsHTML
# (0.08 or later) encodes high-bit chars as HTML entities, so this
# path won't be executed.
if (utf8::is_utf8($str)) {
utf8::encode($str);
}
$str;
}
1;
__END__
=head1 NAME
Plack::Middleware::StackTrace - Displays stack trace when your app dies
=head1 SYNOPSIS
enable "StackTrace";
=head1 DESCRIPTION
This middleware uses C<$SIG{__DIE__}> to intercept I<all> exceptions
(run-time errors) happening in your application, even those that are caught.
For each exception it builds a detailed stack trace.
If the applications aborts by throwing an exception it will be caught and matched
against the saved stack traces. If a match is found it will be displayed as a nice
stack trace screen, if not then the exception will be reported without a stack trace.
The stack trace is also stored in the environment as a plaintext and HTML under the key
C<plack.stacktrace.text> and C<plack.stacktrace.html> respectively, so
that middleware further up the stack can reference it.
This middleware is enabled by default when you run L<plackup> in the
default I<development> mode.
You're recommended to use this middleware during the development and
use L<Plack::Middleware::HTTPExceptions> in the deployment mode as a
replacement, so that all the exceptions thrown from your application
still get caught and rendered as a 500 error response, rather than
crashing the web server.
Catching errors in streaming response is not supported.
=head2 Stack Trace Module
The L<Devel::StackTrace::WithLexicals> module will be used to capture the stack trace
if the installed version is 0.08 or later. Otherwise L<Devel::StackTrace> is used.
=head2 Performance
Gathering the information for a stack trace via L<Devel::StackTrace> is slow,
and L<Devel::StackTrace::WithLexicals> is significantly slower still.
This is not usually a concern in development and when exceptions are rare.
However, your application may include code that's throwing and catching exceptions
that you're not aware of. Such code will run I<significantly> slower with this module.
=head1 CONFIGURATION
=over 4
=item force
enable "StackTrace", force => 1;
Force display the stack trace when an error occurs within your
application and the response code from your application is
500. Defaults to off.
The use case of this option is that when your framework catches all
the exceptions in the main handler and returns all failures in your
code as a normal 500 PSGI error response. In such cases, this
middleware would never have a chance to display errors because it
can't tell if it's an application error or just random C<eval> in your
code. This option enforces the middleware to display stack trace even
if it's not the direct error thrown by the application.
=item no_print_errors
enable "StackTrace", no_print_errors => 1;
Skips printing the text stacktrace to console
(C<psgi.errors>). Defaults to 0, which means the text version of the
stack trace error is printed to the errors handle, which usually is a
standard error.
=back
=head1 AUTHOR
Tokuhiro Matsuno
Tatsuhiko Miyagawa
=head1 SEE ALSO
L<Devel::StackTrace::AsHTML> L<Plack::Middleware> L<Plack::Middleware::HTTPExceptions>
=cut
PLACK_MIDDLEWARE_STACKTRACE
$fatpacked{"Plack/Middleware/Static.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE_STATIC';
examples/fatpacked.plackup view on Meta::CPAN
my $env = shift;
return [ 200, [ 'Content-Type' => 'text/plain' ], [ $env->{REQUEST_URI} ] ];
},
],
[
'filehandle with path()',
sub {
my $cb = shift;
my $res = $cb->(GET "http://127.0.0.1/foo.jpg");
is $res->code, 200;
is $res->message, 'OK';
is $res->header('content_type'), 'image/jpeg';
is length $res->content, 2898;
},
sub {
my $env = shift;
open my $fh, '<', "$share_dir/face.jpg";
Plack::Util::set_io_path($fh, "$share_dir/face.jpg");
return [
200,
[ 'Content-Type' => 'image/jpeg', 'Content-Length' => -s $fh ],
$fh
];
},
],
[
'a big header value > 128 bytes',
sub {
my $cb = shift;
my $req = GET "http://127.0.0.1/";
my $v = ("abcdefgh" x 16);
$req->header('X-Foo' => $v);
my $res = $cb->($req);
is $res->code, 200;
is $res->message, 'OK';
is $res->content, $v;
},
sub {
my $env = shift;
return [
200,
[ 'Content-Type' => 'text/plain' ],
[ $env->{HTTP_X_FOO} ],
];
},
],
[
'coderef res',
sub {
my $cb = shift;
my $res = $cb->(GET "http://127.0.0.1/?name=miyagawa");
return if $res->code == 501;
is $res->code, 200;
is $res->message, 'OK';
is $res->header('content_type'), 'text/plain';
is $res->content, 'Hello, name=miyagawa';
},
sub {
my $env = shift;
$env->{'psgi.streaming'} or return [ 501, ['Content-Type','text/plain'], [] ];
return sub {
my $respond = shift;
$respond->([
200,
[ 'Content-Type' => 'text/plain', ],
[ 'Hello, ' . $env->{QUERY_STRING} ],
]);
}
},
],
[
'coderef streaming',
sub {
my $cb = shift;
my $res = $cb->(GET "http://127.0.0.1/?name=miyagawa");
return if $res->code == 501;
is $res->code, 200;
is $res->message, 'OK';
is $res->header('content_type'), 'text/plain';
is $res->content, 'Hello, name=miyagawa';
},
sub {
my $env = shift;
$env->{'psgi.streaming'} or return [ 501, ['Content-Type','text/plain'], [] ];
return sub {
my $respond = shift;
my $writer = $respond->([
200,
[ 'Content-Type' => 'text/plain', ],
]);
$writer->write("Hello, ");
$writer->write($env->{QUERY_STRING});
$writer->close();
}
},
],
[
'CRLF output and FCGI parse bug',
sub {
my $cb = shift;
my $res = $cb->(GET "http://127.0.0.1/");
is $res->header("Foo"), undef;
is $res->content, "Foo: Bar\r\n\r\nHello World";
},
sub {
return [ 200, [ "Content-Type", "text/plain" ], [ "Foo: Bar\r\n\r\nHello World" ] ];
},
],
[
'newlines',
sub {
my $cb = shift;
my $res = $cb->(GET "http://127.0.0.1/");
is length($res->content), 7;
},
sub {
return [ 200, [ "Content-Type", "text/plain" ], [ "Bar\nBaz" ] ];
},
],
[
'test 404',
sub {
my $cb = shift;
my $res = $cb->(GET "http://127.0.0.1/");
is $res->code, 404;
is $res->message, 'Not Found';
is $res->content, 'Not Found';
},
sub {
return [ 404, [ "Content-Type", "text/plain" ], [ "Not Found" ] ];
},
],
[
'request->input seekable',
sub {
my $cb = shift;
my $req = HTTP::Request->new(POST => "http://127.0.0.1/");
$req->content("body");
$req->content_type('text/plain');
$req->content_length(4);
( run in 1.132 second using v1.01-cache-2.11-cpan-140bd7fdf52 )