DeNA テクノロジーセミナーきいてたら簡単なディスパッチャができた
Perl5.10 以後のみ対応だけど、5.10 以後ならこんな簡単なのでいいのかも。
package MojaMoja; use strict; use warnings; use parent 'Exporter'; use 5.01000; our $VERSION = '0.01'; use Plack::Request; use Plack::Response; our @EXPORT = qw/get put post Delete zigorou res/; my @ROUTE; BEGIN { no strict 'refs'; for my $meth (qw/get put post Delete/) { my $method = uc $meth; *{$meth} = sub ($$) { my $pattern = $_[0]; push @ROUTE, { regexp => do { ref($pattern) ? $pattern : do { $pattern =~ s!\{([^}]+)\}|([^{]+)!$1 ? "(?<\Q$1\E>[^/]+)" : quotemeta($2)!ge; qr{^$pattern$}; } }, code => $_[1], method => $method, }; }; } } sub import { undef @ROUTE; strict->import; warnings->import; __PACKAGE__->export_to_level(1); } sub import { undef @ROUTE; strict->import; warnings->import; __PACKAGE__->export_to_level(1); } sub zigorou() { my @route = @ROUTE; return sub { my $req = Plack::Request->new($_[0]); for my $entry (@route) { if ($req->method eq $entry->{method} && $req->path_info =~ $entry->{ regexp}) { my $res = $entry->{code}->($req); return ref($res) eq 'Plack::Response' ? $res->finalize : $res; } } return [404, ['Content-Type' => 'text/plain'], ['not found']]; }; } sub res { Plack::Response->new(@_) } 1; __END__ =encoding utf8 =head1 NAME MojaMoja - =head1 SYNOPSIS # in myapp.psgi use MojaMoja; get '/' => sub { }; get '/blog/{year}/{month}' => sub { res(200, [], ['display blog content']) }; zigorou; =head1 DESCRIPTION MojaMoja is =head1 AUTHOR Tokuhiro Matsuno E<lt>tokuhirom AAJKLFJEF GMAIL COME<gt> =head1 SEE ALSO L<id:ZIGOROu> =head1 LICENSE Copyright (C) Tokuhiro Matsuno This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut
テストはこんなかんじ。Test::WWW::Mechanize::PSGI++ acme++
use strict; use warnings; use Test::More; use Test::WWW::Mechanize::PSGI; my $app = do { use MojaMoja; get '/' => sub { return [200, [], ['top']]; }; get '/blog/{year}/{month}' => sub { return res(200, [], ["$+{year}-$+{month}'s blog"]); }; post '/comment' => sub { my $req = shift; return res(200, [], ["posted '@{[ $req->param('body') ]}'"]); }; zigorou; }; my $mech = Test::WWW::Mechanize::PSGI->new(app => $app); $mech->get_ok('/'); $mech->content_contains('top'); $mech->get_ok('/blog/2010/03'); $mech->content_is("2010-03's blog"); $mech->post_ok('/comment', {body => 'hi'}); $mech->content_is("posted 'hi'"); done_testing;
【追記】
パーザ部分を変更