Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Copied Plack::Request, Response and its tests from Plack-Request dist.

Tests are adjusted to work with Plack::Test or standalone. All tests
are unmodified YET, to make all the backward incompatilbe changes can
be visible from now on, on this 'plack-request' branch.
  • Loading branch information...
commit c3b071823cccdcead9807381e7517d9237eaa3cc 1 parent 04a11b6
Tatsuhiko Miyagawa miyagawa authored
598 lib/Plack/Request.pm
View
@@ -0,0 +1,598 @@
+package Plack::Request;
+use strict;
+use warnings;
+use 5.008_001;
+our $VERSION = "0.09";
+
+use HTTP::Headers;
+use URI::QueryParam;
+use Carp ();
+
+use Socket qw[AF_INET inet_aton]; # for _build_hostname
+use Plack::Request::Upload;
+use URI;
+
+sub new {
+ my($class, $env) = @_;
+ Carp::confess(q{$env is required})
+ unless defined $env && ref($env) eq 'HASH';
+
+ bless {
+ env => $env,
+ }, $class;
+}
+
+sub env { $_[0]->{env} }
+
+sub address { $_[0]->env->{REMOTE_ADDR} }
+sub protocol { $_[0]->env->{SERVER_PROTOCOL} }
+sub method { $_[0]->env->{REQUEST_METHOD} }
+sub port { $_[0]->env->{SERVER_PORT} }
+sub user { $_[0]->env->{REMOTE_USER} }
+sub request_uri { $_[0]->env->{REQUEST_URI} }
+sub url_scheme { $_[0]->env->{'psgi.url_scheme'} }
+sub session { $_[0]->env->{'psgix.session'} }
+
+sub secure {
+ $_[0]->url_scheme eq 'https';
+}
+
+# we need better cookie lib?
+# http://mark.stosberg.com/blog/2008/12/cookie-handling-in-titanium-catalyst-and-mojo.html
+sub cookies {
+ my $self = shift;
+ if (defined $_[0]) {
+ unless (ref($_[0]) eq 'HASH') {
+ Carp::confess "Attribute (cookies) does not pass the type constraint because: Validation failed for 'HashRef' failed with value $_[0]";
+ }
+ $self->{cookies} = $_[0];
+ } elsif (!defined $self->{cookies}) {
+ require CGI::Simple::Cookie;
+ if (my $header = $self->header('Cookie')) {
+ $self->{cookies} = { CGI::Simple::Cookie->parse($header) };
+ } else {
+ $self->{cookies} = {};
+ }
+ }
+ $self->{cookies};
+}
+
+sub query_parameters {
+ my $self = shift;
+ if (defined $_[0]) {
+ unless (ref($_[0]) eq 'HASH') {
+ Carp::confess "Attribute (query_parameters) does not pass the type constraint because: Validation failed for 'HashRef' failed with value $_[0]";
+ }
+ $self->{query_parameters} = $_[0];
+ } elsif (!defined $self->{query_parameters}) {
+ $self->{query_parameters} = $self->uri->query_form_hash;
+ }
+ $self->{query_parameters};
+}
+
+sub _body_parser {
+ my $self = shift;
+ unless (defined $self->{_body_parser}) {
+ require Plack::Request::BodyParser;
+ $self->{_body_parser} = Plack::Request::BodyParser->new( $self->env );
+ }
+ $self->{_body_parser};
+}
+
+sub raw_body {
+ my $self = shift;
+ if (!defined($self->{raw_body})) {
+ $self->{raw_body} ||= $self->_body_parser->raw_body($self);
+ }
+ $self->{raw_body};
+}
+
+
+sub headers {
+ my $self = shift;
+ if (!defined $self->{headers}) {
+ my $env = $self->env;
+ $self->{headers} = HTTP::Headers->new(
+ map {
+ (my $field = $_) =~ s/^HTTPS?_//;
+ ( $field => $env->{$_} );
+ }
+ grep { /^(?:HTTP|CONTENT|COOKIE)/i } keys %$env
+ );
+ }
+ $self->{headers};
+}
+# shortcut
+sub content_encoding { shift->headers->content_encoding(@_) }
+sub content_length { shift->headers->content_length(@_) }
+sub content_type { shift->headers->content_type(@_) }
+sub header { shift->headers->header(@_) }
+sub referer { shift->headers->referer(@_) }
+sub user_agent { shift->headers->user_agent(@_) }
+
+sub hostname {
+ my $self = shift;
+ if (defined $_[0]) {
+ $self->{hostname} = $_[0];
+ } elsif (!defined $self->{hostname}) {
+ $self->{hostname} = $self->env->{REMOTE_HOST} || $self->_resolve_hostname;
+ }
+ $self->{hostname};
+}
+
+sub _resolve_hostname {
+ my ( $self, ) = @_;
+ gethostbyaddr( inet_aton( $self->address ), AF_INET );
+}
+# for win32 hacks
+BEGIN {
+ if ($^O eq 'MSWin32') {
+ no warnings 'redefine';
+ *_build_hostname = sub {
+ my ( $self, ) = @_;
+ my $address = $self->address;
+ return 'localhost' if $address eq '127.0.0.1';
+ return gethostbyaddr( inet_aton( $address ), AF_INET );
+ };
+ }
+}
+
+# TODO: This attribute should be private. I will remove deps for HTTP::Body
+sub _http_body {
+ my $self = shift;
+ if (!defined $self->{_http_body}) {
+ $self->{_http_body} = $self->_body_parser->http_body();
+ }
+ $self->{_http_body};
+}
+sub body_parameters {
+ my $self = shift;
+
+ if (@_ || defined $self->{_http_body} || $self->method eq 'POST') {
+ return $self->_http_body->param(@_);
+ } else {
+ return {};
+ }
+}
+
+sub body { shift->_http_body->body(@_) }
+
+# contains body_params and query_params
+sub parameters {
+ my $self = shift;
+ if (defined $_[0]) {
+ unless (ref($_[0]) eq 'HASH') {
+ Carp::confess "Attribute (parameters) does not pass the type constraint because: Validation failed for 'HashRef' failed with value $_[0]";
+ }
+ $self->{parameters} = $_[0];
+ } elsif (!defined $self->{parameters}) {
+ $self->{parameters} = $self->_build_parameters;
+ }
+ $self->{parameters};
+}
+sub _build_parameters {
+ my $self = shift;
+
+ my $query = $self->query_parameters;
+ my $body = $self->body_parameters;
+
+ my %merged;
+
+ foreach my $hash ( $query, $body ) {
+ foreach my $name ( keys %$hash ) {
+ my $param = $hash->{$name};
+ push( @{ $merged{$name} ||= [] }, ( ref $param ? @$param : $param ) );
+ }
+ }
+
+ foreach my $param ( values %merged ) {
+ $param = $param->[0] if @$param == 1;
+ }
+
+ return \%merged;
+}
+
+sub uploads {
+ my $self = shift;
+ if (defined $_[0]) {
+ unless (ref($_[0]) eq 'HASH') {
+ Carp::confess "Attribute (uploads) does not pass the type constraint because: Validation failed for 'HashRef' failed with value $_[0]";
+ }
+ $self->{uploads} = $_[0];
+ } elsif (!defined $self->{uploads}) {
+ $self->{uploads} = $self->_build_uploads;
+ }
+ $self->{uploads};
+}
+sub _build_uploads {
+ my $self = shift;
+ my $uploads = $self->_http_body->upload;
+ my %uploads;
+ for my $name (keys %{ $uploads }) {
+ my $files = $uploads->{$name};
+ $files = ref $files eq 'ARRAY' ? $files : [$files];
+
+ my @uploads;
+ for my $upload (@{ $files }) {
+ my $headers = HTTP::Headers->new( %{ $upload->{headers} } );
+ push(
+ @uploads,
+ Plack::Request::Upload->new(
+ headers => $headers,
+ tempname => $upload->{tempname},
+ size => $upload->{size},
+ filename => $upload->{filename},
+ )
+ );
+ }
+ $uploads{$name} = @uploads > 1 ? \@uploads : $uploads[0];
+
+ # support access to the filename as a normal param
+ my @filenames = map { $_->{filename} } @uploads;
+ $self->parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0];
+ }
+ return \%uploads;
+}
+
+# aliases
+sub body_params { shift->body_parameters(@_) }
+sub input { shift->body(@_) }
+sub params { shift->parameters(@_) }
+sub query_params { shift->query_parameters(@_) }
+
+sub path_info { shift->env->{PATH_INFO} }
+sub script_name { shift->env->{SCRIPT_NAME} }
+
+sub cookie {
+ my $self = shift;
+
+ return keys %{ $self->cookies } if @_ == 0;
+
+ if (@_ == 1) {
+ my $name = shift;
+ return undef unless exists $self->cookies->{$name}; ## no critic.
+ return $self->cookies->{$name};
+ }
+ return;
+}
+
+sub param {
+ my $self = shift;
+
+ return keys %{ $self->parameters } if @_ == 0;
+
+ if (@_ == 1) {
+ my $param = shift;
+ return wantarray ? () : undef unless exists $self->parameters->{$param};
+
+ if ( ref $self->parameters->{$param} eq 'ARRAY' ) {
+ return (wantarray)
+ ? @{ $self->parameters->{$param} }
+ : $self->parameters->{$param}->[0];
+ } else {
+ return (wantarray)
+ ? ( $self->parameters->{$param} )
+ : $self->parameters->{$param};
+ }
+ } else {
+ my $field = shift;
+ $self->parameters->{$field} = [@_];
+ }
+}
+
+sub upload {
+ my $self = shift;
+
+ return keys %{ $self->uploads } if @_ == 0;
+
+ if (@_ == 1) {
+ my $upload = shift;
+ return wantarray ? () : undef unless exists $self->uploads->{$upload};
+
+ if (ref $self->uploads->{$upload} eq 'ARRAY') {
+ return (wantarray)
+ ? @{ $self->uploads->{$upload} }
+ : $self->uploads->{$upload}->[0];
+ } else {
+ return (wantarray)
+ ? ( $self->uploads->{$upload} )
+ : $self->uploads->{$upload};
+ }
+ } else {
+ while ( my($field, $upload) = splice(@_, 0, 2) ) {
+ if ( exists $self->uploads->{$field} ) {
+ for ( $self->uploads->{$field} ) {
+ $_ = [$_] unless ref($_) eq "ARRAY";
+ push(@{ $_ }, $upload);
+ }
+ } else {
+ $self->uploads->{$field} = $upload;
+ }
+ }
+ }
+}
+
+sub raw_uri {
+ my $self = shift;
+
+ my $env = $self->env;
+ my $scheme = $env->{'psgi.url_scheme'} || "http";
+
+ # Host header should contain port number as well
+ my $host = $env->{HTTP_HOST} || do {
+ my $port = $env->{SERVER_PORT} || 80;
+ my $is_std_port = ($scheme eq 'http' && $port == 80) || ($scheme eq 'https' && $port == 443);
+ $env->{SERVER_NAME} . ($is_std_port ? "" : ":$port");
+ };
+
+ my $uri = "$scheme\://$host" . $env->{REQUEST_URI};
+ return URI->new($uri);
+}
+
+sub base {
+ my $self = shift;
+
+ my $uri = $self->raw_uri;
+ $uri->path_query($self->env->{SCRIPT_NAME} || "/");
+
+ return $uri;
+}
+
+sub uri {
+ my $self = shift;
+ if (defined $_[0]) {
+ unless (eval { $_[0]->isa('URI') }) {
+ Carp::confess "Attribute (uri) does not pass the type constraint because: Validation failed for 'URI' failed with value $_[0]";
+ }
+ $self->{uri} = $_[0];
+ } elsif (!defined $self->{uri}) {
+ $self->{uri} = $self->_build_uri;
+ }
+ $self->{uri};
+}
+
+sub _build_uri {
+ my($self, ) = @_;
+
+ my $env = $self->env;
+
+ my $base_path = $env->{SCRIPT_NAME} || '/';
+
+ my $path = $base_path . ($env->{PATH_INFO} || '');
+ $path =~ s{^/+}{};
+
+ my $uri = ($env->{'psgi.url_scheme'} || "http") .
+ "://" .
+ ($env->{HTTP_HOST} || (($env->{SERVER_NAME} || "") . ":" . ($env->{SERVER_PORT} || 80))) .
+ "/" .
+ ($path || "") .
+ ($env->{QUERY_STRING} ? "?$env->{QUERY_STRING}" : "");
+
+ # sanitize the URI
+ return URI->new($uri)->canonical;
+}
+
+sub path { shift->uri->path(@_) }
+
+sub new_response {
+ my $self = shift;
+ require Plack::Response;
+ Plack::Response->new(@_);
+}
+
+sub content {
+ my ( $self, @args ) = @_;
+
+ if ( @args ) {
+ Carp::croak "The HTTP::Request method 'content' is unsupported when used as a writer, use Plack::RequestBuilder";
+ } else {
+ return $self->raw_body;
+ }
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Plack::Request - Portable HTTP request object from PSGI env hash
+
+=head1 SYNOPSIS
+
+ use Plack::Request;
+
+ my $env = shift; # PSGI env
+ my $req = Plack::Request->new($env);
+
+ my $path_info = $req->path_info;
+ my $query = $req->param('query');
+
+ my $res = $req->new_response(200); # new Plack::Response
+
+=head1 DESCRIPTION
+
+L<Plack::Request> provides a consistent API for request objects across
+web server environments.
+
+=head1 CAVEAT
+
+Note that this module is intended to be used by web application
+framework developers rather than application developers (end
+users). Writing your web application directly using Plack::Request is
+certainly possible but not recommended: it's like doing so with
+mod_perl's Apache::Request: yet too low level.
+
+If you're writing a web application, not a framework, then you're
+encouraged to use one of the web application frameworks that support
+PSGI, or use L<HTTP::Engine> if you want to write a micro web server
+application.
+
+Also, even if you're a framework developer, you probably want to
+handle Cookies and file uploads in your own way: Plack::Request gives
+you a simple API to deal with these things but ultimately you probably
+want to implement those in your own code.
+
+=head1 METHODS
+
+=head2 new
+
+ Plack::Request->new( $psgi_env );
+
+=head1 ATTRIBUTES
+
+=over 4
+
+=item address
+
+Returns the IP address of the client.
+
+=item cookies
+
+Returns a reference to a hash containing the cookies
+
+=item method
+
+Contains the request method (C<GET>, C<POST>, C<HEAD>, etc).
+
+=item protocol
+
+Returns the protocol (HTTP/1.0 or HTTP/1.1) used for the current request.
+
+=item request_uri
+
+Returns the request uri (like $ENV{REQUEST_URI})
+
+=item query_parameters
+
+Returns a reference to a hash containing query string (GET)
+parameters. Values can be either a scalar or an arrayref containing
+scalars.
+
+=item secure
+
+Returns true or false, indicating whether the connection is secure (https).
+
+=item uri
+
+Returns a URI object for the current request. Stringifies to the URI text.
+
+=item user
+
+Returns REMOTE_USER.
+
+=item raw_body
+
+Returns string containing body(POST).
+
+=item headers
+
+Returns an L<HTTP::Headers> object containing the headers for the current request.
+
+=item hostname
+
+Returns the hostname of the client.
+
+=item parameters
+
+Returns a reference to a hash containing GET and POST parameters. Values can
+be either a scalar or an arrayref containing scalars.
+
+=item uploads
+
+Returns a reference to a hash containing uploads. Values can be either a
+L<Plack::Request::Upload> object, or an arrayref of
+L<Plack::Request::Upload> objects.
+
+=item content_encoding
+
+Shortcut to $req->headers->content_encoding.
+
+=item content_length
+
+Shortcut to $req->headers->content_length.
+
+=item content_type
+
+Shortcut to $req->headers->content_type.
+
+=item header
+
+Shortcut to $req->headers->header.
+
+=item referer
+
+Shortcut to $req->headers->referer.
+
+=item user_agent
+
+Shortcut to $req->headers->user_agent.
+
+=item cookie
+
+A convenient method to access $req->cookies.
+
+ $cookie = $req->cookie('name');
+ @cookies = $req->cookie;
+
+=item param
+
+Returns GET and POST parameters with a CGI.pm-compatible param method. This
+is an alternative method for accessing parameters in $req->parameters.
+
+ $value = $req->param( 'foo' );
+ @values = $req->param( 'foo' );
+ @params = $req->param;
+
+Like L<CGI>, and B<unlike> earlier versions of Catalyst, passing multiple
+arguments to this method, like this:
+
+ $req->param( 'foo', 'bar', 'gorch', 'quxx' );
+
+will set the parameter C<foo> to the multiple values C<bar>, C<gorch> and
+C<quxx>. Previously this would have added C<bar> as another value to C<foo>
+(creating it if it didn't exist before), and C<quxx> as another value for
+C<gorch>.
+
+=item path
+
+Returns the path, i.e. the part of the URI after $req->base, for the current request.
+
+=item upload
+
+A convenient method to access $req->uploads.
+
+ $upload = $req->upload('field');
+ @uploads = $req->upload('field');
+ @fields = $req->upload;
+
+ for my $upload ( $req->upload('field') ) {
+ print $upload->filename;
+ }
+
+=item new_response
+
+ my $res = $req->new_response;
+
+Creates a new L<Plack::Response> by default. Handy to remove
+dependency on L<Plack::Response> in your code for easy subclassing and
+duck typing in web application frameworks, as well as overriding
+Response generation in middlewares.
+
+=back
+
+=head1 AUTHORS
+
+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
105 lib/Plack/Request/BodyParser.pm
View
@@ -0,0 +1,105 @@
+package Plack::Request::BodyParser;
+use strict;
+use warnings;
+BEGIN { require Carp }; # do not call Carp->import for performance
+use HTTP::Body;
+
+# ABOUT: This is internal class. Do not call directly.
+
+sub new {
+ my($class, $env) = @_;
+
+ Carp::confess q{Attribute ($env->{'psgi.input'}) is required}
+ unless defined $env->{'psgi.input'};
+
+ bless {
+ content_length => $env->{'CONTENT_LENGTH'} || 0,
+ content_type => $env->{'CONTENT_TYPE'} || '',
+ input_handle => $env->{'psgi.input'},
+ _read_position => 0,
+ chunk_size => 4096,
+ }, $class;
+}
+
+# tempolary file path for upload file.
+sub upload_tmp {
+ $_[0]->{upload_tmp} = defined $_[1] ? $_[1] : $_[0]->{upload_tmp};
+}
+
+sub http_body {
+ my ( $self, ) = @_;
+
+ $self->_read_to_end();
+ return $self->_http_body;
+}
+
+sub raw_body {
+ my ( $self, ) = @_;
+
+ $self->_read_to_end();
+ return $self->{_raw_body};
+}
+
+sub _http_body {
+ my($self, ) = @_;
+ unless (defined $self->{_http_body}) {
+ my $body = HTTP::Body->new($self->{content_type}, $self->{content_length});
+ $body->tmpdir( $self->upload_tmp ) if $self->upload_tmp;
+ $self->{_http_body} = $body;
+ }
+ $self->{_http_body};
+}
+
+sub _read_position { $_[0]->{_read_position} }
+
+sub input_handle { $_[0]->{input_handle} }
+
+sub _read_to_end {
+ my ( $self, ) = @_;
+
+ my $content_length = $self->{content_length};
+
+ if ($content_length > 0) {
+ while (my $buffer = $self->_read() ) {
+ $self->{_raw_body} .= $buffer;
+ $self->_http_body->add($buffer);
+ }
+
+ # paranoia against wrong Content-Length header
+ my $diff = $content_length - $self->_read_position;
+
+ if ($diff != 0) {
+ if ( $diff > 0) {
+ die "Wrong Content-Length value: " . $content_length;
+ } else {
+ die "Premature end of request body, $diff bytes remaining";
+ }
+ }
+ }
+}
+
+sub _read {
+ my ($self, ) = @_;
+
+ my $remaining = $self->{content_length} - $self->_read_position();
+
+ my $maxlength = $self->{chunk_size};
+
+ # Are we done reading?
+ if ($remaining <= 0) {
+ return;
+ }
+
+ my $readlen = ($remaining > $maxlength) ? $maxlength : $remaining;
+
+ my $rc = $self->input_handle->read(my $buffer, $readlen);
+
+ if (defined $rc) {
+ $self->{_read_position} += $rc;
+ return $buffer;
+ } else {
+ die "Unknown error reading input: $!";
+ }
+}
+
+1;
126 lib/Plack/Request/Upload.pm
View
@@ -0,0 +1,126 @@
+package Plack::Request::Upload;
+use strict;
+use warnings;
+BEGIN { require Carp }; # do not call Carp->import for performance
+
+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 type {
+ my $self = shift;
+ unless ($self->{headers} && $self->{headers}->can('content_type')) {
+ Carp::croak 'Cannot delegate type to content_type because the value of headers is not defined';
+ }
+ $self->{headers}->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};
+}
+
+sub fh {
+ my $self = shift;
+ unless (defined $self->{fh}) {
+ open my $fh, '<', $self->{tempname} or die "Can't open '@{[ $self->tempname ]}': '$!'";
+ $self->{fh} = $fh;
+ }
+ $self->{fh};
+}
+
+sub copy_to {
+ my $self = shift;
+ require File::Copy;
+ File::Copy::copy( $self->{tempname}, @_ );
+}
+
+sub link_to {
+ my ( $self, $target ) = @_;
+ CORE::link( $self->{tempname}, $target );
+}
+
+sub slurp {
+ my ( $self, $layer ) = @_;
+
+ $layer = ':raw' unless $layer;
+
+ my $content = undef;
+ my $handle = $self->fh;
+
+ binmode( $handle, $layer );
+
+ while ( $handle->read( my $buffer, 8192 ) ) {
+ $content .= $buffer;
+ }
+
+ $content;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Plack::Request::Upload - handles file upload requests
+
+=head1 METHODS
+
+=over 4
+
+=item basename
+
+Returns basename for "filename".
+
+=item link_to
+
+Creates a hard link to the temporary file. Returns true for success,
+false for failure.
+
+ $upload->link_to('/path/to/target');
+
+=item slurp
+
+Returns a scalar containing the contents of the temporary file.
+
+=item copy_to
+
+Copies the temporary file using File::Copy. Returns true for success,
+false for failure.
+
+ $upload->copy_to('/path/to/targe')
+
+=back
+
+=head1 AUTHORS
+
+Kazuhiro Osawa and Plack authors.
+
+=head1 THANKS TO
+
+the authors of L<Catalyst::Request::Upload>.
+
+=head1 SEE ALSO
+
+L<Plack>, L<Catalyst::Request::Upload>
+
253 lib/Plack/Response.pm
View
@@ -0,0 +1,253 @@
+package Plack::Response;
+use strict;
+use warnings;
+our $VERSION = '0.01';
+use base qw/Class::Accessor::Fast/;
+use Carp ();
+use Scalar::Util ();
+use CGI::Simple::Cookie ();
+use HTTP::Headers;
+
+__PACKAGE__->mk_accessors(qw/body status/);
+sub code { shift->status(@_) }
+sub content { shift->body(@_) }
+
+sub new {
+ my($class, $rc, $headers, $content) = @_;
+
+ my $self = bless {}, $class;
+ $self->status($rc) if defined $rc;
+ $self->headers($headers) if defined $headers;
+ $self->body($content) if defined $content;
+
+ $self;
+}
+
+sub headers {
+ my $self = shift;
+
+ if (@_) {
+ my $headers = shift;
+ if (ref $headers eq 'ARRAY') {
+ Carp::carp("Odd number of headers") if @$headers % 2 != 0;
+ $headers = HTTP::Headers->new(@$headers);
+ } elsif (ref $headers eq 'HASH') {
+ $headers = HTTP::Headers->new(%$headers);
+ }
+ return $self->{headers} = $headers;
+ } else {
+ return $self->{headers} ||= HTTP::Headers->new();
+ }
+}
+
+sub cookies {
+ my $self = shift;
+ if (@_) {
+ return $self->{cookies} = shift;
+ } else {
+ return $self->{cookies} ||= +{ };
+ }
+}
+
+sub header { shift->headers->header(@_) } # shortcut
+
+sub content_length {
+ shift->headers->content_length(@_);
+}
+
+sub content_type {
+ shift->headers->content_type(@_);
+}
+
+sub content_encoding {
+ shift->headers->content_encoding(@_);
+}
+
+sub location {
+ shift->headers->header('Location' => @_);
+}
+
+sub redirect {
+ my $self = shift;
+
+ if (@_) {
+ my $url = shift;
+ my $status = shift || 302;
+ $self->location($url);
+ $self->status($status);
+ }
+
+ return $self->location;
+}
+
+sub finalize {
+ my $self = shift;
+ die "missing status" unless $self->status();
+
+ $self->_finalize_cookies();
+
+ return [
+ $self->status,
+ +[
+ map {
+ my $k = $_;
+ map { ( $k => $_ ) } $self->headers->header($_);
+ } $self->headers->header_field_names
+ ],
+ $self->_body,
+ ];
+}
+
+sub _body {
+ my $self = shift;
+ my $body = $self->body;
+ $body = [] unless defined $body;
+ if (!ref $body or Scalar::Util::blessed($body) && overload::Method($body, q(""))) {
+ return [ $body ];
+ } else {
+ return $body;
+ }
+}
+
+sub _finalize_cookies {
+ my ( $self ) = @_;
+
+ my $cookies = $self->cookies;
+ my @keys = keys %$cookies;
+ if (@keys) {
+ for my $name (@keys) {
+ my $val = $cookies->{$name};
+ my $cookie = (
+ Scalar::Util::blessed($val)
+ ? $val
+ : CGI::Simple::Cookie->new(
+ -name => $name,
+ -value => $val->{value},
+ -expires => $val->{expires},
+ -domain => $val->{domain},
+ -path => $val->{path},
+ -secure => ( $val->{secure} || 0 )
+ )
+ );
+
+ $self->headers->push_header( 'Set-Cookie' => $cookie->as_string );
+ }
+ }
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Plack::Response - Portable HTTP Response object for PSGI response
+
+=head1 SYNOPSIS
+
+ use Plack::Response;
+
+ sub psgi_handler {
+ my $env = shift;
+
+ my $res = Plack::Response->new(200);
+ $res->content_type('text/html');
+ $res->body("Hello World");
+
+ return $res->finalize;
+ }
+
+=head1 DESCRIPTION
+
+Plack::Response allows you a way to create PSGI response array ref through a simple API.
+
+=head1 METHODS
+
+=over 4
+
+=item new
+
+ $res = Plack::Response->new;
+ $res = Plack::Response->new($status);
+ $res = Plack::Response->new($status, $headers);
+ $res = Plack::Response->new($status, $headers, $body);
+
+Creates a new Plack::Response object.
+
+=item status
+
+ $res->status(200);
+ $status = $res->status;
+
+Sets and gets HTTP status code. C<code> is an alias.
+
+=item headers
+
+ $headers = $res->headers;
+ $res->headers([ 'Content-Type' => 'text/html' ]);
+ $res->headers({ 'Content-Type' => 'text/html' });
+ $res->headers( HTTP::Headers->new );
+
+Sets and gets HTTP headers of the response. Setter can take either an
+array ref, a hash ref or L<HTTP::Headers> object containing a list of
+headers.
+
+=item body
+
+ $res->body($body_str);
+ $res->body([ "Hello", "World" ]);
+ $res->body($io);
+
+Gets and sets HTTP response body. Setter can take either a string, an
+array ref, or an IO::Handle-like object. C<content> is an alias.
+
+=item header
+
+ $res->header('X-Foo' => 'bar');
+ my $val = $res->header('X-Foo');
+
+Shortcut for C<< $res->headers->header >>.
+
+=item content_type, content_length, content_encoding
+
+ $res->content_type('text/plain');
+ $res->content_length(123);
+ $res->content_encoding('gzip');
+
+Shortcut for the equivalent get/set methods in C<< $res->headers >>.
+
+=item redirect
+
+ $res->redirect($url);
+ $res->redirect($url, 301);
+
+Sets redirect URL with an optional status code, which defaults to 302.
+
+=item location
+
+Gets and sets C<Location> header.
+
+=item cookies
+
+ $res->cookies->{foo} = { value => '123' };
+
+Returns a hash reference containing cookies to be set in the
+response. The keys of the hash are the cookies' names, and their
+corresponding values are hash reference used to construct a
+CGI::Simple::Cookie object.
+
+=back
+
+=head1 AUTHOR
+
+Tokuhiro Matsuno
+
+=head1 SEE ALSO
+
+L<Plack::Request>
+
+=head1 LICENSE
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
20 t/Plack-Request/body.t
View
@@ -0,0 +1,20 @@
+use strict;
+use warnings;
+use Test::More;
+use Plack::Test;
+use Plack::Request;
+use HTTP::Request::Common;
+
+my $app = sub {
+ my $req = Plack::Request->new(shift);
+ is $req->raw_body, 'foo=bar';
+ is_deeply $req->body_params, { foo => 'bar' };
+ $req->new_response(200)->finalize;
+};
+
+test_psgi $app, sub {
+ my $cb = shift;
+ $cb->(POST "/", { foo => "bar" });
+};
+
+done_testing;
28 t/Plack-Request/content.t
View
@@ -0,0 +1,28 @@
+use strict;
+use warnings;
+use Test::More;
+use Plack::Test;
+use Plack::Request;
+
+my $app = sub {
+ my $req = Plack::Request->new(shift);
+ is $req->content, 'body';
+ is $req->raw_body, 'body';
+ eval {
+ $req->content("bar");
+ };
+ like $@, qr/unsupported/;
+ $req->new_response(200)->finalize;
+};
+
+test_psgi $app, sub {
+ my $cb = shift;
+
+ my $req = HTTP::Request->new(POST => "/");
+ $req->content("body");
+ $req->content_length(4);
+ $cb->($req);
+};
+
+done_testing;
+
39 t/Plack-Request/cookie.t
View
@@ -0,0 +1,39 @@
+use strict;
+use warnings;
+use Test::More tests => 7;
+use HTTP::Request;
+use Test::Requires qw(CGI::Simple::Cookie);
+use Plack::Test;
+use Plack::Request;
+
+my $app = sub {
+ my $req = Plack::Request->new(shift);
+
+ is '2', $req->cookie;
+ is $req->cookie('undef'), undef;
+ is $req->cookie('undef', 'undef'), undef;
+ is $req->cookie('Foo')->value, 'Bar';
+ is $req->cookie('Bar')->value, 'Baz';
+ is_deeply $req->cookies, {Foo => 'Foo=Bar; path=/', Bar => 'Bar=Baz; path=/'};
+
+ $req->new_response(200)->finalize;
+};
+
+test_psgi $app, sub {
+ my $cb = shift;
+ my $req = HTTP::Request->new(GET => "/");
+ $req->header(Cookie => 'Foo=Bar; Bar=Baz');
+ $cb->($req);
+};
+
+$app = sub {
+ my $req = Plack::Request->new(shift);
+ is_deeply $req->cookies, {};
+ $req->new_response(200)->finalize;
+};
+
+test_psgi $app, sub {
+ my $cb = shift;
+ $cb->(HTTP::Request->new(GET => "/"));
+};
+
21 t/Plack-Request/double_port.t
View
@@ -0,0 +1,21 @@
+use Test::More;
+use Plack::Test;
+use Plack::Request;
+use HTTP::Request::Common;
+
+$Plack::Test::Impl = 'Server';
+
+my $app = sub {
+ my $req = Plack::Request->new(shift);
+ return [200, [], [ $req->uri ]];
+};
+
+test_psgi app => $app, client => sub {
+ my $cb = shift;
+ my $res = $cb->(GET "http://localhost/foo");
+ ok $res->content !~ /:\d+:\d+/;
+};
+
+done_testing;
+
+
14 t/Plack-Request/hostname.t
View
@@ -0,0 +1,14 @@
+use strict;
+use warnings;
+use Test::More;
+use Plack::Test;
+use Plack::Request;
+
+plan tests => 2;
+
+my $req = Plack::Request->new({ REMOTE_HOST => "foo.example.com" });
+is $req->hostname, "foo.example.com";
+
+$req = Plack::Request->new({ REMOTE_HOST => '', REMOTE_ADDR => '127.0.0.1' });
+is $req->hostname, "localhost";
+
85 t/Plack-Request/many_upload.t
View
@@ -0,0 +1,85 @@
+use strict;
+use warnings;
+use Test::More;
+use Plack::Request;
+
+plan tests => 12;
+
+use File::Temp qw( tempdir );
+use Cwd;
+
+my $content = qq{------BOUNDARY
+Content-Disposition: form-data; name="test_upload_file"; filename="yappo.txt"
+Content-Type: text/plain
+
+SHOGUN
+------BOUNDARY
+Content-Disposition: form-data; name="test_upload_file"; filename="yappo2.txt"
+Content-Type: text/plain
+
+SHOGUN2
+------BOUNDARY
+Content-Disposition: form-data; name="test_upload_file3"; filename="yappo3.txt"
+Content-Type: text/plain
+
+SHOGUN3
+------BOUNDARY
+Content-Disposition: form-data; name="test_upload_file4"; filename="yappo4.txt"
+Content-Type: text/plain
+
+SHOGUN4
+------BOUNDARY
+Content-Disposition: form-data; name="test_upload_file4"; filename="yappo5.txt"
+Content-Type: text/plain
+
+SHOGUN4
+------BOUNDARY
+Content-Disposition: form-data; name="test_upload_file6"; filename="yappo6.txt"
+Content-Type: text/plain
+
+SHOGUN6
+------BOUNDARY--
+};
+$content =~ s/\r\n/\n/g;
+$content =~ s/\n/\r\n/g;
+
+{
+ open my $in, '<', \$content;
+ my $req = Plack::Request->new({
+ 'psgi.input' => $in,
+ CONTENT_LENGTH => length($content),
+ CONTENT_TYPE => 'multipart/form-data; boundary=----BOUNDARY',
+ REQUEST_METHOD => 'POST',
+ SCRIPT_NAME => '/',
+ SERVER_PORT => 80,
+ });
+ my $tempdir = tempdir( CLEANUP => 1 );
+ $req->_body_parser->upload_tmp($tempdir);
+
+ my @undef = $req->upload('undef');
+ is @undef, 0;
+ my $undef = $req->upload('undef');
+ is $undef, undef;
+
+ my @uploads = $req->upload('test_upload_file');
+ test_path($uploads[0]->tempname, $tempdir);
+ test_path($uploads[1]->tempname, $tempdir);
+ test_path($req->upload('test_upload_file4')->tempname, $tempdir);
+
+ like $uploads[0]->slurp, qr|^SHOGUN|;
+ like $uploads[1]->slurp, qr|^SHOGUN|;
+ is $req->upload('test_upload_file4')->slurp, 'SHOGUN4';
+
+ my $test_upload_file3 = $req->upload('test_upload_file3');
+ test_path($test_upload_file3->tempname, $tempdir);
+ is $test_upload_file3->slurp, 'SHOGUN3';
+
+ my @test_upload_file6 = $req->upload('test_upload_file6');
+ test_path($test_upload_file6[0]->tempname, $tempdir);
+ is $test_upload_file6[0]->slurp, 'SHOGUN6';
+}
+
+sub test_path {
+ my ($lhs, $rhs) = @_;
+ is index(Cwd::realpath($lhs), Cwd::realpath($rhs)), 0;
+}
27 t/Plack-Request/new.t
View
@@ -0,0 +1,27 @@
+use strict;
+use Test::More;
+use Plack::Request;
+
+my $req = Plack::Request->new({
+ REQUEST_METHOD => 'GET',
+ SERVER_PROTOCOL => 'HTTP/1.1',
+ SERVER_PORT => 80,
+ SERVER_NAME => 'example.com',
+ SCRIPT_NAME => '/foo',
+ REMOTE_ADDR => '127.0.0.1',
+ 'psgi.version' => [ 1, 0 ],
+ 'psgi.input' => undef,
+ 'psgi.errors' => undef,
+ 'psgi.url_scheme' => 'http',
+});
+
+isa_ok($req, 'Plack::Request');
+
+is($req->address, '127.0.0.1', 'address');
+is($req->method, 'GET', 'method');
+is($req->protocol, 'HTTP/1.1', 'protocol');
+is($req->uri, 'http://example.com/foo', 'uri');
+is($req->port, 80, 'port');
+is($req->url_scheme, 'http', 'url_scheme');
+
+done_testing();
21 t/Plack-Request/parameters.t
View
@@ -0,0 +1,21 @@
+use strict;
+use warnings;
+use Test::More tests => 2;
+use Plack::Request;
+
+do {
+ my $req = Plack::Request->new({ 'psgi.input' => \*STDIN });
+ $req->body_parameters(foo => 'bar');
+ $req->body_parameters(hoge => 'one');
+ $req->query_parameters({bar => 'baz', hoge => 'two'});
+ is_deeply $req->parameters(), {foo => 'bar', 'bar' => 'baz', hoge => [qw/ two one /]};
+};
+
+do {
+ my $req = Plack::Request->new({ 'psgi.input' => \*STDIN });
+ $req->body_parameters(foo => 'bar');
+ $req->body_parameters(hoge => 'one');
+ $req->query_parameters({bar => ['baz', 'bar'], hoge => 'two'});
+ is_deeply $req->parameters(), {foo => 'bar', 'bar' => ['baz', 'bar'], hoge => [qw/ two one /]};
+};
+
88 t/Plack-Request/params.t
View
@@ -0,0 +1,88 @@
+use strict;
+use warnings;
+use Test::Base;
+use Plack::Request;
+
+plan tests => 4*blocks;
+
+filters {
+ parameters => [qw/yaml/],
+ options => [qw/yaml/],
+ expected => [qw/yaml/],
+};
+
+run {
+ my $block = shift;
+ my $req = Plack::Request->new({ 'psgi.input' => \*STDIN });
+ $req->parameters($block->parameters);
+ is_deeply $req->params, $block->parameters;
+ is scalar($req->param), scalar(keys %{ $block->parameters });
+
+ my @options = $block->options;
+ @options = @{ $block->options } if ref $block->options;
+
+ my $ret = $req->param(@options);
+ if (@options > 1) {
+ is_deeply $ret, $block->expected;
+ return ok 1
+ }
+ my $expected = $block->expected ? $block->expected->[0] : undef;
+ is $ret, $expected;
+
+ my @ret = $req->param(@options);
+ return ok 1 unless @ret && $block->expected;
+ is_deeply \@ret, $block->expected;
+}
+
+__END__
+
+=== blank
+--- parameters
+ key: value
+ q: term
+--- options
+ - qq
+--- expected
+
+=== normal
+--- parameters
+ key: value
+ q: term
+--- options
+ - q
+--- expected
+ - term
+
+=== array param
+--- parameters
+ key: value
+ q:
+ - term
+ - search
+--- options
+ - q
+--- expected
+ - term
+ - search
+
+=== set param
+--- parameters
+ key: value
+ q: term
+--- options
+ - q
+ - search
+--- expected
+ - search
+
+=== set array param
+--- parameters
+ key: value
+ q: term
+--- options
+ - q
+ - search1
+ - search2
+--- expected
+ - search1
+ - search2
34 t/Plack-Request/path_info.t
View
@@ -0,0 +1,34 @@
+use strict;
+use Test::More;
+use Plack::Test;
+use Plack::App::URLMap;
+use Plack::Test;
+use Plack::Request;
+use HTTP::Request::Common;
+
+my $path_app = sub {
+ my $req = Plack::Request->new(shift);
+ my $res = $req->new_response(200);
+ $res->content_type('text/plain');
+ $res->content($req->path_info);
+ return $res->finalize;
+};
+
+my $app = Plack::App::URLMap->new;
+$app->map("/foo" => $path_app);
+$app->map("/" => $path_app);
+
+test_psgi app => $app->to_app, client => sub {
+ my $cb = shift;
+
+ my $res = $cb->(GET "http://localhost/foo");
+ is $res->content, '';
+
+ $res = $cb->(GET "http://localhost/foo/bar");
+ is $res->content, '/bar';
+
+ $res = $cb->(GET "http://localhost/xxx/yyy");
+ is $res->content, '/xxx/yyy';
+};
+
+done_testing;
20 t/Plack-Request/raw_uri.t
View
@@ -0,0 +1,20 @@
+use strict;
+use HTTP::Message::PSGI;
+use Test::More;
+use Plack::Request;
+use HTTP::Request::Common;
+
+my $raw_uri;
+
+my $app = sub {
+ my $req = Plack::Request->new(shift);
+ $raw_uri = $req->raw_uri;
+};
+
+$app->(req_to_psgi(GET "http://localhost/foo%20bar"));
+is $raw_uri, 'http://localhost/foo%20bar';
+
+$app->(req_to_psgi(GET "http://localhost:2020/FOO/bar,baz"));
+is $raw_uri, 'http://localhost:2020/FOO/bar,baz';
+
+done_testing;
22 t/Plack-Request/readbody.t
View
@@ -0,0 +1,22 @@
+use strict;
+use warnings;
+use Test::More tests => 1;
+use Plack::Test;
+use Plack::Request;
+use Try::Tiny;
+
+{
+ try {
+ my $data = 'a';
+ open my $input, "<", \$data;
+ my $req = Plack::Request->new({
+ 'psgi.input' => $input,
+ CONTENT_LENGTH => 3,
+ CONTENT_TYPE => 'application/octet-stream'
+ });
+ $req->_body_parser->http_body();
+ } catch {
+ like $_, qr/Wrong Content-Length value: 3/;
+ }
+}
+
9 t/Plack-Request/upload-basename.t
View
@@ -0,0 +1,9 @@
+use strict;
+use warnings;
+use Test::More tests => 1;
+use Plack::Request::Upload;
+
+my $upload = Plack::Request::Upload->new(
+ filename => '/tmp/foo/bar/hoge.txt',
+);
+is $upload->basename, 'hoge.txt';
42 t/Plack-Request/upload.t
View
@@ -0,0 +1,42 @@
+use strict;
+use warnings;
+use Test::More tests => 15;
+
+use Plack::Request::Upload;
+use Plack::Request;
+
+my $req = Plack::Request->new({
+ CONTENT_LENGTH => 0,
+ 'psgi.input' => *STDIN,
+ CONTENT_TYPE => 'text/plain'
+});
+
+# file1
+$req->upload(foo => Plack::Request::Upload->new(filename => 'foo1.txt'));
+is ref($req->upload('foo')), 'Plack::Request::Upload';
+is $req->upload('foo')->filename, 'foo1.txt';
+
+# file2
+$req->upload(foo => Plack::Request::Upload->new(filename => 'foo2.txt'));
+is ref($req->upload('foo')), 'Plack::Request::Upload';
+is $req->upload('foo')->filename, 'foo1.txt';
+my @files = $req->upload('foo');
+is scalar(@files), 2;
+is $files[0]->filename, 'foo1.txt';
+is $files[1]->filename, 'foo2.txt';
+
+# file3
+$req->upload(foo => Plack::Request::Upload->new(filename => 'foo3.txt'));
+is ref($req->upload('foo')), 'Plack::Request::Upload';
+is $req->upload('foo')->filename, 'foo1.txt';
+my @files2 = $req->upload('foo');
+is scalar(@files2), 3;
+is $files2[0]->filename, 'foo1.txt';
+is $files2[1]->filename, 'foo2.txt';
+is $files2[2]->filename, 'foo3.txt';
+
+# no arguments
+is join(', ', $req->upload()), 'foo';
+$req->upload(bar => Plack::Request::Upload->new(filename => 'bar1.txt'));
+is join(', ', sort { $a cmp $b } $req->upload()), 'bar, foo';
+
106 t/Plack-Request/uri.t
View
@@ -0,0 +1,106 @@
+use strict;
+use warnings;
+use Test::Base;
+use IO::Scalar;
+use Plack::Request;
+
+plan tests => 2*blocks;
+
+filters {
+ args => ['yaml'],
+ add_env => ['yaml'],
+ expected_params => ['eval'],
+};
+
+run {
+ my $block = shift;
+ my $env = {SERVER_PORT => 80};
+ if ($block->add_env && ref($block->add_env) eq 'HASH') {
+ while (my($key, $val) = each %{ $block->add_env }) {
+ $env->{$key} = $val;
+ }
+ }
+ my $req = Plack::Request->new($env);
+
+ if ($block->nullkey) {
+ $block->args->{$block->nullkey} = undef;
+ }
+
+ is $req->uri, $block->expected_uri;
+ is_deeply $req->query_parameters, $block->expected_params;
+};
+
+__END__
+
+===
+--- add_env
+ HTTP_HOST: example.com
+ SCRIPT_NAME: /
+--- expected_uri: http://example.com/
+--- expected: http://example.com/
+--- expected_params: {}
+
+===
+--- add_env
+ HTTP_HOST: example.com
+ SCRIPT_NAME: /test.c
+--- expected_uri: http://example.com/test.c
+--- expected: http://example.com/test.c
+--- expected_params: {}
+
+===
+--- add_env
+ HTTP_HOST: example.com
+ SCRIPT_NAME: /test.c
+ PATH_INFO: /info
+--- expected_uri: http://example.com/test.c/info
+--- expected: http://example.com/test.c/info
+--- expected_params: {}
+
+===
+--- add_env
+ HTTP_HOST: example.com
+ SCRIPT_NAME: /test
+ QUERY_STRING: dynamic=daikuma
+--- expected_uri: http://example.com/test?dynamic=daikuma
+--- expected: http://example.com/test?dynamic=daikuma
+--- expected_params: { dynamic => 'daikuma' }
+
+
+===
+--- add_env
+ HTTP_HOST: example.com
+ SCRIPT_NAME: /exec/
+--- expected_uri: http://example.com/exec/
+--- expected: http://example.com/exec/
+--- expected_params: {}
+
+===
+--- add_env
+ HTTP_HOST: example.com
+ SCRIPT_NAME: /////exec/
+--- expected_uri: http://example.com/exec/
+--- expected: http://example.com/exec/
+--- expected_params: {}
+
+===
+--- add_env
+ SERVER_NAME: example.com
+--- expected_uri: http://example.com/
+--- expected: http://example.com/
+--- expected_params: {}
+
+===
+--- add_env
+--- expected_uri: http:///
+--- expected: http:///
+--- expected_params: {}
+
+===
+--- add_env
+ HTTP_HOST: example.com
+ SCRIPT_NAME: /
+ QUERY_STRING: aco=tie
+--- expected: http://example.com/?aco=tie
+--- expected_uri: http://example.com/?aco=tie
+--- expected_params: { aco => 'tie' }
15 t/Plack-Request/uri_utf8.t
View
@@ -0,0 +1,15 @@
+use strict;
+use utf8;
+use Plack::Request;
+use HTTP::Request;
+use HTTP::Message::PSGI;
+use Test::More;
+
+my $path = "/Платежи";
+
+my $hreq = HTTP::Request->new(GET => "http://localhost" . $path);
+my $req = Plack::Request->new($hreq->to_psgi);
+
+is $req->path, '/%D0%9F%D0%BB%D0%B0%D1%82%D0%B5%D0%B6%D0%B8';
+
+done_testing;
34 t/Plack-Response/body.t
View
@@ -0,0 +1,34 @@
+use strict;
+use warnings;
+use FindBin;
+use Test::More;
+use Plack::Response;
+use URI;
+
+sub r($) {
+ my $res = Plack::Response->new(200);
+ $res->body(@_);
+ return $res->finalize->[2];
+}
+
+is_deeply r "Hello World", [ "Hello World" ];
+is_deeply r [ "Hello", "World" ], [ "Hello", "World" ];
+
+{
+ open my $fh, "$FindBin::Bin/body.t";
+ is_deeply r $fh, $fh;
+}
+
+{
+ my $foo = "bar";
+ open my $io, "<", \$foo;
+ is_deeply r $io, $io;
+}
+
+{
+ my $uri = URI->new("foo"); # stringified object
+ is_deeply r $uri, [ $uri ];
+}
+
+done_testing;
+
34 t/Plack-Response/new.t
View
@@ -0,0 +1,34 @@
+use strict;
+use warnings;
+use Test::More;
+use Plack::Response;
+
+{
+ my $res = Plack::Response->new(302);
+ is $res->status, 302;
+ is $res->code, 302;
+}
+
+{
+ my $res = Plack::Response->new(200, [ 'Content-Type' => 'text/plain' ]);
+ is $res->content_type, 'text/plain';
+}
+
+{
+ my $res = Plack::Response->new(200, { 'Content-Type' => 'text/plain' });
+ is $res->content_type, 'text/plain';
+}
+
+{
+ my $res = Plack::Response->new(200);
+ $res->content_type('image/png');
+ is $res->content_type, 'image/png';
+}
+
+{
+ my $res = Plack::Response->new(200);
+ $res->header('X-Foo' => "bar");
+ is $res->header('X-Foo'), "bar";
+}
+
+done_testing;
21 t/Plack-Response/redirect.t
View
@@ -0,0 +1,21 @@
+use strict;
+use warnings;
+use Test::More;
+use Plack::Response;
+
+{
+ my $res = Plack::Response->new;
+ $res->redirect('http://www.google.com/');
+ is $res->location, 'http://www.google.com/';
+ is $res->code, 302;
+
+ is_deeply $res->finalize, [ 302, [ 'Location' => 'http://www.google.com/' ], [] ];
+}
+
+{
+ my $res = Plack::Response->new;
+ $res->redirect('http://www.google.com/', 301);
+ is_deeply $res->finalize, [ 301, [ 'Location' => 'http://www.google.com/' ], [] ];
+}
+
+done_testing;
51 t/Plack-Response/response.t
View
@@ -0,0 +1,51 @@
+use strict;
+use warnings;
+use Test::More;
+use Plack::Response;
+
+sub res {
+ my $res = Plack::Response->new;
+ my %v = @_;
+ while (my($k, $v) = each %v) {
+ $res->$k($v);
+ }
+ $res->finalize;
+}
+
+is_deeply(
+ res(
+ status => 200,
+ body => 'hello',
+ ),
+ [ 200, +[], [ 'hello' ] ]
+);
+is_deeply(
+ res(
+ status => 200,
+ cookies => +{
+ 'foo_sid' => +{
+ value => 'ASDFJKL:',
+ expires => 'Thursday, 25-Apr-1999 00:40:33 GMT',
+ domain => 'example.com',
+ path => '/',
+ },
+ 'poo_sid' => +{
+ value => 'QWERTYUI',
+ expires => 'Thursday, 25-Apr-1999 00:40:33 GMT',
+ domain => 'example.com',
+ path => '/',
+ },
+ },
+ body => 'hello',
+ ),
+ [
+ 200,
+ +[
+ 'Set-Cookie' => 'poo_sid=QWERTYUI; domain=example.com; path=/; expires=Thursday, 25-Apr-1999 00:40:33 GMT',
+ 'Set-Cookie' => 'foo_sid=ASDFJKL%3A; domain=example.com; path=/; expires=Thursday, 25-Apr-1999 00:40:33 GMT',
+ ],
+ [ 'hello' ],
+ ]
+);
+
+done_testing;
Please sign in to comment.
Something went wrong with that request. Please try again.