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   require Web::Dispatch::ParamParser;
 129   my $unpack = Web::Dispatch::ParamParser->can("get_unpacked_${type}_from");
 130   sub {
 131     _extract_params($unpack->($_[0]), $spec)
 132   };
 133 }
 134
 135 sub _extract_params {
 136   my ($raw, $spec) = @_;
 137   foreach my $name (@{$spec->{required}||[]}) {
 138     return unless exists $raw->{$name};
 139   }
 140   my @ret = (
 141     {},
 142     map {
 143       $_->{multi} ? $raw->{$_->{name}}||[] : $raw->{$_->{name}}->[-1]
 144     } @{$spec->{positional}||[]}
 145   );
 146   # separated since 'or' is short circuit
 147   my ($named, $star) = ($spec->{named}, $spec->{star});
 148   if ($named or $star) {
 149     my %kw;
 150     if ($star) {
 151       @kw{keys %$raw} = (
 152         $star->{multi}
 153           ? values %$raw
 154           : map $_->[-1], values %$raw
 155       );
 156     }
 157     foreach my $n (@{$named||[]}) {
 158       next if !$n->{multi} and !exists $raw->{$n->{name}};
 159       $kw{$n->{name}} =
 160         $n->{multi} ? $raw->{$n->{name}}||[] : $raw->{$n->{name}}->[-1];
 161     }
 162     push @ret, \%kw;
 163   }
 164   @ret;
 165 }
 166
 167 1;