Commit | Line | Data |
d63bcdae |
1 | package Web::Dispatch::Predicates; |
2 | |
3 | use strictures 1; |
4 | use base qw(Exporter); |
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 { |
74 | my ($re) = @_; |
456dc2bb |
75 | _matcher(sub { |
d63bcdae |
76 | my ($env) = @_; |
77 | if (my @cap = ($env->{PATH_INFO} =~ /$re/)) { |
78 | $cap[0] = {}; return @cap; |
79 | } |
80 | return; |
481da1e2 |
81 | }) |
d63bcdae |
82 | } |
83 | |
84 | sub match_path_strip { |
85 | my ($re) = @_; |
456dc2bb |
86 | _matcher(sub { |
d63bcdae |
87 | my ($env) = @_; |
88 | if (my @cap = ($env->{PATH_INFO} =~ /$re/)) { |
89 | $cap[0] = { |
4ed4fb42 |
90 | SCRIPT_NAME => ($env->{SCRIPT_NAME}||'').$cap[0], |
91 | PATH_INFO => pop(@cap), |
d63bcdae |
92 | }; |
93 | return @cap; |
94 | } |
95 | return; |
481da1e2 |
96 | }) |
d63bcdae |
97 | } |
98 | |
5ba2eb68 |
99 | sub match_extension { |
100 | my ($extension) = @_; |
101 | my $wild = (!$extension or $extension eq '*'); |
102 | my $re = $wild |
103 | ? qr/\.(\w+)$/ |
104 | : qr/\.(\Q${extension}\E)$/; |
456dc2bb |
105 | _matcher(sub { |
5ba2eb68 |
106 | if ($_[0]->{PATH_INFO} =~ $re) { |
107 | ($wild ? ({}, $1) : {}); |
108 | } else { |
109 | (); |
110 | } |
481da1e2 |
111 | }); |
5ba2eb68 |
112 | } |
113 | |
b6bf9ed3 |
114 | sub match_query { |
456dc2bb |
115 | _matcher(_param_matcher(query => $_[0])); |
b6bf9ed3 |
116 | } |
117 | |
118 | sub match_body { |
456dc2bb |
119 | _matcher(_param_matcher(body => $_[0])); |
05aafc1a |
120 | } |
121 | |
122 | sub match_uploads { |
456dc2bb |
123 | _matcher(_param_matcher(uploads => $_[0])); |
05aafc1a |
124 | } |
125 | |
126 | sub _param_matcher { |
127 | my ($type, $spec) = @_; |
6153800d |
128 | # We're probably parsing a match spec while building the parser, and |
129 | # on 5.8.8, loading ParamParser loads Encode which blows away $_ and pos. |
130 | # Furthermore, localizing $_ doesn't restore pos afterwards. So do this |
131 | # stupid thing instead to work on 5.8.8 |
132 | my $saved_pos = pos; |
133 | { |
134 | local $_; |
135 | require Web::Dispatch::ParamParser; |
136 | } |
137 | pos = $saved_pos; |
05aafc1a |
138 | my $unpack = Web::Dispatch::ParamParser->can("get_unpacked_${type}_from"); |
b6bf9ed3 |
139 | sub { |
05aafc1a |
140 | _extract_params($unpack->($_[0]), $spec) |
b6bf9ed3 |
141 | }; |
142 | } |
143 | |
052bdd54 |
144 | sub _extract_params { |
145 | my ($raw, $spec) = @_; |
146 | foreach my $name (@{$spec->{required}||[]}) { |
147 | return unless exists $raw->{$name}; |
148 | } |
149 | my @ret = ( |
150 | {}, |
151 | map { |
152 | $_->{multi} ? $raw->{$_->{name}}||[] : $raw->{$_->{name}}->[-1] |
153 | } @{$spec->{positional}||[]} |
154 | ); |
155 | # separated since 'or' is short circuit |
156 | my ($named, $star) = ($spec->{named}, $spec->{star}); |
157 | if ($named or $star) { |
158 | my %kw; |
159 | if ($star) { |
160 | @kw{keys %$raw} = ( |
161 | $star->{multi} |
162 | ? values %$raw |
163 | : map $_->[-1], values %$raw |
164 | ); |
165 | } |
166 | foreach my $n (@{$named||[]}) { |
167 | next if !$n->{multi} and !exists $raw->{$n->{name}}; |
168 | $kw{$n->{name}} = |
169 | $n->{multi} ? $raw->{$n->{name}}||[] : $raw->{$n->{name}}->[-1]; |
170 | } |
171 | push @ret, \%kw; |
172 | } |
173 | @ret; |
174 | } |
175 | |
d63bcdae |
176 | 1; |