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