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 |
5ba2eb68 |
8 | match_extension |
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 | |
d63bcdae |
104 | 1; |