Commit | Line | Data |
d63bcdae |
1 | package Web::Dispatch::Predicates; |
2 | |
3 | use strictures 1; |
659a3608 |
4 | use Exporter 'import'; |
d63bcdae |
5 | |
5ba2eb68 |
6 | our @EXPORT = qw( |
ce573717 |
7 | match_and match_or match_not match_method match_path match_path_strip |
bc878dde |
8 | match_extension match_query match_body match_uploads match_true match_false |
5ba2eb68 |
9 | ); |
d63bcdae |
10 | |
456dc2bb |
11 | sub _matcher { bless shift, 'Web::Dispatch::Matcher' } |
481da1e2 |
12 | |
bc878dde |
13 | sub match_true { |
14 | _matcher(sub { {} }); |
15 | } |
16 | |
17 | sub match_false { |
18 | _matcher(sub {}); |
19 | } |
20 | |
d63bcdae |
21 | sub match_and { |
22 | my @match = @_; |
456dc2bb |
23 | _matcher(sub { |
d63bcdae |
24 | my ($env) = @_; |
d96756e8 |
25 | my $my_env = { 'Web::Dispatch.original_env' => $env, %$env }; |
d63bcdae |
26 | my $new_env; |
27 | my @got; |
28 | foreach my $match (@match) { |
29 | if (my @this_got = $match->($my_env)) { |
4ed4fb42 |
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; |
33 | push @got, @this_got; |
d63bcdae |
34 | } else { |
4ed4fb42 |
35 | return; |
d63bcdae |
36 | } |
37 | } |
38 | return ($new_env, @got); |
481da1e2 |
39 | }) |
d63bcdae |
40 | } |
41 | |
42 | sub match_or { |
43 | my @match = @_; |
456dc2bb |
44 | _matcher(sub { |
d63bcdae |
45 | foreach my $try (@match) { |
46 | if (my @ret = $try->(@_)) { |
47 | return @ret; |
48 | } |
49 | } |
50 | return; |
481da1e2 |
51 | }) |
d63bcdae |
52 | } |
53 | |
ce573717 |
54 | sub match_not { |
55 | my ($match) = @_; |
456dc2bb |
56 | _matcher(sub { |
ce573717 |
57 | if (my @discard = $match->($_[0])) { |
58 | (); |
59 | } else { |
60 | ({}); |
61 | } |
481da1e2 |
62 | }) |
ce573717 |
63 | } |
64 | |
d63bcdae |
65 | sub match_method { |
66 | my ($method) = @_; |
456dc2bb |
67 | _matcher(sub { |
d63bcdae |
68 | my ($env) = @_; |
69 | $env->{REQUEST_METHOD} eq $method ? {} : () |
481da1e2 |
70 | }) |
d63bcdae |
71 | } |
72 | |
73 | sub match_path { |
b83ac307 |
74 | my ($re, $names) = @_; |
456dc2bb |
75 | _matcher(sub { |
d63bcdae |
76 | my ($env) = @_; |
77 | if (my @cap = ($env->{PATH_INFO} =~ /$re/)) { |
b83ac307 |
78 | $cap[0] = {}; |
79 | $cap[1] = do { my %c; @c{@$names} = splice @cap, 1; \%c } if $names; |
80 | return @cap; |
d63bcdae |
81 | } |
82 | return; |
481da1e2 |
83 | }) |
d63bcdae |
84 | } |
85 | |
86 | sub match_path_strip { |
b83ac307 |
87 | my ($re, $names) = @_; |
456dc2bb |
88 | _matcher(sub { |
d63bcdae |
89 | my ($env) = @_; |
90 | if (my @cap = ($env->{PATH_INFO} =~ /$re/)) { |
91 | $cap[0] = { |
4ed4fb42 |
92 | SCRIPT_NAME => ($env->{SCRIPT_NAME}||'').$cap[0], |
93 | PATH_INFO => pop(@cap), |
d63bcdae |
94 | }; |
b83ac307 |
95 | $cap[1] = do { my %c; @c{@$names} = splice @cap, 1; \%c } if $names; |
d63bcdae |
96 | return @cap; |
97 | } |
98 | return; |
481da1e2 |
99 | }) |
d63bcdae |
100 | } |
101 | |
5ba2eb68 |
102 | sub match_extension { |
103 | my ($extension) = @_; |
104 | my $wild = (!$extension or $extension eq '*'); |
105 | my $re = $wild |
106 | ? qr/\.(\w+)$/ |
107 | : qr/\.(\Q${extension}\E)$/; |
456dc2bb |
108 | _matcher(sub { |
5ba2eb68 |
109 | if ($_[0]->{PATH_INFO} =~ $re) { |
110 | ($wild ? ({}, $1) : {}); |
111 | } else { |
112 | (); |
113 | } |
481da1e2 |
114 | }); |
5ba2eb68 |
115 | } |
116 | |
b6bf9ed3 |
117 | sub match_query { |
456dc2bb |
118 | _matcher(_param_matcher(query => $_[0])); |
b6bf9ed3 |
119 | } |
120 | |
121 | sub match_body { |
456dc2bb |
122 | _matcher(_param_matcher(body => $_[0])); |
05aafc1a |
123 | } |
124 | |
125 | sub match_uploads { |
456dc2bb |
126 | _matcher(_param_matcher(uploads => $_[0])); |
05aafc1a |
127 | } |
128 | |
129 | sub _param_matcher { |
130 | my ($type, $spec) = @_; |
6153800d |
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 |
135 | my $saved_pos = pos; |
136 | { |
137 | local $_; |
138 | require Web::Dispatch::ParamParser; |
139 | } |
140 | pos = $saved_pos; |
05aafc1a |
141 | my $unpack = Web::Dispatch::ParamParser->can("get_unpacked_${type}_from"); |
b6bf9ed3 |
142 | sub { |
05aafc1a |
143 | _extract_params($unpack->($_[0]), $spec) |
b6bf9ed3 |
144 | }; |
145 | } |
146 | |
052bdd54 |
147 | sub _extract_params { |
148 | my ($raw, $spec) = @_; |
149 | foreach my $name (@{$spec->{required}||[]}) { |
150 | return unless exists $raw->{$name}; |
151 | } |
152 | my @ret = ( |
153 | {}, |
154 | map { |
155 | $_->{multi} ? $raw->{$_->{name}}||[] : $raw->{$_->{name}}->[-1] |
156 | } @{$spec->{positional}||[]} |
157 | ); |
158 | # separated since 'or' is short circuit |
159 | my ($named, $star) = ($spec->{named}, $spec->{star}); |
160 | if ($named or $star) { |
161 | my %kw; |
162 | if ($star) { |
163 | @kw{keys %$raw} = ( |
164 | $star->{multi} |
165 | ? values %$raw |
166 | : map $_->[-1], values %$raw |
167 | ); |
168 | } |
169 | foreach my $n (@{$named||[]}) { |
170 | next if !$n->{multi} and !exists $raw->{$n->{name}}; |
171 | $kw{$n->{name}} = |
172 | $n->{multi} ? $raw->{$n->{name}}||[] : $raw->{$n->{name}}->[-1]; |
173 | } |
174 | push @ret, \%kw; |
175 | } |
176 | @ret; |
177 | } |
178 | |
d63bcdae |
179 | 1; |