Move test fixtures to samples/

samples/perl/Request.pm

@@ -0,0 +1,695 @@
+package Plack::Request;
+use strict;
+use warnings;
+use 5.008_001;
+our $VERSION = '0.9988';
+$VERSION = eval $VERSION;
+
+use HTTP::Headers;
+use Carp ();
+use Hash::MultiValue;
+use HTTP::Body;
+
+use Plack::Request::Upload;
+use Plack::TempBuffer;
+use URI;
+use URI::Escape ();
+
+sub _deprecated {
+    my $alt = shift;
+    my $method = (caller(1))[3];
+    Carp::carp("$method is deprecated. Use '$alt' instead.");
+}
+
+sub new {
+    my($class, $env) = @_;
+    Carp::croak(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 remote_host { $_[0]->env->{REMOTE_HOST} }
+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 path_info   { $_[0]->env->{PATH_INFO} }
+sub path        { $_[0]->env->{PATH_INFO} || '/' }
+sub script_name { $_[0]->env->{SCRIPT_NAME} }
+sub scheme      { $_[0]->env->{'psgi.url_scheme'} }
+sub secure      { $_[0]->scheme eq 'https' }
+sub body        { $_[0]->env->{'psgi.input'} }
+sub input       { $_[0]->env->{'psgi.input'} }
+
+sub content_length   { $_[0]->env->{CONTENT_LENGTH} }
+sub content_type     { $_[0]->env->{CONTENT_TYPE} }
+
+sub session         { $_[0]->env->{'psgix.session'} }
+sub session_options { $_[0]->env->{'psgix.session.options'} }
+sub logger          { $_[0]->env->{'psgix.logger'} }
+
+sub cookies {
+    my $self = shift;
+
+    return {} unless $self->env->{HTTP_COOKIE};
+
+    # HTTP_COOKIE hasn't changed: reuse the parsed cookie
+    if (   $self->env->{'plack.cookie.parsed'}
+        && $self->env->{'plack.cookie.string'} eq $self->env->{HTTP_COOKIE}) {
+        return $self->env->{'plack.cookie.parsed'};
+    }
+
+    $self->env->{'plack.cookie.string'} = $self->env->{HTTP_COOKIE};
+
+    my %results;
+    my @pairs = grep /=/, split "[;,] ?", $self->env->{'plack.cookie.string'};
+    for my $pair ( @pairs ) {
+        # trim leading trailing whitespace
+        $pair =~ s/^\s+//; $pair =~ s/\s+$//;
+
+        my ($key, $value) = map URI::Escape::uri_unescape($_), split( "=", $pair, 2 );
+
+        # Take the first one like CGI.pm or rack do
+        $results{$key} = $value unless exists $results{$key};
+    }
+
+    $self->env->{'plack.cookie.parsed'} = \%results;
+}
+
+sub query_parameters {
+    my $self = shift;
+    $self->env->{'plack.request.query'} ||= Hash::MultiValue->new($self->uri->query_form);
+}
+
+sub content {
+    my $self = shift;
+
+    unless ($self->env->{'psgix.input.buffered'}) {
+        $self->_parse_request_body;
+    }
+
+    my $fh = $self->input                 or return '';
+    my $cl = $self->env->{CONTENT_LENGTH} or return'';
+    $fh->read(my($content), $cl, 0);
+    $fh->seek(0, 0);
+
+    return $content;
+}
+
+sub raw_body { $_[0]->content }
+
+# XXX you can mutate headers with ->headers but it's not written through to the env
+
+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};
+}
+
+sub content_encoding { shift->headers->content_encoding(@_) }
+sub header           { shift->headers->header(@_) }
+sub referer          { shift->headers->referer(@_) }
+sub user_agent       { shift->headers->user_agent(@_) }
+
+sub body_parameters {
+    my $self = shift;
+
+    unless ($self->env->{'plack.request.body'}) {
+        $self->_parse_request_body;
+    }
+
+    return $self->env->{'plack.request.body'};
+}
+
+# contains body + query
+sub parameters {
+    my $self = shift;
+
+    $self->env->{'plack.request.merged'} ||= do {
+        my $query = $self->query_parameters;
+        my $body  = $self->body_parameters;
+        Hash::MultiValue->new($query->flatten, $body->flatten);
+    };
+}
+
+sub uploads {
+    my $self = shift;
+
+    if ($self->env->{'plack.request.upload'}) {
+        return $self->env->{'plack.request.upload'};
+    }
+
+    $self->_parse_request_body;
+    return $self->env->{'plack.request.upload'};
+}
+
+sub hostname     { _deprecated 'remote_host';      $_[0]->remote_host || $_[0]->address }
+sub url_scheme   { _deprecated 'scheme';           $_[0]->scheme }
+sub params       { _deprecated 'parameters';       shift->parameters(@_) }
+sub query_params { _deprecated 'query_parameters'; shift->query_parameters(@_) }
+sub body_params  { _deprecated 'body_parameters';  shift->body_parameters(@_) }
+
+sub cookie {
+    my $self = shift;
+    _deprecated 'cookies';
+
+    return keys %{ $self->cookies } if @_ == 0;
+
+    my $name = shift;
+    return $self->cookies->{$name};
+}
+
+sub param {
+    my $self = shift;
+
+    return keys %{ $self->parameters } if @_ == 0;
+
+    my $key = shift;
+    return $self->parameters->{$key} unless wantarray;
+    return $self->parameters->get_all($key);
+}
+
+sub upload {
+    my $self = shift;
+
+    return keys %{ $self->uploads } if @_ == 0;
+
+    my $key = shift;
+    return $self->uploads->{$key} unless wantarray;
+    return $self->uploads->get_all($key);
+}
+
+sub raw_uri {
+    my $self = shift;
+    _deprecated 'base';
+
+    my $base = $self->base;
+    $base->path_query($self->env->{REQUEST_URI});
+
+    $base;
+}
+
+sub uri {
+    my $self = shift;
+
+    my $base = $self->_uri_base;
+
+    # We have to escape back PATH_INFO in case they include stuff like
+    # ? or # so that the URI parser won't be tricked. However we should
+    # preserve '/' since encoding them into %2f doesn't make sense.
+    # This means when a request like /foo%2fbar comes in, we recognize
+    # it as /foo/bar which is not ideal, but that's how the PSGI PATH_INFO
+    # spec goes and we can't do anything about it. See PSGI::FAQ for details.
+    # http://github.com/miyagawa/Plack/issues#issue/118
+    my $path_escape_class = '^A-Za-z0-9\-\._~/';
+
+    my $path = URI::Escape::uri_escape($self->env->{PATH_INFO} || '', $path_escape_class);
+    $path .= '?' . $self->env->{QUERY_STRING}
+        if defined $self->env->{QUERY_STRING} && $self->env->{QUERY_STRING} ne '';
+
+    $base =~ s!/$!! if $path =~ m!^/!;
+
+    return URI->new($base . $path)->canonical;
+}
+
+sub base {
+    my $self = shift;
+    URI->new($self->_uri_base)->canonical;
+}
+
+sub _uri_base {
+    my $self = shift;
+
+    my $env = $self->env;
+
+    my $uri = ($env->{'psgi.url_scheme'} || "http") .
+        "://" .
+        ($env->{HTTP_HOST} || (($env->{SERVER_NAME} || "") . ":" . ($env->{SERVER_PORT} || 80))) .
+        ($env->{SCRIPT_NAME} || '/');
+
+    return $uri;
+}
+
+sub new_response {
+    my $self = shift;
+    require Plack::Response;
+    Plack::Response->new(@_);
+}
+
+sub _parse_request_body {
+    my $self = shift;
+
+    my $ct = $self->env->{CONTENT_TYPE};
+    my $cl = $self->env->{CONTENT_LENGTH};
+    if (!$ct && !$cl) {
+        # No Content-Type nor Content-Length -> GET/HEAD
+        $self->env->{'plack.request.body'}   = Hash::MultiValue->new;
+        $self->env->{'plack.request.upload'} = Hash::MultiValue->new;
+        return;
+    }
+
+    my $body = HTTP::Body->new($ct, $cl);
+
+    # HTTP::Body will create temporary files in case there was an
+    # upload.  Those temporary files can be cleaned up by telling
+    # HTTP::Body to do so. It will run the cleanup when the request
+    # env is destroyed. That the object will not go out of scope by
+    # the end of this sub we will store a reference here.
+    $self->env->{'plack.request.http.body'} = $body;
+    $body->cleanup(1);
+
+    my $input = $self->input;
+
+    my $buffer;
+    if ($self->env->{'psgix.input.buffered'}) {
+        # Just in case if input is read by middleware/apps beforehand
+        $input->seek(0, 0);
+    } else {
+        $buffer = Plack::TempBuffer->new($cl);
+    }
+
+    my $spin = 0;
+    while ($cl) {
+        $input->read(my $chunk, $cl < 8192 ? $cl : 8192);
+        my $read = length $chunk;
+        $cl -= $read;
+        $body->add($chunk);
+        $buffer->print($chunk) if $buffer;
+
+        if ($read == 0 && $spin++ > 2000) {
+            Carp::croak "Bad Content-Length: maybe client disconnect? ($cl bytes remaining)";
+        }
+    }
+
+    if ($buffer) {
+        $self->env->{'psgix.input.buffered'} = 1;
+        $self->env->{'psgi.input'} = $buffer->rewind;
+    } else {
+        $input->seek(0, 0);
+    }
+
+    $self->env->{'plack.request.body'}   = Hash::MultiValue->from_mixed($body->param);
+
+    my @uploads = Hash::MultiValue->from_mixed($body->upload)->flatten;
+    my @obj;
+    while (my($k, $v) = splice @uploads, 0, 2) {
+        push @obj, $k, $self->_make_upload($v);
+    }
+
+    $self->env->{'plack.request.upload'} = Hash::MultiValue->new(@obj);
+
+    1;
+}
+
+sub _make_upload {
+    my($self, $upload) = @_;
+    my %copy = %$upload;
+    $copy{headers} = HTTP::Headers->new(%{$upload->{headers}});
+    Plack::Request::Upload->new(%copy);
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Plack::Request - Portable HTTP request object from PSGI env hash
+
+=head1 SYNOPSIS
+
+  use Plack::Request;
+
+  my $app_or_middleware = sub {
+      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
+      $res->finalize;
+  };
+
+=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 Plack middleware
+developers and 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 (L<http://plackperl.org/#frameworks>),
+or see modules like L<HTTP::Engine> to provide higher level
+Request and Response API on top of PSGI.
+
+=head1 METHODS
+
+Some of the methods defined in the earlier versions are deprecated in
+version 0.99. Take a look at L</"INCOMPATIBILITIES">.
+
+Unless otherwise noted, all methods and attributes are B<read-only>,
+and passing values to the method like an accessor doesn't work like
+you expect it to.
+
+=head2 new
+
+    Plack::Request->new( $env );
+
+Creates a new request object.
+
+=head1 ATTRIBUTES
+
+=over 4
+
+=item env
+
+Returns the shared PSGI environment hash reference. This is a
+reference, so writing to this environment passes through during the
+whole PSGI request/response cycle.
+
+=item address
+
+Returns the IP address of the client (C<REMOTE_ADDR>).
+
+=item remote_host
+
+Returns the remote host (C<REMOTE_HOST>) of the client. It may be
+empty, in which case you have to get the IP address using C<address>
+method and resolve on your own.
+
+=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 raw, undecoded request URI path. You probably do B<NOT>
+want to use this to dispatch requests.
+
+=item path_info
+
+Returns B<PATH_INFO> in the environment. Use this to get the local
+path for the requests.
+
+=item path
+
+Similar to C<path_info> but returns C</> in case it is empty. In other
+words, it returns the virtual path of the request URI after C<<
+$req->base >>. See L</"DISPATCHING"> for details.
+
+=item script_name
+
+Returns B<SCRIPT_NAME> in the environment. This is the absolute path
+where your application is hosted.
+
+=item scheme
+
+Returns the scheme (C<http> or C<https>) of the request.
+
+=item secure
+
+Returns true or false, indicating whether the connection is secure (https).
+
+=item body, input
+
+Returns C<psgi.input> handle.
+
+=item session
+
+Returns (optional) C<psgix.session> hash. When it exists, you can
+retrieve and store per-session data from and to this hash.
+
+=item session_options
+
+Returns (optional) C<psgix.session.options> hash.
+
+=item logger
+
+Returns (optional) C<psgix.logger> code reference. When it exists,
+your application is supposed to send the log message to this logger,
+using:
+
+  $req->logger->({ level => 'debug', message => "This is a debug message" });
+
+=item cookies
+
+Returns a reference to a hash containing the cookies. Values are
+strings that are sent by clients and are URI decoded.
+
+=item query_parameters
+
+Returns a reference to a hash containing query string (GET)
+parameters. This hash reference is L<Hash::MultiValue> object.
+
+=item body_parameters
+
+Returns a reference to a hash containing posted parameters in the
+request body (POST). As with C<query_parameters>, the hash
+reference is a L<Hash::MultiValue> object.
+
+=item parameters
+
+Returns a L<Hash::MultiValue> hash reference containing (merged) GET
+and POST parameters.
+
+=item content, raw_body
+
+Returns the request content in an undecoded byte string for POST requests.
+
+=item uri
+
+Returns an URI object for the current request. The URI is constructed
+using various environment values such as C<SCRIPT_NAME>, C<PATH_INFO>,
+C<QUERY_STRING>, C<HTTP_HOST>, C<SERVER_NAME> and C<SERVER_PORT>.
+
+Every time this method is called it returns a new, cloned URI object.
+
+=item base
+
+Returns an URI object for the base path of current request. This is
+like C<uri> but only contains up to C<SCRIPT_NAME> where your
+application is hosted at.
+
+Every time this method is called it returns a new, cloned URI object.
+
+=item user
+
+Returns C<REMOTE_USER> if it's set.
+
+=item headers
+
+Returns an L<HTTP::Headers> object containing the headers for the current request.
+
+=item uploads
+
+Returns a reference to a hash containing uploads. The hash reference
+is a L<Hash::MultiValue> object and values are 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 param
+
+Returns GET and POST parameters with a CGI.pm-compatible param
+method. This is an alternative method for accessing parameters in
+$req->parameters. Unlike CGI.pm, it does I<not> allow
+setting or modifying query parameters.
+
+    $value  = $req->param( 'foo' );
+    @values = $req->param( 'foo' );
+    @params = $req->param;
+
+=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> object. 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
+
+=head2 Hash::MultiValue parameters
+
+Parameters that can take one or multiple values (i.e. C<parameters>,
+C<query_parameters>, C<body_parameters> and C<uploads>) store the
+hash reference as a L<Hash::MultiValue> object. This means you can use
+the hash reference as a plain hash where values are B<always> scalars
+(B<NOT> array references), so you don't need to code ugly and unsafe
+C<< ref ... eq 'ARRAY' >> anymore.
+
+And if you explicitly want to get multiple values of the same key, you
+can call the C<get_all> method on it, such as:
+
+  my @foo = $req->query_parameters->get_all('foo');
+
+You can also call C<get_one> to always get one parameter independent
+of the context (unlike C<param>), and even call C<mixed> (with
+Hash::MultiValue 0.05 or later) to get the I<traditional> hash
+reference,
+
+  my $params = $req->parameters->mixed;
+
+where values are either a scalar or an array reference depending on
+input, so it might be useful if you already have the code to deal with
+that ugliness.
+
+=head2 PARSING POST BODY and MULTIPLE OBJECTS
+
+The methods to parse request body (C<content>, C<body_parameters> and
+C<uploads>) are carefully coded to save the parsed body in the
+environment hash as well as in the temporary buffer, so you can call
+them multiple times and create Plack::Request objects multiple times
+in a request and they should work safely, and won't parse request body
+more than twice for the efficiency.
+
+=head1 DISPATCHING
+
+If your application or framework wants to dispatch (or route) actions
+based on request paths, be sure to use C<< $req->path_info >> not C<<
+$req->uri->path >>.
+
+This is because C<path_info> gives you the virtual path of the request,
+regardless of how your application is mounted. If your application is
+hosted with mod_perl or CGI scripts, or even multiplexed with tools
+like L<Plack::App::URLMap>, request's C<path_info> always gives you
+the action path.
+
+Note that C<path_info> might give you an empty string, in which case
+you should assume that the path is C</>.
+
+You will also want to use C<< $req->base >> as a base prefix when
+building URLs in your templates or in redirections. It's a good idea
+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.
+
+The following methods are deprecated: C<hostname>, C<url_scheme>,
+C<params>, C<query_params>, C<body_params>, C<cookie> and
+C<raw_uri>. They will be removed in the next major release.
+
+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->cookie->{foo} ? $req->cookie->{foo}->value : undef;
+
+and instead, simply do:
+
+  $v = $req->cookie->{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

samples/perl/Response.pm

@@ -0,0 +1,309 @@
+package Plack::Response;
+use strict;
+use warnings;
+our $VERSION = '0.9988';
+$VERSION = eval $VERSION;
+
+use Plack::Util::Accessor qw(body status);
+use Carp ();
+use Scalar::Util ();
+use HTTP::Headers;
+use URI::Escape ();
+
+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 (@_) {
+        $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 {
+    my $self = shift;
+    return $self->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;
+    Carp::croak "missing status" unless $self->status();
+
+    my $headers = $self->headers->clone;
+    $self->_finalize_cookies($headers);
+
+    return [
+        $self->status,
+        +[
+            map {
+                my $k = $_;
+                map {
+                    my $v = $_;
+                    $v =~ s/\015\012[\040|\011]+/chr(32)/ge; # replace LWS with a single SP
+                    $v =~ s/\015|\012//g; # remove CR and LF since the char is invalid here
+
+                    ( $k => $v )
+                } $headers->header($_);
+
+            } $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("")) && !$body->can('getline')) {
+        return [ $body ];
+    } else {
+        return $body;
+    }
+}
+
+sub _finalize_cookies {
+    my($self, $headers) = @_;
+
+    while (my($name, $val) = each %{$self->cookies}) {
+        my $cookie = $self->_bake_cookie($name, $val);
+        $headers->push_header('Set-Cookie' => $cookie);
+    }
+}
+
+sub _bake_cookie {
+    my($self, $name, $val) = @_;
+
+    return '' unless defined $val;
+    $val = { value => $val } unless ref $val eq 'HASH';
+
+    my @cookie = ( URI::Escape::uri_escape($name) . "=" . URI::Escape::uri_escape($val->{value}) );
+    push @cookie, "domain=" . $val->{domain}   if $val->{domain};
+    push @cookie, "path=" . $val->{path}       if $val->{path};
+    push @cookie, "expires=" . $self->_date($val->{expires}) if $val->{expires};
+    push @cookie, "secure"                     if $val->{secure};
+    push @cookie, "HttpOnly"                   if $val->{httponly};
+
+    return join "; ", @cookie;
+}
+
+my @MON  = qw( Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec );
+my @WDAY = qw( Sun Mon Tue Wed Thu Fri Sat );
+
+sub _date {
+    my($self, $expires) = @_;
+
+    if ($expires =~ /^\d+$/) {
+        # all numbers -> epoch date
+        # (cookies use '-' as date separator, HTTP uses ' ')
+        my($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($expires);
+        $year += 1900;
+
+        return sprintf("%s, %02d-%s-%04d %02d:%02d:%02d GMT",
+                       $WDAY[$wday], $mday, $MON[$mon], $year, $hour, $min, $sec);
+
+    }
+
+    return $expires;
+}
+
+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.
+
+Note that this method doesn't automatically set I<Content-Length> for
+the response. You have to set it manually if you want, with the
+C<content_length> method (see below).
+
+=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.
+
+Note that this method doesn't normalize the given URI string. Users of
+this module have to be responsible about properly encoding URI paths
+and parameters.
+
+=item location
+
+Gets and sets C<Location> header.
+
+Note that this method doesn't normalize the given URI string in the
+setter. See above in C<redirect> for details.
+
+=item cookies
+
+  $res->cookies->{foo} = 123;
+  $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 a plain string (for C<value> with everything
+else defaults) or a hash reference that can contain keys such as
+C<value>, C<domain>, C<expires>, C<path>, C<httponly>, C<secure>.
+
+C<expires> can take a string or an integer (as an epoch time) and
+B<does not> convert string formats such as C<+3M>.
+
+  $res->cookies->{foo} = {
+      value => 'test',
+      path  => "/",
+      domain => '.example.com',
+      expires => time + 24 * 60 * 60,
+  };
+
+=item finalize
+
+  $res->finalize;
+
+Returns the status code, headers, and body of this response as a PSGI
+response array reference.
+
+=back
+
+=head1 AUTHOR
+
+Tokuhiro Matsuno
+
+Tatsuhiko Miyagawa
+
+=head1 SEE ALSO
+
+L<Plack::Request>
+
+=cut

samples/perl/fib.pl

@@ -0,0 +1,42 @@
+#! perl
+# Copyright (C) 2001-2003, Parrot Foundation.
+
+=head1 NAME
+
+examples/benchmarks/fib.pl - Fibonacci Benchmark
+
+=head1 SYNOPSIS
+
+    % time perl examples/benchmarks/fib.pl n
+
+=head1 DESCRIPTION
+
+Calculates the Fibonacci Number for C<n> (defaults to 28 if
+unspecified).
+
+=cut
+
+use strict;
+use warnings;
+
+sub fib {
+    my $n = shift;
+    return $n if ( $n < 2 );
+    return fib( $n - 1 ) + fib( $n - 2 );
+}
+my $N = shift || 28;
+
+print "fib($N) = ", fib($N), "\n";
+
+=head1 SEE ALSO
+
+F<examples/benchmarks/fib.pir>.
+
+=cut
+
+# Local Variables:
+#   mode: cperl
+#   cperl-indent-level: 4
+#   fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:

samples/perl/oo1.pl

@@ -0,0 +1,27 @@
+#! perl
+
+# Copyright (C) 2004-2006, Parrot Foundation.
+
+use strict;
+use warnings;
+
+for my $i ( 1 .. 100000 ) {
+    my $o = new Foo();
+}
+my $o = new Foo();
+print $o->[0], "\n";
+
+package Foo;
+
+sub new {
+    my $self = ref $_[0] ? ref shift : shift;
+    return bless [ 10, 20 ], $self;
+}
+1;
+
+# Local Variables:
+#   mode: cperl
+#   cperl-indent-level: 4
+#   fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:

samples/perl/oo2.pl

@@ -0,0 +1,27 @@
+#! perl
+
+# Copyright (C) 2004-2006, Parrot Foundation.
+
+use strict;
+use warnings;
+
+for my $i ( 1 .. 500000 ) {
+    my $o = new Foo();
+}
+my $o = new Foo();
+print $o->[0], "\n";
+
+package Foo;
+
+sub new {
+    my $self = ref $_[0] ? ref shift : shift;
+    return bless [ 10, 20 ], $self;
+}
+1;
+
+# Local Variables:
+#   mode: cperl
+#   cperl-indent-level: 4
+#   fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:

samples/perl/oo3.pl

@@ -0,0 +1,29 @@
+#! perl
+
+# Copyright (C) 2004-2006, Parrot Foundation.
+
+use strict;
+use warnings;
+
+my $o = new Foo();
+for my $i ( 1 .. 500000 ) {
+    my $x = $o->[0];
+    my $y = $o->[1];
+}
+print $o->[0], "\n";
+
+package Foo;
+
+sub new {
+    my $self = ref $_[0] ? ref shift : shift;
+    return bless [ 10, 20 ], $self;
+}
+
+1;
+
+# Local Variables:
+#   mode: cperl
+#   cperl-indent-level: 4
+#   fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:

samples/perl/perl-test.t

@@ -0,0 +1,10 @@
+use strict;
+use warnings;
+
+use Foo::Bar
+
+$n = 42;
+$name = "world";
+@array = ("1","2","3");
+%hash = ("foo":"bar");
+my $name = "josh";

samples/perl/script.pl

@@ -0,0 +1,2 @@
+#!/usr/local/bin/perl
+print "Perl\n"

samples/perl/test-perl.pl

@@ -0,0 +1,2 @@
+#!/usr/bin/perl
+print "Hello, world!\n";

samples/perl/test-perl2.pl

@@ -0,0 +1,3 @@
+
+# Perl file without shebang
+print "Hello, world!\n";