File Coverage

blib/lib/Router/Resource.pm

Criterion	Covered	Total	%
statement	56	56	100.0
branch	11	12	91.6
condition	5	8	62.5
subroutine	21	21	100.0
pod	8	14	57.1
total	101	111	90.9

use 5.008001; use strict; use warnings;

package Router::Resource;

our $VERSION = '0.22';

use Router::Simple::Route;
use Sub::Exporter -setup => {
    exports => [ qw(router resource missing GET POST PUT DELETE HEAD OPTIONS TRACE CONNECT PATCH)],
    groups  => { default => [ qw(resource router missing GET POST PUT DELETE HEAD OPTIONS TRACE CONNECT PATCH) ] }
};

sub new {
    my $class = shift;
    bless { @_, routes => [] };
}

our (%METHS, $ROUTER);

sub router(&;@) {
    my ($block, @settings) = @_;
    local $ROUTER = __PACKAGE__->new(@settings);
    $block->();
    return $ROUTER;
}

sub resource ($&) {
    my ($path, $code) = @_;
    local %METHS = ();
    $code->();

    # Let HEAD use GET if not specified.
    $METHS{HEAD} ||= $METHS{GET};

    # Add OPTIONS if requested.
    if ($ROUTER->{auto_options} && !$METHS{OPTIONS}) {
        my $methods = join(', ' => 'OPTIONS', keys %METHS);
        $METHS{OPTIONS} = sub { [200, ['Allow', $methods], []] };
    }

    # Add the route.
    push @{ $ROUTER->{routes} }, Router::Simple::Route->new(
        $path, { meths => { %METHS } }
    );
}

sub missing(&) { $ROUTER->{missing} = shift }
sub GET(&)     { $METHS{GET}     = shift }
sub HEAD(&)    { $METHS{HEAD}    = shift }
sub POST(&)    { $METHS{POST}    = shift }
sub PUT(&)     { $METHS{PUT}     = shift }
sub DELETE(&)  { $METHS{DELETE}  = shift }
sub OPTIONS(&) { $METHS{OPTIONS} = shift }
sub TRACE(&)   { $METHS{TRACE}   = shift }
sub CONNECT(&) { $METHS{CONNECT} = shift }
sub PATCH(&)   { $METHS{PATCH}   = shift }

sub dispatch {
    my ($self, $env) = @_;
    my $match = $self->match($env);
    if (my $meth = $match->{meth}) {
        return $meth->($env, $match->{data});
    }
    my $missing = $self->{missing} or return [
        $match->{code}, $match->{headers}, [$match->{message}]
    ];
    return $missing->($env, $match);
}

sub match {
    my ($self, $env) = @_;
    my $meth = uc($env->{REQUEST_METHOD} || '') or return;

    for my $route (@{ $self->{routes} }) {
        my $match = $route->match($env) or next;
        my $meths = delete $match->{meths};
        my $code = $meths->{$meth} or return {
            code    => 405,
            message => 'not allowed',
            headers => [Allow => join ', ', sort keys %{ $meths } ],
        };
        return { meth => $code, code => 200, data => $match };
    }
    return { code => 404, message => 'not found', headers => [] };
}

1;

__END__