# ABSTRACT: Dancer2's route handler
package Dancer2::Core::Route;
$Dancer2::Core::Route::VERSION = '0.140001';
use strict;
use warnings;
use Moo;
use Dancer2::Core::Types;
use Carp 'croak';
has method => (
is => 'ro',
isa => Dancer2Method,
required => 1,
);
has code => (
is => 'ro',
required => 1,
isa => CodeRef,
);
has regexp => (
is => 'ro',
required => 1,
);
has spec_route => ( is => 'ro' );
has prefix => (
is => 'ro',
isa => Maybe [Dancer2Prefix],
predicate => 1,
);
has options => (
is => 'ro',
isa => HashRef,
trigger => \&_check_options,
predicate => 1,
);
sub _check_options {
my ( $self, $options ) = @_;
return 1 unless defined $options;
my @supported_options = (
qw/content_type agent user_agent content_length
path_info/
);
for my $opt ( keys %{$options} ) {
croak "Not a valid option for route matching: `$opt'"
if not( grep {/^$opt$/} @supported_options );
}
return 1;
}
# private attributes
has _should_capture => (
is => 'ro',
isa => Bool,
);
has _match_data => (
is => 'rw',
isa => HashRef,
);
has _params => (
is => 'ro',
isa => ArrayRef,
default => sub { [] },
);
sub match {
my ( $self, $request ) = @_;
if ( $self->has_options ) {
return unless $self->validate_options($request);
}
my %params;
my @values = $request->dispatch_path =~ $self->regexp;
# the regex comments are how we know if we captured
# a splat or a megasplat
if ( my @splat_or_megasplat = $self->regexp =~ /\(\?#((?:mega)?splat)\)/g )
{
for (@values) {
$_ = [ split '/' => $_ ]
if ( shift @splat_or_megasplat ) =~ /megasplat/;
}
}
# if some named captures are found, return captures
# no warnings is for perl < 5.10
if (my %captures =
do { no warnings; %+ }
)
{
return $self->_match_data( { captures => \%captures } );
}
return unless @values;
# save the route pattern that matched
# TODO : as soon as we have proper Dancer2::Internal, we should remove
# that, it's just a quick hack for plugins to access the matching
# pattern.
# NOTE: YOU SHOULD NOT USE THAT, OR IF YOU DO, YOU MUST KNOW
# IT WILL MOVE VERY SOON
# $request->{_route_pattern} = $self->regexp;
# named tokens
my @tokens = @{ $self->_params };
if (@tokens) {
for ( my $i = 0; $i < @tokens; $i++ ) {
$params{ $tokens[$i] } = $values[$i];
}
return $self->_match_data( \%params );
}
elsif ( $self->_should_capture ) {
return $self->_match_data( { splat => \@values } );
}
return $self->_match_data( {} );
}
sub execute {
my ( $self, @args ) = @_;
return $self->code->(@args);
}
# private subs
sub BUILDARGS {
my ( $class, %args ) = @_;
my $prefix = $args{prefix};
my $regexp = $args{regexp};
# regexp must have a leading /
if ( ref($regexp) ne 'Regexp' ) {
index( $regexp, '/', 0 ) == 0
or die "regexp must begin with /\n";
}
# init prefix
if ( $prefix ) {
$args{regexp} =
ref($regexp) eq 'Regexp' ? qr{^\Q${prefix}\E${regexp}$} :
$regexp eq '/' ? qr{^\Q${prefix}\E/?$} :
$prefix . $regexp;
}
# init regexp
$regexp = $args{regexp}; # updated value
$args{spec_route} = $regexp;
if ( ref($regexp) eq 'Regexp') {
$args{_should_capture} = 1;
}
else {
@args{qw/ regexp _params _should_capture/} =
@{ _build_regexp_from_string($regexp) };
}
return \%args;
}
sub _build_regexp_from_string {
my ($string) = @_;
my $capture = 0;
my @params;
# look for route with params (/hello/:foo)
if ( $string =~ /:/ ) {
@params = $string =~ /:([^\/\.\?]+)/g;
if (@params) {
$string =~ s/(:[^\/\.\?]+)/\(\[\^\/\]\+\)/g;
$capture = 1;
}
}
# parse megasplat
# we use {0,} instead of '*' not to fall in the splat rule
# same logic for [^\n] instead of '.'
$capture = 1 if $string =~ s!\Q**\E!(?#megasplat)([^\n]+)!g;
# parse wildcards
$capture = 1 if $string =~ s!\*!(?#splat)([^/]+)!g;
# escape dots
$string =~ s/\./\\\./g if $string =~ /\./;
# escape slashes
$string =~ s/\//\\\//g;
return [ "^$string\$", \@params, $capture ];
}
sub validate_options {
my ( $self, $request ) = @_;
while ( my ( $option, $value ) = each %{ $self->options } ) {
return 0
if ( not $request->$option ) || ( $request->$option !~ $value );
}
return 1;
}
1;
__END__
=pod
=head1 NAME
Dancer2::Core::Route - Dancer2's route handler
=head1 VERSION
version 0.140001
=head1 ATTRIBUTES
=head2 method
The HTTP method of the route (lowercase). Required.
=head2 code
The code reference to execute when the route is ran. Required.
=head2 regexp
The regular expression that defines the path of the route.
Required. Coerce from Dancer2's route I<patterns>.
=head2 prefix
The prefix to prepend to the C<regexp>. Optional.
=head2 options
A HashRef of conditions on which the matching will depend. Optional.
=head1 METHODS
=head2 match
Try to match the route with a given pair of method/path.
Returns the hash of matching data if success (captures and values of the route
against the path) or undef if not.
my $match = $route->match( get => '/hello/sukria' );
=head2 execute
Runs the coderef of the route.
=head1 AUTHOR
Dancer Core Developers
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2014 by Alexis Sukrieh.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut