Web-Simple-0.033/0000755000372100001440000000000013064012245013234 5ustar matthewtusersWeb-Simple-0.033/examples/0000755000372100001440000000000013064012245015052 5ustar matthewtusersWeb-Simple-0.033/examples/dispatchex/0000755000372100001440000000000013064012245017206 5ustar matthewtusersWeb-Simple-0.033/examples/dispatchex/dispatchex.cgi0000644000372100001440000000113311303636162022030 0ustar matthewtusersuse Web::Simple 'DispatchEx'; package DispatchEx; dispatch { response_filter { [ 200, [ 'Content-type' => 'text/plain' ], $_[1] ]; }, subdispatch sub (.html) { [ response_filter { [ @{$_[1]}, '.html' ] }, sub (/foo) { [ '/foo' ] }, ] }, subdispatch sub (/domain/*/...) { return unless (my $domain_id = $_[1]) =~ /^\d+$/; [ sub (/) { [ "Domain ${domain_id}" ] }, sub (/user/*) { return unless (my $user_id = $_[1]) =~ /^\d+$/; [ "Domain ${domain_id} user ${user_id}" ] } ] } }; DispatchEx->run_if_script; Web-Simple-0.033/examples/hello-world/0000755000372100001440000000000013064012245017302 5ustar matthewtusersWeb-Simple-0.033/examples/hello-world/hello-world.cgi0000644000372100001440000000047511477667071022247 0ustar matthewtusers#!/usr/bin/perl use Web::Simple 'HelloWorld'; { package HelloWorld; sub dispatch_request { sub (GET) { [ 200, [ 'Content-type', 'text/plain' ], [ 'Hello world!' ] ] }, sub () { [ 405, [ 'Content-type', 'text/plain' ], [ 'Method not allowed' ] ] } }; } HelloWorld->run_if_script; Web-Simple-0.033/examples/golf/0000755000372100001440000000000013064012245016001 5ustar matthewtusersWeb-Simple-0.033/examples/golf/golf.cgi0000755000372100001440000000022412000773413017415 0ustar matthewtusers#!/usr/bin/perl use Web::Simple; sub dispatch_request { [ 200, [ 'Content-type', 'text/plain' ], [ 'Hello world!' ] ] } __PACKAGE__->run_if_script; Web-Simple-0.033/examples/bloggery/0000755000372100001440000000000013064012245016664 5ustar matthewtusersWeb-Simple-0.033/examples/bloggery/posts/0000755000372100001440000000000013064012245020034 5ustar matthewtusersWeb-Simple-0.033/examples/bloggery/posts/Another-Post.html0000644000372100001440000000003411270331016023237 0ustar matthewtusers

This is also a post!

Web-Simple-0.033/examples/bloggery/posts/One-Post.html0000644000372100001440000000002711270331016022362 0ustar matthewtusers

This is a post!

Web-Simple-0.033/examples/bloggery/posts/One-Post.summary.html0000644000372100001440000000002311270331016024052 0ustar matthewtusers

Excitement!

Web-Simple-0.033/examples/bloggery/bloggery.cgi0000755000372100001440000000602211477667071021210 0ustar matthewtusers#!/usr/bin/perl use FindBin; use lib $FindBin::Bin.'/code'; use Web::Simple 'Bloggery'; package Bloggery::PostList; use File::stat; sub from_dir { my ($class, $dir) = @_; bless ({ dir => $dir }, $class); } sub all { my ($self) = @_; map { Bloggery::Post->from_file($_) } sort { stat($a)->mtime <=> stat($b)->mtime } grep { !/\.summary\.html$/ } glob($self->{dir}.'/*.html'); } sub post { my ($self, $name) = @_; my $file = $self->{dir}."/${name}.html"; return unless $file && -f $file; return Bloggery::Post->from_file($file); } sub map { my ($self, $code) = @_; map $code->($_), $self->all; } package Bloggery::Post; sub from_file { my ($class, $file) = @_; bless({ file => $file }, $class); } sub name { my $name = shift->{file}; $name =~ s/.*\///; $name =~ s/\.html$//; $name; } sub title { my $title = shift->name; $title =~ s/-/ /g; $title; } sub html { \do { local (@ARGV, $/) = shift->{file}; <> }; } sub summary_html { my $file = shift->{file}; $file =~ s/\.html$/.summary.html/; return \'

No summary

' unless -f $file; \do { local (@ARGV, $/) = $file; <> }; } package Bloggery; has post_list => (is => 'lazy'); sub default_config { ( title => 'Bloggery', posts_dir => $FindBin::Bin.'/posts', ); } sub _build_post_list { my ($self) = @_; Bloggery::PostList->from_dir( $self->config->{posts_dir} ); } sub post { my ($self, $post) = @_; $self->post_list->post($post); } sub dispatch_request { my $self = shift; sub (GET + /) { redispatch_to '/index.html' }, sub (.html) { response_filter { $self->render_html(@_) } }, sub (GET + /index) { $self->post_list }, sub (GET + /*) { $self->post($_[1]) }, sub (GET) { [ 404, [ 'Content-type', 'text/plain' ], [ 'Not found' ] ] }, sub { [ 405, [ 'Content-type', 'text/plain' ], [ 'Method not allowed' ] ] }, }; sub render_html { my ($self, $data) = @_; use HTML::Tags; return $data if ref($data) eq 'ARRAY'; return [ 200, [ 'Content-type', 'text/html' ], [ HTML::Tags::to_html_string( , , , $self->title_for($data), , , ,

, $self->title_for($data),

,
, $self->main_html_for($data),
, , ) ] ]; } sub title_for { my ($self, $data) = @_; if ($data->isa('Bloggery::Post')) { return $data->title; } return $self->config->{title}; } sub main_html_for { my ($self, $data) = @_; use HTML::Tags; if ($data->isa('Bloggery::Post')) { $data->html } elsif ($data->isa('Bloggery::PostList')) { ; } else {

, "Don't know how to render $data",

; } } Bloggery->run_if_script; Web-Simple-0.033/maint/0000755000372100001440000000000013064012245014344 5ustar matthewtusersWeb-Simple-0.033/maint/Makefile.PL.include0000644000372100001440000000053411752040732017746 0ustar matthewtusersBEGIN { -e 'Distar' or system("git clone git://git.shadowcat.co.uk/p5sagit/Distar.git") } use lib "Distar/lib"; use Distar; author 'mst - Matt S. Trout (cpan:MSTROUT) '; manifest_include 't/globbery' => qr/.*/; manifest_include 'docs' => qr/.*/; manifest_include 'examples' => qr/.*/; manifest_include 'lib' => qr/.*\.pod$/; Web-Simple-0.033/t/0000755000372100001440000000000013064012245013477 5ustar matthewtusersWeb-Simple-0.033/t/tags.t0000644000372100001440000000475413063546500014641 0ustar matthewtusersuse strict; use warnings FATAL => 'all'; use Test::More qw(no_plan); my $globbery; BEGIN { $globbery = join(', ', ) } { package Foo; sub foo { use XML::Tags qw(one two three); , , ; } sub bar { no warnings 'once'; # this is supposed to warn, it's broken } sub baz { use XML::Tags qw(bar); ; } sub quux { use HTML::Tags; , , "YAY", , ; } sub xquux { use HTML::Tags; , ,,,,
,'x',,1,,
; } sub fleem { use XML::Tags qw(woo); my $ent = 'one&two"four'; ; } sub flaax { use XML::Tags qw(woo); my $data = "one&twofour"; , $data, , , \$data, ; } sub HTML_comment { use HTML::Tags; ; } sub PI { use XML::Tags; ; } sub DTD { use HTML::Tags; } sub globbery { ; } } is( join(', ', XML::Tags::to_xml_string Foo::foo()), ', , ', 'open tags ok' ); ok(!eval { Foo::bar(); 1 }, 'Death on use of unimported tag'); is( join(', ', XML::Tags::to_xml_string Foo::baz()), '', 'close tag ok' ); is( join('', HTML::Tags::to_html_string Foo::quux), 'YAY', 'HTML tags ok' ); is( join('', HTML::Tags::to_html_string Foo::xquux), '' . '
x1
', 'Conflicting HTML tags ok' ); is( join('', XML::Tags::to_xml_string Foo::HTML_comment), '', 'HTML comment ok' ); is( join('', XML::Tags::to_xml_string Foo::fleem), '', 'Escaping ok' ); is( join('', XML::Tags::to_xml_string Foo::flaax), 'one&two<three>fourone&twofour', 'Escaping user data ok' ); is( join('', XML::Tags::to_xml_string Foo::PI), '', 'XML processing instruction' ); is( join('', HTML::Tags::to_html_string Foo::DTD), '', 'DTD ok' ); is( join(', ', Foo::globbery), $globbery, 'real glob re-installed ok' ); Web-Simple-0.033/t/bloggery.t0000644000372100001440000000167411471752216015517 0ustar matthewtusersuse strict; use warnings FATAL => 'all'; use Test::More qw(no_plan); require_ok 'examples/bloggery/bloggery.cgi'; __END__ #use Test::More ( # eval { require HTTP::Request::AsCGI } # ? 'no_plan' ## : (skip_all => 'No HTTP::Request::AsCGI') #); use HTTP::Request::AsCGI; use HTTP::Request::Common qw(GET POST); require 'examples/bloggery/bloggery.cgi'; my $app = Bloggery->new( { config => { posts_dir => 'examples/bloggery/posts' } } ); sub run_request { my $request = shift; my $c = HTTP::Request::AsCGI->new($request, SCRIPT_NAME=> $0)->setup; $app->run; $c->restore; return $c->response; } my $res; warn run_request(GET 'http://localhost/index.html')->as_string; warn run_request(GET 'http://localhost/')->as_string; warn run_request(GET 'http://localhost/One-Post.html')->as_string; warn run_request(GET 'http://localhost/Not-There.html')->as_string; warn run_request(POST 'http://localhost/One-Post.html')->as_string; Web-Simple-0.033/t/response-filter.t0000644000372100001440000000131613012655624017015 0ustar matthewtusersuse strictures 1; use Test::More 0.88; use Plack::Test; use HTTP::Request::Common qw(GET POST); { package t::Web::Simple::ResponseFilter; use Web::Simple; sub dispatch_request { my $self = shift; sub (.html) { response_filter { return [ 200, [ 'Content-Type' => 'text/html' ], [ shift->{name} ], ]; } }, sub (GET + /index) { bless {name=>'john'}, 'CrazyHotWildWet'; }, } } ok my $app = t::Web::Simple::ResponseFilter->new->to_psgi_app, 'Got a plack app'; test_psgi $app, sub { my $cb = shift; my $res = $cb->(GET "/index.html"); like $res->content, qr/john/, 'Got Expected Content'; }; done_testing; Web-Simple-0.033/t/sub-dispatch-env.t0000644000372100001440000000105113012655624017044 0ustar matthewtusersuse strictures 1; use Test::More 0.88; { package TestApp; use Web::Simple; sub dispatch_request { sub (/foo/...) { sub (GET) { [ 200, [], [ $_[PSGI_ENV]->{PATH_INFO} ] ] } }, sub (POST) { [ 200, [], [ $_[PSGI_ENV]->{PATH_INFO} ] ] } } } my $app = TestApp->new->to_psgi_app; my $call = sub { $app->({ SCRIPT_NAME => '/base', PATH_INFO => '/foo/bar', REQUEST_METHOD => shift })->[2]->[0] }; is($call->('GET'), '/bar', 'recursive strip ok'); is($call->('POST'), '/foo/bar', 'later dispatchers unaffected'); done_testing; Web-Simple-0.033/t/predicate_objects.t0000644000372100001440000001037111752040732017343 0ustar matthewtusersuse strict; use warnings FATAL => 'all'; use Data::Dumper::Concise; use Test::More 'no_plan'; use Plack::Test; { use Web::Simple 't::Web::Simple::SubDispatchArgs'; package t::Web::Simple::SubDispatchArgs; use Web::Dispatch::Predicates; has 'attr' => (is=>'ro'); sub dispatch_request { my $self = shift; ## sub(/) { match_path(qr/(?-xism:^(\/)$)/), sub { $self->show_landing(@_); }, ## sub(/...) { match_path_strip(qr/(?-xism:^()(\/.*)$)/) => sub { match_and ( match_method('GET'), match_path(qr/(?-xism:^(\/user(?:\.\w+)?)$)/) ) => sub { $self->show_users(@_); }, match_path(qr/(?-xism:^(\/user\/([^\/]+?)(?:\.\w+)?)$)/), sub { match_method('GET') => sub { $self->show_user(@_); }, match_and ( match_method('POST'), match_body ({ named => [ { multi => "", name => "id" }, { multi => 1, name => "roles" } ], required => ["id"] }) ) => sub { $self->process_post(@_); } }, } }; sub show_landing { my ($self, @args) = @_; local $self->{_dispatcher}; local $args[-1]->{'Web::Dispatch.original_env'}; return [ 200, ['Content-Type' => 'application/perl' ], [::Dumper \@args], ]; } sub show_users { my ($self, @args) = @_; local $self->{_dispatcher}; local $args[-1]->{'Web::Dispatch.original_env'}; return [ 200, ['Content-Type' => 'application/perl' ], [::Dumper \@args], ]; } sub show_user { my ($self, @args) = @_; local $self->{_dispatcher}; local $args[-1]->{'Web::Dispatch.original_env'}; return [ 200, ['Content-Type' => 'application/perl' ], [::Dumper \@args], ]; } sub process_post { my ($self, @args) = @_; local $self->{_dispatcher}; local $args[-1]->{'Web::Dispatch.original_env'}; return [ 200, ['Content-Type' => 'application/perl' ], [::Dumper \@args], ]; } } ok my $app = t::Web::Simple::SubDispatchArgs->new, 'made app'; sub run_request { $app->run_test_request(@_); } ok my $get_landing = run_request(GET => 'http://localhost/' ), 'got landing'; cmp_ok $get_landing->code, '==', 200, '200 on GET'; no strict 'refs'; { my ($self, $env, @noextra) = @{eval($get_landing->content)||[]}; die $@ if $@; is scalar(@noextra), 0, 'No extra stuff'; is ref($self), 't::Web::Simple::SubDispatchArgs', 'got object'; is ref($env), 'HASH', 'Got hashref'; } ok my $get_users = run_request(GET => 'http://localhost/user'), 'got user'; cmp_ok $get_users->code, '==', 200, '200 on GET'; { my ($self, $env, @noextra) = @{eval $get_users->content}; is scalar(@noextra), 0, 'No extra stuff'; is ref($self), 't::Web::Simple::SubDispatchArgs', 'got object'; is ref($env), 'HASH', 'Got hashref'; } ok my $get_user = run_request(GET => 'http://localhost/user/42'), 'got user'; cmp_ok $get_user->code, '==', 200, '200 on GET'; { my ($self, $env, @noextra) = @{eval $get_user->content}; is scalar(@noextra), 0, 'No extra stuff'; is ref($self), 't::Web::Simple::SubDispatchArgs', 'got object'; is ref($env), 'HASH', 'Got hashref'; } ok my $post_user = run_request(POST => 'http://localhost/user/42', id => '99' ), 'post user'; cmp_ok $post_user->code, '==', 200, '200 on POST'; { my ($self, $params, $env, @noextra) = @{eval $post_user->content or die $@}; is scalar(@noextra), 0, 'No extra stuff'; is ref($self), 't::Web::Simple::SubDispatchArgs', 'got object'; is ref($params), 'HASH', 'Got POST hashref'; is $params->{id}, 99, 'got expected value for id'; is ref($env), 'HASH', 'Got hashref'; } Web-Simple-0.033/t/globbery/0000755000372100001440000000000013064012245015304 5ustar matthewtusersWeb-Simple-0.033/t/globbery/two0000644000372100001440000000000011270331016016023 0ustar matthewtusersWeb-Simple-0.033/t/globbery/one0000644000372100001440000000000011270331016015773 0ustar matthewtusersWeb-Simple-0.033/t/globbery/three0000644000372100001440000000000013063546500016331 0ustar matthewtusersWeb-Simple-0.033/t/dispatch_misc.t0000644000372100001440000001362313012655624016512 0ustar matthewtusersuse strict; use warnings FATAL => 'all'; no warnings::illegalproto; use Test::More 0.88; use HTTP::Request::Common qw(GET POST); use Web::Dispatch; use HTTP::Response; use Web::Dispatch::Predicates 'match_true'; my @dispatch; { use Web::Simple 'MiscTest'; package MiscTest; sub dispatch_request { @dispatch } sub string_method { [ 999, [], [""] ]; } sub can { die "Passed undef to can, this blows up on 5.8" unless defined($_[1]); shift->SUPER::can(@_) } } my $app = MiscTest->new; sub run_request { $app->run_test_request( @_ ); } string_method_name(); app_is_non_plack(); app_is_object(); app_is_just_sub(); plack_app_return(); broken_route_def(); invalid_psgi_responses(); middleware_as_only_route(); route_returns_middleware_plus_extra(); route_returns_undef(); matcher_nonsub_pair(); matcher_undef_method(); done_testing(); sub string_method_name { @dispatch = ( '/' => "string_method" ); my $get = run_request( GET => 'http://localhost/' ); cmp_ok $get->code, '==', 999, "a dispatcher that's a string matching a method on the dispatch object gets executed"; } sub app_is_non_plack { my $r = HTTP::Response->new( 999 ); my $d = Web::Dispatch->new( dispatch_app => $r ); eval { $d->call }; like $@, qr/No idea how we got here with HTTP::Response/, "Web::Dispatch dies when run with an app() that is a non-PSGI object"; undef $@; } sub app_is_object { { package ObjectApp; use Moo; sub to_app { [ 999, [], ["ok"] ] } } my $o = ObjectApp->new; my $d = Web::Dispatch->new( dispatch_object => $o ); my $res = $d->call; cmp_ok $res->[0], '==', 999, "Web::Dispatch can dispatch properly, given only an object with to_app method"; } sub app_is_just_sub { my $d = Web::Dispatch->new( dispatch_app => sub () { [ 999, [], ["ok"] ] } ); my $res = $d->call( {} ); cmp_ok $res->[0], '==', 999, "Web::Dispatch can dispatch properly, given only an app that's just a sub, with no object involved"; } sub plack_app_return { { package FauxPlackApp; sub new { bless {}, $_[0] } sub to_app { return sub { [ 999, [], [""] ]; }; } } @dispatch = ( sub (/) { FauxPlackApp->new; } ); my $get = run_request( GET => 'http://localhost/' ); cmp_ok $get->code, '==', 999, "when a route returns a thing that look like a Plack app, the web app redispatches to that thing"; } sub broken_route_def { @dispatch = ( '/' => "" ); my $get = run_request( GET => 'http://localhost/' ); cmp_ok $get->code, '==', 500, "a route definition by hash that doesn't pair a sub with a route dies"; like $get->content, qr[No idea how we got here with /], "the error message points out the broken definition"; } sub invalid_psgi_responses { undef $@; my @responses = ( [ [ sub { } ], "an arrayref with a single sub in it" ], [ ["moo"], "an arrayref with a scalar that is not a sub" ], [ bless( {}, "FauxObject" ), "an object without to_app method" ], ); for my $response ( @responses ) { @dispatch = ( sub (/) { $response->[0] } ); my $message = sprintf( "if a route returns %s, then that is returned as a response by WD, causing HTTP::Message::PSGI to choke", $response->[1] ); # Somewhere between 1.0028 and 1.0031 Plack changed so that the # FauxObject case became a 500 rather than a die; in case it later does # the same thing for other stuff, just accept either sort of error my $res = eval { run_request( GET => 'http://localhost/' ) }; if ($res) { ok $res->is_error, $message; } else { like $@, qr/Can't call method "request" on an undefined value .*MockHTTP/, $message; } undef $@; } } sub middleware_as_only_route { @dispatch = ( bless {}, "Plack::Middleware" ); my $get = run_request( GET => 'http://localhost/' ); cmp_ok $get->code, '==', 500, "a route definition consisting of only a middleware causes a bail"; like $get->content, qr[Multiple results but first one is a middleware \(Plack::Middleware=], "the error message mentions the middleware class"; } sub route_returns_middleware_plus_extra { @dispatch = ( sub (/) { return ( bless( {}, "Plack::Middleware" ), "" ); } ); my $get = run_request( GET => 'http://localhost/' ); cmp_ok $get->code, '==', 500, "a route returning a middleware and at least one other variable causes a bail"; like $get->content, qr[Multiple results but first one is a middleware \(Plack::Middleware=], "the error message mentions the middleware class"; } sub route_returns_undef { @dispatch = ( sub (/) { ( sub(/) { undef; }, sub(/) { [ 900, [], [""] ]; } ); }, sub () { [ 400, [], [""] ]; } ); my $get = run_request( GET => 'http://localhost/' ); cmp_ok $get->code, '==', 900, "a route that returns undef causes WD to ignore it and resume dispatching"; } sub matcher_nonsub_pair { @dispatch = ( match_true() => 5 ); my $get = run_request( GET => 'http://localhost/' ); cmp_ok $get->code, '==', 500, "a route definition that pairs a WD::Matcher a non-sub dies"; like $get->content, qr[No idea how we got here with Web::Dispatch::M], "the error message points out the broken definition"; } sub matcher_undef_method { @dispatch = ( 'GET', undef ); my $get = run_request( GET => 'http://localhost/' ); cmp_ok $get->code, '==', 500, "a route definition that pairs a WD::Matcher a non-sub dies"; like $get->content, qr[No idea how we got here with GET], "the error message points out the broken definition"; } Web-Simple-0.033/t/wd-http-methods.t0000644000372100001440000000573413012655624016734 0ustar matthewtusersuse strictures 1; use Test::More 0.88; { package t::Web::Simple::HTTPMethods; use Web::Simple; use Web::Dispatch::HTTPMethods; sub as_text { [200, ['Content-Type' => 'text/plain'], [$_[0]->{REQUEST_METHOD}, $_[0]->{REQUEST_URI}] ] } sub dispatch_request { sub (/get) { GET { as_text(pop) } }, sub (/get-head-options) { GET { as_text(pop) } HEAD { [204,[],[]] } OPTIONS { [204,[],[]] }, }, sub (/get-post-put) { GET { as_text(pop) } POST { as_text(pop) } PUT { as_text(pop) } }, } } ok my $app = t::Web::Simple::HTTPMethods->new, 'made app'; for my $uri ('http://localhost/get-post-put') { ## Check allowed methods and responses for(ok my $res = $app->run_test_request(GET => $uri)) { is $res->content, 'GET/get-post-put'; } for(ok my $res = $app->run_test_request(POST => $uri)) { is $res->content, 'POST/get-post-put'; } for(ok my $res = $app->run_test_request(PUT => $uri)) { is $res->content, 'PUT/get-post-put'; } ## Since GET is allowed, check for implict HEAD for(ok my $head = $app->run_test_request(HEAD => $uri)) { is $head->code, 200; is $head->content, ''; } ## Check the implicit support for OPTIONS for(ok my $options = $app->run_test_request(OPTIONS => $uri)) { is $options->code, 200; is $options->content, ''; is $options->header('Allow'), 'GET,HEAD,POST,PUT,OPTIONS'; } ## Check implicitly added not allowed for(ok my $not_allowed = $app->run_test_request(DELETE => $uri)) { is $not_allowed->code, 405; is $not_allowed->content, 'Method Not Allowed'; is $not_allowed->header('Allow'), 'GET,HEAD,POST,PUT,OPTIONS'; } } for my $uri ('http://localhost/get-head-options') { ## Check allowed methods and responses for(ok my $res = $app->run_test_request(GET => $uri)) { is $res->content, 'GET/get-head-options'; } for(ok my $head = $app->run_test_request(HEAD => $uri)) { is $head->code, 204; is $head->content, ''; } for(ok my $options = $app->run_test_request(OPTIONS => $uri)) { is $options->code, 204; is $options->content, ''; } ## Check implicitly added not allowed for(ok my $not_allowed = $app->run_test_request(PUT => $uri)) { is $not_allowed->code, 405; is $not_allowed->content, 'Method Not Allowed'; is $not_allowed->header('Allow'), 'GET,HEAD,OPTIONS'; } } for my $uri ('http://localhost/get') { ## Check allowed methods and responses for(ok my $res = $app->run_test_request(GET => $uri)) { is $res->content, 'GET/get'; } ## Check implicitly added not allowed for(ok my $not_allowed = $app->run_test_request(PUT => $uri)) { is $not_allowed->code, 405; is $not_allowed->content, 'Method Not Allowed'; is $not_allowed->header('Allow'), 'GET,HEAD,OPTIONS'; } ## Since GET is allowed, check for implict HEAD for(ok my $head = $app->run_test_request(HEAD => $uri)) { is $head->code, 200; is $head->content, ''; } } done_testing; Web-Simple-0.033/t/underscore.t0000644000372100001440000000043513012655624016046 0ustar matthewtusersuse Web::Simple 'TestApp'; use Test::More 0.88; sub TestApp::dispatch_request { sub (GET + ?*) { [ 200, [ 'Content-type' => 'text/plain' ], [ $_{foo} ] ] } } my $res = TestApp->new->run_test_request(GET => '/?foo=bar'); is($res->content, 'bar', '%_ set ok'); done_testing; Web-Simple-0.033/t/leak.t0000644000372100001440000000056313012655624014613 0ustar matthewtusersuse strictures; use Test::More 0.88; plan skip_all => 'No Devel::Cycle' unless eval { require Devel::Cycle; 1 }; use Web::Simple; my $counter; my $on_cycle = sub { Devel::Cycle::_do_report( ++$counter, shift ) }; { local *STDOUT = *STDERR; Devel::Cycle::find_cycle( main->new->to_psgi_app, $on_cycle ); } ok !$counter, "no leak in to_psgi_app"; done_testing; Web-Simple-0.033/t/role.t0000644000372100001440000000164313012655624014640 0ustar matthewtusersuse strict; use warnings FATAL => 'all'; use Test::More 0.88; { package BazRole; use Web::Simple::Role; around dispatch_request => sub { my ($orig, $self) = @_; return ( $self->$orig, sub (GET + /baz) { [ 200, [ "Content-type" => "text/plain" ], [ 'baz' ], ] } ); }; } { package FooBar; use Web::Simple; with 'BazRole'; sub dispatch_request { sub (GET + /foo) { [ 200, [ "Content-type" => "text/plain" ], [ 'foo' ], ] }, sub (GET + /bar) { [ 200, [ "Content-type" => "text/plain" ], [ 'bar' ], ] }, } } use HTTP::Request::Common qw(GET POST); my $app = FooBar->new; sub run_request { $app->run_test_request(@_); } for my $word (qw/ foo bar baz /) { my $get = run_request(GET "http://localhost/${word}"); is($get->content, $word, "Dispatch $word"); } done_testing; Web-Simple-0.033/t/request_mode_heuristics.t0000644000372100001440000000316513012655624020636 0ustar matthewtusersuse strictures; use Test::More 0.88; use Web::Simple::Application; use Socket; run(); done_testing; sub run { my $a = Web::Simple::Application->new; my ( $cli, $cgi, $fcgi, $test ) = qw( cli cgi fcgi test ); my $res; no warnings 'redefine'; local *Web::Simple::Application::_run_fcgi = sub { $res = "fcgi" }; local *Web::Simple::Application::_run_cgi = sub { $res = "cgi" }; local *Web::Simple::Application::_run_cli = sub { $res = "cli" }; local *Web::Simple::Application::_run_cli_test_request = sub { $res = "test" }; use strictures; { $a->run; is $res, "cli", "empty invocation goes to CLI mode"; } SKIP: { skip "windows does not support the needed socket manipulation", 2 if $^O eq 'MSWin32' or $^O eq 'cygwin'; { socket my $socket, AF_INET, SOCK_STREAM, 0 or die "socket: $!"; open my $old_in, '<&STDIN' or die "open: $!"; open STDIN, '<&', $socket or die "open: $!"; $a->run; is $res, "fcgi", "STDIN being a socket means FCGI"; open STDIN, '<&', $old_in or die "open: $!"; } { local $ENV{GATEWAY_INTERFACE} = "CGI 1.1"; socket my $socket, AF_INET, SOCK_STREAM, 0 or die "socket: $!"; open my $old_in, '<&STDIN' or die "open: $!"; open STDIN, '<&', $socket or die "open: $!"; $a->run; isnt $res, "fcgi", "STDIN being a socket doesn't mean FCGI if GATEWAY_INTERFACE is set"; open STDIN, '<&', $old_in or die "open: $!"; } } return; } Web-Simple-0.033/t/env.t0000644000372100001440000000061511643061272014463 0ustar matthewtusersuse strict; use warnings FATAL => 'all'; use Test::More 'no_plan'; use Plack::Test; { use Web::Simple 'EnvTest'; package EnvTest; sub dispatch_request { sub (GET) { my $env = $_[PSGI_ENV]; [ 200, [ "Content-type" => "text/plain" ], [ 'foo' ] ] }, } } my $app = EnvTest->new; ok $app->run_test_request(GET => 'http://localhost/')->is_success; Web-Simple-0.033/t/test-request-basic-auth.t0000644000372100001440000000235213012655624020360 0ustar matthewtusersuse strictures 1; use Test::More 0.88; my $auth_result; my @auth_args; { package TestApp; use Web::Simple; use Plack::Middleware::Auth::Basic; sub dispatch_request { sub () { Plack::Middleware::Auth::Basic->new( authenticator => sub { @auth_args = @_; return $auth_result } ) }, sub () { [ 200, [ 'Content-type' => 'text/plain' ], [ 'Woo' ] ] } } } my $ta = TestApp->new; my $res = $ta->run_test_request(GET => '/'); is($res->code, '401', 'Auth failed with no user/pass'); ok(!@auth_args, 'Auth callback never called with no user/pass'); $res = $ta->run_test_request(GET => 'bob:secret@/'); is($res->code, '401', 'Auth failed with bad user/pass'); is($auth_args[0], 'bob', 'Username passed ok'); is($auth_args[1], 'secret', 'Password passed ok'); $auth_result = 1; @auth_args = (); $res = $ta->run_test_request(GET => '/'); is($res->code, '401', 'Auth failed with no user/pass'); ok(!@auth_args, 'Auth callback never called with no user/pass'); $res = $ta->run_test_request(GET => 'bob:secret@/'); is($res->code, '200', 'Auth succeeded with good user/pass'); is($auth_args[0], 'bob', 'Username passed ok'); is($auth_args[1], 'secret', 'Password passed ok'); done_testing; Web-Simple-0.033/t/sub-dispatch-args.t0000644000372100001440000000671111643415004017212 0ustar matthewtusersuse strict; use warnings FATAL => 'all'; use Data::Dumper::Concise; use Test::More 'no_plan'; use Plack::Test; { use Web::Simple 't::Web::Simple::SubDispatchArgs'; package t::Web::Simple::SubDispatchArgs; has 'attr' => (is=>'ro'); sub dispatch_request { my $self = shift; sub (/) { $self->show_landing(@_); }, sub(/...) { q(GET + /user) => sub { $self->show_users(@_); }, sub (/user/*) { sub (GET) { $self->show_user(@_); }, sub (POST + %:id=&:@roles~) { $self->process_post(@_); } }, } }; sub show_landing { my ($self, @args) = @_; local $self->{_dispatcher}; local $args[-1]->{'Web::Dispatch.original_env'}; return [ 200, ['Content-Type' => 'application/perl' ], [::Dumper \@args], ]; } sub show_users { my ($self, @args) = @_; local $self->{_dispatcher}; local $args[-1]->{'Web::Dispatch.original_env'}; return [ 200, ['Content-Type' => 'application/perl' ], [::Dumper \@args], ]; } sub show_user { my ($self, @args) = @_; local $self->{_dispatcher}; local $args[-1]->{'Web::Dispatch.original_env'}; return [ 200, ['Content-Type' => 'application/perl' ], [::Dumper \@args], ]; } sub process_post { my ($self, @args) = @_; local $self->{_dispatcher}; local $args[-1]->{'Web::Dispatch.original_env'}; return [ 200, ['Content-Type' => 'application/perl' ], [::Dumper \@args], ]; } } ok my $app = t::Web::Simple::SubDispatchArgs->new, 'made app'; sub run_request { $app->run_test_request(@_); } ok my $get_landing = run_request(GET => 'http://localhost/' ), 'got landing'; cmp_ok $get_landing->code, '==', 200, '200 on GET'; no strict 'refs'; { my ($self, $env, @noextra) = @{eval($get_landing->content)||[]}; die $@ if $@; is scalar(@noextra), 0, 'No extra stuff'; is ref($self), 't::Web::Simple::SubDispatchArgs', 'got object'; is ref($env), 'HASH', 'Got hashref'; } ok my $get_users = run_request(GET => 'http://localhost/user'), 'got user'; cmp_ok $get_users->code, '==', 200, '200 on GET'; { my ($self, $env, @noextra) = @{eval $get_users->content}; is scalar(@noextra), 0, 'No extra stuff'; is ref($self), 't::Web::Simple::SubDispatchArgs', 'got object'; is ref($env), 'HASH', 'Got hashref'; } ok my $get_user = run_request(GET => 'http://localhost/user/42'), 'got user'; cmp_ok $get_user->code, '==', 200, '200 on GET'; { my ($self, $env, @noextra) = @{eval $get_user->content}; is scalar(@noextra), 0, 'No extra stuff'; is ref($self), 't::Web::Simple::SubDispatchArgs', 'got object'; is ref($env), 'HASH', 'Got hashref'; } ok my $post_user = run_request(POST => 'http://localhost/user/42', [id => '99'] ), 'post user'; cmp_ok $post_user->code, '==', 200, '200 on POST'; { my ($self, $params, $env, @noextra) = @{eval $post_user->content}; is scalar(@noextra), 0, 'No extra stuff'; is ref($self), 't::Web::Simple::SubDispatchArgs', 'got object'; is ref($params), 'HASH', 'Got POST hashref'; is $params->{id}, 99, 'got expected value for id'; is ref($env), 'HASH', 'Got hashref'; } Web-Simple-0.033/t/stream_test.t0000644000372100001440000000172311752040732016225 0ustar matthewtusersuse strict; use warnings FATAL => 'all'; use Test::More ( eval { require HTTP::Request::AsCGI } ? 'no_plan' : (skip_all => 'No HTTP::Request::AsCGI') ); use HTTP::Request::Common qw(GET POST); my $app = StreamTest->new; ok run_request( $app, GET 'http://localhost/' )->is_success; is run_request( $app, GET 'http://localhost/' )->content, "foo"; sub run_request { my ( $app, $request ) = @_; my $c = HTTP::Request::AsCGI->new( $request )->setup; $app->run; $c->restore; return $c->response; } { package StreamTest; use Web::Simple; sub dispatch_request { sub (GET) { [ sub { my $respond = shift; my $writer = $respond->( [ 200, [ "Content-type" => "text/plain" ] ] ); $writer->write( 'f' ); $writer->write( 'o' ); $writer->write( 'o' ); } ]; },; } } Web-Simple-0.033/t/param_parser.t0000644000372100001440000000200513012655621016341 0ustar matthewtusersuse strict; use warnings FATAL => 'all'; use Test::More qw(no_plan); use Web::Dispatch::ParamParser; my $param_sample = 'foo=bar&baz=quux&foo=%2F&xyzzy'; my $unpacked = { baz => [ "quux" ], foo => [ "bar", "/" ], xyzzy => [ 1 ] }; is_deeply( Web::Dispatch::ParamParser::_unpack_params('foo=bar&baz=quux&foo=%2F&xyzzy'), $unpacked, 'Simple unpack ok' ); my $env = { 'QUERY_STRING' => $param_sample }; is_deeply( Web::Dispatch::ParamParser::get_unpacked_query_from($env), $unpacked, 'Dynamic unpack ok' ); is_deeply( $env->{+Web::Dispatch::ParamParser::UNPACKED_QUERY}, $unpacked, 'Unpack cached ok' ); sub FakeBody::param { { baz => "quux", foo => [ "bar", "/" ], xyzzy => [ 1 ] } } my $body_env = { CONTENT_TYPE => "multipart/form-data", CONTENT_LENGTH => 1, +Web::Dispatch::ParamParser::UNPACKED_BODY_OBJECT => [ bless {}, "FakeBody" ] }; is_deeply( Web::Dispatch::ParamParser::get_unpacked_body_from($body_env), $unpacked, 'Body cached multipart ok' ); 1; Web-Simple-0.033/t/css_declare.t0000644000372100001440000000061411307447744016152 0ustar matthewtusersuse strict; use warnings FATAL => 'all'; use Test::More qw(no_plan); { package Foo; sub foo { use CSS::Declare; return ( '*' => [ color 'red' ], 'tr, td' => [ margin '1px' ], ); } } is( CSS::Declare::to_css_string(Foo::foo()), '* {color:red} tr, td {margin:1px}', 'Basic CSS::Declare usage' ); ok(!Foo->can('color'), 'Death on use of unimported tag'); Web-Simple-0.033/t/post.t0000644000372100001440000000553712255016140014662 0ustar matthewtusersuse strict; use warnings FATAL => 'all'; use Test::More qw(no_plan); { use Web::Simple 'PostTest'; package PostTest; sub dispatch_request { sub (%:foo=&:bar~) { $_[1]->{bar} ||= 'EMPTY'; [ 200, [ "Content-type" => "text/plain" ], [ join(' ',@{$_[1]}{qw(foo bar)}) ] ] }, sub (*baz=) { [ 200, [ "Content-type" => "text/plain" ], [ $_[1]->reason || $_[1]->filename ], ] }, sub (POST + %* + %biff=) { $_[1]->{bar} ||= 'EMPTY'; [ 200, [ "Content-type" => "text/plain" ], [ join(' ',@{$_[1]}{qw(biff bong)}) ] ] }, } } use HTTP::Request::Common qw(GET POST); my $app = PostTest->new; sub run_request { $app->run_test_request(@_); } my $get = run_request(GET 'http://localhost/'); cmp_ok($get->code, '==', 404, '404 on GET'); my $no_body = run_request(POST 'http://localhost/'); cmp_ok($no_body->code, '==', 404, '404 with empty body'); my $no_foo = run_request(POST 'http://localhost/' => [ bar => 'BAR' ]); cmp_ok($no_foo->code, '==', 404, '404 with no foo param'); my $no_bar = run_request(POST 'http://localhost/' => [ foo => 'FOO' ]); cmp_ok($no_bar->code, '==', 200, '200 with only foo param'); is($no_bar->content, 'FOO EMPTY', 'bar defaulted'); my $both = run_request( POST 'http://localhost/' => [ foo => 'FOO', bar => 'BAR' ] ); 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_splat = run_request( POST 'http://localhost' => Content_Type => 'form-data' => Content => [ biff => 'frew', bong => 'fru' ] ); cmp_ok($upload_splat->code, '==', 200, '200 with multipart'); is($upload_splat->content, 'frew fru', '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' ); Web-Simple-0.033/t/dispatch_parser.t0000644000372100001440000003335612336725226017064 0ustar matthewtusersuse strict; use warnings FATAL => 'all'; use Test::More qw(no_plan); use Web::Dispatch::Parser; my $dp = Web::Dispatch::Parser->new; { my $all = $dp->parse(''); is_deeply( [ $all->({ REQUEST_METHOD => 'GET' }) ], [ {} ], 'GET matches' ); is_deeply( [ $all->({ REQUEST_METHOD => 'POST' }) ], [ {} ], 'POST matches' ); }; { my $get = $dp->parse('GET'); is_deeply( [ $get->({ REQUEST_METHOD => 'GET' }) ], [ {} ], 'GET matches' ); is_deeply( [ $get->({ REQUEST_METHOD => 'POST' }) ], [], 'POST does not match' ); } { my $html = $dp->parse('.html'); is_deeply( [ $html->({ PATH_INFO => '/foo/bar.html' }) ], [ { } ], '.html matches' ); is_deeply( [ $html->({ PATH_INFO => '/foo/bar.xml' }) ], [], '.xml does not match .html' ); } { my $any_ext = $dp->parse('.*'); is_deeply( [ $any_ext->({ PATH_INFO => '/foo/bar.html' }) ], [ { }, 'html' ], '.html matches .* and extension returned' ); is_deeply( [ $any_ext->({ PATH_INFO => '/foo/bar' }) ], [], 'no extension does not match .*' ); } { my $slash = $dp->parse('/'); is_deeply( [ $slash->({ PATH_INFO => '/' }) ], [ {} ], '/ matches /' ); is_deeply( [ $slash->({ PATH_INFO => '/foo' }) ], [ ], '/foo does not match /' ); } { my $post = $dp->parse('/post/*'); is_deeply( [ $post->({ PATH_INFO => '/post/one' }) ], [ {}, 'one' ], '/post/one parses out one' ); is_deeply( [ $post->({ PATH_INFO => '/post/one/' }) ], [], '/post/one/ does not match' ); is_deeply( [ $post->({ PATH_INFO => '/post/one.html' }) ], [ {}, 'one' ], '/post/one.html still parses out one' ); } { my $post = $dp->parse('/foo-bar/*'); is_deeply( [ $post->({ PATH_INFO => '/foo-bar/one' }) ], [ {}, 'one' ], '/foo-bar/one parses out one' ); is_deeply( [ $post->({ PATH_INFO => '/foo-bar/one/' }) ], [], '/foo-bar/one/ does not match' ); } { my $combi = $dp->parse('GET+/post/*'); is_deeply( [ $combi->({ PATH_INFO => '/post/one', REQUEST_METHOD => 'GET' }) ], [ {}, 'one' ], '/post/one parses out one' ); is_deeply( [ $combi->({ PATH_INFO => '/post/one/', REQUEST_METHOD => 'GET' }) ], [], '/post/one/ does not match' ); is_deeply( [ $combi->({ PATH_INFO => '/post/one', REQUEST_METHOD => 'POST' }) ], [], 'POST /post/one does not match' ); } { my $or = $dp->parse('GET|POST'); foreach my $meth (qw(GET POST)) { is_deeply( [ $or->({ REQUEST_METHOD => $meth }) ], [ {} ], 'GET|POST matches method '.$meth ); } is_deeply( [ $or->({ REQUEST_METHOD => 'PUT' }) ], [], 'GET|POST does not match PUT' ); } { my $or = $dp->parse('GET|POST|DELETE'); foreach my $meth (qw(GET POST DELETE)) { is_deeply( [ $or->({ REQUEST_METHOD => $meth }) ], [ {} ], 'GET|POST|DELETE matches method '.$meth ); } is_deeply( [ $or->({ REQUEST_METHOD => 'PUT' }) ], [], 'GET|POST|DELETE does not match PUT' ); } { my $nest = $dp->parse('(GET+/foo)|POST'); is_deeply( [ $nest->({ PATH_INFO => '/foo', REQUEST_METHOD => 'GET' }) ], [ {} ], '(GET+/foo)|POST matches GET /foo' ); is_deeply( [ $nest->({ PATH_INFO => '/bar', REQUEST_METHOD => 'GET' }) ], [], '(GET+/foo)|POST does not match GET /bar' ); is_deeply( [ $nest->({ PATH_INFO => '/bar', REQUEST_METHOD => 'POST' }) ], [ {} ], '(GET+/foo)|POST matches POST /bar' ); is_deeply( [ $nest->({ PATH_INFO => '/foo', REQUEST_METHOD => 'PUT' }) ], [], '(GET+/foo)|POST does not match PUT /foo' ); } { my $spec = '(GET+/foo)|(POST+/foo)'; my $nest = $dp->parse($spec); for my $method (qw( GET POST )) { is_deeply( [ $nest->({ PATH_INFO => '/foo', REQUEST_METHOD => $method }) ], [ {} ], "$spec matches $method /foo" ); is_deeply( [ $nest->({ PATH_INFO => '/bar', REQUEST_METHOD => $method }) ], [], "$spec does not match $method /bar" ); } is_deeply( [ $nest->({ PATH_INFO => '/foo', REQUEST_METHOD => 'PUT' }) ], [], "$spec does not match PUT /foo" ); } { local $@; ok( !eval { $dp->parse('/foo+(GET'); 1 }, 'Death with missing closing )' ); my $err = q{ /foo+(GET ^ }; (s/^\n//s,s/\n $//s,s/^ //mg) for $err; like( $@, qr{\Q$err\E}, "Error $@ matches\n${err}\n" ); } { my $not = $dp->parse('!.html+.*'); is_deeply( [ $not->({ PATH_INFO => '/foo.xml' }) ], [ {}, 'xml' ], '!.html+.* matches /foo.xml' ); is_deeply( [ $not->({ PATH_INFO => '/foo.html' }) ], [], '!.html+.* does not match /foo.html' ); is_deeply( [ $not->({ PATH_INFO => '/foo' }) ], [], '!.html+.* does not match /foo' ); } { my $ext = $dp->parse('/foo.bar'); is_deeply( [ $ext->({ PATH_INFO => '/foo.bar' }) ], [ {} ], '/foo.bar matches /foo.bar' ); is_deeply( [ $ext->({ PATH_INFO => '/foo.bar.ext' }) ], [ {} ], '/foo.bar matches /foo.bar.ext' ); is_deeply( [ $ext->({ PATH_INFO => '/foo.notbar' }) ], [], '/foo.bar does not match /foo.notbar' ); } { my $sub = $dp->parse('/foo/*/...'); is_deeply( [ $sub->({ PATH_INFO => '/foo/1/bar' }) ], [ { PATH_INFO => '/bar', SCRIPT_NAME => '/foo/1' }, 1 ], '/foo/*/... matches /foo/1/bar and strips to /bar' ); is_deeply( [ $sub->({ PATH_INFO => '/foo/1/' }) ], [ { PATH_INFO => '/', SCRIPT_NAME => '/foo/1' }, 1 ], '/foo/*/... matches /foo/1/bar and strips to /' ); is_deeply( [ $sub->({ PATH_INFO => '/foo/1' }) ], [], '/foo/*/... does not match /foo/1 (no trailing /)' ); } { my $sub = $dp->parse('/foo/**/belief'); my $match = 'barred/beyond'; is_deeply( [ $sub->({ PATH_INFO => "/foo/${match}/belief" }) ], [ {}, $match ], "/foo/**/belief matches /foo/${match}/belief" ); } { my $match = '~'; my $sub = $dp->parse($match); is_deeply( [ $sub->({ PATH_INFO => '/foo' }) ], [], "$match does not match /foo" ); is_deeply( [ $sub->({ PATH_INFO => '' }) ], [ {} ], "$match matches empty path with empty env" ); } { my $match = '/foo...'; my $sub = $dp->parse($match); is_deeply( [ $sub->({ PATH_INFO => '/foobar' }) ], [], "$match does not match /foobar" ); is_deeply( [ $sub->({ PATH_INFO => '/foo/bar' }) ], [ { PATH_INFO => '/bar', SCRIPT_NAME => '/foo' } ], "$match matches /foo/bar and strips to /bar" ); is_deeply( [ $sub->({ PATH_INFO => '/foo/' }) ], [ { PATH_INFO => '/', SCRIPT_NAME => '/foo' } ], "$match matches /foo/ and strips to /" ); is_deeply( [ $sub->({ PATH_INFO => '/foo' }) ], [ { PATH_INFO => '', SCRIPT_NAME => '/foo' } ], "$match matches /foo and strips to empty path" ); } { my @dot_pairs = ( [ '/one/*' => 'two' ], [ '/one/*.*' => 'two.three' ], [ '/**' => 'one/two' ], [ '/**.*' => 'one/two.three' ], ); foreach my $p (@dot_pairs) { is_deeply( [ $dp->parse($p->[0])->({ PATH_INFO => '/one/two.three' }) ], [ {}, $p->[1] ], "${\$p->[0]} matches /one/two.three and returns ${\$p->[1]}" ); } } { my @named = ( [ '/foo/*:foo_id' => '/foo/1' => { foo_id => 1 } ], [ '/foo/:foo_id' => '/foo/1' => { foo_id => 1 } ], [ '/foo/:id/**:rest' => '/foo/id/rest/of/the/path.ext' => { id => 'id', rest => 'rest/of/the/path' } ], [ '/foo/:id/**.*:rest' => '/foo/id/rest/of/the/path.ext' => { id => 'id', rest => 'rest/of/the/path.ext' } ], ); foreach my $n (@named) { is_deeply( [ $dp->parse($n->[0])->({ PATH_INFO => $n->[1] }) ], [ {}, $n->[2] ], "${\$n->[0]} matches ${\$n->[1]} with correct captures" ); } } # # query string # my $q = 'foo=FOO&bar=BAR1&baz=one+two&quux=QUUX1&quux=QUUX2' .'&foo.bar=FOOBAR1&foo.bar=FOOBAR2&foo.baz=FOOBAZ' .'&bar=BAR2&quux=QUUX3&evil=%2F'; my %all_single = ( foo => 'FOO', bar => 'BAR2', baz => 'one two', quux => 'QUUX3', evil => '/', 'foo.baz' => 'FOOBAZ', 'foo.bar' => 'FOOBAR2', ); my %all_multi = ( foo => [ 'FOO' ], bar => [ qw(BAR1 BAR2) ], baz => [ 'one two' ], quux => [ qw(QUUX1 QUUX2 QUUX3) ], evil => [ '/' ], 'foo.baz' => [ 'FOOBAZ' ], 'foo.bar' => [ qw(FOOBAR1 FOOBAR2) ], ); foreach my $lose ('?foo=','?:foo=','?@foo=','?:@foo=') { my $foo = $dp->parse($lose); is_deeply( [ $foo->({ QUERY_STRING => '' }) ], [], "${lose} fails with no query" ); is_deeply( [ $foo->({ QUERY_STRING => 'bar=baz' }) ], [], "${lose} fails with query missing foo key" ); } foreach my $win ( [ '?foo=' => 'FOO' ], [ '?:foo=' => { foo => 'FOO' } ], [ '?spoo~' => undef ], [ '?:spoo~' => {} ], [ '?@spoo~' => [] ], [ '?:@spoo~' => { spoo => [] } ], [ '?bar=' => 'BAR2' ], [ '?:bar=' => { bar => 'BAR2' } ], [ '?@bar=' => [ qw(BAR1 BAR2) ] ], [ '?:@bar=' => { bar => [ qw(BAR1 BAR2) ] } ], [ '?foo=&@bar=' => 'FOO', [ qw(BAR1 BAR2) ] ], [ '?foo=&:@bar=' => 'FOO', { bar => [ qw(BAR1 BAR2) ] } ], [ '?:foo=&:@bar=' => { foo => 'FOO', bar => [ qw(BAR1 BAR2) ] } ], [ '?:baz=&:evil=' => { baz => 'one two', evil => '/' } ], [ '?*' => \%all_single ], [ '?@*' => \%all_multi ], [ '?foo=&@*' => 'FOO', \%all_multi ], [ '?:foo=&@*' => { %all_multi, foo => 'FOO' } ], [ '?:@bar=&*' => { %all_single, bar => [ qw(BAR1 BAR2) ] } ], [ '?foo.baz=' => 'FOOBAZ' ], [ '?:foo.baz=' => { 'foo.baz' => 'FOOBAZ' } ], [ '?foo.bar=' => 'FOOBAR2' ], [ '?:foo.bar=' => { 'foo.bar' => 'FOOBAR2' } ], [ '?@foo.bar=' => [ qw(FOOBAR1 FOOBAR2) ] ], [ '?:@foo.bar=' => { 'foo.bar' => [ qw(FOOBAR1 FOOBAR2) ] } ], ) { my ($spec, @res) = @$win; my $match = $dp->parse($spec); #use Data::Dump::Streamer; warn Dump($match); is_deeply( [ $match->({ QUERY_STRING => $q }) ], [ {}, @res ], "${spec} matches correctly" ); } # # /path/info/ + query string # foreach my $lose2 ('/foo/bar/+?foo=','/foo/bar/+?:foo=','/foo/bar/+?@foo=','/foo/bar/+?:@foo=') { my $foo = $dp->parse($lose2); is_deeply( [ $foo->({ PATH_INFO => '/foo/bar/', QUERY_STRING => '' }) ], [ ], "${lose2} fails with no query" ); is_deeply( [ $foo->({ PATH_INFO => '/foo/bar/', QUERY_STRING => 'bar=baz' }) ], [ ], "${lose2} fails with query missing foo key" ); } foreach my $win2 ( [ '/foo/bar/+?foo=' => 'FOO' ], [ '/foo/bar/+?:foo=' => { foo => 'FOO' } ], [ '/foo/bar/+?spoo~' => undef ], [ '/foo/bar/+?:spoo~' => {} ], [ '/foo/bar/+?@spoo~' => [] ], [ '/foo/bar/+?:@spoo~' => { spoo => [] } ], [ '/foo/bar/+?bar=' => 'BAR2' ], [ '/foo/bar/+?:bar=' => { bar => 'BAR2' } ], [ '/foo/bar/+?@bar=' => [ qw(BAR1 BAR2) ] ], [ '/foo/bar/+?:@bar=' => { bar => [ qw(BAR1 BAR2) ] } ], [ '/foo/bar/+?foo=&@bar=' => 'FOO', [ qw(BAR1 BAR2) ] ], [ '/foo/bar/+?foo=&:@bar=' => 'FOO', { bar => [ qw(BAR1 BAR2) ] } ], [ '/foo/bar/+?:foo=&:@bar=' => { foo => 'FOO', bar => [ qw(BAR1 BAR2) ] } ], [ '/foo/bar/+?:baz=&:evil=' => { baz => 'one two', evil => '/' } ], [ '/foo/bar/+?*' => \%all_single ], [ '/foo/bar/+?@*' => \%all_multi ], [ '/foo/bar/+?foo=&@*' => 'FOO', \%all_multi ], [ '/foo/bar/+?:foo=&@*' => { %all_multi, foo => 'FOO' } ], [ '/foo/bar/+?:@bar=&*' => { %all_single, bar => [ qw(BAR1 BAR2) ] } ], [ '/foo/bar/+?foo.baz=' => 'FOOBAZ' ], [ '/foo/bar/+?:foo.baz=' => { 'foo.baz' => 'FOOBAZ' } ], [ '/foo/bar/+?foo.bar=' => 'FOOBAR2' ], [ '/foo/bar/+?:foo.bar=' => { 'foo.bar' => 'FOOBAR2' } ], [ '/foo/bar/+?@foo.bar=' => [ qw(FOOBAR1 FOOBAR2) ] ], [ '/foo/bar/+?:@foo.bar=' => { 'foo.bar' => [ qw(FOOBAR1 FOOBAR2) ] } ], ) { my ($spec, @res) = @$win2; my $match = $dp->parse($spec); # use Data::Dump::Streamer; warn Dump($match); is_deeply( [ $match->({ PATH_INFO => '/foo/bar/', QUERY_STRING => $q }) ], [ {}, @res ], "${spec} matches correctly" ); } # # /path/info + query string # foreach my $lose3 ('/foo/bar+?foo=','/foo/bar+?:foo=','/foo/bar+?@foo=','/foo/bar+?:@foo=') { my $foo = $dp->parse($lose3); is_deeply( [ $foo->({ PATH_INFO => '/foo/bar', QUERY_STRING => '' }) ], [ ], "${lose3} fails with no query" ); is_deeply( [ $foo->({ PATH_INFO => '/foo/bar', QUERY_STRING => 'bar=baz' }) ], [ ], "${lose3} fails with query missing foo key" ); } foreach my $win3 ( [ '/foo/bar+?foo=' => 'FOO' ], [ '/foo/bar+?:foo=' => { foo => 'FOO' } ], [ '/foo/bar+?spoo~' => undef ], [ '/foo/bar+?:spoo~' => {} ], [ '/foo/bar+?@spoo~' => [] ], [ '/foo/bar+?:@spoo~' => { spoo => [] } ], [ '/foo/bar+?bar=' => 'BAR2' ], [ '/foo/bar+?:bar=' => { bar => 'BAR2' } ], [ '/foo/bar+?@bar=' => [ qw(BAR1 BAR2) ] ], [ '/foo/bar+?:@bar=' => { bar => [ qw(BAR1 BAR2) ] } ], [ '/foo/bar+?foo=&@bar=' => 'FOO', [ qw(BAR1 BAR2) ] ], [ '/foo/bar+?foo=&:@bar=' => 'FOO', { bar => [ qw(BAR1 BAR2) ] } ], [ '/foo/bar+?:foo=&:@bar=' => { foo => 'FOO', bar => [ qw(BAR1 BAR2) ] } ], [ '/foo/bar+?:baz=&:evil=' => { baz => 'one two', evil => '/' } ], [ '/foo/bar+?*' => \%all_single ], [ '/foo/bar+?@*' => \%all_multi ], [ '/foo/bar+?foo=&@*' => 'FOO', \%all_multi ], [ '/foo/bar+?:foo=&@*' => { %all_multi, foo => 'FOO' } ], [ '/foo/bar+?:@bar=&*' => { %all_single, bar => [ qw(BAR1 BAR2) ] } ], [ '/foo/bar+?foo.baz=' => 'FOOBAZ' ], [ '/foo/bar+?:foo.baz=' => { 'foo.baz' => 'FOOBAZ' } ], [ '/foo/bar+?foo.bar=' => 'FOOBAR2' ], [ '/foo/bar+?:foo.bar=' => { 'foo.bar' => 'FOOBAR2' } ], [ '/foo/bar+?@foo.bar=' => [ qw(FOOBAR1 FOOBAR2) ] ], [ '/foo/bar+?:@foo.bar=' => { 'foo.bar' => [ qw(FOOBAR1 FOOBAR2) ] } ], ) { my ($spec, @res) = @$win3; my $match = $dp->parse($spec); # use Data::Dump::Streamer; warn Dump($match); is_deeply( [ $match->({ PATH_INFO => '/foo/bar', QUERY_STRING => $q }) ], [ {}, @res ], "${spec} matches correctly" ); } Web-Simple-0.033/t/match-home.t0000644000372100001440000000315213012655624015716 0ustar matthewtusersuse strictures 1; use Test::More 0.88; { package t::Web::Simple::MatchHome; use Web::Simple; sub as_text { [200, ['Content-Type' => 'text/plain'], [$_[0]->{REQUEST_METHOD}, $_[0]->{REQUEST_URI}] ] } sub dispatch_request { sub (/foo...) { sub (~) { as_text(pop) }, sub (/bar) { as_text(pop) }, sub (/baz) { as_text(pop) }, sub (/*) { as_text(pop) }, sub (/bork...) { sub (~) { as_text(pop) }, sub (/bar) { as_text(pop) }, } }, sub (/...) { sub (/baz) { as_text(pop) }, sub (/fob...) { sub (~) { as_text(pop) }, sub (/bar) { as_text(pop) }, } } } } ok my $app = t::Web::Simple::MatchHome->new, 'made app'; for(ok my $res = $app->run_test_request(GET => '/foo')) { is $res->content, 'GET/foo'; } for(ok my $res = $app->run_test_request(GET => '/foo/bar')) { is $res->content, 'GET/foo/bar'; } for(ok my $res = $app->run_test_request(GET => '/foo/baz')) { is $res->content, 'GET/foo/baz'; } for(ok my $res = $app->run_test_request(GET => '/foo/id')) { is $res->content, 'GET/foo/id'; } for(ok my $res = $app->run_test_request(GET => '/foo/bork')) { is $res->content, 'GET/foo/bork'; } for(ok my $res = $app->run_test_request(GET => '/foo/bork/bar')) { is $res->content, 'GET/foo/bork/bar'; } for(ok my $res = $app->run_test_request(GET => '/fob')) { is $res->content, 'GET/fob'; } for(ok my $res = $app->run_test_request(GET => '/baz')) { is $res->content, 'GET/baz'; } for(ok my $res = $app->run_test_request(GET => '/fob/bar')) { is $res->content, 'GET/fob/bar'; } done_testing; Web-Simple-0.033/README0000644000372100001440000006605513064012245014130 0ustar matthewtusersNAME Web::Simple - A quick and easy way to build simple web applications SYNOPSIS #!/usr/bin/env perl package HelloWorld; use Web::Simple; sub dispatch_request { GET => sub { [ 200, [ 'Content-type', 'text/plain' ], [ 'Hello world!' ] ] }, '' => sub { [ 405, [ 'Content-type', 'text/plain' ], [ 'Method not allowed' ] ] } } HelloWorld->run_if_script; If you save this file into your cgi-bin as "hello-world.cgi" and then visit: http://my.server.name/cgi-bin/hello-world.cgi/ you'll get the "Hello world!" string output to your browser. At the same time this file will also act as a class module, so you can save it as HelloWorld.pm and use it as-is in test scripts or other deployment mechanisms. Note that you should retain the ->run_if_script even if your app is a module, since this additionally makes it valid as a .psgi file, which can be extremely useful during development. For more complex examples and non-CGI deployment, see Web::Simple::Deployment. To get help with Web::Simple, please connect to the irc.perl.org IRC network and join #web-simple. DESCRIPTION The philosophy of Web::Simple is to keep to an absolute bare minimum for everything. It is not designed to be used for large scale applications; the Catalyst web framework already works very nicely for that and is a far more mature, well supported piece of software. However, if you have an application that only does a couple of things, and want to not have to think about complexities of deployment, then Web::Simple might be just the thing for you. The only public interface the Web::Simple module itself provides is an "import" based one: use Web::Simple 'NameOfApplication'; This sets up your package (in this case "NameOfApplication" is your package) so that it inherits from Web::Simple::Application and imports strictures, as well as installs a "PSGI_ENV" constant for convenience, as well as some other subroutines. Importing strictures will automatically make your code use the "strict" and "warnings" pragma, so you can skip the usual: use strict; use warnings FATAL => 'all'; provided you 'use Web::Simple' at the top of the file. Note that we turn on *fatal* warnings so if you have any warnings at any point from the file that you did 'use Web::Simple' in, then your application will die. This is, so far, considered a feature. When we inherit from Web::Simple::Application we also use Moo, which is the the equivalent of: { package NameOfApplication; use Moo; extends 'Web::Simple::Application'; } So you can use Moo features in your application, such as creating attributes using the "has" subroutine, etc. Please see the documentation for Moo for more information. It also exports the following subroutines for use in dispatchers: response_filter { ... }; redispatch_to '/somewhere'; Finally, import sets $INC{"NameOfApplication.pm"} = 'Set by "use Web::Simple;" invocation'; so that perl will not attempt to load the application again even if require NameOfApplication; is encountered in other code. One important thing to remember when using NameOfApplication->run_if_script; At the end of your app is that this call will create an instance of your app for you automatically, regardless of context. An easier way to think of this would be if the method were more verbosely named NameOfApplication->run_request_if_script_else_turn_coderef_for_psgi; DISPATCH STRATEGY Web::Simple despite being straightforward to use, has a powerful system for matching all sorts of incoming URLs to one or more subroutines. These subroutines can be simple actions to take for a given URL, or something more complicated, including entire Plack applications, Plack::Middleware and nested subdispatchers. Examples sub dispatch_request { ( # matches: GET /user/1.htm?show_details=1 # GET /user/1.htm 'GET + /user/* + ?show_details~ + .htm|.html|.xhtml' => sub { my ($self, $user_id, $show_details) = @_; ... }, # matches: POST /user?username=frew # POST /user?username=mst&first_name=matt&last_name=trout 'POST + /user + ?username=&*' => sub { my ($self, $username, $misc_params) = @_; ... }, # matches: DELETE /user/1/friend/2 'DELETE + /user/*/friend/*' => sub { my ($self, $user_id, $friend_id) = @_; ... }, # matches: PUT /user/1?first_name=Matt&last_name=Trout 'PUT + /user/* + ?first_name~&last_name~' => sub { my ($self, $user_id, $first_name, $last_name) = @_; ... }, '/user/*/...' => sub { my $user_id = $_[1]; ( # matches: PUT /user/1/role/1 'PUT + /role/*' => sub { my $role_id = $_[1]; ... }, # matches: DELETE /user/1/role/1 'DELETE + /role/*' => sub { my $role_id = $_[1]; ... }, ); }, ); } The dispatch cycle At the beginning of a request, your app's dispatch_request method is called with the PSGI $env as an argument. You can handle the request entirely in here and return a PSGI response arrayref if you want: sub dispatch_request { my ($self, $env) = @_; [ 404, [ 'Content-type' => 'text/plain' ], [ 'Amnesia == fail' ] ] } However, generally, instead of that, you return a set of route/target pairs: sub dispatch_request { my $self = shift; ( '/' => sub { redispatch_to '/index.html' }, '/user/*' => sub { $self->show_user($_[1]) }, 'POST + %*' => 'handle_post', ... ); } Well, a sub is a valid PSGI response too (for ultimate streaming and async cleverness). If you want to return a PSGI sub you have to wrap it into an array ref. sub dispatch_request { [ sub { my $respond = shift; # This is pure PSGI here, so read perldoc PSGI } ] } If you return a string followed by a subroutine or method name, the string is treated as a match specification - and if the test is passed, the subroutine is called as a method and passed any matched arguments (see below for more details). You can also return a plain subroutine which will be called with just $env - remember that in this case if you need $self you must close over it. If you return a normal object, Web::Simple will simply return it upwards on the assumption that a response_filter (or some arbitrary Plack::Middleware) somewhere will convert it to something useful. This allows: sub dispatch_request { my $self = shift; ( '.html' => sub { response_filter { $self->render_zoom($_[0]) } }, '/user/*' => sub { $self->users->get($_[1]) }, ); } An alternative to using string + suborutine to declare a route is to use the sub prototype - sub dispatch_request { my $self = shift; ( sub (.html) { response_filter { $self->render_zoom($_[0]) } }, sub (/user/) { $self->users->get($_[1]) }, $self->can('handle_post'), # if declared as 'sub handle_post (...) {' ) } This can be useful sugar, especially if you want to keep method-based dispatchers' route specifications on the methods. to render a user object to HTML, if there is an incoming URL such as: http://myweb.org/user/111.html This works because as we descend down the dispachers, we first match "sub (.html)", which adds a "response_filter" (basically a specialized routine that follows the Plack::Middleware specification), and then later we also match "sub (/user/*)" which gets a user and returns that as the response. This user object 'bubbles up' through all the wrapping middleware until it hits the "response_filter" we defined, after which the return is converted to a true html response. However, two types of objects are treated specially - a "Plack::Component" object will have its "to_app" method called and be used as a dispatcher: sub dispatch_request { my $self = shift; ( '/static/...' => sub { Plack::App::File->new(...) }, ... ); } A Plack::Middleware object will be used as a filter for the rest of the dispatch being returned into: ## responds to /admin/track_usage AND /admin/delete_accounts sub dispatch_request { my $self = shift; ( '/admin/**' => sub { Plack::Middleware::Session->new(%opts); }, '/admin/track_usage' => sub { ## something that needs a session }, '/admin/delete_accounts' => sub { ## something else that needs a session }, ); } Note that this is for the dispatch being returned to, so if you want to provide it inline you need to do: ## ALSO responds to /admin/track_usage AND /admin/delete_accounts sub dispatch_request { my $self = shift; ( '/admin/...' => sub { ( sub { Plack::Middleware::Session->new(%opts); }, '/track_usage' => sub { ## something that needs a session }, '/delete_accounts' => sub { ## something else that needs a session }, ); } ); } And that's it - but remember that all this happens recursively - it's dispatchers all the way down. A URL incoming pattern will run all matching dispatchers and then hit all added filters or Plack::Middleware. Web::Simple match specifications Method matches 'GET' => sub { A match specification beginning with a capital letter matches HTTP requests with that request method. Path matches '/login' => sub { A match specification beginning with a / is a path match. In the simplest case it matches a specific path. To match a path with a wildcard part, you can do: '/user/*' => sub { $self->handle_user($_[1]) This will match /user/ where does not include a literal / character. The matched part becomes part of the match arguments. You can also match more than one part: '/user/*/*' => sub { my ($self, $user_1, $user_2) = @_; '/domain/*/user/*' => sub { my ($self, $domain, $user) = @_; and so on. To match an arbitrary number of parts, use "**": '/page/**' => sub { my ($self, $match) = @_; This will result in a single element for the entire match. Note that you can do '/page/**/edit' => sub { to match an arbitrary number of parts up to but not including some final part. Note: Since Web::Simple handles a concept of file extensions, "*" and "**" matchers will not by default match things after a final dot, and this can be modified by using "*.*" and "**.*" in the final position, e.g.: /one/* matches /one/two.three and captures "two" /one/*.* matches /one/two.three and captures "two.three" /** matches /one/two.three and captures "one/two" /**.* matches /one/two.three and captures "one/two.three" Finally, '/foo/...' => sub { Will match "/foo/" on the beginning of the path and strip it. This is designed to be used to construct nested dispatch structures, but can also prove useful for having e.g. an optional language specification at the start of a path. Note that the '...' is a "maybe something here, maybe not" so the above specification will match like this: /foo # no match /foo/ # match and strip path to '/' /foo/bar/baz # match and strip path to '/bar/baz' Almost the same, '/foo...' => sub { Will match on "/foo/bar/baz", but also include "/foo". Otherwise it operates the same way as "/foo/...". /foo # match and strip path to '' /foo/ # match and strip path to '/' /foo/bar/baz # match and strip path to '/bar/baz' Please note the difference between "sub(/foo/...)" and "sub(/foo...)". In the first case, this is expecting to find something after "/foo" (and fails to match if nothing is found), while in the second case we can match both "/foo" and "/foo/more/to/come". The following are roughly the same: '/foo' => sub { 'I match /foo' }, '/foo/...' => sub { ( '/bar' => sub { 'I match /foo/bar' }, '/*' => sub { 'I match /foo/{id}' }, ); } Versus '/foo...' => sub { ( '~' => sub { 'I match /foo' }, '/bar' => sub { 'I match /foo/bar' }, '/*' => sub { 'I match /foo/{id}' }, ); } You may prefer the latter example should you wish to take advantage of subdispatchers to scope common activities. For example: '/user...' => sub { my $user_rs = $schema->resultset('User'); ( '~' => sub { $user_rs }, '/*' => sub { $user_rs->find($_[1]) }, ); } You should note the special case path match "sub (~)" which is only meaningful when it is contained in this type of path match. It matches to an empty path. Naming your patch matches Any "*", "**", "*.*", or "**.*" match can be followed with ":name" to make it into a named match, so: '/*:one/*:two/*:three/*:four' => sub { "I match /1/2/3/4 capturing { one => 1, two => 2, three => 3, four => 4 }" } '/**.*:allofit' => sub { "I match anything capturing { allofit => \$whole_path }" } In the specific case of a simple single-* match, the * may be omitted, to allow you to write: '/:one/:two/:three/:four' => sub { "I match /1/2/3/4 capturing { one => 1, two => 2, three => 3, four => 4 }" } "/foo" and "/foo/" are different specs As you may have noticed with the difference between '/foo/...' and '/foo...', trailing slashes in path specs are significant. This is intentional and necessary to retain the ability to use relative links on websites. Let's demonstrate on this link: bar If the user loads the url "/foo/" and clicks on this link, they will be sent to "/foo/bar". However when they are on the url "/foo" and click this link, then they will be sent to "/bar". This makes it necessary to be explicit about the trailing slash. Extension matches '.html' => sub { will match .html from the path (assuming the subroutine itself returns something, of course). This is normally used for rendering - e.g.: '.html' => sub { response_filter { $self->render_html($_[1]) } } Additionally, '.*' => sub { will match any extension and supplies the extension as a match argument. Query and body parameter matches Query and body parameters can be match via '?' => sub { # match URI query '%' => sub { # match body params The body spec will match if the request content is either application/x-www-form-urlencoded or multipart/form-data - the latter of which is required for uploads - see below. The param spec is elements of one of the following forms: param~ # optional parameter param= # required parameter @param~ # optional multiple parameter @param= # required multiple parameter :param~ # optional parameter in hashref :param= # required parameter in hashref :@param~ # optional multiple in hashref :@param= # required multiple in hashref * # include all other parameters in hashref @* # include all other parameters as multiple in hashref separated by the "&" character. The arguments added to the request are one per non-":"/"*" parameter (scalar for normal, arrayref for multiple), plus if any ":"/"*" specs exist a hashref containing those values. If a parameter has no value, i.e. appears as '?foo&', a value of 1 will be captured. Please note that if you specify a multiple type parameter match, you are ensured of getting an arrayref for the value, EVEN if the current incoming request has only one value. However if a parameter is specified as single and multiple values are found, the last one will be used. For example to match a "page" parameter with an optional "order_by" parameter one would write: '?page=&order_by~' => sub { my ($self, $page, $order_by) = @_; return unless $page =~ /^\d+$/; $order_by ||= 'id'; response_filter { $_[1]->search_rs({}, { page => $page, order_by => $order_by }); } } to implement paging and ordering against a DBIx::Class::ResultSet object. Another Example: To get all parameters as a hashref of arrayrefs, write: '?@*' => sub { my ($self, $params) = @_; ... To get two parameters as a hashref, write: '?:user~&:domain~' => sub { my ($self, $params) = @_; # params contains only 'user' and 'domain' keys You can also mix these, so: '?foo=&@bar~&:coffee=&@*' => sub { my ($self, $foo, $bar, $params) = @_; where $bar is an arrayref (possibly an empty one), and $params contains arrayref values for all parameters not mentioned and a scalar value for the 'coffee' parameter. Note, in the case where you combine arrayref, single parameter and named hashref style, the arrayref and single parameters will appear in @_ in the order you defined them in the prototype, but all hashrefs will merge into a single $params, as in the example above. Upload matches '*foo=' => sub { # 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 "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 "Web::Dispatch::NotAnUpload" object, which will "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 Plack::Request::Upload with the addition of a stringify to the temporary filename to make copying it somewhere else easier to handle. Combining matches Matches may be combined with the + character - e.g. 'GET + /user/*' => sub { to create an AND match. They may also be combined with the | character - e.g. 'GET|POST' => sub { to create an OR match. Matches can be nested with () - e.g. '(GET|POST + /user/*)' => sub { and negated with ! - e.g. '!/user/foo + /user/*' => sub { ! binds to the immediate rightmost match specification, so if you want to negate a combination you will need to use '!(POST|PUT|DELETE)' => sub { and | binds tighter than +, so '(GET|POST) + /user/*' => sub { and 'GET|POST + /user/*' => sub { are equivalent, but '(GET + /admin/...) | (POST + /admin/...)' => sub { and 'GET + /admin/... | POST + /admin/...' => sub { are not - the latter is equivalent to 'GET + (/admin/...|POST) + /admin/...' => sub { which will never match! Whitespace Note that for legibility you are permitted to use whitespace: 'GET + /user/*' => sub { but it will be ignored. This is because the perl parser strips whitespace from subroutine prototypes, so this is equivalent to 'GET+/user/*' => sub { Accessing parameters via %_ If your dispatch specification causes your dispatch subroutine to receive a hash reference as its first argument, the contained named parameters will be accessible via %_. This can be used to access your path matches, if they are named: 'GET + /foo/:path_part' => sub { [ 200, ['Content-type' => 'text/plain'], ["We are in $_{path_part}"], ]; } Or, if your first argument would be a hash reference containing named query parameters: 'GET + /foo + ?:some_param=' => sub { [ 200, ['Content-type' => 'text/plain'], ["We received $_{some_param} as parameter"], ]; } Of course this also works when all you are doing is slurping the whole set of parameters by their name: 'GET + /foo + ?*' => sub { [ 200, ['Content-type' => 'text/plain'], [exists($_{foo}) ? "Received a foo: $_{foo}" : "No foo!"], ], } Note that only the first hash reference will be available via %_. If you receive additional hash references, you will need to access them as usual. Accessing the PSGI env hash In some cases you may wish to get the raw PSGI env hash - to do this, you can either use a plain sub: sub { my ($env) = @_; ... } or use the "PSGI_ENV" constant exported to retrieve it from @_: 'GET + /foo + ?some_param=' => sub { my $param = $_[1]; my $env = $_[PSGI_ENV]; } but note that if you're trying to add a middleware, you should simply use Web::Simple's direct support for doing so. EXPORTED SUBROUTINES response_filter response_filter { # Hide errors from the user because we hates them, preciousss if (ref($_[0]) eq 'ARRAY' && $_[0]->[0] == 500) { $_[0] = [ 200, @{$_[0]}[1..$#{$_[0]}] ]; } return $_[0]; }; The response_filter subroutine is designed for use inside dispatch subroutines. It creates and returns a special dispatcher that always matches, and calls the block passed to it as a filter on the result of running the rest of the current dispatch chain. Thus the filter above runs further dispatch as normal, but if the result of dispatch is a 500 (Internal Server Error) response, changes this to a 200 (OK) response without altering the headers or body. redispatch_to redispatch_to '/other/url'; The redispatch_to subroutine is designed for use inside dispatch subroutines. It creates and returns a special dispatcher that always matches, and instead of continuing dispatch re-delegates it to the start of the dispatch process, but with the path of the request altered to the supplied URL. Thus if you receive a POST to "/some/url" and return a redispatch to "/other/url", the dispatch behaviour will be exactly as if the same POST request had been made to "/other/url" instead. Note, this is not the same as returning an HTTP 3xx redirect as a response; rather it is a much more efficient internal process. CHANGES BETWEEN RELEASES Changes between 0.004 and 0.005 * dispatch {} replaced by declaring a dispatch_request method dispatch {} has gone away - instead, you write: sub dispatch_request { my $self = shift; ( 'GET /foo/' => sub { ... }, ... ); } Note that this method is still returning the dispatch code - just like "dispatch" did. Also note that you need the "my $self = shift" since the magic $self variable went away. * the magic $self variable went away. Just add "my $self = shift;" while writing your "sub dispatch_request {" like a normal perl method. * subdispatch deleted - all dispatchers can now subdispatch In earlier releases you needed to write: subdispatch sub (/foo/...) { ... [ sub (GET /bar/) { ... }, ... ] } As of 0.005, you can instead write simply: sub (/foo/...) { ... ( sub (GET /bar/) { ... }, ... ) } Changes since Antiquated Perl * filter_response renamed to response_filter This is a pure rename; a global search and replace should fix it. * dispatch [] changed to dispatch {} Simply changing dispatch [ sub(...) { ... }, ... ]; to dispatch { sub(...) { ... }, ... }; should work fine. DEVELOPMENT HISTORY Web::Simple was originally written to form part of my Antiquated Perl talk for Italian Perl Workshop 2009, but in writing the bloggery example I realised that having a bare minimum system for writing web applications that doesn't drive me insane was rather nice and decided to spend my attempt at nanowrimo for 2009 improving and documenting it to the point where others could use it. The Antiquated Perl talk can be found at and the slides are reproduced in this distribution under Web::Simple::AntiquatedPerl. COMMUNITY AND SUPPORT IRC channel irc.perl.org #web-simple No mailing list yet Because mst's non-work email is a bombsite so he'd never read it anyway. Git repository Gitweb is on http://git.shadowcat.co.uk/ and the clone URL is: git clone git://git.shadowcat.co.uk/catagits/Web-Simple.git AUTHOR Matt S. Trout (mst) CONTRIBUTORS Devin Austin (dhoss) Arthur Axel 'fREW' Schmidt gregor herrmann (gregoa) John Napiorkowski (jnap) Josh McMichael Justin Hunter (arcanez) Kjetil Kjernsmo markie Christian Walde (Mithaldu) nperez Robin Edwards Andrew Rodland (hobbs) Robert Sedlacek (phaylon) Hakim Cassimally (osfameron) Karen Etheridge (ether) COPYRIGHT Copyright (c) 2011 the Web::Simple "AUTHOR" and "CONTRIBUTORS" as listed above. LICENSE This library is free software and may be distributed under the same terms as perl itself. Web-Simple-0.033/META.json0000644000372100001440000000340213064012245014654 0ustar matthewtusers{ "abstract" : "A quick and easy way to build simple web applications", "author" : [ "mst - Matt S. Trout (cpan:MSTROUT) " ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 7.2, CPAN::Meta::Converter version 2.150005", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Web-Simple", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : {} }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Encode" : "0", "Exporter" : "5.57", "HTTP::Body" : "1.22", "Moo" : "0.009014", "Plack" : "0.9968", "Scalar::Util" : "0", "Syntax::Keyword::Gather" : "1.001", "perl" : "5.006", "strictures" : "1", "warnings::illegalproto" : "0" } }, "test" : { "requires" : { "Data::Dumper::Concise" : "2.020", "Test::More" : "0.88" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "mailto" : "bug-Web-Simple@rt.cpan.org", "web" : "https://rt.cpan.org/Public/Dist/Display.html?Name=Web-Simple" }, "repository" : { "type" : "git", "url" : "git://git.shadowcat.co.uk/catagits/Web-Simple.git", "web" : "http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits/Web-Simple.git" } }, "version" : "0.033", "x_serialization_backend" : "JSON::PP version 2.27300" } Web-Simple-0.033/Makefile.PL0000644000372100001440000000572713064012205015215 0ustar matthewtusersuse strict; use warnings FATAL => 'all'; use 5.006; use ExtUtils::MakeMaker; (do './maint/Makefile.PL.include' or die $@) unless -f 'META.yml'; my %WriteMakefileArgs = ( NAME => 'Web::Simple', VERSION_FROM => 'lib/Web/Simple.pm', META_MERGE => { 'meta-spec' => { version => 2 }, dynamic_config => 0, resources => { # r/w: catagits@git.shadowcat.co.uk:Web-Simple.git repository => { url => 'git://git.shadowcat.co.uk/catagits/Web-Simple.git', web => 'http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits/Web-Simple.git', type => 'git', }, bugtracker => { mailto => 'bug-Web-Simple@rt.cpan.org', web => 'https://rt.cpan.org/Public/Dist/Display.html?Name=Web-Simple', }, }, }, META_ADD => { prereqs => { configure => { requires => { 'ExtUtils::MakeMaker' => 0, }, }, runtime => { requires => { 'Encode' => '0', # not core in 5.6 'Exporter' => '5.57', # use Exporter 'import' 'Moo' => '0.009014', 'Plack' => '0.9968', 'HTTP::Body' => '1.22', 'Scalar::Util' => '0', # not core in 5.6 'Syntax::Keyword::Gather' => '1.001', 'strictures' => '1', 'warnings::illegalproto' => '0', 'perl' => '5.006', }, }, test => { requires => { 'Data::Dumper::Concise' => '2.020', 'Test::More' => '0.88', }, recommends => { 'Devel::Cycle' => '0', 'HTTP::Request::AsCGI' => '0', }, }, }, }, ); my $eumm_version = eval $ExtUtils::MakeMaker::VERSION; for (qw(configure build test runtime)) { my $key = $_ eq 'runtime' ? 'PREREQ_PM' : uc $_.'_REQUIRES'; next unless exists $WriteMakefileArgs{META_ADD}{prereqs}{$_} or exists $WriteMakefileArgs{$key}; my $r = $WriteMakefileArgs{$key} = { %{$WriteMakefileArgs{META_ADD}{prereqs}{$_}{requires} || {}}, %{delete $WriteMakefileArgs{$key} || {}}, }; defined $r->{$_} or delete $r->{$_} for keys %$r; } # dynamic prereqs get added here. $WriteMakefileArgs{MIN_PERL_VERSION} = delete $WriteMakefileArgs{PREREQ_PM}{perl} || 0; die 'attention developer: you need to do a sane meta merge here!' if keys %{$WriteMakefileArgs{BUILD_REQUIRES}}; $WriteMakefileArgs{BUILD_REQUIRES} = { %{$WriteMakefileArgs{BUILD_REQUIRES} || {}}, %{delete $WriteMakefileArgs{TEST_REQUIRES}} } if $eumm_version < 6.63_03; $WriteMakefileArgs{PREREQ_PM} = { %{$WriteMakefileArgs{PREREQ_PM}}, %{delete $WriteMakefileArgs{BUILD_REQUIRES}} } if $eumm_version < 6.55_01; delete $WriteMakefileArgs{CONFIGURE_REQUIRES} if $eumm_version < 6.51_03; delete $WriteMakefileArgs{MIN_PERL_VERSION} if $eumm_version < 6.48; delete @WriteMakefileArgs{qw(META_ADD META_MERGE)} if $eumm_version < 6.46; delete $WriteMakefileArgs{LICENSE} if $eumm_version < 6.31; WriteMakefile(%WriteMakefileArgs); Web-Simple-0.033/MANIFEST0000644000372100001440000000264713064012245014376 0ustar matthewtusersChanges examples/bloggery/bloggery.cgi examples/bloggery/posts/Another-Post.html examples/bloggery/posts/One-Post.html examples/bloggery/posts/One-Post.summary.html examples/dispatchex/dispatchex.cgi examples/golf/golf.cgi examples/hello-world/hello-world.cgi lib/CSS/Declare.pm lib/HTML/Tags.pm lib/Plack/Middleware/Dispatch.pm lib/Web/Dispatch.pm lib/Web/Dispatch/HTTPMethods.pm lib/Web/Dispatch/Node.pm lib/Web/Dispatch/ParamParser.pm lib/Web/Dispatch/Parser.pm lib/Web/Dispatch/Predicates.pm lib/Web/Dispatch/ToApp.pm lib/Web/Dispatch/Upload.pm lib/Web/Dispatch/Wrapper.pm lib/Web/Simple.pm lib/Web/Simple/AntiquatedPerl.pod lib/Web/Simple/Application.pm lib/Web/Simple/Deployment.pod lib/Web/Simple/HackedPlack.pm lib/Web/Simple/Role.pm lib/XML/Tags.pm maint/Makefile.PL.include Makefile.PL MANIFEST This list of files t/bloggery.t t/css_declare.t t/dispatch_misc.t t/dispatch_parser.t t/env.t t/globbery/one t/globbery/three t/globbery/two t/leak.t t/match-home.t t/param_parser.t t/post.t t/predicate_objects.t t/request_mode_heuristics.t t/response-filter.t t/role.t t/stream_test.t t/sub-dispatch-args.t t/sub-dispatch-env.t t/tags.t t/test-request-basic-auth.t t/underscore.t t/wd-http-methods.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) README README file (added by Distar) Web-Simple-0.033/META.yml0000644000372100001440000000171313064012245014507 0ustar matthewtusers--- abstract: 'A quick and easy way to build simple web applications' author: - 'mst - Matt S. Trout (cpan:MSTROUT) ' build_requires: Data::Dumper::Concise: '2.020' Test::More: '0.88' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 0 generated_by: 'ExtUtils::MakeMaker version 7.2, CPAN::Meta::Converter version 2.150005' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Web-Simple no_index: directory: - t - inc requires: Encode: '0' Exporter: '5.57' HTTP::Body: '1.22' Moo: '0.009014' Plack: '0.9968' Scalar::Util: '0' Syntax::Keyword::Gather: '1.001' perl: '5.006' strictures: '1' warnings::illegalproto: '0' resources: bugtracker: https://rt.cpan.org/Public/Dist/Display.html?Name=Web-Simple repository: git://git.shadowcat.co.uk/catagits/Web-Simple.git version: '0.033' x_serialization_backend: 'CPAN::Meta::YAML version 0.012' Web-Simple-0.033/Changes0000644000372100001440000001044413064012235014531 0ustar matthewtusersRevision history for Web-Simple 0.033 - 2017-03-20 - reinstate the right glob in XML::Tags 0.032 - 2016-11-15 - add HTTP::Body dep - fix Test::More dep - documention fixes 0.031 - 2015-08-14 - rewrite docs to use string form first - handle empty query parameters - produce a sensible error for (GET => undef) on 5.8 0.030 - 2014-08-07 - make dispatch_misc.t handle Plack's MockHTTP's on error behaviour changing 0.029 - 2014-07-27 - fix repository metadata (Thomas Sibley) 0.028 - 2014-07-11 - remove use of 'use base' - lower minimum required version of perl properly down to 5.6 0.027 - 2014-07-11 - stable release of 0.026_001 0.026_001 - 2014-07-09 - fix prerequisite declarations on older toolchain 0.026 - 2014-07-09 - remove erroneous XML::Tags prereq 0.025 - 2014-07-07 - fixes a memory leak that occurs when calling Web::Simple::Application::to_psgi_app (Christian Walde) - more complete prerequisite declarations 0.024 - 2014-07-03 - small documentation fixes 0.023 - 2014-05-23 - Re-dist to fix MANIFEST 0.022 - 2014-05-23 - Remove erroneous require of deleted Web::Dispatch::Node 0.021 - 2014-05-20 - Handle ) as last character of composite spec - Allow passing method names to dispatcher - Added Web::Simple::Role - Assorted doc updates 0.020 - 2012-08-03 - re-dist for botched release 0.019 - 2012-07-30 - Add %_ alias if first argument is a hashref - Un-mark upload matches as experimental since they work 0.018 - 2012-07-15 - Allow dots in parameter names - Support for basic authentication in test requests 0.017 - 2012-07-05 - Don't falsely recognize mod_cgid as FCGI 0.016 - 2012-05-11 - Actually import weaken so the 0.015 fix doesn't implode 0.015 - 2012-05-10 - Fix a per-application-instance memory leak 0.014 - 2012-04-27 - Add named path matching - Allow headers on CLI calls 0.013 - 2012-04-03 - Fix a weird interaction between match-spec parsing and module loading that was causing brokenness and test failures with perl 5.8.8 0.012 - 2012-01-30 - Added match predicates match_true and match_false - Added '~' to match an empty path - Sub-dispatch via '...' is now permissible without a trailing slash - Only word char sequences with singular periods are parsed as path parts now - Various doc fixes - All query body parameters are now decoded from UTF8 - Allow dots in path matches, so you can have sub (/foo.html) 0.011 - 2011-12-23 - Add Web::Dispatch::HTTPMethods - Fix [ sub {} ] for async code - Support match_foo(...) => sub {} as a dispatcher return 0.010 - 2011-10-06 - Provide $app->run_test_request for use in test scripts - Preserve original env in Web::Dispatch so ParamParser can cache in there (stops HTTP::Body object getting destroyed early thereby losing uploads) 0.009 - 2011-10-03 - Complete port from HTTP::Request::AsCGI to Plack::Test - 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 to STDOUT so that './myapp /foo.html >foo.html' works sanely - Add *.* and **.* dispatch types to keep extension - Add Antiquated Perl slides in a POD document. 0.008 - 2011-02-16 - Once more. 0.007 - 2011-02-16 - Re-release due to indexing failure 0.006 - 2011-02-15 - Fix Content-type issue (ie, Content-type: blah works, but Content-type: blah; charset: blah shits flames) - Make Web::Dispatch return [\$cv] as \$cv to allow subref responses - Stop undef errors killing XML::Tags conversion to string - Fixup dispatcher logic so dispatchers within a /foo/... work correctly 0.005 - Tue Jan 11 2011 22:09 UTC - Redocument to cover changes - Factor dispatcher code out into Web::Dispatch - Support 'use Web::Simple;' to default to current package 0.004 - Thu Jul 08 2010 22:08 UTC - Hide Plack Modules from PAUSE 0.003 - Thu Jul 08 2010 14:48 UTC - Experimentally use $_[ENV] for the PSGI env - Add CSS::Declare - Add more tags to HTML::Tags 0.002 - Tue Dec 01 2009 00:30 UTC - fix dispatcher construction to recognise '' as no proto (we expected undef) - plackup support, as_psgi_app method - Fix SYNOPSIS 0.001 - Tue Nov 24 2009 21:54 UTC - Initial release Web-Simple-0.033/lib/0000755000372100001440000000000013064012245014002 5ustar matthewtusersWeb-Simple-0.033/lib/HTML/0000755000372100001440000000000013064012245014546 5ustar matthewtusersWeb-Simple-0.033/lib/HTML/Tags.pm0000644000372100001440000000157411307447744016027 0ustar matthewtuserspackage HTML::Tags; use strict; use warnings FATAL => 'all'; use XML::Tags (); my @HTML_TAGS = qw( a abbr address area article aside audio b base bb bdo blockquote body br button canvas caption cite code col colgroup command datagrid datalist dd del details dialog dfn div dl dt em embed eventsource fieldset figure footer form h1 h2 h3 h4 h5 h6 head header hr html i iframe img input ins kbd label legend li link mark map menu meta meter nav noscript object ol optgroup option output p param pre progress q ruby rp rt samp script section select small source span strong style sub sup table tbody td textarea tfoot th thead time title tr ul var video ); sub import { my ($class, @rest) = @_; my $opts = ref($rest[0]) eq 'HASH' ? shift(@rest) : {}; ($opts->{into_level}||=1)++; XML::Tags->import($opts, @HTML_TAGS, @rest); } sub to_html_string { XML::Tags::to_xml_string(@_) } 1; Web-Simple-0.033/lib/Plack/0000755000372100001440000000000013064012245015034 5ustar matthewtusersWeb-Simple-0.033/lib/Plack/Middleware/0000755000372100001440000000000013064012245017111 5ustar matthewtusersWeb-Simple-0.033/lib/Plack/Middleware/Dispatch.pm0000644000372100001440000000046012057472520021215 0ustar matthewtuserspackage Plack::Middleware::Dispatch; use Moo; extends 'Web::Dispatch'; has app => (is => 'ro', writer => '_set_app'); sub wrap { my ($self, $app, @args) = @_; if (ref $self) { $self->_set_app($app); } else { $self = $self->new({ app => $app, @args }); } return $self->to_app; } 1; Web-Simple-0.033/lib/XML/0000755000372100001440000000000013064012245014442 5ustar matthewtusersWeb-Simple-0.033/lib/XML/Tags.pm0000644000372100001440000000647113063546500015713 0ustar matthewtuserspackage XML::Tags; use strict; use warnings FATAL => 'all'; use File::Glob (); require overload; my $IN_SCOPE = 0; sub import { die "Can't import XML::Tags into a scope when already compiling one that uses it" if $IN_SCOPE; my ($class, @args) = @_; my $opts = shift(@args) if ref($args[0]) eq 'HASH'; my $target = $class->_find_target(0, $opts); my @tags = $class->_find_tags(@args); my $unex = $class->_export_tags_into($target => @tags); if ($INC{"bareword/filehandles.pm"}) { bareword::filehandles->import } $class->_install_unexporter($unex); $IN_SCOPE = 1; } sub to_xml_string { map { # string == text -> HTML, scalarref == raw HTML, other == passthrough ref($_) ? (ref $_ eq 'SCALAR' ? $$_ : $_) : do { local $_ = $_; # copy if (defined) { s/&/&/g; s/"/"/g; s//>/g; $_; } else { '' } } } @_ } sub _find_tags { shift; @_ } sub _find_target { my ($class, $extra_levels, $opts) = @_; return $opts->{into} if defined($opts->{into}); my $level = ($opts->{into_level} || 1) + $extra_levels; return (caller($level))[0]; } sub _set_glob { # stupid insanity. delete anything already there so we disassociated # the *CORE::GLOBAL::glob typeglob. Then the string reference call # revivifies it - i.e. creates us a new glob, which we get a reference # to, which we can then assign to. # doing it without the quotes doesn't - it binds to the version in scope # at compile time, which means after a delete you get a nice warm segv. delete ${CORE::GLOBAL::}{glob}; no strict 'refs'; *{'CORE::GLOBAL::glob'} = $_[0]; } sub _export_tags_into { my ($class, $into, @tags) = @_; foreach my $tag (@tags) { no strict 'refs'; tie *{"${into}::${tag}"}, 'XML::Tags::TIEHANDLE', \"<${tag}>"; } _set_glob(sub { local $XML::Tags::StringThing::IN_GLOBBERY = 1; \('<'."$_[0]".'>'); }); overload::constant(q => sub { XML::Tags::StringThing->from_constant(@_) }); return sub { foreach my $tag (@tags) { no strict 'refs'; delete ${"${into}::"}{$tag} } _set_glob(\&File::Glob::csh_glob); overload::remove_constant('q'); $IN_SCOPE = 0; }; } sub _install_unexporter { my ($class, $unex) = @_; $^H |= 0x20000; # localize %^H $^H{'XML::Tags::Unex'} = bless($unex, 'XML::Tags::Unex'); } package XML::Tags::TIEHANDLE; sub TIEHANDLE { my $str = $_[1]; bless \$str, $_[0] } sub READLINE { ${$_[0]} } package XML::Tags::Unex; sub DESTROY { local $@; eval { $_[0]->(); 1 } || warn "ARGH: $@" } package XML::Tags::StringThing; use overload ( '.' => 'concat', '""' => 'stringify', fallback => 1 ); sub stringify { join( '', ((our $IN_GLOBBERY) ? XML::Tags::to_xml_string(@{$_[0]}) : (map +(ref $_ ? $$_ : $_), @{$_[0]}) ) ); } sub from_constant { my ($class, $initial, $parsed, $type) = @_; return $parsed unless $type eq 'qq'; return $class->new($parsed); } sub new { my ($class, $string) = @_; bless([ \$string ], $class); } sub concat { my ($self, $other, $rev) = @_; my @extra = do { if (ref($other) && ($other =~ /[a-z]=[A-Z]/) && $other->isa(__PACKAGE__)) { @{$other} } else { $other; } }; my @new = @{$self}; $rev ? unshift(@new, @extra) : push(@new, @extra); bless(\@new, ref($self)); } 1; Web-Simple-0.033/lib/Web/0000755000372100001440000000000013064012245014517 5ustar matthewtusersWeb-Simple-0.033/lib/Web/Dispatch.pm0000644000372100001440000001021313012655621016615 0ustar matthewtuserspackage Web::Dispatch; use Sub::Quote; use Scalar::Util qw(blessed); sub MAGIC_MIDDLEWARE_KEY { __PACKAGE__.'.middleware' } use Moo; use Web::Dispatch::Parser; use Web::Dispatch::Node; with 'Web::Dispatch::ToApp'; has dispatch_app => ( is => 'lazy', builder => sub { shift->dispatch_object->to_app } ); has dispatch_object => (is => 'ro', required => 0, weak_ref => 1); has parser_class => ( is => 'ro', default => quote_sub q{ 'Web::Dispatch::Parser' } ); has node_class => ( is => 'ro', default => quote_sub q{ 'Web::Dispatch::Node' } ); has _parser => (is => 'lazy'); after BUILDARGS => sub { my ( $self, %args ) = @_; die "Either dispatch_app or dispatch_object need to be supplied." if !$args{dispatch_app} and !$args{dispatch_object} }; sub _build__parser { my ($self) = @_; $self->parser_class->new; } sub call { my ($self, $env) = @_; my $res = $self->_dispatch($env, $self->dispatch_app); return $res->[0] if ref($res) eq 'ARRAY' and @{$res} == 1 and ref($res->[0]) eq 'CODE'; return $res; } sub _dispatch { my ($self, $env, @match) = @_; while (defined(my $try = shift @match)) { return $try if ref($try) eq 'ARRAY'; if (ref($try) eq 'HASH') { $env = { 'Web::Dispatch.original_env' => $env, %$env, %$try }; next; } my @result = $self->_to_try($try, \@match)->($env, @match); next unless @result and defined($result[0]); my $first = $result[0]; if (my $res = $self->_have_result($first, \@result, \@match, $env)) { return $res; } # make a copy so we don't screw with it assigning further up my $env = $env; unshift @match, sub { $self->_dispatch($env, @result) }; } return; } sub _have_result { my ($self, $first, $result, $match, $env) = @_; if (ref($first) eq 'ARRAY') { return $first; } elsif (blessed($first) && $first->isa('Plack::Middleware')) { return $self->_uplevel_middleware($first, $result); } elsif (ref($first) eq 'HASH' and $first->{+MAGIC_MIDDLEWARE_KEY}) { return $self->_redispatch_with_middleware($first, $match, $env); } elsif ( blessed($first) && not($first->can('to_app')) && not($first->isa('Web::Dispatch::Matcher')) ) { return $first; } return; } sub _uplevel_middleware { my ($self, $match, $results) = @_; die "Multiple results but first one is a middleware ($match)" if @{$results} > 1; # middleware needs to uplevel exactly once to wrap the rest of the # level it was created for - next elsif unwraps it return { MAGIC_MIDDLEWARE_KEY, $match }; } sub _redispatch_with_middleware { my ($self, $first, $match, $env) = @_; my $mw = $first->{+MAGIC_MIDDLEWARE_KEY}; $mw->app(sub { $self->_dispatch($_[0], @{$match}) }); return $mw->to_app->($env); } sub _to_try { my ($self, $try, $more) = @_; # sub () {} becomes a dispatcher # sub {} is a PSGI app and can be returned as is # '' => sub {} becomes a dispatcher # $obj isa WD:Predicates::Matcher => sub { ... } - become a dispatcher # $obj w/to_app method is a Plack::App-like thing - call it to get a PSGI app # if (ref($try) eq 'CODE') { if (defined(my $proto = prototype($try))) { $self->_construct_node(match => $proto, run => $try); } else { $try } } elsif (!ref($try) and (ref($more->[0]) eq 'CODE' or ($more->[0] and !ref($more->[0]) and $self->dispatch_object and $self->dispatch_object->can($more->[0]))) ) { $self->_construct_node(match => $try, run => shift(@$more)); } elsif ( (blessed($try) && $try->isa('Web::Dispatch::Matcher')) and (ref($more->[0]) eq 'CODE') ) { $self->_construct_node(match => $try, run => shift(@$more)); } elsif (blessed($try) && $try->can('to_app')) { $try->to_app; } else { die "No idea how we got here with $try"; } } sub _construct_node { my ($self, %args) = @_; $args{match} = $self->_parser->parse($args{match}) if !ref $args{match}; if ( my $obj = $self->dispatch_object) { # if possible, call dispatchers as methods of the app object my $dispatch_sub = $args{run}; $args{run} = sub { $obj->$dispatch_sub(@_) }; } $self->node_class->new(\%args)->to_app; } 1; Web-Simple-0.033/lib/Web/Simple.pm0000644000372100001440000006346513063546517016341 0ustar matthewtuserspackage Web::Simple; use strictures 1; use warnings::illegalproto (); use Moo (); use Web::Dispatch::Wrapper (); our $VERSION = '0.033'; sub import { my ($class, $app_package) = @_; $app_package ||= caller; $class->_export_into($app_package); eval "package $app_package; use Web::Dispatch::Wrapper; use Moo; 1" or die "Failed to setup app package: $@"; strictures->import; warnings::illegalproto->unimport; } sub _export_into { my ($class, $app_package) = @_; { no strict 'refs'; *{"${app_package}::PSGI_ENV"} = sub () { -1 }; require Web::Simple::Application; unshift(@{"${app_package}::ISA"}, 'Web::Simple::Application'); } (my $name = $app_package) =~ s/::/\//g; $INC{"${name}.pm"} = 'Set by "use Web::Simple;" invocation'; } 1; =head1 NAME Web::Simple - A quick and easy way to build simple web applications =head1 SYNOPSIS #!/usr/bin/env perl package HelloWorld; use Web::Simple; sub dispatch_request { GET => sub { [ 200, [ 'Content-type', 'text/plain' ], [ 'Hello world!' ] ] }, '' => sub { [ 405, [ 'Content-type', 'text/plain' ], [ 'Method not allowed' ] ] } } HelloWorld->run_if_script; If you save this file into your cgi-bin as C and then visit: http://my.server.name/cgi-bin/hello-world.cgi/ you'll get the "Hello world!" string output to your browser. At the same time this file will also act as a class module, so you can save it as HelloWorld.pm and use it as-is in test scripts or other deployment mechanisms. Note that you should retain the ->run_if_script even if your app is a module, since this additionally makes it valid as a .psgi file, which can be extremely useful during development. For more complex examples and non-CGI deployment, see L. To get help with L, please connect to the irc.perl.org IRC network and join #web-simple. =head1 DESCRIPTION The philosophy of L is to keep to an absolute bare minimum for everything. It is not designed to be used for large scale applications; the L web framework already works very nicely for that and is a far more mature, well supported piece of software. However, if you have an application that only does a couple of things, and want to not have to think about complexities of deployment, then L might be just the thing for you. The only public interface the L module itself provides is an C based one: use Web::Simple 'NameOfApplication'; This sets up your package (in this case "NameOfApplication" is your package) so that it inherits from L and imports L, as well as installs a C constant for convenience, as well as some other subroutines. Importing L will automatically make your code use the C and C pragma, so you can skip the usual: use strict; use warnings FATAL => 'all'; provided you 'use Web::Simple' at the top of the file. Note that we turn on *fatal* warnings so if you have any warnings at any point from the file that you did 'use Web::Simple' in, then your application will die. This is, so far, considered a feature. When we inherit from L we also use L, which is the the equivalent of: { package NameOfApplication; use Moo; extends 'Web::Simple::Application'; } So you can use L features in your application, such as creating attributes using the C subroutine, etc. Please see the documentation for L for more information. It also exports the following subroutines for use in dispatchers: response_filter { ... }; redispatch_to '/somewhere'; Finally, import sets $INC{"NameOfApplication.pm"} = 'Set by "use Web::Simple;" invocation'; so that perl will not attempt to load the application again even if require NameOfApplication; is encountered in other code. One important thing to remember when using NameOfApplication->run_if_script; At the end of your app is that this call will create an instance of your app for you automatically, regardless of context. An easier way to think of this would be if the method were more verbosely named NameOfApplication->run_request_if_script_else_turn_coderef_for_psgi; =head1 DISPATCH STRATEGY L despite being straightforward to use, has a powerful system for matching all sorts of incoming URLs to one or more subroutines. These subroutines can be simple actions to take for a given URL, or something more complicated, including entire L applications, L and nested subdispatchers. =head2 Examples sub dispatch_request { ( # matches: GET /user/1.htm?show_details=1 # GET /user/1.htm 'GET + /user/* + ?show_details~ + .htm|.html|.xhtml' => sub { my ($self, $user_id, $show_details) = @_; ... }, # matches: POST /user?username=frew # POST /user?username=mst&first_name=matt&last_name=trout 'POST + /user + ?username=&*' => sub { my ($self, $username, $misc_params) = @_; ... }, # matches: DELETE /user/1/friend/2 'DELETE + /user/*/friend/*' => sub { my ($self, $user_id, $friend_id) = @_; ... }, # matches: PUT /user/1?first_name=Matt&last_name=Trout 'PUT + /user/* + ?first_name~&last_name~' => sub { my ($self, $user_id, $first_name, $last_name) = @_; ... }, '/user/*/...' => sub { my $user_id = $_[1]; ( # matches: PUT /user/1/role/1 'PUT + /role/*' => sub { my $role_id = $_[1]; ... }, # matches: DELETE /user/1/role/1 'DELETE + /role/*' => sub { my $role_id = $_[1]; ... }, ); }, ); } =head2 The dispatch cycle At the beginning of a request, your app's dispatch_request method is called with the PSGI $env as an argument. You can handle the request entirely in here and return a PSGI response arrayref if you want: sub dispatch_request { my ($self, $env) = @_; [ 404, [ 'Content-type' => 'text/plain' ], [ 'Amnesia == fail' ] ] } However, generally, instead of that, you return a set of route/target pairs: sub dispatch_request { my $self = shift; ( '/' => sub { redispatch_to '/index.html' }, '/user/*' => sub { $self->show_user($_[1]) }, 'POST + %*' => 'handle_post', ... ); } Well, a sub is a valid PSGI response too (for ultimate streaming and async cleverness). If you want to return a PSGI sub you have to wrap it into an array ref. sub dispatch_request { [ sub { my $respond = shift; # This is pure PSGI here, so read perldoc PSGI } ] } If you return a string followed by a subroutine or method name, the string is treated as a match specification - and if the test is passed, the subroutine is called as a method and passed any matched arguments (see below for more details). You can also return a plain subroutine which will be called with just C<$env> - remember that in this case if you need C<$self> you B close over it. If you return a normal object, L will simply return it upwards on the assumption that a response_filter (or some arbitrary L) somewhere will convert it to something useful. This allows: sub dispatch_request { my $self = shift; ( '.html' => sub { response_filter { $self->render_zoom($_[0]) } }, '/user/*' => sub { $self->users->get($_[1]) }, ); } An alternative to using string + suborutine to declare a route is to use the sub prototype - sub dispatch_request { my $self = shift; ( sub (.html) { response_filter { $self->render_zoom($_[0]) } }, sub (/user/) { $self->users->get($_[1]) }, $self->can('handle_post'), # if declared as 'sub handle_post (...) {' ) } This can be useful sugar, especially if you want to keep method-based dispatchers' route specifications on the methods. to render a user object to HTML, if there is an incoming URL such as: http://myweb.org/user/111.html This works because as we descend down the dispachers, we first match C, which adds a C (basically a specialized routine that follows the L specification), and then later we also match C which gets a user and returns that as the response. This user object 'bubbles up' through all the wrapping middleware until it hits the C we defined, after which the return is converted to a true html response. However, two types of objects are treated specially - a C object will have its C method called and be used as a dispatcher: sub dispatch_request { my $self = shift; ( '/static/...' => sub { Plack::App::File->new(...) }, ... ); } A L object will be used as a filter for the rest of the dispatch being returned into: ## responds to /admin/track_usage AND /admin/delete_accounts sub dispatch_request { my $self = shift; ( '/admin/**' => sub { Plack::Middleware::Session->new(%opts); }, '/admin/track_usage' => sub { ## something that needs a session }, '/admin/delete_accounts' => sub { ## something else that needs a session }, ); } Note that this is for the dispatch being B to, so if you want to provide it inline you need to do: ## ALSO responds to /admin/track_usage AND /admin/delete_accounts sub dispatch_request { my $self = shift; ( '/admin/...' => sub { ( sub { Plack::Middleware::Session->new(%opts); }, '/track_usage' => sub { ## something that needs a session }, '/delete_accounts' => sub { ## something else that needs a session }, ); } ); } And that's it - but remember that all this happens recursively - it's dispatchers all the way down. A URL incoming pattern will run all matching dispatchers and then hit all added filters or L. =head2 Web::Simple match specifications =head3 Method matches 'GET' => sub { A match specification beginning with a capital letter matches HTTP requests with that request method. =head3 Path matches '/login' => sub { A match specification beginning with a / is a path match. In the simplest case it matches a specific path. To match a path with a wildcard part, you can do: '/user/*' => sub { $self->handle_user($_[1]) This will match /user/ where does not include a literal / character. The matched part becomes part of the match arguments. You can also match more than one part: '/user/*/*' => sub { my ($self, $user_1, $user_2) = @_; '/domain/*/user/*' => sub { my ($self, $domain, $user) = @_; and so on. To match an arbitrary number of parts, use C<**>: '/page/**' => sub { my ($self, $match) = @_; This will result in a single element for the entire match. Note that you can do '/page/**/edit' => sub { to match an arbitrary number of parts up to but not including some final part. Note: Since Web::Simple handles a concept of file extensions, C<*> and C<**> matchers will not by default match things after a final dot, and this can be modified by using C<*.*> and C<**.*> in the final position, e.g.: /one/* matches /one/two.three and captures "two" /one/*.* matches /one/two.three and captures "two.three" /** matches /one/two.three and captures "one/two" /**.* matches /one/two.three and captures "one/two.three" Finally, '/foo/...' => sub { Will match C on the beginning of the path B strip it. This is designed to be used to construct nested dispatch structures, but can also prove useful for having e.g. an optional language specification at the start of a path. Note that the '...' is a "maybe something here, maybe not" so the above specification will match like this: /foo # no match /foo/ # match and strip path to '/' /foo/bar/baz # match and strip path to '/bar/baz' Almost the same, '/foo...' => sub { Will match on C, but also include C. Otherwise it operates the same way as C. /foo # match and strip path to '' /foo/ # match and strip path to '/' /foo/bar/baz # match and strip path to '/bar/baz' Please note the difference between C and C. In the first case, this is expecting to find something after C (and fails to match if nothing is found), while in the second case we can match both C and C. The following are roughly the same: '/foo' => sub { 'I match /foo' }, '/foo/...' => sub { ( '/bar' => sub { 'I match /foo/bar' }, '/*' => sub { 'I match /foo/{id}' }, ); } Versus '/foo...' => sub { ( '~' => sub { 'I match /foo' }, '/bar' => sub { 'I match /foo/bar' }, '/*' => sub { 'I match /foo/{id}' }, ); } You may prefer the latter example should you wish to take advantage of subdispatchers to scope common activities. For example: '/user...' => sub { my $user_rs = $schema->resultset('User'); ( '~' => sub { $user_rs }, '/*' => sub { $user_rs->find($_[1]) }, ); } You should note the special case path match C which is only meaningful when it is contained in this type of path match. It matches to an empty path. =head4 Naming your patch matches Any C<*>, C<**>, C<*.*>, or C<**.*> match can be followed with C<:name> to make it into a named match, so: '/*:one/*:two/*:three/*:four' => sub { "I match /1/2/3/4 capturing { one => 1, two => 2, three => 3, four => 4 }" } '/**.*:allofit' => sub { "I match anything capturing { allofit => \$whole_path }" } In the specific case of a simple single-* match, the * may be omitted, to allow you to write: '/:one/:two/:three/:four' => sub { "I match /1/2/3/4 capturing { one => 1, two => 2, three => 3, four => 4 }" } =head4 C and C are different specs As you may have noticed with the difference between C<'/foo/...'> and C<'/foo...'>, trailing slashes in path specs are significant. This is intentional and necessary to retain the ability to use relative links on websites. Let's demonstrate on this link: bar If the user loads the url C and clicks on this link, they will be sent to C. However when they are on the url C and click this link, then they will be sent to C. This makes it necessary to be explicit about the trailing slash. =head3 Extension matches '.html' => sub { will match .html from the path (assuming the subroutine itself returns something, of course). This is normally used for rendering - e.g.: '.html' => sub { response_filter { $self->render_html($_[1]) } } Additionally, '.*' => sub { will match any extension and supplies the extension as a match argument. =head3 Query and body parameter matches Query and body parameters can be match via '?' => sub { # match URI query '%' => sub { # match body params The body spec will match if the request content is either application/x-www-form-urlencoded or multipart/form-data - the latter of which is required for uploads - see below. The param spec is elements of one of the following forms: param~ # optional parameter param= # required parameter @param~ # optional multiple parameter @param= # required multiple parameter :param~ # optional parameter in hashref :param= # required parameter in hashref :@param~ # optional multiple in hashref :@param= # required multiple in hashref * # include all other parameters in hashref @* # include all other parameters as multiple in hashref separated by the C<&> character. The arguments added to the request are one per non-C<:>/C<*> parameter (scalar for normal, arrayref for multiple), plus if any C<:>/C<*> specs exist a hashref containing those values. If a parameter has no value, i.e. appears as '?foo&', a value of 1 will be captured. Please note that if you specify a multiple type parameter match, you are ensured of getting an arrayref for the value, EVEN if the current incoming request has only one value. However if a parameter is specified as single and multiple values are found, the last one will be used. For example to match a C parameter with an optional C parameter one would write: '?page=&order_by~' => sub { my ($self, $page, $order_by) = @_; return unless $page =~ /^\d+$/; $order_by ||= 'id'; response_filter { $_[1]->search_rs({}, { page => $page, order_by => $order_by }); } } to implement paging and ordering against a L object. Another Example: To get all parameters as a hashref of arrayrefs, write: '?@*' => sub { my ($self, $params) = @_; ... To get two parameters as a hashref, write: '?:user~&:domain~' => sub { my ($self, $params) = @_; # params contains only 'user' and 'domain' keys You can also mix these, so: '?foo=&@bar~&:coffee=&@*' => sub { my ($self, $foo, $bar, $params) = @_; where $bar is an arrayref (possibly an empty one), and $params contains arrayref values for all parameters B mentioned and a scalar value for the 'coffee' parameter. Note, in the case where you combine arrayref, single parameter and named hashref style, the arrayref and single parameters will appear in C<@_> in the order you defined them in the prototype, but all hashrefs will merge into a single C<$params>, as in the example above. =head3 Upload matches '*foo=' => sub { # 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 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 object, which will C 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 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. 'GET + /user/*' => sub { to create an AND match. They may also be combined with the | character - e.g. 'GET|POST' => sub { to create an OR match. Matches can be nested with () - e.g. '(GET|POST + /user/*)' => sub { and negated with ! - e.g. '!/user/foo + /user/*' => sub { ! binds to the immediate rightmost match specification, so if you want to negate a combination you will need to use '!(POST|PUT|DELETE)' => sub { and | binds tighter than +, so '(GET|POST) + /user/*' => sub { and 'GET|POST + /user/*' => sub { are equivalent, but '(GET + /admin/...) | (POST + /admin/...)' => sub { and 'GET + /admin/... | POST + /admin/...' => sub { are not - the latter is equivalent to 'GET + (/admin/...|POST) + /admin/...' => sub { which will never match! =head3 Whitespace Note that for legibility you are permitted to use whitespace: 'GET + /user/*' => sub { but it will be ignored. This is because the perl parser strips whitespace from subroutine prototypes, so this is equivalent to 'GET+/user/*' => sub { =head3 Accessing parameters via C<%_> If your dispatch specification causes your dispatch subroutine to receive a hash reference as its first argument, the contained named parameters will be accessible via C<%_>. This can be used to access your path matches, if they are named: 'GET + /foo/:path_part' => sub { [ 200, ['Content-type' => 'text/plain'], ["We are in $_{path_part}"], ]; } Or, if your first argument would be a hash reference containing named query parameters: 'GET + /foo + ?:some_param=' => sub { [ 200, ['Content-type' => 'text/plain'], ["We received $_{some_param} as parameter"], ]; } Of course this also works when all you are doing is slurping the whole set of parameters by their name: 'GET + /foo + ?*' => sub { [ 200, ['Content-type' => 'text/plain'], [exists($_{foo}) ? "Received a foo: $_{foo}" : "No foo!"], ], } Note that only the first hash reference will be available via C<%_>. If you receive additional hash references, you will need to access them as usual. =head3 Accessing the PSGI env hash In some cases you may wish to get the raw PSGI env hash - to do this, you can either use a plain sub: sub { my ($env) = @_; ... } or use the C constant exported to retrieve it from C<@_>: 'GET + /foo + ?some_param=' => sub { my $param = $_[1]; my $env = $_[PSGI_ENV]; } but note that if you're trying to add a middleware, you should simply use Web::Simple's direct support for doing so. =head1 EXPORTED SUBROUTINES =head2 response_filter response_filter { # Hide errors from the user because we hates them, preciousss if (ref($_[0]) eq 'ARRAY' && $_[0]->[0] == 500) { $_[0] = [ 200, @{$_[0]}[1..$#{$_[0]}] ]; } return $_[0]; }; The response_filter subroutine is designed for use inside dispatch subroutines. It creates and returns a special dispatcher that always matches, and calls the block passed to it as a filter on the result of running the rest of the current dispatch chain. Thus the filter above runs further dispatch as normal, but if the result of dispatch is a 500 (Internal Server Error) response, changes this to a 200 (OK) response without altering the headers or body. =head2 redispatch_to redispatch_to '/other/url'; The redispatch_to subroutine is designed for use inside dispatch subroutines. It creates and returns a special dispatcher that always matches, and instead of continuing dispatch re-delegates it to the start of the dispatch process, but with the path of the request altered to the supplied URL. Thus if you receive a POST to C and return a redispatch to C, the dispatch behaviour will be exactly as if the same POST request had been made to C instead. Note, this is not the same as returning an HTTP 3xx redirect as a response; rather it is a much more efficient internal process. =head1 CHANGES BETWEEN RELEASES =head2 Changes between 0.004 and 0.005 =over 4 =item * dispatch {} replaced by declaring a dispatch_request method dispatch {} has gone away - instead, you write: sub dispatch_request { my $self = shift; ( 'GET /foo/' => sub { ... }, ... ); } Note that this method is still B the dispatch code - just like C did. Also note that you need the C<< my $self = shift >> since the magic $self variable went away. =item * the magic $self variable went away. Just add C<< my $self = shift; >> while writing your C<< sub dispatch_request { >> like a normal perl method. =item * subdispatch deleted - all dispatchers can now subdispatch In earlier releases you needed to write: subdispatch sub (/foo/...) { ... [ sub (GET /bar/) { ... }, ... ] } As of 0.005, you can instead write simply: sub (/foo/...) { ... ( sub (GET /bar/) { ... }, ... ) } =back =head2 Changes since Antiquated Perl =over 4 =item * filter_response renamed to response_filter This is a pure rename; a global search and replace should fix it. =item * dispatch [] changed to dispatch {} Simply changing dispatch [ sub(...) { ... }, ... ]; to dispatch { sub(...) { ... }, ... }; should work fine. =back =head1 DEVELOPMENT HISTORY Web::Simple was originally written to form part of my Antiquated Perl talk for Italian Perl Workshop 2009, but in writing the bloggery example I realised that having a bare minimum system for writing web applications that doesn't drive me insane was rather nice and decided to spend my attempt at nanowrimo for 2009 improving and documenting it to the point where others could use it. The Antiquated Perl talk can be found at L and the slides are reproduced in this distribution under L. =head1 COMMUNITY AND SUPPORT =head2 IRC channel irc.perl.org #web-simple =head2 No mailing list yet Because mst's non-work email is a bombsite so he'd never read it anyway. =head2 Git repository Gitweb is on http://git.shadowcat.co.uk/ and the clone URL is: git clone git://git.shadowcat.co.uk/catagits/Web-Simple.git =head1 AUTHOR Matt S. Trout (mst) =head1 CONTRIBUTORS Devin Austin (dhoss) Arthur Axel 'fREW' Schmidt gregor herrmann (gregoa) John Napiorkowski (jnap) Josh McMichael Justin Hunter (arcanez) Kjetil Kjernsmo markie Christian Walde (Mithaldu) nperez Robin Edwards Andrew Rodland (hobbs) Robert Sedlacek (phaylon) Hakim Cassimally (osfameron) Karen Etheridge (ether) =head1 COPYRIGHT Copyright (c) 2011 the Web::Simple L and L as listed above. =head1 LICENSE This library is free software and may be distributed under the same terms as perl itself. =cut Web-Simple-0.033/lib/Web/Simple/0000755000372100001440000000000013064012245015750 5ustar matthewtusersWeb-Simple-0.033/lib/Web/Simple/Application.pm0000644000372100001440000002451113012655624020563 0ustar matthewtuserspackage Web::Simple::Application; use Scalar::Util 'weaken'; use Moo; has 'config' => ( is => 'ro', default => sub { my ($self) = @_; +{ $self->default_config } }, trigger => sub { my ($self, $value) = @_; my %default = $self->default_config; my @not = grep !exists $value->{$_}, keys %default; @{$value}{@not} = @default{@not}; } ); sub default_config { () } has '_dispatcher' => (is => 'lazy'); sub _build__dispatcher { my $self = shift; require Web::Dispatch; my $final = $self->_build_final_dispatcher; # We need to weaken both the copy of $self that the # app parameter will close over and the copy that'll # be passed through as a node argument. # # To ensure that this doesn't then result in us being # DESTROYed unexpectedly early, our to_psgi_app method # closes back over $self weaken($self); my %dispatch_args = ( dispatch_app => sub { $self->dispatch_request(@_), $final }, dispatch_object => $self ); weaken($dispatch_args{dispatch_object}); Web::Dispatch->new(%dispatch_args); } sub _build_final_dispatcher { [ 404, [ 'Content-type', 'text/plain' ], [ 'Not found' ] ] } sub run_if_script { # ->to_psgi_app is true for require() but also works for plackup return $_[0]->to_psgi_app if caller(1); my $self = ref($_[0]) ? $_[0] : $_[0]->new; $self->run(@_); } sub _run_cgi { my $self = shift; require Plack::Handler::CGI; Plack::Handler::CGI->new->run($self->to_psgi_app); } sub _run_fcgi { my $self = shift; require Plack::Handler::FCGI; Plack::Handler::FCGI->new->run($self->to_psgi_app); } sub to_psgi_app { my $self = ref($_[0]) ? $_[0] : $_[0]->new; my $app = $self->_dispatcher->to_app; # Close over $self to keep $self alive even though # we weakened the copies the dispatcher has; the # if 0 causes the ops to be optimised away to # minimise the performance impact and avoid void # context warnings while still doing the closing # over part. As Mithaldu said: "Gnarly." ... return sub { $self if 0; goto &$app; }; } sub run { my $self = shift; if ( $ENV{PHP_FCGI_CHILDREN} || $ENV{FCGI_ROLE} || $ENV{FCGI_SOCKET_PATH} || ( -S STDIN && !$ENV{GATEWAY_INTERFACE} ) # If STDIN is a socket, almost certainly FastCGI, except for mod_cgid ) { return $self->_run_fcgi; } elsif ($ENV{GATEWAY_INTERFACE}) { return $self->_run_cgi; } unless (@ARGV && $ARGV[0] =~ m{(^[A-Z/])|\@}) { return $self->_run_cli(@ARGV); } my @args = @ARGV; unshift(@args, 'GET') if $args[0] !~ /^[A-Z]/; $self->_run_cli_test_request(@args); } sub _test_request_spec_to_http_request { my ($self, $method, $path, @rest) = @_; # if it's a reference, assume a request object return $method if ref($method); if ($path =~ s/^(.*?)\@//) { my $basic = $1; require MIME::Base64; unshift @rest, 'Authorization:', 'Basic '.MIME::Base64::encode($basic); } my $request = HTTP::Request->new($method => $path); my @params; while (my ($header, $value) = splice(@rest, 0, 2)) { unless ($header =~ s/:$//) { push @params, $header, $value; } $header =~ s/_/-/g; if ($header eq 'Content') { $request->content($value); } else { $request->headers->push_header($header, $value); } } if (($method eq 'POST' or $method eq 'PUT') and @params) { my $content = do { require URI; my $url = URI->new('http:'); $url->query_form(@params); $url->query; }; $request->header('Content-Type' => 'application/x-www-form-urlencoded'); $request->header('Content-Length' => length($content)); $request->content($content); } return $request; } sub run_test_request { my ($self, @req) = @_; require HTTP::Request; require Plack::Test; my $request = $self->_test_request_spec_to_http_request(@req); Plack::Test::test_psgi( $self->to_psgi_app, sub { shift->($request) } ); } sub _run_cli_test_request { my ($self, @req) = @_; my $response = $self->run_test_request(@req); binmode(STDOUT); binmode(STDERR); # for win32 print STDERR $response->status_line."\n"; print STDERR $response->headers_as_string("\n")."\n"; my $content = $response->content; $content .= "\n" if length($content) and $content !~ /\n\z/; print STDOUT $content if $content; } sub _run_cli { my $self = shift; die $self->_cli_usage; } sub _cli_usage { "To run this script in CGI test mode, pass a URL path beginning with /:\n". "\n". " $0 /some/path\n". " $0 /\n" } 1; =head1 NAME Web::Simple::Application - A base class for your Web-Simple application =head1 DESCRIPTION This is a base class for your L application. You probably don't need to construct this class yourself, since L does the 'heavy lifting' for you in that regards. =head1 METHODS This class exposes the following public methods. =head2 default_config Merges with the C initializer to provide configuration information for your application. For example: sub default_config { ( title => 'Bloggery', posts_dir => $FindBin::Bin.'/posts', ); } Now, the C attribute of C<$self> will be set to a HashRef containing keys 'title' and 'posts_dir'. The keys from default_config are merged into any config supplied, so if you construct your application like: MyWebSimpleApp::Web->new( config => { title => 'Spoon', environment => 'dev' } ) then C will contain: { title => 'Spoon', posts_dir => '/path/to/myapp/posts', environment => 'dev' } =head2 run_if_script The run_if_script method is designed to be used at the end of the script or .pm file where your application class is defined - for example: ## my_web_simple_app.pl #!/usr/bin/env perl use Web::Simple 'HelloWorld'; { package HelloWorld; sub dispatch_request { sub (GET) { [ 200, [ 'Content-type', 'text/plain' ], [ 'Hello world!' ] ] }, sub () { [ 405, [ 'Content-type', 'text/plain' ], [ 'Method not allowed' ] ] } } } HelloWorld->run_if_script; This returns a true value, so your file is now valid as a module - so require 'my_web_simple_app.pl'; my $hw = HelloWorld->new; will work fine (and you can rename it to lib/HelloWorld.pm later to make it a real use-able module). However, it detects if it's being run as a script (via testing $0) and if so attempts to do the right thing. If run under a CGI environment, your application will execute as a CGI. If run under a FastCGI environment, your application will execute as a FastCGI process (this works both for dynamic shared-hosting-style FastCGI and for apache FastCgiServer style setups). If run from the commandline with a URL path, it runs a GET request against that path - $ perl -Ilib examples/hello-world/hello-world.cgi / 200 OK Content-Type: text/plain Hello world! You can also provide a method name - $ perl -Ilib examples/hello-world/hello-world.cgi POST / 405 Method Not Allowed Content-Type: text/plain Method not allowed For a POST or PUT request, pairs on the command line will be treated as form variables. For any request, pairs on the command line ending in : are treated as headers, and 'Content:' will set the request body - $ ./myapp POST / Accept: text/html form_field_name form_field_value $ ./myapp POST / Content-Type: text/json Content: '{ "json": "here" }' The body of the response is sent to STDOUT and the headers to STDERR, so $ ./myapp GET / >index.html will generally do the right thing. To send basic authentication credentials, use user:pass@ syntax - $ ./myapp GET bob:secret@/protected/path Additionally, you can treat the file as though it were a standard PSGI application file (*.psgi). For example you can start up up with C plackup my_web_simple_app.pl or C starman my_web_simple_app.pl =head2 to_psgi_app This method is called by L to create the L app coderef for use via L and L. If you want to globally add middleware, you can override this method: use Web::Simple 'HelloWorld'; { package HelloWorld; use Plack::Builder; around 'to_psgi_app', sub { my ($orig, $self) = (shift, shift); my $app = $self->$orig(@_); builder { enable ...; ## whatever middleware you want $app; }; }; } This method can also be used to mount a Web::Simple application within a separate C<*.psgi> file - use strictures 1; use Plack::Builder; use WSApp; use AnotherWSApp; builder { mount '/' => WSApp->to_psgi_app; mount '/another' => AnotherWSApp->to_psgi_app; }; This method can be called as a class method, in which case it implicitly calls ->new, or as an object method ... in which case it doesn't. =head2 run Used for running your application under stand-alone CGI and FCGI modes. I should document this more extensively but run_if_script will call it when you need it, so don't worry about it too much. =head2 run_test_request my $res = $app->run_test_request(GET => '/' => %headers); my $res = $app->run_test_request(POST => '/' => %headers_or_form); my $res = $app->run_test_request($http_request); Accepts either an L object or ($method, $path) and runs that request against the application, returning an L object. If the HTTP method is POST or PUT, then a series of pairs can be passed after this to create a form style message body. If you need to test an upload, then create an L object by hand or use the C subroutine provided by L. If you prefix the URL with 'user:pass@' this will be converted into an Authorization header for HTTP basic auth: my $res = $app->run_test_request( GET => 'bob:secret@/protected/resource' ); If pairs are passed where the key ends in :, it is instead treated as a headers, so: my $res = $app->run_test_request( POST => '/', 'Accept:' => 'text/html', some_form_key => 'value' ); will do what you expect. You can also pass a special key of Content: to set the request body: my $res = $app->run_test_request( POST => '/', 'Content-Type:' => 'text/json', 'Content:' => '{ "json": "here" }', ); =head1 AUTHORS See L for authors. =head1 COPYRIGHT AND LICENSE See L for the copyright and license. =cut Web-Simple-0.033/lib/Web/Simple/Role.pm0000644000372100001440000000167113063546661017231 0ustar matthewtuserspackage Web::Simple::Role; use strictures 1; use warnings::illegalproto (); use Moo::Role (); our $VERSION = '0.033'; sub import { my ($class, $app_package) = @_; $app_package ||= caller; eval "package $app_package; use Web::Dispatch::Wrapper; use Moo::Role; 1" or die "Failed to setup app package: $@"; strictures->import; warnings::illegalproto->unimport; } 1; __END__ =head1 NAME Web::Simple::Role - Define roles for Web::Simple applications =head1 SYNOPSIS package MyApp; use Web::Simple; with MyApp::Role; sub dispatch_request { ... } and in the role: package MyApp::Role; use Web::Simple::Role; around dispatch_request => sub { my ($orig, $self) = @_; return ( $self->$orig, sub (GET + /baz) { ... } ); }; Now C can also dispatch C =head1 AUTHORS See L for authors. =head1 COPYRIGHT AND LICENSE See L for the copyright and license. =cut Web-Simple-0.033/lib/Web/Simple/AntiquatedPerl.pod0000644000372100001440000001423411752040732021406 0ustar matthewtusers=head1 NAME Web::Simple::AntiquatedPerl - the slides from the talk =head1 WHAT? Web::Simple was originally introduced in a talk at the Italian Perl Workshop, entitled Antiquated Perl. The video is available on the Shadowcat site: If you don't particularly want to watch me confusing a bunch of Italian perl mongers, the slides are reproduced below. =head1 SLIDES Antiquated Perl ---- Modern Perl? ---- Post Modern Perl ---- Enlightened Perl ---- everybody knows ---- Catalyst Moose DBIx::Class ---- Modern Perl? ---- perl5 v10 ---- given ($x) { when (3) { ... ---- ~~ ---- what's the opposite? ---- Old Perl? ---- if it works ---- Legacy Perl? ---- not interesting ---- Stupid Perl ---- *$&^*(^ FormMail.PL ---- Antiquated Perl ---- Antique ---- Old *and* beautiful ---- Simple Elegant ---- $|++ ---- use IO::Handle; STDOUT->autoflush(1); ---- it's core. it's fine. ---- but why think? ---- select((select(FOO),$|++)[0]) ---- (select(FOO),$|++) -> ($old_selected_fh,$|) ---- (select(FOO),$|++)[0] -> $old_select_fh ---- select((select(FOO),$|++)[0]) -> use IO::Handle; FOO->autoflush(1) ---- ~~ ---- ~~@x ---- ~(~(@x)) ---- bitwise negation ---- so ... ---- ~@x -> ~(scalar @x) ---- ~~$number -> $number ---- ~~@x -> scalar @x ---- perl -MMoose -e'print ~~keys %INC' 84 ---- overload::constant ---- lets you affect parsing ---- numbers strings ---- q qq qr t s qw ---- i18n.pm ---- ~~"$foo bar" loc("_[0] bar", $foo) ---- for ---- for ($foo) { /bar/ and ... ---- for ($foo) { /bar/ and return do { } ---- /foo/gc ---- /\Gbar/gc ---- sub parse { my ($self, $str) = @_; for ($str) { /match1/gc and return $self->_subparse_1($_) ---- sub _subparse_1 { my ($self) = @_; for ($_[1]) { /\Gsubmatch1/gc ... ---- prototypes ---- sub foo (&) { ---- foo { ... }; ---- prototype \&foo ---- typeglobs ---- *{"${package}::${name}"} = sub { ... } ---- local ---- local $_ ---- local *Carp::croak = \&Carp::confess; ---- do { local (@ARGV, $/) = $file; <> } ---- strict and warnings ---- strict->import ---- affects compilation scope ---- sub strict_and_warnings::import { strict->import; warnings->import; } ---- use strict_and_warnings; ---- $^H %^H ---- $^H |= 0x20000; $^H{'foo'} = bless($foo, 'My::Foo'); ---- sub My::Foo::DESTROY { ---- delete ${$package}{myimport} ---- B::Hooks::EndOfScope ---- tie ---- tie $var, 'Foo'; ---- sub FETCH sub STORE ---- Scalar Array Hash Handle ---- now ... ---- mst: destruction testing technology since March 1983 ---- 3 days old ---- 2 weeks early ---- incubator ---- glass box plastic tray heater ---- design flaw ---- BANG ---- so ... ---- interesting fact ---- prototypes only warn when parsed ---- error when compiled ---- so ... ---- dispatch [ sub (GET + /) { ... }, sub (GET + /user/*) { ... } ]; ---- foreach my $sub (@$dispatch) { my $proto = prototype $sub; $parser->parse($proto); ... ---- PARSE: { do { push @match, $self->_parse_spec_section($spec) or $self->_blam("Unable to work out what the next section is"); last PARSE if (pos == length); /\G\+/gc or $self->_blam('Spec sections must be separated by +'); } until (pos == length) }; ---- sub _blam { my ($self, $error) = @_; my $hat = (' ' x pos).'^'; die "Error parsing dispatch specification: ${error}\n ${_} ${hat} here\n"; } ---- Error parsing ... GET+/foo ^ here ---- sub (GET + /user/*) { my ($self, $user) = @_; ---- I hate fetching $self ---- *{"${app}::self"} = \${"${app}::self"}; ---- use vars ---- sub _run_with_self { my ($self, $run, @args) = @_; my $class = ref($self); no strict 'refs'; local *{"${class}::self"} = \$self; $self->$run(@args); } ---- HTML output ---- templates ---- HTML is NOT TEXT ----
, $text,
; ----
---- <$fh> ---- tie *{"${app}::${name}"}, 'XML::Tags::TIEHANDLE', "<${name}>"; ---- sub TIEHANDLE { my $str = $_[1]; bless \$str, $_[0] } sub READLINE { ${$_[0]} } ---- sub DESTROY { my ($into, @names) = @$_[0]; no strict 'refs'; delete ${$into}{$_} for @names; } ----
---- glob('/div'); ---- *CORE::GLOBAL::glob = sub { ... }; ---- delete ${CORE::GLOBAL::}{glob}; ---- sub foo { use XML::Tags qw(div);
, "foo!",
; } ---- what about interpolation ---- my $stuff = 'foo"bar'; ---- hmm ... ---- overload::constant! ---- glob('a href="'.$stuff.'"'); ---- glob( bless(\'a href="', 'MagicTag') .$stuff .bless(\'"', 'MagicTag') ) ---- use overload '.' => 'concat'; sub concat { ---- hooking it up ---- sub (.html) { filter_response { $self->render_html($_[1]) } } ---- bless( $_[1], 'Web::Simple::ResponseFilter' ); ---- if ($self->_is_response_filter($result)) { return $self->_run_with_self( $result, $self->_run_dispatch_for($new_env, \@disp) ); } ---- and the result? ---- goto &demo; ---- questions? ---- thank you =head1 AUTHOR Matt S. Trout =head1 COPYRIGHT Copyright (c) 2011 Matt S. Trout =head1 LICENSE This text is free documentation under the same license as perl itself. =cut Web-Simple-0.033/lib/Web/Simple/Deployment.pod0000644000372100001440000000336511752040732020607 0ustar matthewtusers=head1 NAME Web::Simple::Deployment - various deployment options =head1 DESCRIPTION This file documents common deployment methods for Web::Simple. If you feel one is missing, please ask in the IRC channel and we'll work with you to add it. =head1 CGI The most basic deployment option is as a CGI script loading and running your Web::Simple-module: #!/usr/bin/env perl use Your::Web::Simple::App; Your::Web::Simple::App->run_if_script; Save that as script.cgi and your web server will handle it correctly. =head1 Plack-Server This works in with exactly the same code as CGI deployment. However instead of letting your web server load script.cgi, you run this on the command line: plackup script.cgi =head2 Self-contained CGI Sometimes your app is so small that you have only one or two tiny classes that you want to run as a CGI script. Web::Simple offers a helpful mechanism to achieve that. #!/usr/bin/env perl use Web::Simple 'HelloWorld'; # enables strictures and warnings for the file # additionally, HelloWorld is upgraded to a # Web::Simple application { package HelloWorld; sub dispatch_request { sub (GET) { [ 200, [ 'Content-type', 'text/plain' ], [ 'Hello world! It is a fine ' . HelloWorld::Helper->day ] ] }, sub () { [ 405, [ 'Content-type', 'text/plain' ], [ 'Method not allowed' ] ] } } } { package HelloWorld::Helper; use DateTime; sub day { return DateTime->now->day_name; } } HelloWorld->run_if_script; =head1 AUTHORS See L for authors. =head1 COPYRIGHT AND LICENSE See L for the copyright and license. =cut Web-Simple-0.033/lib/Web/Simple/HackedPlack.pm0000644000372100001440000000466311434064217020456 0ustar matthewtusers# This is Plack::Server::CGI, copied almost verbatim. # Except I inlined the bits of Plack::Util it needed. # Because it loads a number of modules that I didn't. # miyagawa, I'm sorry to butcher your code like this. # The apology would have been in the form of a haiku. # But I needed more syllables than that would permit. # So I thought perhaps I'd make it bricktext instead. # -- love, mst # Hide from PAUSE package Plack::Server::CGI; use strict; use warnings; use IO::Handle; BEGIN { # Hide from PAUSE package Plack::Util; sub foreach { my($body, $cb) = @_; if (ref $body eq 'ARRAY') { for my $line (@$body) { $cb->($line) if length $line; } } else { local $/ = \4096 unless ref $/; while (defined(my $line = $body->getline)) { $cb->($line) if length $line; } $body->close; } } sub TRUE() { 1==1 } sub FALSE() { !TRUE } } sub new { bless {}, shift } sub run { my ($self, $app) = @_; my %env; while (my ($k, $v) = each %ENV) { next unless $k =~ qr/^(?:REQUEST_METHOD|SCRIPT_NAME|PATH_INFO|QUERY_STRING|SERVER_NAME|SERVER_PORT|SERVER_PROTOCOL|CONTENT_LENGTH|CONTENT_TYPE|REMOTE_ADDR|REQUEST_URI)$|^HTTP_/; $env{$k} = $v; } $env{'HTTP_COOKIE'} ||= $ENV{COOKIE}; $env{'psgi.version'} = [ 1, 0 ]; $env{'psgi.url_scheme'} = ($ENV{HTTPS}||'off') =~ /^(?:on|1)$/i ? 'https' : 'http'; $env{'psgi.input'} = *STDIN; $env{'psgi.errors'} = *STDERR; $env{'psgi.multithread'} = Plack::Util::FALSE; $env{'psgi.multiprocess'} = Plack::Util::TRUE; $env{'psgi.run_once'} = Plack::Util::TRUE; my $res = $app->(\%env); print "Status: $res->[0]\n"; my $headers = $res->[1]; while (my ($k, $v) = splice(@$headers, 0, 2)) { print "$k: $v\n"; } print "\n"; my $body = $res->[2]; my $cb = sub { print STDOUT $_[0] }; Plack::Util::foreach($body, $cb); } 1; __END__ =head1 SYNOPSIS ## in your .cgi #!/usr/bin/perl use Plack::Server::CGI; # or Plack::Util::load_psgi("/path/to/app.psgi"); my $app = sub { my $env = shift; return [ 200, [ 'Content-Type' => 'text/plain', 'Content-Length' => 13 ], 'Hello, world!', ]; }; Plack::Server::CGI->new->run($app); =head1 SEE ALSO L =cut Web-Simple-0.033/lib/Web/Dispatch/0000755000372100001440000000000013064012245016256 5ustar matthewtusersWeb-Simple-0.033/lib/Web/Dispatch/ParamParser.pm0000644000372100001440000001053513012655621021041 0ustar matthewtuserspackage Web::Dispatch::ParamParser; use strict; use warnings FATAL => 'all'; use Encode 'decode_utf8'; 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 ORIG_ENV () { 'Web::Dispatch.original_env' } sub get_unpacked_query_from { return ($_[0]->{+ORIG_ENV}||$_[0])->{+UNPACKED_QUERY} ||= do { _unpack_params($_[0]->{QUERY_STRING}) }; } sub get_unpacked_body_from { return ($_[0]->{+ORIG_ENV}||$_[0])->{+UNPACKED_BODY} ||= do { 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 (functional, $p does not belong to us, # do NOT replace this with a side-effect ridden "simpler" version) +{ 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]->{+ORIG_ENV}||$_[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 my $DECODE = qr/%([0-9a-fA-F]{2})/; my %hex_chr; foreach my $num ( 0 .. 255 ) { my $h = sprintf "%02X", $num; $hex_chr{ lc $h } = $hex_chr{ uc $h } = chr $num; } sub _unpack_params { my %unpack; (my $params = $_[0]) =~ s/\+/ /g; my ($name, $value); foreach my $pair (split(/[&;](?:\s+)?/, $params)) { $value = 1 unless (($name, $value) = split(/=/, $pair, 2)) == 2; s/$DECODE/$hex_chr{$1}/gs for ($name, $value); $_ = decode_utf8 $_ for ($name, $value); push(@{$unpack{$name}||=[]}, $value); } \%unpack; } } { # 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; Web-Simple-0.033/lib/Web/Dispatch/HTTPMethods.pm0000644000372100001440000001143212357776067020747 0ustar matthewtuserspackage Web::Dispatch::HTTPMethods; use strictures 1; use Web::Dispatch::Predicates qw(match_method); use Scalar::Util qw(blessed); use Exporter 'import'; our @EXPORT = qw(GET HEAD POST PUT DELETE OPTIONS); sub HEAD(&;@) { method_helper(HEAD => @_) } sub GET(&;@) { method_helper(GET => @_) } sub POST(&;@) { method_helper(POST => @_) } sub PUT(&;@) { method_helper(PUT => @_) } sub DELETE(&;@) { method_helper(DELETE => @_) } sub OPTIONS(&;@) { method_helper(OPTIONS => @_) } { package Web::Dispatch::HTTPMethods::Endpoint; sub new { bless { map { $_=>0 } @EXPORT }, shift } sub hdrs { 'Content-Type' => 'text/plain' } sub create_implicit_HEAD { my $self = shift; if($self->{GET} && not $self->{HEAD}) { $self->{HEAD} = sub { [ @{$self->{GET}->(@_)}[0,1], []] }; } } sub create_implicit_OPTIONS { my $self = shift; $self->{OPTIONS} = sub { [200, [$self->hdrs, Allow=>$self->allowed] , [] ]; }; } sub allowed { join ',', grep { $_[0]->{$_} } @EXPORT } sub to_app { my $self = shift; my $implicit_HEAD = $self->create_implicit_HEAD; my $implicit_OPTIONS = $self->create_implicit_OPTIONS; return sub { my $env = shift; if($env->{REQUEST_METHOD} eq 'HEAD') { $implicit_HEAD->($env); } elsif($env->{REQUEST_METHOD} eq 'OPTIONS') { $implicit_OPTIONS->($env); } else { [405, [$self->hdrs, Allow=>$self->allowed] , ['Method Not Allowed'] ]; } }; } } sub isa_endpoint { blessed($_[0]) && $_[0]->isa('Web::Dispatch::HTTPMethods::Endpoint') } sub endpoint_from { return $_[-1] } sub new_endpoint { Web::Dispatch::HTTPMethods::Endpoint->new(@_) } sub method_helper { my $predicate = match_method(my $method = shift); my ($code, @following ) = @_; endpoint_from( my @dispatchers = scalar(@following) ? ($predicate, @_) : ($predicate, @_, new_endpoint) )->{$method} = $code; die "Non HTTP Method dispatcher detected in HTTP Method scope" unless(isa_endpoint($dispatchers[-1])); return @dispatchers; } 1; =head1 NAME Web::Dispatch::HTTPMethods - Helpers to make RESTFul Dispatchers Easier =head1 SYNOPSIS package MyApp:WithHTTPMethods; use Web::Simple; use Web::Dispatch::HTTPMethods; sub as_text { [200, ['Content-Type' => 'text/plain'], [$_[0]->{REQUEST_METHOD}, $_[0]->{REQUEST_URI}] ] } sub dispatch_request { sub (/get) { GET { as_text(pop) } }, sub (/get-head) { GET { as_text(pop) } HEAD { [204,[],[]] }, }, sub (/get-post-put) { GET { as_text(pop) } ## NOTE: no commas separating http methods POST { as_text(pop) } PUT { as_text(pop) } }, } =head1 DESCRIPTION Exports the most commonly used HTTP methods as subroutine helpers into your L based application. Use of these methods additionally adds an automatic HTTP code 405 C response if none of the HTTP methods match for a given dispatch and also adds a dispatch rule for C if no C exists but a C does (in which case the C returns the C dispatch with an empty body.) We also add support at the end of the chain for the OPTIONS method. This defaults to HTTP 200 OK + Allows http headers. We also try to set correct HTTP headers such as C as makes sense based on your dispatch chain. The following dispatch chains are basically the same: sub dispatch_request { sub (/get-http-methods) { GET { [200, ['Content-Type' => 'text/plain'], ['Hello World']] } }, sub(/get-classic) { sub (GET) { [200, ['Content-Type' => 'text/plain'], ['Hello World']] }, sub (HEAD) { [200, ['Content-Type' => 'text/plain'], []] }, sub (OPTIONS) { [200, ['Content-Type' => 'text/plain', Allows=>'GET,HEAD,OPTIONS'], []]; }, sub () { [405, ['Content-Type' => 'text/plain', Allows=>'GET,HEAD,OPTIONS'], ['Method Not Allowed']] }, } } The idea here is less boilerplate to distract the reader from the main point of the code and also to encapsulate some best practices. B You currently cannot mix http method style and prototype sub style in the same scope, as in the following example: sub dispatch_request { sub (/get-head) { GET { ... } sub (HEAD) { ... } }, } If you try this our code will notice and issue a C. If you have a good use case please bring it to the authors. =head2 EXPORTS This automatically exports the following subroutines: GET PUT POST HEAD DELETE OPTIONS =head1 AUTHOR See L for AUTHOR =head1 CONTRIBUTORS See L for CONTRIBUTORS =head1 COPYRIGHT See L for COPYRIGHT =head1 LICENSE See L for LICENSE =cut Web-Simple-0.033/lib/Web/Dispatch/Wrapper.pm0000644000372100001440000000145711525153624020252 0ustar matthewtuserspackage Web::Dispatch::Wrapper; use strictures 1; use Moo; use Exporter 'import'; our @EXPORT = qw(dispatch_wrapper redispatch_to response_filter); extends 'Plack::Middleware'; has 'wrapper' => (is => 'ro', required => 1); sub dispatch_wrapper (&) { my ($code) = @_; __PACKAGE__->from_code($code); } sub from_code { my ($class, $code) = @_; $class->new(wrapper => $code); } sub redispatch_to { my ($new_path) = @_; __PACKAGE__->from_code(sub { $_[1]->({ %{$_[0]}, PATH_INFO => $new_path }); }); } sub response_filter (&) { my ($code) = @_; __PACKAGE__->from_code(sub { my @result = $_[1]->($_[0]); if (@result) { $code->(@result); } else { () } }); } sub to_app { my $code = $_[0]->wrapper; my $app = $_[0]->app; sub { $code->($_[0], $app) } } 1; Web-Simple-0.033/lib/Web/Dispatch/Upload.pm0000644000372100001440000000153712357776027020071 0ustar matthewtusersuse strictures 1; { package Web::Dispatch::Upload; require Plack::Request::Upload; our @ISA = 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-0.033/lib/Web/Dispatch/Parser.pm0000644000372100001440000001463412336725226020073 0ustar matthewtuserspackage Web::Dispatch::Parser; sub DEBUG () { 0 } BEGIN { if ($ENV{WEB_DISPATCH_PARSER_DEBUG}) { no warnings 'redefine'; *DEBUG = sub () { 1 } } } use Sub::Quote; use Web::Dispatch::Predicates; use Moo; has _cache => ( is => 'lazy', default => quote_sub q{ {} } ); sub diag { if (DEBUG) { warn $_[0] } } sub _wtf { my ($self, $error) = @_; my $hat = (' ' x (pos||0)).'^'; warn "Warning parsing dispatch specification: ${error}\n ${_} ${hat} here\n"; } sub _blam { my ($self, $error) = @_; my $hat = (' ' x (pos||0)).'^'; die "Error parsing dispatch specification: ${error}\n ${_} ${hat} here\n"; } sub parse { my ($self, $spec) = @_; $spec =~ s/\s+//g; # whitespace is not valid return $self->_cache->{$spec} ||= $self->_parse_spec($spec); } sub _parse_spec { my ($self, $spec, $nested) = @_; return match_true() unless length($spec); for ($_[1]) { my @match; my $close; PARSE: { do { push @match, $self->_parse_spec_section($_) or $self->_blam("Unable to work out what the next section is"); if (/\G\)/gc) { $self->_blam("Found closing ) with no opening (") unless $nested; $close = 1; last PARSE; } last PARSE if (pos == length); $match[-1] = $self->_parse_spec_combinator($_, $match[-1]) or $self->_blam('No valid combinator - expected + or |'); } until (pos == length) }; # accept trailing whitespace if (!$close and $nested and pos == length) { pos = $nested - 1; $self->_blam("No closing ) found for opening ("); } return $match[0] if (@match == 1); return match_and(@match); } } sub _parse_spec_combinator { my ($self, $spec, $match) = @_; for ($_[1]) { /\G\+/gc and return $match; /\G\|/gc and return do { my @match = $match; PARSE: { do { push @match, $self->_parse_spec_section($_) or $self->_blam("Unable to work out what the next section is"); last PARSE if (pos == length); last PARSE unless /\G\|/gc; # give up when next thing isn't | } until (pos == length) }; # accept trailing whitespace return match_or(@match); }; } return; } sub _parse_spec_section { my ($self) = @_; for ($_[1]) { # ~ /\G~/gc and return match_path('^$'); # GET POST PUT HEAD ... /\G([A-Z]+)/gc and return match_method($1); # /... /\G(?=\/)/gc and return $self->_url_path_match($_); # .* and .html /\G\.(\*|\w+)/gc and return match_extension($1); # (...) /\G\(/gc and return $self->_parse_spec($_, pos); # !something /\G!/gc and return match_not($self->_parse_spec_section($_)); # ? /\G\?/gc and return $self->_parse_param_handler($_, 'query'); # % /\G\%/gc and return $self->_parse_param_handler($_, 'body'); # * /\G\*/gc and return $self->_parse_param_handler($_, 'uploads'); } return; # () will trigger the blam in our caller } sub _url_path_match { my ($self) = @_; for ($_[1]) { my (@path, @names, $seen_nameless); my $end = ''; my $keep_dot; PATH: while (/\G\//gc) { /\G\.\.\./gc and do { $end = '(/.*)'; last PATH; }; my ($segment) = $self->_url_path_segment_match($_) or $self->_blam("Couldn't parse path match segment"); if (ref($segment)) { ($segment, $keep_dot, my $name) = @$segment; if (defined($name)) { $self->_blam("Can't mix positional and named captures in path match") if $seen_nameless; push @names, $name; } else { $self->_blam("Can't mix positional and named captures in path match") if @names; $seen_nameless = 1; } } push @path, $segment; /\G\.\.\./gc and do { $end = '(|/.*)'; last PATH; }; /\G\.\*/gc and $keep_dot = 1; last PATH if $keep_dot; } if (@path && !$end && !$keep_dot) { length and $_ .= '(?:\.\w+)?' for $path[-1]; } my $re = '^('.join('/','',@path).')'.$end.'$'; $re = qr/$re/; if ($end) { return match_path_strip($re, @names ? \@names : ()); } else { return match_path($re, @names ? \@names : ()); } } return; } sub _url_path_segment_match { my ($self) = @_; for ($_[1]) { # trailing / -> require / on end of URL /\G(?:(?=[+|\)])|$)/gc and return ''; # word chars only -> exact path part match / \G( (?: # start matching at a space followed by: [\w\-] # word chars or dashes | # OR \. # a period (?!\.) # not followed by another period ) + # then grab as far as possible ) /gcx and return "\Q$1"; # ** -> capture unlimited path parts /\G\*\*(?:(\.\*)?\:(\w+))?/gc and return [ '(.*?[^/])', $1, $2 ]; # * -> capture path part # *:name -> capture named path part /\G\*(?:(\.\*)?\:(\w+))?/gc and return [ '([^/]+?)', $1, $2 ]; # :name -> capture named path part /\G\:(\w+)/gc and return [ '([^/]+?)', 0, $1 ]; } return (); } sub _parse_param_handler { my ($self, $spec, $type) = @_; for ($_[1]) { my (@required, @single, %multi, $star, $multistar, %positional, $have_kw); my %spec; my $pos_idx = 0; PARAM: { do { # ?:foo or ?@:foo my $is_kw = /\G\:/gc; # ?@foo or ?@* my $multi = /\G\@/gc; # @* or * if (/\G\*/gc) { $self->_blam("* is always named; no need to supply :") if $is_kw; if ($star) { $self->_blam("Can only use one * or \@* in a parameter match"); } $spec{star} = { multi => $multi }; } else { # @foo= or foo= or @foo~ or foo~ /\G([\w.]*)/gc or $self->_blam('Expected parameter name'); my $name = $1; # check for = or ~ on the end /\G\=/gc ? push(@{$spec{required}||=[]}, $name) : (/\G\~/gc or $self->_blam('Expected = or ~ after parameter name')); # record positional or keyword push @{$spec{$is_kw ? 'named' : 'positional'}||=[]}, { name => $name, multi => $multi }; } } while (/\G\&/gc) } return Web::Dispatch::Predicates->can("match_${type}")->(\%spec); } } 1; Web-Simple-0.033/lib/Web/Dispatch/ToApp.pm0000644000372100001440000000020111471752216017641 0ustar matthewtuserspackage Web::Dispatch::ToApp; use Moo::Role; requires 'call'; sub to_app { my ($self) = @_; sub { $self->call(@_) } } 1; Web-Simple-0.033/lib/Web/Dispatch/Predicates.pm0000644000372100001440000000741612357776045020732 0ustar matthewtuserspackage Web::Dispatch::Predicates; use strictures 1; use Exporter 'import'; our @EXPORT = qw( match_and match_or match_not match_method match_path match_path_strip match_extension match_query match_body match_uploads match_true match_false ); sub _matcher { bless shift, 'Web::Dispatch::Matcher' } sub match_true { _matcher(sub { {} }); } sub match_false { _matcher(sub {}); } sub match_and { my @match = @_; _matcher(sub { my ($env) = @_; my $my_env = { 'Web::Dispatch.original_env' => $env, %$env }; my $new_env; my @got; foreach my $match (@match) { if (my @this_got = $match->($my_env)) { my %change_env = %{shift(@this_got)}; @{$my_env}{keys %change_env} = values %change_env; @{$new_env}{keys %change_env} = values %change_env; push @got, @this_got; } else { return; } } return ($new_env, @got); }) } sub match_or { my @match = @_; _matcher(sub { foreach my $try (@match) { if (my @ret = $try->(@_)) { return @ret; } } return; }) } sub match_not { my ($match) = @_; _matcher(sub { if (my @discard = $match->($_[0])) { (); } else { ({}); } }) } sub match_method { my ($method) = @_; _matcher(sub { my ($env) = @_; $env->{REQUEST_METHOD} eq $method ? {} : () }) } sub match_path { my ($re, $names) = @_; _matcher(sub { my ($env) = @_; if (my @cap = ($env->{PATH_INFO} =~ /$re/)) { $cap[0] = {}; $cap[1] = do { my %c; @c{@$names} = splice @cap, 1; \%c } if $names; return @cap; } return; }) } sub match_path_strip { my ($re, $names) = @_; _matcher(sub { my ($env) = @_; if (my @cap = ($env->{PATH_INFO} =~ /$re/)) { $cap[0] = { SCRIPT_NAME => ($env->{SCRIPT_NAME}||'').$cap[0], PATH_INFO => pop(@cap), }; $cap[1] = do { my %c; @c{@$names} = splice @cap, 1; \%c } if $names; return @cap; } return; }) } sub match_extension { my ($extension) = @_; my $wild = (!$extension or $extension eq '*'); my $re = $wild ? qr/\.(\w+)$/ : qr/\.(\Q${extension}\E)$/; _matcher(sub { if ($_[0]->{PATH_INFO} =~ $re) { ($wild ? ({}, $1) : {}); } else { (); } }); } sub match_query { _matcher(_param_matcher(query => $_[0])); } sub match_body { _matcher(_param_matcher(body => $_[0])); } sub match_uploads { _matcher(_param_matcher(uploads => $_[0])); } sub _param_matcher { my ($type, $spec) = @_; # We're probably parsing a match spec while building the parser, and # on 5.8.8, loading ParamParser loads Encode which blows away $_ and pos. # Furthermore, localizing $_ doesn't restore pos afterwards. So do this # stupid thing instead to work on 5.8.8 my $saved_pos = pos; { local $_; require Web::Dispatch::ParamParser; } pos = $saved_pos; my $unpack = Web::Dispatch::ParamParser->can("get_unpacked_${type}_from"); sub { _extract_params($unpack->($_[0]), $spec) }; } sub _extract_params { my ($raw, $spec) = @_; foreach my $name (@{$spec->{required}||[]}) { return unless exists $raw->{$name}; } my @ret = ( {}, map { $_->{multi} ? $raw->{$_->{name}}||[] : $raw->{$_->{name}}->[-1] } @{$spec->{positional}||[]} ); # separated since 'or' is short circuit my ($named, $star) = ($spec->{named}, $spec->{star}); if ($named or $star) { my %kw; if ($star) { @kw{keys %$raw} = ( $star->{multi} ? values %$raw : map $_->[-1], values %$raw ); } foreach my $n (@{$named||[]}) { next if !$n->{multi} and !exists $raw->{$n->{name}}; $kw{$n->{name}} = $n->{multi} ? $raw->{$n->{name}}||[] : $raw->{$n->{name}}->[-1]; } push @ret, \%kw; } @ret; } 1; Web-Simple-0.033/lib/Web/Dispatch/Node.pm0000644000372100001440000000120012336725215017503 0ustar matthewtuserspackage Web::Dispatch::Node; use Moo; with 'Web::Dispatch::ToApp'; for (qw(match run)) { has "_${_}" => (is => 'ro', required => 1, init_arg => $_); } sub call { my ($self, $env) = @_; if (my ($env_delta, @match) = $self->_match->($env)) { ($env_delta, $self->_curry(@match)); } else { () } } sub _curry { my ($self, @args) = @_; my $run = $self->_run; my $code = sub { $run->(@args, $_[0]) }; # if the first argument is a hashref, localize %_ to it to permit # use of $_{name} inside the dispatch sub ref($args[0]) eq 'HASH' ? do { my $v = $args[0]; sub { local *_ = $v; &$code } } : $code } 1; Web-Simple-0.033/lib/CSS/0000755000372100001440000000000013064012245014432 5ustar matthewtusersWeb-Simple-0.033/lib/CSS/Declare.pm0000644000372100001440000000752711752040732016346 0ustar matthewtuserspackage CSS::Declare; use strict; use warnings; use Syntax::Keyword::Gather; my $IN_SCOPE = 0; sub import { die "Can't import CSS::Declare into a scope when already compiling one that uses it" if $IN_SCOPE; my ($class, @args) = @_; my $opts = shift(@args) if ref($args[0]) eq 'HASH'; my $target = $class->_find_target(0, $opts); my $unex = $class->_export_tags_into($target); $class->_install_unexporter($unex); $IN_SCOPE = 1; } sub _find_target { my ($class, $extra_levels, $opts) = @_; return $opts->{into} if defined($opts->{into}); my $level = ($opts->{into_level} || 1) + $extra_levels; return (caller($level))[0]; } my @properties = qw{ accelerator azimuth background background_attachment background_color background_image background_position background_position_x background_position_y background_repeat behavior border border_bottom border_bottom_color border_bottom_style border_bottom_width border_collapse border_color border_left border_left_color border_left_style border_left_width border_right border_right_color border_right_style border_right_width border_spacing border_style border_top border_top_color border_top_style border_top_width border_width bottom caption_side clear clip color content counter_increment counter_reset cue cue_after cue_before cursor direction display elevation empty_cells filter float font font_family font_size font_size_adjust font_stretch font_style font_variant font_weight height ime_mode include_source layer_background_color layer_background_image layout_flow layout_grid layout_grid_char layout_grid_char_spacing layout_grid_line layout_grid_mode layout_grid_type left letter_spacing line_break line_height list_style list_style_image list_style_position list_style_type margin margin_bottom margin_left margin_right margin_top marker_offset marks max_height max_width min_height min_width orphans outline outline_color outline_style outline_width overflow overflow_X overflow_Y padding padding_bottom padding_left padding_right padding_top page page_break_after page_break_before page_break_inside pause pause_after pause_before pitch pitch_range play_during position quotes _replace richness right ruby_align ruby_overhang ruby_position size speak speak_header speak_numeral speak_punctuation speech_rate stress scrollbar_arrow_color scrollbar_base_color scrollbar_dark_shadow_color scrollbar_face_color scrollbar_highlight_color scrollbar_shadow_color scrollbar_3d_light_color scrollbar_track_color table_layout text_align text_align_last text_decoration text_indent text_justify text_overflow text_shadow text_transform text_autospace text_kashida_space text_underline_position top unicode_bidi vertical_align visibility voice_family volume white_space widows width word_break word_spacing word_wrap writing_mode z_index zoom }; sub _export_tags_into { my ($class, $into) = @_; for my $property (@properties) { my $property_name = $property; $property_name =~ tr/_/-/; no strict 'refs'; *{"$into\::$property"} = sub ($) { return ($property_name => $_[0]) }; } return sub { foreach my $property (@properties) { no strict 'refs'; delete ${"${into}::"}{$property} } $IN_SCOPE = 0; }; } sub _install_unexporter { my ($class, $unex) = @_; $^H |= 0x20000; # localize %^H $^H{'CSS::Declare::Unex'} = bless($unex, 'CSS::Declare::Unex'); } sub to_css_string { my @css = @_; return join q{ }, gather { while (my ($selector, $declarations) = splice(@css, 0, 2)) { take "$selector "._generate_declarations($declarations) } }; } sub _generate_declarations { my $declarations = shift; return '{'.join(q{;}, gather { while (my ($property, $value) = splice(@{$declarations}, 0, 2)) { take "$property:$value" } }).'}'; } package CSS::Declare::Unex; sub DESTROY { local $@; eval { $_[0]->(); 1 } || warn "ARGH: $@" } 1;