use strict;
use warnings FATAL => 'all';
+sub DEBUG () { 0 }
+
+BEGIN {
+ if ($ENV{WEB_SIMPLE_DISPATCHPARSER_DEBUG}) {
+ no warnings 'redefine';
+ *DEBUG = sub () { 1 }
+ }
+}
+
+sub diag { if (DEBUG) { warn $_[0] } }
+
sub new { bless({}, ref($_[0])||$_[0]) }
sub _blam {
my ($self, $error) = @_;
- my $hat = (' ' x pos).'^';
+ my $hat = (' ' x (pos||0)).'^';
die "Error parsing dispatch specification: ${error}\n
${_}
${hat} here\n";
}
sub _parse_spec {
- my ($self, $spec) = @_;
+ my ($self, $spec, $nested) = @_;
for ($_[1]) {
my @match;
- local $self->{already_have};
/^\G\s*/; # eat leading whitespace
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;
+ 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) {
+ pos = $nested - 1;
+ $self->_blam("No closing ) found for opening (");
+ }
return $match[0] if (@match == 1);
return sub {
my $env = { %{$_[0]} };
}
}
-sub _dupe_check {
- my ($self, $type) = @_;
- $self->_blam("Can't have more than one ${type} match in a specification")
- if $self->{already_have}{$type};
- $self->{already_have}{$type} = 1;
+sub _parse_spec_combinator {
+ my ($self, $spec, $match) = @_;
+ for ($_[1]) {
+
+ /\G\+/gc and
+ return $match;
+
+ /\G\|/gc and
+ return do {
+ my @match = $match;
+ PARSE: { do {
+ push @match, $self->_parse_spec_section($_)
+ or $self->_blam("Unable to work out what the next section is");
+ last PARSE if (pos == length);
+ last PARSE unless /\G\|/gc; # give up when next thing isn't |
+ } until (pos == length) }; # accept trailing whitespace
+ return sub {
+ foreach my $try (@match) {
+ if (my @ret = $try->(@_)) {
+ return @ret;
+ }
+ }
+ return;
+ };
+ };
+ }
+ return;
}
sub _parse_spec_section {
/\G\.(\*|\w+)/gc and
return $self->_url_extension_match($_, $1);
- }
- return; # () will trigger the blam in our caller
-}
-sub _parse_spec_combinator {
- my ($self, $spec, $match) = @_;
- for ($_[1]) {
+ # (...)
- /\G\+/gc and
- return $match;
+ /\G\(/gc and
+ return $self->_parse_spec($_, pos);
- /\G\|/gc and
+ # !something
+
+ /\G!/gc and
return do {
- my @match = $match;
- PARSE: { do {
- local $self->{already_have};
- push @match, $self->_parse_spec_section($_)
- or $self->_blam("Unable to work out what the next section is");
- last PARSE if (pos == length);
- last PARSE unless /\G\|/gc; # give up when next thing isn't |
- } until (pos == length) }; # accept trailing whitespace
+ my $match = $self->_parse_spec_section($_);
return sub {
- foreach my $try (@match) {
- if (my @ret = $try->(@_)) {
- return @ret;
- }
- }
+ return {} unless $match->(@_);
return;
};
};
+
+ # ?<param spec>
+ /\G\?/gc and
+ return $self->_parse_param_handler($_, 'query');
+
+ # %<param spec>
+ /\G\%/gc and
+ return $self->_parse_param_handler($_, 'body');
}
- return;
+ return; # () will trigger the blam in our caller
}
sub _http_method_match {
my ($self, $str, $method) = @_;
- $self->_dupe_check('method');
sub { shift->{REQUEST_METHOD} eq $method ? {} : () };
}
sub _url_path_match {
my ($self) = @_;
- $self->_dupe_check('path');
for ($_[1]) {
my @path;
- while (/\G\//gc) {
+ my $full_path = '$';
+ PATH: while (/\G\//gc) {
+ /\G\.\.\./gc
+ and do {
+ $full_path = '';
+ last PATH;
+ };
push @path, $self->_url_path_segment_match($_)
or $self->_blam("Couldn't parse path match segment");
}
- my $re = '^()'.join('/','',@path).'$';
+ my $re = '^()'.join('/','',@path).($full_path ? '$' : '(/.*)$');
+ $re = qr/$re/;
+ if ($full_path) {
+ return sub {
+ if (my @cap = (shift->{PATH_INFO} =~ /$re/)) {
+ $cap[0] = {}; return @cap;
+ }
+ return ();
+ };
+ }
return sub {
if (my @cap = (shift->{PATH_INFO} =~ /$re/)) {
- $cap[0] = {}; return @cap;
+ $cap[0] = { PATH_INFO => pop(@cap) }; return @cap;
}
return ();
};
my ($self) = @_;
for ($_[1]) {
# trailing / -> require / on end of URL
- /\G(?:(?=\s)|$)/gc and
+ /\G(?:(?=[+|\)])|$)/gc and
return '$';
# word chars only -> exact path part match
/\G(\w+)/gc and
sub _url_extension_match {
my ($self, $str, $extension) = @_;
- $self->_dupe_check('extension');
if ($extension eq '*') {
sub {
if ((my $tmp = shift->{PATH_INFO}) =~ s/\.(\w+)$//) {
}
}
+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 $pos_idx = 0;
+ PARAM: { do {
+
+ # ?:foo or ?@:foo
+
+ my $is_kw = /\G\:/gc;
+
+ # ?@foo or ?@*
+
+ my $multi = /\G\@/gc;
+
+ # @* or *
+
+ if (/\G\*/gc) {
+
+ $self->_blam("* is always named; no need to supply :") if $is_kw;
+
+ $multi ? ($multistar = 1) : ($star = 1);
+
+ $have_kw = 1;
+
+ if ($star && $multistar) {
+ $self->_blam("Can't use * and \@* in the same parameter match");
+ }
+ } else {
+
+ # @foo= or foo= or @foo~ or foo~
+
+ /\G(\w+)/gc or $self->_blam('Expected parameter name');
+
+ my $name = $1;
+
+ # check for = or ~ on the end
+
+ /\G\=/gc
+ ? push(@required, $name)
+ : (/\G\~/gc or $self->_blam('Expected = or ~ after parameter name'));
+
+ # record the key in the right category depending on the multi (@) flag
+
+ $multi ? ($multi{$name} = 1) : (push @single, $name);
+
+ # record positional or keyword
+
+ $is_kw ? ($have_kw = 1) : ($positional{$name} = $pos_idx++);
+ }
+ } while (/\G\&/gc) }
+
+ return sub {
+ my $raw = $unpacker->($_[0]);
+ foreach my $name (@required) {
+ return unless exists $raw->{$name};
+ }
+ my (%p, %done);
+ my @p = (undef) x $pos_idx;
+ foreach my $name (
+ @single,
+ ($star
+ ? (grep { !exists $multi{$_} } keys %$raw)
+ : ()
+ )
+ ) {
+ if (exists $raw->{$name}) {
+ if (exists $positional{$name}) {
+ $p[$positional{$name}] = $raw->{$name}->[-1];
+ } else {
+ $p{$name} = $raw->{$name}->[-1];
+ }
+ }
+ $done{$name} = 1;
+ }
+ foreach my $name (
+ keys %multi,
+ ($multistar
+ ? (grep { !exists $done{$_} && !exists $multi{$_} } keys %$raw)
+ : ()
+ )
+ ) {
+ if (exists $positional{$name}) {
+ $p[$positional{$name}] = $raw->{$name}||[];
+ } else {
+ $p{$name} = $raw->{$name}||[];
+ }
+ }
+ $p[$pos_idx] = \%p if $have_kw;
+ return ({}, @p);
+ };
+ }
+}
+
1;
projects / catagits/Web-Simple.git / blobdiff