Commit | Line | Data |
d63bcdae |
1 | package Web::Dispatch::Predicates; |
2 | |
3 | use strictures 1; |
4 | use base qw(Exporter); |
5 | |
6 | our @EXPORT = qw(match_and match_or match_method match_path match_path_strip); |
7 | |
8 | sub match_and { |
9 | my @match = @_; |
10 | sub { |
11 | my ($env) = @_; |
12 | my $my_env = { %$env }; |
13 | my $new_env; |
14 | my @got; |
15 | foreach my $match (@match) { |
16 | if (my @this_got = $match->($my_env)) { |
17 | my %change_env = %{shift(@this_got)}; |
18 | @{$my_env}{keys %change_env} = values %change_env; |
19 | @{$new_env}{keys %change_env} = values %change_env; |
20 | push @got, @this_got; |
21 | } else { |
22 | return; |
23 | } |
24 | } |
25 | return ($new_env, @got); |
26 | } |
27 | } |
28 | |
29 | sub match_or { |
30 | my @match = @_; |
31 | sub { |
32 | foreach my $try (@match) { |
33 | if (my @ret = $try->(@_)) { |
34 | return @ret; |
35 | } |
36 | } |
37 | return; |
38 | } |
39 | } |
40 | |
41 | sub match_method { |
42 | my ($method) = @_; |
43 | sub { |
44 | my ($env) = @_; |
45 | $env->{REQUEST_METHOD} eq $method ? {} : () |
46 | } |
47 | } |
48 | |
49 | sub match_path { |
50 | my ($re) = @_; |
51 | sub { |
52 | my ($env) = @_; |
53 | if (my @cap = ($env->{PATH_INFO} =~ /$re/)) { |
54 | $cap[0] = {}; return @cap; |
55 | } |
56 | return; |
57 | } |
58 | } |
59 | |
60 | sub match_path_strip { |
61 | my ($re) = @_; |
62 | sub { |
63 | my ($env) = @_; |
64 | if (my @cap = ($env->{PATH_INFO} =~ /$re/)) { |
65 | $cap[0] = { |
66 | SCRIPT_NAME => ($env->{SCRIPT_NAME}||'').$cap[0], |
67 | PATH_INFO => pop(@cap), |
68 | }; |
69 | return @cap; |
70 | } |
71 | return; |
72 | } |
73 | } |
74 | |
75 | 1; |