use strictures 1;
use base qw(Exporter);
-our @EXPORT = qw(match_and match_or match_method match_path match_path_strip);
+our @EXPORT = qw(
+ match_and match_or match_not match_method match_path match_path_strip
+ match_extension match_query match_body match_uploads
+);
sub match_and {
my @match = @_;
my @got;
foreach my $match (@match) {
if (my @this_got = $match->($my_env)) {
- my %change_env = %{shift(@this_got)};
- @{$my_env}{keys %change_env} = values %change_env;
- @{$new_env}{keys %change_env} = values %change_env;
- push @got, @this_got;
+ my %change_env = %{shift(@this_got)};
+ @{$my_env}{keys %change_env} = values %change_env;
+ @{$new_env}{keys %change_env} = values %change_env;
+ push @got, @this_got;
} else {
- return;
+ return;
}
}
return ($new_env, @got);
}
}
+sub match_not {
+ my ($match) = @_;
+ sub {
+ if (my @discard = $match->($_[0])) {
+ ();
+ } else {
+ ({});
+ }
+ }
+}
+
sub match_method {
my ($method) = @_;
sub {
my ($env) = @_;
if (my @cap = ($env->{PATH_INFO} =~ /$re/)) {
$cap[0] = {
- SCRIPT_NAME => ($env->{SCRIPT_NAME}||'').$cap[0],
- PATH_INFO => pop(@cap),
+ SCRIPT_NAME => ($env->{SCRIPT_NAME}||'').$cap[0],
+ PATH_INFO => pop(@cap),
};
return @cap;
}
}
}
+sub match_extension {
+ my ($extension) = @_;
+ my $wild = (!$extension or $extension eq '*');
+ my $re = $wild
+ ? qr/\.(\w+)$/
+ : qr/\.(\Q${extension}\E)$/;
+ sub {
+ if ($_[0]->{PATH_INFO} =~ $re) {
+ ($wild ? ({}, $1) : {});
+ } else {
+ ();
+ }
+ };
+}
+
+sub match_query {
+ _param_matcher(query => $_[0]);
+}
+
+sub match_body {
+ _param_matcher(body => $_[0]);
+}
+
+sub match_uploads {
+ _param_matcher(uploads => $_[0]);
+}
+
+sub _param_matcher {
+ my ($type, $spec) = @_;
+ require Web::Dispatch::ParamParser;
+ my $unpack = Web::Dispatch::ParamParser->can("get_unpacked_${type}_from");
+ sub {
+ _extract_params($unpack->($_[0]), $spec)
+ };
+}
+
+sub _extract_params {
+ my ($raw, $spec) = @_;
+ foreach my $name (@{$spec->{required}||[]}) {
+ return unless exists $raw->{$name};
+ }
+ my @ret = (
+ {},
+ map {
+ $_->{multi} ? $raw->{$_->{name}}||[] : $raw->{$_->{name}}->[-1]
+ } @{$spec->{positional}||[]}
+ );
+ # separated since 'or' is short circuit
+ my ($named, $star) = ($spec->{named}, $spec->{star});
+ if ($named or $star) {
+ my %kw;
+ if ($star) {
+ @kw{keys %$raw} = (
+ $star->{multi}
+ ? values %$raw
+ : map $_->[-1], values %$raw
+ );
+ }
+ foreach my $n (@{$named||[]}) {
+ next if !$n->{multi} and !exists $raw->{$n->{name}};
+ $kw{$n->{name}} =
+ $n->{multi} ? $raw->{$n->{name}}||[] : $raw->{$n->{name}}->[-1];
+ }
+ push @ret, \%kw;
+ }
+ @ret;
+}
+
1;