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
   9 );
  10
  11 sub match_and {
  12   my @match = @_;
  13   sub {
  14     my ($env) = @_;
  15     my $my_env = { 'Web::Dispatch.original_env' => $env, %$env };
  16     my $new_env;
  17     my @got;
  18     foreach my $match (@match) {
  19       if (my @this_got = $match->($my_env)) {
  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;
  24       } else {
  25         return;
  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
  44 sub match_not {
  45   my ($match) = @_;
  46   sub {
  47     if (my @discard = $match->($_[0])) {
  48       ();
  49     } else {
  50       ({});
  51     }
  52   }
  53 }
  54
  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] = {
  80         SCRIPT_NAME => ($env->{SCRIPT_NAME}||'').$cap[0],
  81         PATH_INFO => pop(@cap),
  82       };
  83       return @cap;
  84     }
  85     return;
  86   }
  87 }
  88
  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
 104 sub match_query {
 105   _param_matcher(query => $_[0]);
 106 }
 107
 108 sub match_body {
 109   _param_matcher(body => $_[0]);
 110 }
 111
 112 sub match_uploads {
 113   _param_matcher(uploads => $_[0]);
 114 }
 115
 116 sub _param_matcher {
 117   my ($type, $spec) = @_;
 118   require Web::Dispatch::ParamParser;
 119   my $unpack = Web::Dispatch::ParamParser->can("get_unpacked_${type}_from");
 120   sub {
 121     _extract_params($unpack->($_[0]), $spec)
 122   };
 123 }
 124
 125 sub _extract_params {
 126   my ($raw, $spec) = @_;
 127   foreach my $name (@{$spec->{required}||[]}) {
 128     return unless exists $raw->{$name};
 129   }
 130   my @ret = (
 131     {},
 132     map {
 133       $_->{multi} ? $raw->{$_->{name}}||[] : $raw->{$_->{name}}->[-1]
 134     } @{$spec->{positional}||[]}
 135   );
 136   # separated since 'or' is short circuit
 137   my ($named, $star) = ($spec->{named}, $spec->{star});
 138   if ($named or $star) {
 139     my %kw;
 140     if ($star) {
 141       @kw{keys %$raw} = (
 142         $star->{multi}
 143           ? values %$raw
 144           : map $_->[-1], values %$raw
 145       );
 146     }
 147     foreach my $n (@{$named||[]}) {
 148       next if !$n->{multi} and !exists $raw->{$n->{name}};
 149       $kw{$n->{name}} =
 150         $n->{multi} ? $raw->{$n->{name}}||[] : $raw->{$n->{name}}->[-1];
 151     }
 152     push @ret, \%kw;
 153   }
 154   @ret;
 155 }
 156
 157 1;