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;

【追記】
パーザ部分を変更

Published: 2010-03-03(Tue) 11:49