Change log for Web::Simple
+ - Add experimental upload support
- Update Plack usage to call ::Handler:: classes not ::Server::
- Assume FastCGI mode if STDIN is a socket (works some places env vars fail)
- Change CLI mode to print status line and headers to STDERR and content
sub UNPACKED_QUERY () { __PACKAGE__.'.unpacked_query' }
sub UNPACKED_BODY () { __PACKAGE__.'.unpacked_body' }
+sub UNPACKED_BODY_OBJECT () { __PACKAGE__.'.unpacked_body_object' }
+sub UNPACKED_UPLOADS () { __PACKAGE__.'.unpacked_uploads' }
sub get_unpacked_query_from {
return $_[0]->{+UNPACKED_QUERY} ||= do {
sub get_unpacked_body_from {
return $_[0]->{+UNPACKED_BODY} ||= do {
- if (index(lc($_[0]->{CONTENT_TYPE}||''), 'application/x-www-form-urlencoded') >= 0
- and defined $_[0]->{CONTENT_LENGTH}) {
+ my $ct = lc($_[0]->{CONTENT_TYPE}||'');
+ if (!$_[0]->{CONTENT_LENGTH}) {
+ {}
+ } elsif (index($ct, 'application/x-www-form-urlencoded') >= 0) {
$_[0]->{'psgi.input'}->read(my $buf, $_[0]->{CONTENT_LENGTH});
_unpack_params($buf);
+ } elsif (index($ct, 'multipart/form-data') >= 0) {
+ my $p = get_unpacked_body_object_from($_[0])->param;
+ # forcible arrayification
+ +{
+ map +(ref($p->{$_}) eq 'ARRAY'
+ ? ($_ => $p->{$_})
+ : ($_ => [ $p->{$_} ])
+ ), keys %$p
+ };
} else {
{}
}
};
}
+sub get_unpacked_body_object_from {
+ # we may have no object at all - so use a single element arrayref for ||=
+ return ($_[0]->{+UNPACKED_BODY_OBJECT} ||= do {
+ if (!$_[0]->{CONTENT_LENGTH}) {
+ [ undef ]
+ } elsif (index(lc($_[0]->{CONTENT_TYPE}||''),'multipart/form-data')==-1) {
+ [ undef ]
+ } else {
+ [ _make_http_body($_[0]) ]
+ }
+ })->[0];
+}
+
+sub get_unpacked_uploads_from {
+ $_[0]->{+UNPACKED_UPLOADS} ||= do {
+ require Web::Dispatch::Upload; require HTTP::Headers;
+ my ($final, $reason) = (
+ {}, "field %s exists with value %s but body was not multipart/form-data"
+ );
+ if (my $body = get_unpacked_body_object_from($_[0])) {
+ my $u = $body->upload;
+ $reason = "field %s exists with value %s but was not an upload";
+ foreach my $k (keys %$u) {
+ foreach my $v (ref($u->{$k}) eq 'ARRAY' ? @{$u->{$k}} : $u->{$k}) {
+ push(@{$final->{$k}||=[]}, Web::Dispatch::Upload->new(
+ %{$v},
+ headers => HTTP::Headers->new($v->{headers})
+ ));
+ }
+ }
+ }
+ my $b = get_unpacked_body_from($_[0]);
+ foreach my $k (keys %$b) {
+ next if $final->{$k};
+ foreach my $v (@{$b->{$k}}) {
+ next unless $v;
+ push(@{$final->{$k}||=[]}, Web::Dispatch::NotAnUpload->new(
+ filename => $v,
+ reason => sprintf($reason, $k, $v)
+ ));
+ }
+ }
+ $final;
+ };
+}
{
# shamelessly stolen from HTTP::Body::UrlEncoded by Christian Hansen
}
}
+{
+ # shamelessly stolen from Plack::Request by miyagawa
+
+ sub _make_http_body {
+
+ # Can't actually do this yet, since Plack::Request deletes the
+ # header structure out of the uploads in its copy of the body.
+ # I suspect I need to supply miyagawa with a failing test.
+
+ #if (my $plack_body = $_[0]->{'plack.request.http.body'}) {
+ # # Plack already constructed one; probably wasteful to do it again
+ # return $plack_body;
+ #}
+
+ require HTTP::Body;
+ my $body = HTTP::Body->new(@{$_[0]}{qw(CONTENT_TYPE CONTENT_LENGTH)});
+ $body->cleanup(1);
+ my $spin = 0;
+ my $input = $_[0]->{'psgi.input'};
+ my $cl = $_[0]->{CONTENT_LENGTH};
+ while ($cl) {
+ $input->read(my $chunk, $cl < 8192 ? $cl : 8192);
+ my $read = length $chunk;
+ $cl -= $read;
+ $body->add($chunk);
+
+ if ($read == 0 && $spin++ > 2000) {
+ require Carp;
+ Carp::croak("Bad Content-Length: maybe client disconnect? ($cl bytes remaining)");
+ }
+ }
+ return $body;
+ }
+}
+
1;
# %<param spec>
/\G\%/gc and
return $self->_parse_param_handler($_, 'body');
+
+ # *<param spec>
+ /\G\*/gc and
+ return $self->_parse_param_handler($_, 'uploads');
}
return; # () will trigger the blam in our caller
}
our @EXPORT = qw(
match_and match_or match_not match_method match_path match_path_strip
- match_extension match_query match_body
+ match_extension match_query match_body match_uploads
);
sub match_and {
}
sub match_query {
- my $spec = shift;
- require Web::Dispatch::ParamParser;
- sub {
- _extract_params(
- Web::Dispatch::ParamParser::get_unpacked_query_from($_[0]),
- $spec
- )
- };
+ _param_matcher(query => $_[0]);
}
sub match_body {
- my $spec = shift;
+ _param_matcher(body => $_[0]);
+}
+
+sub match_uploads {
+ _param_matcher(uploads => $_[0]);
+}
+
+sub _param_matcher {
+ my ($type, $spec) = @_;
require Web::Dispatch::ParamParser;
+ my $unpack = Web::Dispatch::ParamParser->can("get_unpacked_${type}_from");
sub {
- _extract_params(
- Web::Dispatch::ParamParser::get_unpacked_body_from($_[0]),
- $spec
- )
+ _extract_params($unpack->($_[0]), $spec)
};
}
--- /dev/null
+use strictures 1;
+
+{
+ package Web::Dispatch::Upload;
+ use base qw(Plack::Request::Upload);
+ use overload '""' => 'tempname', fallback => 1;
+
+ sub is_upload { 1 }
+
+ sub reason { '' }
+}
+
+{
+ package Web::Dispatch::NotAnUpload;
+
+ use overload '""' => '_explode', fallback => 1;
+
+ sub new {
+ my ($class, %args) = @_;
+ bless {
+ filename => $args{filename},
+ reason => $args{reason}
+ }, $class;
+ }
+
+ sub is_upload { 0 }
+
+ sub reason { $_[0]->{reason} }
+
+ sub _explode {
+ die "Not actually an upload: ".$_[0]->{reason}
+ }
+
+ sub filename { $_[0]->_explode }
+ sub headers { $_[0]->_explode }
+ sub size { $_[0]->_explode }
+ sub tempname { $_[0]->_explode }
+ sub path { $_[0]->_explode }
+ sub content_type { $_[0]->_explode }
+ sub type { $_[0]->_explode }
+ sub basename { $_[0]->_explode }
+}
+
+1;
Web::Simple - A quick and easy way to build simple web applications
-=head1 WARNING
-
-This is really quite new. If you're reading this on CPAN, it means the stuff
-that's here we're probably happy with. But only probably. So we may have to
-change stuff. And if you're reading this from git, come check with irc.perl.org
-#web-simple that we're actually sure we're going to keep anything that's
-different from the CPAN version.
-
-If we do find we have to change stuff we'll add to the
-L<CHANGES BETWEEN RELEASES> section explaining how to switch your code across
-to the new version, and we'll do our best to make it as painless as possible
-because we've got Web::Simple applications too. But we can't promise not to
-change things at all. Not yet. Sorry.
=head1 SYNOPSIS
order you defined them in the protoype, but all hashrefs will merge into a
single C<$params>, as in the example above.
+=head3 Upload matches (EXPERIMENTAL)
+
+Note: This feature is experimental. This means that it may not remain
+100% in its current form. If we change it, notes on updating your code
+will be added to the L</CHANGES BETWEEN RELEASES> section below.
+
+ sub (*foo=) { # param specifier can be anything valid for query or body
+
+The upload match system functions exactly like a query/body match, except
+that the values returned (if any) are C<Web::Dispatch::Upload> objects.
+
+Note that this match type will succeed in two circumstances where you might
+not expect it to - first, when the field exists but is not an upload field
+and second, when the field exists but the form is not an upload form (i.e.
+content type "application/x-www-form-urlencoded" rather than
+"multipart/form-data"). In either of these cases, what you'll get back is
+a C<Web::Dispatch::NotAnUpload> object, which will C<die> with an error
+pointing out the problem if you try and use it. To be sure you have a real
+upload object, call
+
+ $upload->is_upload # returns 1 on a valid upload, 0 on a non-upload field
+
+and to get the reason why such an object is not an upload, call
+
+ $upload->reason # returns a reason or '' on a valid upload.
+
+Other than these two methods, the upload object provides the same interface
+as L<Plack::Request::Upload> with the addition of a stringify to the temporary
+filename to make copying it somewhere else easier to handle.
+
=head3 Combining matches
Matches may be combined with the + character - e.g.
use strict;
use warnings FATAL => 'all';
-use Test::More (
- eval { require HTTP::Request::AsCGI }
- ? 'no_plan'
- : (skip_all => 'No HTTP::Request::AsCGI')
-);
+use Test::More qw(no_plan);
{
use Web::Simple 'PostTest';
[ join(' ',@{$_[1]}{qw(foo bar)}) ]
]
},
+ sub (*baz=) {
+ [ 200,
+ [ "Content-type" => "text/plain" ],
+ [ $_[1]->reason || $_[1]->filename ],
+ ]
+ },
}
}
+use Plack::Test;
use HTTP::Request::Common qw(GET POST);
my $app = PostTest->new;
sub run_request {
my $request = shift;
- my $c = HTTP::Request::AsCGI->new($request)->setup;
- $app->run;
- $c->restore;
- return $c->response;
+ my $response;
+ test_psgi($app->to_psgi_app, sub { $response = shift->($request) });
+ return $response;
}
my $get = run_request(GET 'http://localhost/');
cmp_ok($both->code, '==', 200, '200 with both params');
is($both->content, 'FOO BAR', 'both params returned');
+
+my $upload = run_request(
+ POST 'http://localhost'
+ => Content_Type => 'form-data'
+ => Content => [
+ foo => 'FOO',
+ bar => 'BAR'
+ ]
+);
+
+cmp_ok($upload->code, '==', 200, '200 with multipart');
+
+is($upload->content, 'FOO BAR', 'both params returned');
+
+my $upload_wrongtype = run_request(
+ POST 'http://localhost'
+ => [ baz => 'fleem' ]
+);
+
+is(
+ $upload_wrongtype->content,
+ 'field baz exists with value fleem but body was not multipart/form-data',
+ 'error points out wrong body type'
+);
+
+my $upload_notupload = run_request(
+ POST 'http://localhost'
+ => Content_Type => 'form-data'
+ => Content => [ baz => 'fleem' ]
+);
+
+is(
+ $upload_notupload->content,
+ 'field baz exists with value fleem but was not an upload',
+ 'error points out field was not an upload'
+);
+
+my $upload_isupload = run_request(
+ POST 'http://localhost'
+ => Content_Type => 'form-data'
+ => Content => [
+ baz => [
+ undef, 'TESTFILE',
+ Content => 'test content', 'Content-Type' => 'text/plain'
+ ],
+ ]
+);
+
+is(
+ $upload_isupload->content,
+ 'TESTFILE',
+ 'Actual upload returns filename ok'
+);
projects / catagits/Web-Simple.git / commitdiff