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