view release on metacpan or  search on metacpan

t/corpus-stack/PSGI-Handy/lib/PSGI/Handy/Router.pm  view on Meta::CPAN

# match - look up a route
#   my $r = $router->match($method, $path);
# Returns:
#   - on success           : { handler => CODE, params => HASH }
#   - path matched, method not (405) : { allowed => [ method, ... ] }
#   - no match at all (404) : undef
# First registered matching route wins.
# --------------------------------------------------------------------
sub match {
    my ($self, $method, $path) = @_;
    defined $method or croak "match: method is required";
    defined $path   or croak "match: path is required";
    $method = uc($method);

    my @allowed;
    my $route;
    for $route (@{ $self->{routes} }) {
        my @caps = ($path =~ $route->{regex});
        next unless @caps;                 # this pattern did not match the path

        if ($route->{method} eq $method) {
            my %params;
            my $names = $route->{names};
            my $i;
            for ($i = 0; $i < scalar(@$names); $i++) {
                $params{ $names->[$i] } = $caps[$i];
            }
            return { handler => $route->{handler}, params => { %params } };
        }
        push @allowed, $route->{method};   # remember for a possible 405
    }

    if (@allowed) {
        my %seen;
        my @uniq = grep { !$seen{$_}++ } @allowed;
        return { allowed => \@uniq };
    }
    return undef;
}

# --------------------------------------------------------------------
# routes - return the internal route list (array reference).
# Mainly for introspection and testing.
# --------------------------------------------------------------------
sub routes {
    my $self = shift;
    return $self->{routes};
}

# --------------------------------------------------------------------
# _compile - turn a path pattern into (qr//, \@param_names)
#
# A pattern is split on '/' into segments. Each segment becomes:
#   ':name'  -> ([^/]+)   and records the parameter name 'name'
#   '*' (only as the LAST segment) -> (.*)   recorded as 'splat'
#   anything else -> quotemeta (literal, dots are NOT wildcards)
# The whole thing is anchored with \A ... \z so matching is exact.
# --------------------------------------------------------------------
sub _compile {
    my ($pattern) = @_;
    my @segs = split m{/}, $pattern, -1;   # -1 keeps trailing empty fields
    my @names;
    my @parts;
    my $last = $#segs;
    my $i;
    for ($i = 0; $i <= $last; $i++) {
        my $seg = $segs[$i];
        if ($seg eq '*' && $i == $last) {
            push @parts, '(.*)';
            push @names, 'splat';
        }
        elsif ($seg =~ /\A:([A-Za-z_]\w*)\z/) {
            push @parts, '([^/]+)';
            push @names, $1;
        }
        else {
            push @parts, quotemeta($seg);
        }
    }
    my $source = '\\A' . join('/', @parts) . '\\z';
    my $regex  = qr{$source};
    return ($regex, \@names);
}

1;

__END__

=head1 NAME

PSGI::Handy::Router - tiny PSGI route dispatcher for Perl 5.5.3 and later

=head1 VERSION

Version 0.01

=head1 SYNOPSIS

    use PSGI::Handy::Router;

    my $router = PSGI::Handy::Router->new;

    $router->add('GET',  '/',            \&home);
    $router->add('GET',  '/users/:id',   \&show_user);
    $router->add('POST', '/users',       \&create_user);
    $router->add('GET',  '/files/*',     \&serve_file);

    my $r = $router->match('GET', '/users/42');
    if ($r && $r->{handler}) {
        # $r->{params} = { id => 42 }
        my $response = $r->{handler}->($env, $r->{params});
    }
    elsif ($r && $r->{allowed}) {
        # path exists but method not allowed -> HTTP 405
        # Allow: join(', ', @{ $r->{allowed} })
    }
    else {
        # no route matched -> HTTP 404
    }

=head1 TABLE OF CONTENTS