;
}
}
Bloggery->run_if_script;
Web-Simple-0.033/maint/ 0000755 0003721 0000144 00000000000 13064012245 014344 5 ustar matthewt users Web-Simple-0.033/maint/Makefile.PL.include 0000644 0003721 0000144 00000000534 11752040732 017746 0 ustar matthewt users BEGIN { -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/ 0000755 0003721 0000144 00000000000 13064012245 013477 5 ustar matthewt users Web-Simple-0.033/t/tags.t 0000644 0003721 0000144 00000004754 13063546500 014641 0 ustar matthewt users use 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.t 0000644 0003721 0000144 00000001674 11471752216 015517 0 ustar matthewt users use 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.t 0000644 0003721 0000144 00000001316 13012655624 017015 0 ustar matthewt users use 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.t 0000644 0003721 0000144 00000001051 13012655624 017044 0 ustar matthewt users use 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.t 0000644 0003721 0000144 00000010371 11752040732 017343 0 ustar matthewt users use 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/ 0000755 0003721 0000144 00000000000 13064012245 015304 5 ustar matthewt users Web-Simple-0.033/t/globbery/two 0000644 0003721 0000144 00000000000 11270331016 016023 0 ustar matthewt users Web-Simple-0.033/t/globbery/one 0000644 0003721 0000144 00000000000 11270331016 015773 0 ustar matthewt users Web-Simple-0.033/t/globbery/three 0000644 0003721 0000144 00000000000 13063546500 016331 0 ustar matthewt users Web-Simple-0.033/t/dispatch_misc.t 0000644 0003721 0000144 00000013623 13012655624 016512 0 ustar matthewt users use 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.t 0000644 0003721 0000144 00000005734 13012655624 016734 0 ustar matthewt users use 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.t 0000644 0003721 0000144 00000000435 13012655624 016046 0 ustar matthewt users use 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.t 0000644 0003721 0000144 00000000563 13012655624 014613 0 ustar matthewt users use 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.t 0000644 0003721 0000144 00000001643 13012655624 014640 0 ustar matthewt users use 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.t 0000644 0003721 0000144 00000003165 13012655624 020636 0 ustar matthewt users use 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.t 0000644 0003721 0000144 00000000615 11643061272 014463 0 ustar matthewt users use 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.t 0000644 0003721 0000144 00000002352 13012655624 020360 0 ustar matthewt users use 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.t 0000644 0003721 0000144 00000006711 11643415004 017212 0 ustar matthewt users use 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.t 0000644 0003721 0000144 00000001723 11752040732 016225 0 ustar matthewt users use 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.t 0000644 0003721 0000144 00000002005 13012655621 016341 0 ustar matthewt users use 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.t 0000644 0003721 0000144 00000000614 11307447744 016152 0 ustar matthewt users use 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.t 0000644 0003721 0000144 00000005537 12255016140 014662 0 ustar matthewt users use 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.t 0000644 0003721 0000144 00000033356 12336725226 017064 0 ustar matthewt users use 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.t 0000644 0003721 0000144 00000003152 13012655624 015716 0 ustar matthewt users use 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/README 0000644 0003721 0000144 00000066055 13064012245 014130 0 ustar matthewt users NAME
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.json 0000644 0003721 0000144 00000003402 13064012245 014654 0 ustar matthewt users {
"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.PL 0000644 0003721 0000144 00000005727 13064012205 015215 0 ustar matthewt users use 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/MANIFEST 0000644 0003721 0000144 00000002647 13064012245 014376 0 ustar matthewt users Changes
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.yml 0000644 0003721 0000144 00000001713 13064012245 014507 0 ustar matthewt users ---
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/Changes 0000644 0003721 0000144 00000010444 13064012235 014531 0 ustar matthewt users Revision 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/ 0000755 0003721 0000144 00000000000 13064012245 014002 5 ustar matthewt users Web-Simple-0.033/lib/HTML/ 0000755 0003721 0000144 00000000000 13064012245 014546 5 ustar matthewt users Web-Simple-0.033/lib/HTML/Tags.pm 0000644 0003721 0000144 00000001574 11307447744 016027 0 ustar matthewt users package 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/ 0000755 0003721 0000144 00000000000 13064012245 015034 5 ustar matthewt users Web-Simple-0.033/lib/Plack/Middleware/ 0000755 0003721 0000144 00000000000 13064012245 017111 5 ustar matthewt users Web-Simple-0.033/lib/Plack/Middleware/Dispatch.pm 0000644 0003721 0000144 00000000460 12057472520 021215 0 ustar matthewt users package 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/ 0000755 0003721 0000144 00000000000 13064012245 014442 5 ustar matthewt users Web-Simple-0.033/lib/XML/Tags.pm 0000644 0003721 0000144 00000006471 13063546500 015713 0 ustar matthewt users package 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; 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/ 0000755 0003721 0000144 00000000000 13064012245 014517 5 ustar matthewt users Web-Simple-0.033/lib/Web/Dispatch.pm 0000644 0003721 0000144 00000010213 13012655621 016615 0 ustar matthewt users package 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.pm 0000644 0003721 0000144 00000063465 13063546517 016341 0 ustar matthewt users package 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/ 0000755 0003721 0000144 00000000000 13064012245 015750 5 ustar matthewt users Web-Simple-0.033/lib/Web/Simple/Application.pm 0000644 0003721 0000144 00000024511 13012655624 020563 0 ustar matthewt users package 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.pm 0000644 0003721 0000144 00000001671 13063546661 017231 0 ustar matthewt users package 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.pod 0000644 0003721 0000144 00000014234 11752040732 021406 0 ustar matthewt users =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);