lib/Web/Dispatch/Predicates.pm

   1 package Web::Dispatch::Predicates;
   2
   3 use strictures 1;
   4 use Exporter 'import';
   5
   6 our @EXPORT = qw(
   7   match_and match_or match_not match_method match_path match_path_strip
   8   match_extension match_query match_body match_uploads match_true match_false
   9 );
  10
  11 sub _matcher { bless shift, 'Web::Dispatch::Matcher' }
  12
  13 sub match_true {
  14   _matcher(sub { {} });
  15 }
  16
  17 sub match_false {
  18   _matcher(sub {});
  19 }
  20
  21 sub match_and {
  22   my @match = @_;
  23   _matcher(sub {
  24     my ($env) = @_;
  25     my $my_env = { 'Web::Dispatch.original_env' => $env, %$env };
  26     my $new_env;
  27     my @got;
  28     foreach my $match (@match) {
  29       if (my @this_got = $match->($my_env)) {
  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;
  34       } else {
  35         return;
  36       }
  37     }
  38     return ($new_env, @got);
  39   })
  40 }
  41
  42 sub match_or {
  43   my @match = @_;
  44   _matcher(sub {
  45     foreach my $try (@match) {
  46       if (my @ret = $try->(@_)) {
  47         return @ret;
  48       }
  49     }
  50     return;
  51   })
  52 }
  53
  54 sub match_not {
  55   my ($match) = @_;
  56   _matcher(sub {
  57     if (my @discard = $match->($_[0])) {
  58       ();
  59     } else {
  60       ({});
  61     }
  62   })
  63 }
  64
  65 sub match_method {
  66   my ($method) = @_;
  67   _matcher(sub {
  68     my ($env) = @_;
  69     $env->{REQUEST_METHOD} eq $method ? {} : ()
  70   })
  71 }
  72
  73 sub match_path {
  74   my ($re, $names) = @_;
  75   _matcher(sub {
  76     my ($env) = @_;
  77     if (my @cap = ($env->{PATH_INFO} =~ /$re/)) {
  78       $cap[0] = {};
  79       $cap[1] = do { my %c; @c{@$names} = splice @cap, 1; \%c } if $names;
  80       return @cap;
  81     }
  82     return;
  83   })
  84 }
  85
  86 sub match_path_strip {
  87   my ($re, $names) = @_;
  88   _matcher(sub {
  89     my ($env) = @_;
  90     if (my @cap = ($env->{PATH_INFO} =~ /$re/)) {
  91       $cap[0] = {
  92         SCRIPT_NAME => ($env->{SCRIPT_NAME}||'').$cap[0],
  93         PATH_INFO => pop(@cap),
  94       };
  95       $cap[1] = do { my %c; @c{@$names} = splice @cap, 1; \%c } if $names;
  96       return @cap;
  97     }
  98     return;
  99   })
 100 }
 101
 102 sub match_extension {
 103   my ($extension) = @_;
 104   my $wild = (!$extension or $extension eq '*');
 105   my $re = $wild
 106              ? qr/\.(\w+)$/
 107              : qr/\.(\Q${extension}\E)$/;
 108   _matcher(sub {
 109     if ($_[0]->{PATH_INFO} =~ $re) {
 110       ($wild ? ({}, $1) : {});
 111     } else {
 112       ();
 113     }
 114    });
 115 }
 116
 117 sub match_query {
 118   _matcher(_param_matcher(query => $_[0]));
 119 }
 120
 121 sub match_body {
 122   _matcher(_param_matcher(body => $_[0]));
 123 }
 124
 125 sub match_uploads {
 126   _matcher(_param_matcher(uploads => $_[0]));
 127 }
 128
 129 sub _param_matcher {
 130   my ($type, $spec) = @_;
 131   # We're probably parsing a match spec while building the parser, and
 132   # on 5.8.8, loading ParamParser loads Encode which blows away $_ and pos.
 133   # Furthermore, localizing $_ doesn't restore pos afterwards. So do this
 134   # stupid thing instead to work on 5.8.8
 135   my $saved_pos = pos;
 136   {
 137     local $_;
 138     require Web::Dispatch::ParamParser;
 139   }
 140   pos = $saved_pos;
 141   my $unpack = Web::Dispatch::ParamParser->can("get_unpacked_${type}_from");
 142   sub {
 143     _extract_params($unpack->($_[0]), $spec)
 144   };
 145 }
 146
 147 sub _extract_params {
 148   my ($raw, $spec) = @_;
 149   foreach my $name (@{$spec->{required}||[]}) {
 150     return unless exists $raw->{$name};
 151   }
 152   my @ret = (
 153     {},
 154     map {
 155       $_->{multi} ? $raw->{$_->{name}}||[] : $raw->{$_->{name}}->[-1]
 156     } @{$spec->{positional}||[]}
 157   );
 158   # separated since 'or' is short circuit
 159   my ($named, $star) = ($spec->{named}, $spec->{star});
 160   if ($named or $star) {
 161     my %kw;
 162     if ($star) {
 163       @kw{keys %$raw} = (
 164         $star->{multi}
 165           ? values %$raw
 166           : map $_->[-1], values %$raw
 167       );
 168     }
 169     foreach my $n (@{$named||[]}) {
 170       next if !$n->{multi} and !exists $raw->{$n->{name}};
 171       $kw{$n->{name}} =
 172         $n->{multi} ? $raw->{$n->{name}}||[] : $raw->{$n->{name}}->[-1];
 173     }
 174     push @ret, \%kw;
 175   }
 176   @ret;
 177 }
 178
 179 1;