sub diag { if (DEBUG) { warn $_[0] } }
+sub _wtf {
+ my ($self, $error) = @_;
+ my $hat = (' ' x (pos||0)).'^';
+ warn "Warning parsing dispatch specification: ${error}\n
+${_}
+${hat} here\n";
+}
+
sub _blam {
my ($self, $error) = @_;
my $hat = (' ' x (pos||0)).'^';
sub _parse_spec {
my ($self, $spec, $nested) = @_;
+ return match_true() unless length($spec);
for ($_[1]) {
my @match;
+ my $close;
PARSE: { do {
push @match, $self->_parse_spec_section($_)
or $self->_blam("Unable to work out what the next section is");
if (/\G\)/gc) {
$self->_blam("Found closing ) with no opening (") unless $nested;
+ $close = 1;
last PARSE;
}
last PARSE if (pos == length);
$match[-1] = $self->_parse_spec_combinator($_, $match[-1])
or $self->_blam('No valid combinator - expected + or |');
} until (pos == length) }; # accept trailing whitespace
- if ($nested and pos == length) {
+ if (!$close and $nested and pos == length) {
pos = $nested - 1;
$self->_blam("No closing ) found for opening (");
}
my ($self) = @_;
for ($_[1]) {
+ # ~
+
+ /\G~/gc and
+ return match_path('^$');
+
# GET POST PUT HEAD ...
/\G([A-Z]+)/gc and
# %<param spec>
/\G\%/gc and
return $self->_parse_param_handler($_, 'body');
+
+ # *<param spec>
+ /\G\*/gc and
+ return $self->_parse_param_handler($_, 'uploads');
}
return; # () will trigger the blam in our caller
}
sub _url_path_match {
my ($self) = @_;
for ($_[1]) {
- my @path;
+ my (@path, @names, $seen_nameless);
my $end = '';
+ my $keep_dot;
PATH: while (/\G\//gc) {
/\G\.\.\./gc
and do {
$end = '(/.*)';
last PATH;
};
- push @path, $self->_url_path_segment_match($_)
+
+ my ($segment) = $self->_url_path_segment_match($_)
or $self->_blam("Couldn't parse path match segment");
+
+ if (ref($segment)) {
+ ($segment, $keep_dot, my $name) = @$segment;
+ if (defined($name)) {
+ $self->_blam("Can't mix positional and named captures in path match")
+ if $seen_nameless;
+ push @names, $name;
+ } else {
+ $self->_blam("Can't mix positional and named captures in path match")
+ if @names;
+ $seen_nameless = 1;
+ }
+ }
+ push @path, $segment;
+
+ /\G\.\.\./gc
+ and do {
+ $end = '(|/.*)';
+ last PATH;
+ };
+ /\G\.\*/gc
+ and $keep_dot = 1;
+
+ last PATH if $keep_dot;
}
- if (@path && !$end) {
+ if (@path && !$end && !$keep_dot) {
length and $_ .= '(?:\.\w+)?' for $path[-1];
}
my $re = '^('.join('/','',@path).')'.$end.'$';
$re = qr/$re/;
if ($end) {
- return match_path_strip($re);
+ return match_path_strip($re, @names ? \@names : ());
} else {
- return match_path($re);
+ return match_path($re, @names ? \@names : ());
}
}
return;
/\G(?:(?=[+|\)])|$)/gc and
return '';
# word chars only -> exact path part match
- /\G([\w\-]+)/gc and
+ /
+ \G(
+ (?: # start matching at a space followed by:
+ [\w\-] # word chars or dashes
+ | # OR
+ \. # a period
+ (?!\.) # not followed by another period
+ )
+ + # then grab as far as possible
+ )
+ /gcx and
return "\Q$1";
# ** -> capture unlimited path parts
- /\G\*\*/gc and
- return '(.*?[^/])';
+ /\G\*\*(?:(\.\*)?\:(\w+))?/gc and
+ return [ '(.*?[^/])', $1, $2 ];
# * -> capture path part
- /\G\*/gc and
- return '([^/]+?)';
+ # *:name -> capture named path part
+ /\G\*(?:(\.\*)?\:(\w+))?/gc and
+ return [ '([^/]+?)', $1, $2 ];
+
+ # :name -> capture named path part
+ /\G\:(\w+)/gc and
+ return [ '([^/]+?)', 0, $1 ];
}
return ();
}
sub _parse_param_handler {
my ($self, $spec, $type) = @_;
- require Web::Simple::ParamParser;
- my $unpacker = Web::Simple::ParamParser->can("get_unpacked_${type}_from");
-
for ($_[1]) {
my (@required, @single, %multi, $star, $multistar, %positional, $have_kw);
my %spec;
# @foo= or foo= or @foo~ or foo~
- /\G(\w+)/gc or $self->_blam('Expected parameter name');
+ /\G([\w.]*)/gc or $self->_blam('Expected parameter name');
my $name = $1;
}
} while (/\G\&/gc) }
- return sub {
- my $raw = $unpacker->($_[0]);
- Web::Dispatch::Predicates::_extract_params($raw, \%spec);
- };
+ return Web::Dispatch::Predicates->can("match_${type}")->(\%spec);
}
}