Container-Builder
view release on metacpan or search on metacpan
examples/fatpacked.plackup view on Meta::CPAN
my $log_handler = Apache::LogFormat::Compiler->new(
'%z %{HTTP_X_FORWARDED_FOR|REMOTE_ADDR}Z',
char_handlers => +{
'z' => sub {
my ($env,$req) = @_;
return $env->{HTTP_X_FORWARDED_FOR};
}
},
block_handlers => +{
'Z' => sub {
my ($block,$env,$req) = @_;
# block eq 'HTTP_X_FORWARDED_FOR|REMOTE_ADDR'
my ($main, $alt) = split('\|', $args);
return exists $env->{$main} ? $env->{$main} : $env->{$alt};
}
},
);
Any single letter can be used, other than those already defined by Apache::LogFormat::Compiler.
Your sub is called with two or three arguments: the content inside the C<{}>
from the format (block_handlers only), the PSGI environment (C<$env>),
and the ArrayRef of the response. It should return the string to be logged.
=head1 AUTHOR
Masahiro Nagano E<lt>kazeburo@gmail.comE<gt>
=head1 SEE ALSO
L<Plack::Middleware::AccessLog>, L<http://httpd.apache.org/docs/2.2/mod/mod_log_config.html>
=head1 LICENSE
Copyright (C) Masahiro Nagano
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
APACHE_LOGFORMAT_COMPILER
$fatpacked{"HTTP/Message/PSGI.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_MESSAGE_PSGI';
package HTTP::Message::PSGI;
use strict;
use warnings;
use parent qw(Exporter);
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/^\/+/\//;
}
examples/fatpacked.plackup view on Meta::CPAN
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;
my $content = '';
while (defined(my $buf = $body->getline)) {
$content .= $buf;
}
$body->close;
$res->content($content);
}
${ $res_ref } = $res;
return;
};
if (!defined $body) {
$body = [];
my $o = Plack::Util::inline_object
write => sub { push @$body, @_ },
close => $convert_resp;
return $o;
}
$convert_resp->();
}
sub HTTP::Request::to_psgi {
req_to_psgi(@_);
}
sub HTTP::Response::from_psgi {
my $class = shift;
res_from_psgi(@_);
}
package
HTTP::Message::PSGI::ChunkedInput;
sub new {
my($class, $content, $chunked) = @_;
my $content_cb;
if ($chunked) {
my $done;
$content_cb = sub {
my $chunk = $content->();
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";
};
} else {
$content_cb = $content;
}
bless { content => $content_cb }, $class;
}
sub read {
my $self = shift;
my $chunk = $self->{content}->();
return 0 unless defined $chunk;
$_[0] = '';
substr($_[0], $_[2] || 0, length $chunk) = $chunk;
return length $chunk;
}
sub close { }
package HTTP::Message::PSGI;
1;
__END__
=head1 NAME
HTTP::Message::PSGI - Converts HTTP::Request and HTTP::Response from/to PSGI env and response
=head1 SYNOPSIS
use HTTP::Message::PSGI;
# $req is HTTP::Request, $res is HTTP::Response
my $env = req_to_psgi($req);
my $res = res_from_psgi([ $status, $headers, $body ]);
# Adds methods to HTTP::Request/Response class as well
my $env = $req->to_psgi;
my $res = HTTP::Response->from_psgi([ $status, $headers, $body ]);
=head1 DESCRIPTION
HTTP::Message::PSGI gives you convenient methods to convert an L<HTTP::Request>
object to a PSGI env hash and convert a PSGI response arrayref to
a L<HTTP::Response> object.
If you want the other way around, see L<Plack::Request> and
L<Plack::Response>.
=head1 METHODS
=over 4
=item req_to_psgi
my $env = req_to_psgi($req [, $key => $val ... ]);
Converts a L<HTTP::Request> object into a PSGI env hash reference.
=item HTTP::Request::to_psgi
my $env = $req->to_psgi;
Same as C<req_to_psgi> but an instance method in L<HTTP::Request>.
=item res_from_psgi
my $res = res_from_psgi([ $status, $headers, $body ]);
Creates a L<HTTP::Response> object from a PSGI response array ref.
=item HTTP::Response->from_psgi
my $res = HTTP::Response->from_psgi([ $status, $headers, $body ]);
Same as C<res_from_psgi>, but is a class method in L<HTTP::Response>.
=back
=head1 AUTHOR
Tatsuhiko Miyagawa
=head1 SEE ALSO
L<HTTP::Request::AsCGI> L<HTTP::Message> L<Plack::Test>
=cut
HTTP_MESSAGE_PSGI
$fatpacked{"HTTP/Server/PSGI.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_SERVER_PSGI';
package HTTP::Server::PSGI;
use strict;
use warnings;
use Carp ();
use Plack;
use Plack::HTTPParser qw( parse_http_request );
use IO::Socket::INET;
use HTTP::Date;
use HTTP::Status;
use List::Util qw(max sum);
use Plack::Util;
use Stream::Buffered;
use Plack::Middleware::ContentLength;
use POSIX qw(EINTR);
use Socket qw(IPPROTO_TCP);
use Try::Tiny;
use Time::HiRes qw(time);
use constant TCP_NODELAY => try { Socket::TCP_NODELAY };
my $alarm_interval;
BEGIN {
if ($^O eq 'MSWin32') {
$alarm_interval = 1;
} else {
Time::HiRes->import('alarm');
$alarm_interval = 0.1;
}
}
use constant MAX_REQUEST_SIZE => 131072;
use constant MSWin32 => $^O eq 'MSWin32';
sub new {
my($class, %args) = @_;
my $self = bless {
($args{listen_sock} ? (
listen_sock => $args{listen_sock},
host => $args{listen_sock}->sockhost,
port => $args{listen_sock}->sockport,
):(
host => $args{host} || 0,
port => $args{port} || 8080,
)),
timeout => $args{timeout} || 300,
server_software => $args{server_software} || $class,
server_ready => $args{server_ready} || sub {},
ssl => $args{ssl},
ipv6 => $args{ipv6},
ssl_key_file => $args{ssl_key_file},
ssl_cert_file => $args{ssl_cert_file},
examples/fatpacked.plackup view on Meta::CPAN
would be loaded (via perl's core function C<do>) to return the PSGI
application code reference.
# Hello.psgi
my $app = sub {
my $env = shift;
# ...
return [ $status, $headers, $body ];
};
If you use a web framework, chances are that they provide a helper
utility to automatically generate these C<.psgi> files for you, such
as:
# MyApp.psgi
use MyApp;
my $app = sub { MyApp->run_psgi(@_) };
It's important that the return value of C<.psgi> file is the code
reference. See C<eg/dot-psgi> directory for more examples of C<.psgi>
files.
=head2 plackup, Plack::Runner
L<plackup> is a command line launcher to run PSGI applications from
command line using L<Plack::Loader> to load PSGI backends. It can be
used to run standalone servers and FastCGI daemon processes. Other
server backends like Apache2 needs a separate configuration but
C<.psgi> application file can still be the same.
If you want to write your own frontend that replaces, or adds
functionalities to L<plackup>, take a look at the L<Plack::Runner> module.
=head2 Plack::Middleware
PSGI middleware is a PSGI application that wraps an existing PSGI
application and plays both side of application and servers. From the
servers the wrapped code reference still looks like and behaves
exactly the same as PSGI applications.
L<Plack::Middleware> gives you an easy way to wrap PSGI applications
with a clean API, and compatibility with L<Plack::Builder> DSL.
=head2 Plack::Builder
L<Plack::Builder> gives you a DSL that you can enable Middleware in
C<.psgi> files to wrap existent PSGI applications.
=head2 Plack::Request, Plack::Response
L<Plack::Request> gives you a nice wrapper API around PSGI C<$env>
hash to get headers, cookies and query parameters much like
L<Apache::Request> in mod_perl.
L<Plack::Response> does the same to construct the response array
reference.
=head2 Plack::Test
L<Plack::Test> is a unified interface to test your PSGI application
using standard L<HTTP::Request> and L<HTTP::Response> pair with simple
callbacks.
=head2 Plack::Test::Suite
L<Plack::Test::Suite> is a test suite to test a new PSGI server backend.
=head1 CONTRIBUTING
=head2 Patches and Bug Fixes
Small patches and bug fixes can be either submitted via nopaste on IRC
L<irc://irc.perl.org/#plack> or L<the github issue
tracker|http://github.com/plack/Plack/issues>. Forking on
L<github|http://github.com/plack/Plack> is another good way if you
intend to make larger fixes.
See also L<http://contributing.appspot.com/plack> when you think this
document is terribly outdated.
=head2 Module Namespaces
Modules added to the Plack:: sub-namespaces should be reasonably generic
components which are useful as building blocks and not just simply using
Plack.
Middleware authors are free to use the Plack::Middleware:: namespace for
their middleware components. Middleware must be written in the pipeline
style such that they can chained together with other middleware components.
The Plack::Middleware:: modules in the core distribution are good examples
of such modules. It is recommended that you inherit from L<Plack::Middleware>
for these types of modules.
Not all middleware components are wrappers, but instead are more like
endpoints in a middleware chain. These types of components should use the
Plack::App:: namespace. Again, look in the core modules to see excellent
examples of these (L<Plack::App::File>, L<Plack::App::Directory>, etc.).
It is recommended that you inherit from L<Plack::Component> for these
types of modules.
B<DO NOT USE> Plack:: namespace to build a new web application or a
framework. It's like naming your application under CGI:: namespace if
it's supposed to run on CGI and that is a really bad choice and
would confuse people badly.
=head1 AUTHOR
Tatsuhiko Miyagawa
=head1 COPYRIGHT
The following copyright notice applies to all the files provided in
this distribution, including binary files, unless explicitly noted
otherwise.
Copyright 2009-2013 Tatsuhiko Miyagawa
=head1 CORE DEVELOPERS
Tatsuhiko Miyagawa (miyagawa)
examples/fatpacked.plackup view on Meta::CPAN
--host 127.0.0.1 --port 9091 --timeout 120
=head1 DESCRIPTION
Plack::Handler::Standalone is an adapter for default Plack server
implementation L<HTTP::Server::PSGI>. This is just an alias for
L<Plack::Handler::HTTP::Server::PSGI>.
=head1 SEE ALSO
L<Plack::Handler::HTTP::Server::PSGI>
=cut
PLACK_HANDLER_STANDALONE
$fatpacked{"Plack/LWPish.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_LWPISH';
package Plack::LWPish;
use strict;
use warnings;
use HTTP::Tiny;
use HTTP::Response;
use Hash::MultiValue;
sub new {
my $class = shift;
my $self = bless {}, $class;
$self->{http} = @_ == 1 ? $_[0] : HTTP::Tiny->new(verify_SSL => 1, @_);
$self;
}
sub request {
my($self, $req) = @_;
my @headers;
$req->headers->scan(sub { push @headers, @_ });
my $options = {
headers => Hash::MultiValue->new(@headers)->mixed,
};
$options->{content} = $req->content if defined $req->content && length($req->content);
my $response = $self->{http}->request($req->method, $req->url, $options);
my $res = HTTP::Response->new(
$response->{status},
$response->{reason},
[ Hash::MultiValue->from_mixed($response->{headers})->flatten ],
$response->{content},
);
$res->request($req);
return $res;
}
1;
__END__
=head1 NAME
Plack::LWPish - HTTP::Request/Response compatible interface with HTTP::Tiny backend
=head1 SYNOPSIS
use Plack::LWPish;
my $request = HTTP::Request->new(GET => 'http://perl.com/');
my $ua = Plack::LWPish->new;
my $res = $ua->request($request); # returns HTTP::Response
=head1 DESCRIPTION
This module is an adapter object that implements one method,
C<request> that acts like L<LWP::UserAgent>'s request method
i.e. takes HTTP::Request object and returns HTTP::Response object.
This module is used solely inside L<Plack::Test::Suite> and
L<Plack::Test::Server>, and you are recommended to take a look at
L<HTTP::Thin> if you would like to use this outside Plack.
=head1 AUTHOR
Tatsuhiko Miyagawa
=head1 SEE ALSO
L<HTTP::Thin> L<HTTP::Tiny> L<LWP::UserAgent>
=cut
PLACK_LWPISH
$fatpacked{"Plack/Loader.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_LOADER';
package Plack::Loader;
use strict;
use Carp ();
use Plack::Util;
use Try::Tiny;
sub new {
my $class = shift;
bless {}, $class;
}
sub watch {
# do nothing. Override in subclass
}
sub auto {
my($class, @args) = @_;
my $backend = $class->guess
or Carp::croak("Couldn't auto-guess server server implementation. Set it with PLACK_SERVER");
my $server = try {
$class->load($backend, @args);
} catch {
if (($ENV{PLACK_ENV}||'') eq 'development' or !/^Can't locate /) {
warn "Autoloading '$backend' backend failed. Falling back to the Standalone. ",
"(You might need to install Plack::Handler::$backend from CPAN. Caught error was: $_)\n"
if $ENV{PLACK_ENV} && $ENV{PLACK_ENV} eq 'development';
}
$class->load('Standalone' => @args);
};
return $server;
}
sub load {
my($class, $server, @args) = @_;
my($server_class, $error);
try {
$server_class = Plack::Util::load_class($server, 'Plack::Handler');
} catch {
$error ||= $_;
examples/fatpacked.plackup view on Meta::CPAN
for you to subclass Plack::Request and define methods such as:
sub uri_for {
my($self, $path, $args) = @_;
my $uri = $self->base;
$uri->path($uri->path . $path);
$uri->query_form(@$args) if $args;
$uri;
}
So you can say:
my $link = $req->uri_for('/logout', [ signoff => 1 ]);
and if C<< $req->base >> is C</app> you'll get the full URI for
C</app/logout?signoff=1>.
=head1 INCOMPATIBILITIES
In version 0.99, many utility methods are removed or deprecated, and
most methods are made read-only. These methods were deleted in version
1.0001.
All parameter-related methods such as C<parameters>,
C<body_parameters>, C<query_parameters> and C<uploads> now contains
L<Hash::MultiValue> objects, rather than I<scalar or an array
reference depending on the user input> which is insecure. See
L<Hash::MultiValue> for more about this change.
C<< $req->path >> method had a bug, where the code and the document
was mismatching. The document was suggesting it returns the sub
request path after C<< $req->base >> but the code was always returning
the absolute URI path. The code is now updated to be an alias of C<<
$req->path_info >> but returns C</> in case it's empty. If you need
the older behavior, just call C<< $req->uri->path >> instead.
Cookie handling is simplified, and doesn't use L<CGI::Simple::Cookie>
anymore, which means you B<CAN NOT> set array reference or hash
reference as a cookie value and expect it be serialized. You're always
required to set string value, and encoding or decoding them is totally
up to your application or framework. Also, C<cookies> hash reference
now returns I<strings> for the cookies rather than CGI::Simple::Cookie
objects, which means you no longer have to write a wacky code such as:
$v = $req->cookies->{foo} ? $req->cookies->{foo}->value : undef;
and instead, simply do:
$v = $req->cookies->{foo};
=head1 AUTHORS
Tatsuhiko Miyagawa
Kazuhiro Osawa
Tokuhiro Matsuno
=head1 SEE ALSO
L<Plack::Response> L<HTTP::Request>, L<Catalyst::Request>
=head1 LICENSE
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
PLACK_REQUEST
$fatpacked{"Plack/Request/Upload.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_REQUEST_UPLOAD';
package Plack::Request::Upload;
use strict;
use warnings;
use Carp ();
sub new {
my($class, %args) = @_;
bless {
headers => $args{headers},
tempname => $args{tempname},
size => $args{size},
filename => $args{filename},
}, $class;
}
sub filename { $_[0]->{filename} }
sub headers { $_[0]->{headers} }
sub size { $_[0]->{size} }
sub tempname { $_[0]->{tempname} }
sub path { $_[0]->{tempname} }
sub content_type {
my $self = shift;
$self->{headers}->content_type(@_);
}
sub type { shift->content_type(@_) }
sub basename {
my $self = shift;
unless (defined $self->{basename}) {
require File::Spec::Unix;
my $basename = $self->{filename};
$basename =~ s|\\|/|g;
$basename = ( File::Spec::Unix->splitpath($basename) )[2];
$basename =~ s|[^\w\.-]+|_|g;
$self->{basename} = $basename;
}
$self->{basename};
}
1;
__END__
=head1 NAME
Plack::Request::Upload - handles file upload requests
=head1 SYNOPSIS
examples/fatpacked.plackup view on Meta::CPAN
}
return $class->SUPER::new(@_);
}
1;
PLACK_TEMPBUFFER
$fatpacked{"Plack/Test.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_TEST';
package Plack::Test;
use strict;
use warnings;
use Carp;
use parent qw(Exporter);
our @EXPORT = qw(test_psgi);
our $Impl;
$Impl ||= $ENV{PLACK_TEST_IMPL} || "MockHTTP";
sub create {
my($class, $app, @args) = @_;
my $subclass = "Plack::Test::$Impl";
eval "require $subclass";
die $@ if $@;
no strict 'refs';
if (defined &{"Plack::Test::$Impl\::test_psgi"}) {
return \&{"Plack::Test::$Impl\::test_psgi"};
}
$subclass->new($app, @args);
}
sub test_psgi {
if (ref $_[0] && @_ == 2) {
@_ = (app => $_[0], client => $_[1]);
}
my %args = @_;
my $app = delete $args{app}; # Backward compat: some implementations don't need app
my $client = delete $args{client} or Carp::croak "client test code needed";
my $tester = Plack::Test->create($app, %args);
return $tester->(@_) if ref $tester eq 'CODE'; # compatibility
$client->(sub { $tester->request(@_) });
}
1;
__END__
=head1 NAME
Plack::Test - Test PSGI applications with various backends
=head1 SYNOPSIS
use Plack::Test;
use HTTP::Request::Common;
# Simple OO interface
my $app = sub { return [ 200, [], [ "Hello" ] ] };
my $test = Plack::Test->create($app);
my $res = $test->request(GET "/");
is $res->content, "Hello";
# traditional - named params
test_psgi
app => sub {
my $env = shift;
return [ 200, [ 'Content-Type' => 'text/plain' ], [ "Hello World" ] ],
},
client => sub {
my $cb = shift;
my $req = HTTP::Request->new(GET => "http://localhost/hello");
my $res = $cb->($req);
like $res->content, qr/Hello World/;
};
# positional params (app, client)
my $app = sub { return [ 200, [], [ "Hello" ] ] };
test_psgi $app, sub {
my $cb = shift;
my $res = $cb->(GET "/");
is $res->content, "Hello";
};
=head1 DESCRIPTION
Plack::Test is a unified interface to test PSGI applications using
L<HTTP::Request> and L<HTTP::Response> objects. It also allows you to run PSGI
applications in various ways. The default backend is C<Plack::Test::MockHTTP>,
but you may also use any L<Plack::Handler> implementation to run live HTTP
requests against a web server.
=head1 METHODS
=over 4
=item create
$test = Plack::Test->create($app, %options);
creates an instance of Plack::Test implementation class. C<$app> has
to be a valid PSGI application code reference.
=item request
$res = $test->request($request);
takes an HTTP::Request object, runs it through the PSGI application to
test and returns an HTTP::Response object.
=back
=head1 FUNCTIONS
Plack::Test also provides a functional interface that takes two
callbacks, each of which represents PSGI application and HTTP client
code that tests the application.
=over 4
=item test_psgi
test_psgi $app, $client;
test_psgi app => $app, client => $client;
Runs the client test code C<$client> against a PSGI application
C<$app>. The client callback gets one argument C<$cb>, a
callback that accepts an C<HTTP::Request> object and returns an
C<HTTP::Response> object.
Use L<HTTP::Request::Common> to import shortcuts for creating requests for
C<GET>, C<POST>, C<DELETE>, and C<PUT> operations.
For your convenience, the C<HTTP::Request> given to the callback automatically
uses the HTTP protocol and the localhost (I<127.0.0.1> by default), so the
following code just works:
use HTTP::Request::Common;
test_psgi $app, sub {
my $cb = shift;
my $res = $cb->(GET "/hello");
};
Note that however, it is not a good idea to pass an arbitrary
(i.e. user-input) string to C<GET> or even C<<
HTTP::Request->new >> by assuming that it always represents a path,
because:
my $req = GET "//foo/bar";
would represent a request for a URL that has no scheme, has a hostname
I<foo> and a path I</bar>, instead of a path I<//foo/bar> which you
might actually want.
=back
=head1 OPTIONS
Specify the L<Plack::Test> backend using the environment
variable C<PLACK_TEST_IMPL> or C<$Plack::Test::Impl> package variable.
The available values for the backend are:
=over 4
=item MockHTTP
(Default) Creates a PSGI env hash out of HTTP::Request object, runs
the PSGI application in-process and returns HTTP::Response.
=item Server
Runs one of Plack::Handler backends (C<Standalone> by default) and
sends live HTTP requests to test.
=item ExternalServer
Runs tests against an external server specified in the
C<PLACK_TEST_EXTERNALSERVER_URI> environment variable instead of spawning the
application in a server locally.
=back
For instance, test your application with the C<HTTP::Server::ServerSimple>
server backend with:
> env PLACK_TEST_IMPL=Server PLACK_SERVER=HTTP::Server::ServerSimple \
prove -l t/test.t
=head1 AUTHOR
Tatsuhiko Miyagawa
=cut
PLACK_TEST
$fatpacked{"Plack/Test/MockHTTP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_TEST_MOCKHTTP';
package Plack::Test::MockHTTP;
use strict;
use warnings;
use Carp;
use HTTP::Request;
use HTTP::Response;
use HTTP::Message::PSGI;
use Try::Tiny;
sub new {
my($class, $app) = @_;
bless { app => $app }, $class;
}
sub request {
my($self, $req) = @_;
$req->uri->scheme('http') unless defined $req->uri->scheme;
$req->uri->host('localhost') unless defined $req->uri->host;
my $env = $req->to_psgi;
my $res = try {
HTTP::Response->from_psgi($self->{app}->($env));
} catch {
HTTP::Response->from_psgi([ 500, [ 'Content-Type' => 'text/plain' ], [ $_ ] ]);
};
$res->request($req);
return $res;
}
1;
__END__
=head1 NAME
Plack::Test::MockHTTP - Run mocked HTTP tests through PSGI applications
=head1 DESCRIPTION
Plack::Test::MockHTTP is a utility to run PSGI application given
HTTP::Request objects and return HTTP::Response object out of PSGI
application response. See L<Plack::Test> how to use this module.
=head1 AUTHOR
Tatsuhiko Miyagawa
=head1 SEE ALSO
L<Plack::Test>
=cut
PLACK_TEST_MOCKHTTP
$fatpacked{"Plack/Test/Server.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_TEST_SERVER';
package Plack::Test::Server;
use strict;
use warnings;
use Carp;
use HTTP::Request;
use HTTP::Response;
use Test::TCP;
use Plack::Loader;
use Plack::LWPish;
sub new {
my($class, $app, %args) = @_;
my $host = $args{host} || '127.0.0.1';
my $server = Test::TCP->new(
listen => $args{listen},
host => $host,
code => sub {
my $sock_or_port = shift;
my $server = Plack::Loader->auto(
($args{listen} ? (
listen_sock => $sock_or_port,
):(
port => $sock_or_port,
host => $host,
))
);
$server->run($app);
exit;
},
);
bless { server => $server, %args }, $class;
}
sub port {
my $self = shift;
$self->{server}->port;
}
sub request {
my($self, $req) = @_;
my $ua = $self->{ua} || Plack::LWPish->new( no_proxy => [qw/127.0.0.1/] );
$req->uri->scheme('http');
$req->uri->host($self->{host} || '127.0.0.1');
$req->uri->port($self->port);
return $ua->request($req);
}
1;
__END__
=head1 NAME
Plack::Test::Server - Run HTTP tests through live Plack servers
=head1 DESCRIPTION
Plack::Test::Server is a utility to run PSGI application with Plack
server implementations, and run the live HTTP tests with the server
using a callback. See L<Plack::Test> how to use this module.
=head1 AUTHOR
Tatsuhiko Miyagawa
Tokuhiro Matsuno
=head1 SEE ALSO
L<Plack::Loader> L<Test::TCP> L<Plack::Test>
=cut
PLACK_TEST_SERVER
$fatpacked{"Plack/Test/Suite.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_TEST_SUITE';
package Plack::Test::Suite;
use strict;
use warnings;
use Digest::MD5;
use File::ShareDir;
use HTTP::Request;
use HTTP::Request::Common;
use Test::More;
use Test::TCP;
use Plack::Loader;
use Plack::Middleware::Lint;
use Plack::Util;
use Plack::Request;
use Try::Tiny;
use Plack::LWPish;
my $share_dir = try { File::ShareDir::dist_dir('Plack') } || 'share';
$ENV{PLACK_TEST_SCRIPT_NAME} = '';
# 0: test name
# 1: request generator coderef.
# 2: request handler
# 3: test case for response
our @TEST = (
[
'SCRIPT_NAME',
sub {
my $cb = shift;
my $res = $cb->(GET "http://127.0.0.1/");
is $res->content, "script_name=$ENV{PLACK_TEST_SCRIPT_NAME}";
},
sub {
my $env = shift;
return [ 200, ["Content-Type", "text/plain"], [ "script_name=$env->{SCRIPT_NAME}" ] ];
},
],
[
'GET',
sub {
my $cb = shift;
my $res = $cb->(GET "http://127.0.0.1/?name=miyagawa");
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;
return [
200,
[ 'Content-Type' => 'text/plain', ],
[ 'Hello, ' . $env->{QUERY_STRING} ],
];
},
],
[
'POST',
sub {
my $cb = shift;
my $res = $cb->(POST "http://127.0.0.1/", [name => 'tatsuhiko']);
is $res->code, 200;
is $res->message, 'OK';
is $res->header('Client-Content-Length'), 14;
is $res->header('Client-Content-Type'), 'application/x-www-form-urlencoded';
is $res->header('content_type'), 'text/plain';
is $res->content, 'Hello, name=tatsuhiko';
},
sub {
my $env = shift;
my $body;
$env->{'psgi.input'}->read($body, $env->{CONTENT_LENGTH});
return [
200,
[ 'Content-Type' => 'text/plain',
'Client-Content-Length' => $env->{CONTENT_LENGTH},
'Client-Content-Type' => $env->{CONTENT_TYPE},
],
[ 'Hello, ' . $body ],
];
},
],
[
'big POST',
sub {
my $cb = shift;
my $chunk = "abcdefgh" x 12000;
my $req = HTTP::Request->new(POST => "http://127.0.0.1/");
$req->content_length(length $chunk);
$req->content_type('application/octet-stream');
$req->content($chunk);
my $res = $cb->($req);
is $res->code, 200;
is $res->message, 'OK';
is $res->header('Client-Content-Length'), length $chunk;
is length $res->content, length $chunk;
is Digest::MD5::md5_hex($res->content), Digest::MD5::md5_hex($chunk);
},
sub {
my $env = shift;
my $len = $env->{CONTENT_LENGTH};
my $body = '';
my $spin;
while ($len > 0) {
my $rc = $env->{'psgi.input'}->read($body, $env->{CONTENT_LENGTH}, length $body);
$len -= $rc;
last if $spin++ > 2000;
}
return [
200,
[ 'Content-Type' => 'text/plain',
'Client-Content-Length' => $env->{CONTENT_LENGTH},
'Client-Content-Type' => $env->{CONTENT_TYPE},
],
[ $body ],
];
},
],
[
'psgi.url_scheme',
sub {
my $cb = shift;
my $res = $cb->(POST "http://127.0.0.1/");
is $res->code, 200;
is $res->message, 'OK';
is $res->header('content_type'), 'text/plain';
is $res->content, 'http';
},
sub {
my $env = $_[0];
return [
200,
[ 'Content-Type' => 'text/plain', ],
[ $env->{'psgi.url_scheme'} ],
];
},
],
[
'return glob',
sub {
my $cb = shift;
my $res = $cb->(GET "http://127.0.0.1/");
is $res->code, 200;
is $res->message, 'OK';
is $res->header('content_type'), 'text/plain';
like $res->content, qr/^package /;
like $res->content, qr/END_MARK_FOR_TESTING$/;
examples/fatpacked.plackup view on Meta::CPAN
return [
200,
[ 'Content-Type' => 'text/plain', ],
CalledClose->new(),
];
},
],
[
'has errors',
sub {
my $cb = shift;
my $res = $cb->(GET "http://127.0.0.1/has_errors");
is $res->content, 1;
},
sub {
my $env = shift;
my $err = $env->{'psgi.errors'};
my $has_errors = defined $err;
return [
200,
[ 'Content-Type' => 'text/plain', ],
[$has_errors]
];
},
],
[
'status line',
sub {
my $cb = shift;
my $res = $cb->(GET "http://127.0.0.1/foo/?dankogai=kogaidan");
is($res->status_line, '200 OK');
},
sub {
my $env = shift;
return [
200,
[ 'Content-Type' => 'text/plain', ],
[1]
];
},
],
[
'Do not crash when the app dies',
sub {
my $cb = shift;
my $res = $cb->(GET "http://127.0.0.1/");
is $res->code, 500;
is $res->message, 'Internal Server Error';
},
sub {
my $env = shift;
open my $io, '>', \my $error;
$env->{'psgi.errors'} = $io;
die "Throwing an exception from app handler. Server shouldn't crash.";
},
],
[
'multi headers (request)',
sub {
my $cb = shift;
my $req = HTTP::Request->new(
GET => "http://127.0.0.1/",
);
$req->push_header(Foo => "bar");
$req->push_header(Foo => "baz");
my $res = $cb->($req);
like($res->content, qr/^bar,\s*baz$/);
},
sub {
my $env = shift;
return [
200,
[ 'Content-Type' => 'text/plain', ],
[ $env->{HTTP_FOO} ]
];
},
],
[
'multi headers (response)',
sub {
my $cb = shift;
my $res = $cb->(HTTP::Request->new(GET => "http://127.0.0.1/"));
my $foo = $res->header('X-Foo');
like $foo, qr/foo,\s*bar,\s*baz/;
},
sub {
my $env = shift;
return [
200,
[ 'Content-Type' => 'text/plain', 'X-Foo', 'foo', 'X-Foo', 'bar, baz' ],
[ 'hi' ]
];
},
],
[
'Do not set $env->{COOKIE}',
sub {
my $cb = shift;
my $req = HTTP::Request->new(
GET => "http://127.0.0.1/",
);
$req->push_header(Cookie => "foo=bar");
my $res = $cb->($req);
is($res->header('X-Cookie'), 0);
is $res->content, 'foo=bar';
},
sub {
my $env = shift;
return [
200,
[ 'Content-Type' => 'text/plain', 'X-Cookie' => $env->{COOKIE} ? 1 : 0 ],
[ $env->{HTTP_COOKIE} ]
];
},
],
[
'no entity headers on 304',
sub {
my $cb = shift;
my $res = $cb->(GET "http://127.0.0.1/");
is $res->code, 304;
is $res->message, 'Not Modified';
is $res->content, '';
ok ! defined $res->header('content_type'), "No Content-Type";
ok ! defined $res->header('content_length'), "No Content-Length";
ok ! defined $res->header('transfer_encoding'), "No Transfer-Encoding";
},
sub {
my $env = shift;
return [ 304, [], [] ];
},
],
[
'REQUEST_URI is set',
sub {
my $cb = shift;
my $res = $cb->(GET "http://127.0.0.1/foo/bar%20baz%73?x=a");
is $res->content, $ENV{PLACK_TEST_SCRIPT_NAME} . "/foo/bar%20baz%73?x=a";
},
sub {
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 [
examples/fatpacked.plackup view on Meta::CPAN
},
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);
my $res = $cb->($req);
is $res->content, 'body';
},
sub {
my $req = Plack::Request->new(shift);
return [ 200, [ "Content-Type", "text/plain" ], [ $req->content ] ];
},
],
[
'request->content on GET',
sub {
my $cb = shift;
my $res = $cb->(GET "http://127.0.0.1/");
ok $res->is_success;
},
sub {
my $req = Plack::Request->new(shift);
$req->content;
return [ 200, [ "Content-Type", "text/plain" ], [ "OK" ] ];
},
],
[
'handle Authorization header',
sub {
my $cb = shift;
SKIP: {
skip "Authorization header is unsupported under CGI", 4 if ($ENV{PLACK_TEST_HANDLER} || "") eq "CGI";
{
my $req = HTTP::Request->new(
GET => "http://127.0.0.1/",
);
$req->push_header(Authorization => 'Basic XXXX');
my $res = $cb->($req);
is $res->header('X-AUTHORIZATION'), 1;
is $res->content, 'Basic XXXX';
};
{
my $req = HTTP::Request->new(
GET => "http://127.0.0.1/",
);
my $res = $cb->($req);
is $res->header('X-AUTHORIZATION'), 0;
is $res->content, 'no_auth';
};
};
},
sub {
my $env = shift;
return [
200,
[ 'Content-Type' => 'text/plain', 'X-AUTHORIZATION' => exists($env->{HTTP_AUTHORIZATION}) ? 1 : 0 ],
[ $env->{HTTP_AUTHORIZATION} || 'no_auth' ],
];
},
],
[
'repeated slashes',
sub {
my $cb = shift;
my $res = $cb->(GET "http://127.0.0.1//foo///bar/baz");
is $res->code, 200;
is $res->message, 'OK';
is $res->header('content_type'), 'text/plain';
is $res->content, '//foo///bar/baz';
},
sub {
my $env = shift;
return [
200,
[ 'Content-Type' => 'text/plain', ],
[ $env->{PATH_INFO} ],
];
},
],
);
sub runtests {
my($class, $runner) = @_;
for my $test (@TEST) {
$runner->(@$test);
}
}
sub run_server_tests {
my($class, $server, $server_port, $http_port, %args) = @_;
if (ref $server ne 'CODE') {
my $server_class = $server;
$server = sub {
my($port, $app) = @_;
my $server = Plack::Loader->load($server_class, port => $port, host => "127.0.0.1", %args);
$app = Plack::Middleware::Lint->wrap($app);
$server->run($app);
}
}
test_tcp(
client => sub {
( run in 0.895 second using v1.01-cache-2.11-cpan-acf6aa7dc9e )