lib/Web/Dispatch/Predicates.pm

   1 package Web::Dispatch::Predicates;
   2
   3 use strictures 1;
   4 use base qw(Exporter);
   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) = @_;
  75   _matcher(sub {
  76     my ($env) = @_;
  77     if (my @cap = ($env->{PATH_INFO} =~ /$re/)) {
  78       $cap[0] = {}; return @cap;
  79     }
  80     return;
  81   })
  82 }
  83
  84 sub match_path_strip {
  85   my ($re) = @_;
  86   _matcher(sub {
  87     my ($env) = @_;
  88     if (my @cap = ($env->{PATH_INFO} =~ /$re/)) {
  89       $cap[0] = {
  90         SCRIPT_NAME => ($env->{SCRIPT_NAME}||'').$cap[0],
  91         PATH_INFO => pop(@cap),
  92       };
  93       return @cap;
  94     }
  95     return;
  96   })
  97 }
  98
  99 sub match_extension {
 100   my ($extension) = @_;
 101   my $wild = (!$extension or $extension eq '*');
 102   my $re = $wild
 103              ? qr/\.(\w+)$/
 104              : qr/\.(\Q${extension}\E)$/;
 105   _matcher(sub {
 106     if ($_[0]->{PATH_INFO} =~ $re) {
 107       ($wild ? ({}, $1) : {});
 108     } else {
 109       ();
 110     }
 111    });
 112 }
 113
 114 sub match_query {
 115   _matcher(_param_matcher(query => $_[0]));
 116 }
 117
 118 sub match_body {
 119   _matcher(_param_matcher(body => $_[0]));
 120 }
 121
 122 sub match_uploads {
 123   _matcher(_param_matcher(uploads => $_[0]));
 124 }
 125
 126 sub _param_matcher {
 127   my ($type, $spec) = @_;
 128   # We're probably parsing a match spec while building the parser, and
 129   # on 5.8.8, loading ParamParser loads Encode which blows away $_ and pos.
 130   # Furthermore, localizing $_ doesn't restore pos afterwards. So do this
 131   # stupid thing instead to work on 5.8.8
 132   my $saved_pos = pos;
 133   {
 134     local $_;
 135     require Web::Dispatch::ParamParser;
 136   }
 137   pos = $saved_pos;
 138   my $unpack = Web::Dispatch::ParamParser->can("get_unpacked_${type}_from");
 139   sub {
 140     _extract_params($unpack->($_[0]), $spec)
 141   };
 142 }
 143
 144 sub _extract_params {
 145   my ($raw, $spec) = @_;
 146   foreach my $name (@{$spec->{required}||[]}) {
 147     return unless exists $raw->{$name};
 148   }
 149   my @ret = (
 150     {},
 151     map {
 152       $_->{multi} ? $raw->{$_->{name}}||[] : $raw->{$_->{name}}->[-1]
 153     } @{$spec->{positional}||[]}
 154   );
 155   # separated since 'or' is short circuit
 156   my ($named, $star) = ($spec->{named}, $spec->{star});
 157   if ($named or $star) {
 158     my %kw;
 159     if ($star) {
 160       @kw{keys %$raw} = (
 161         $star->{multi}
 162           ? values %$raw
 163           : map $_->[-1], values %$raw
 164       );
 165     }
 166     foreach my $n (@{$named||[]}) {
 167       next if !$n->{multi} and !exists $raw->{$n->{name}};
 168       $kw{$n->{name}} =
 169         $n->{multi} ? $raw->{$n->{name}}||[] : $raw->{$n->{name}}->[-1];
 170     }
 171     push @ret, \%kw;
 172   }
 173   @ret;
 174 }
 175
 176 1;