1 package Web::Dispatch::Predicates;
7 match_and match_or match_not match_method match_path match_path_strip
8 match_extension match_query match_body match_uploads match_true match_false
11 sub _matcher { bless shift, 'Web::Dispatch::Matcher' }
25 my $my_env = { 'Web::Dispatch.original_env' => $env, %$env };
28 foreach my $match (@match) {
29 if (my @this_got = $match->($my_env)) {
30 my %change_env = %{shift(@this_got)};
31 @{$my_env}{keys %change_env} = values %change_env;
32 @{$new_env}{keys %change_env} = values %change_env;
38 return ($new_env, @got);
45 foreach my $try (@match) {
46 if (my @ret = $try->(@_)) {
57 if (my @discard = $match->($_[0])) {
69 $env->{REQUEST_METHOD} eq $method ? {} : ()
74 my ($re, $names) = @_;
77 if (my @cap = ($env->{PATH_INFO} =~ /$re/)) {
79 $cap[1] = do { my %c; @c{@$names} = splice @cap, 1; \%c } if $names;
86 sub match_path_strip {
87 my ($re, $names) = @_;
90 if (my @cap = ($env->{PATH_INFO} =~ /$re/)) {
92 SCRIPT_NAME => ($env->{SCRIPT_NAME}||'').$cap[0],
93 PATH_INFO => pop(@cap),
95 $cap[1] = do { my %c; @c{@$names} = splice @cap, 1; \%c } if $names;
102 sub match_extension {
103 my ($extension) = @_;
104 my $wild = (!$extension or $extension eq '*');
107 : qr/\.(\Q${extension}\E)$/;
109 if ($_[0]->{PATH_INFO} =~ $re) {
110 ($wild ? ({}, $1) : {});
118 _matcher(_param_matcher(query => $_[0]));
122 _matcher(_param_matcher(body => $_[0]));
126 _matcher(_param_matcher(uploads => $_[0]));
130 my ($type, $spec) = @_;
131 # We're probably parsing a match spec while building the parser, and
132 # on 5.8.8, loading ParamParser loads Encode which blows away $_ and pos.
133 # Furthermore, localizing $_ doesn't restore pos afterwards. So do this
134 # stupid thing instead to work on 5.8.8
138 require Web::Dispatch::ParamParser;
141 my $unpack = Web::Dispatch::ParamParser->can("get_unpacked_${type}_from");
143 _extract_params($unpack->($_[0]), $spec)
147 sub _extract_params {
148 my ($raw, $spec) = @_;
149 foreach my $name (@{$spec->{required}||[]}) {
150 return unless exists $raw->{$name};
155 $_->{multi} ? $raw->{$_->{name}}||[] : $raw->{$_->{name}}->[-1]
156 } @{$spec->{positional}||[]}
158 # separated since 'or' is short circuit
159 my ($named, $star) = ($spec->{named}, $spec->{star});
160 if ($named or $star) {
166 : map $_->[-1], values %$raw
169 foreach my $n (@{$named||[]}) {
170 next if !$n->{multi} and !exists $raw->{$n->{name}};
172 $n->{multi} ? $raw->{$n->{name}}||[] : $raw->{$n->{name}}->[-1];