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 _matcher { bless shift, 'Web::Dispatch::Matcher' }
  12
  13 sub match_and {
  14   my @match = @_;
  15   _matcher(sub {
  16     my ($env) = @_;
  17     my $my_env = { 'Web::Dispatch.original_env' => $env, %$env };
  18     my $new_env;
  19     my @got;
  20     foreach my $match (@match) {
  21       if (my @this_got = $match->($my_env)) {
  22         my %change_env = %{shift(@this_got)};
  23         @{$my_env}{keys %change_env} = values %change_env;
  24         @{$new_env}{keys %change_env} = values %change_env;
  25         push @got, @this_got;
  26       } else {
  27         return;
  28       }
  29     }
  30     return ($new_env, @got);
  31   })
  32 }
  33
  34 sub match_or {
  35   my @match = @_;
  36   _matcher(sub {
  37     foreach my $try (@match) {
  38       if (my @ret = $try->(@_)) {
  39         return @ret;
  40       }
  41     }
  42     return;
  43   })
  44 }
  45
  46 sub match_not {
  47   my ($match) = @_;
  48   _matcher(sub {
  49     if (my @discard = $match->($_[0])) {
  50       ();
  51     } else {
  52       ({});
  53     }
  54   })
  55 }
  56
  57 sub match_method {
  58   my ($method) = @_;
  59   _matcher(sub {
  60     my ($env) = @_;
  61     $env->{REQUEST_METHOD} eq $method ? {} : ()
  62   })
  63 }
  64
  65 sub match_path {
  66   my ($re) = @_;
  67   _matcher(sub {
  68     my ($env) = @_;
  69     if (my @cap = ($env->{PATH_INFO} =~ /$re/)) {
  70       $cap[0] = {}; return @cap;
  71     }
  72     return;
  73   })
  74 }
  75
  76 sub match_path_strip {
  77   my ($re) = @_;
  78   _matcher(sub {
  79     my ($env) = @_;
  80     if (my @cap = ($env->{PATH_INFO} =~ /$re/)) {
  81       $cap[0] = {
  82         SCRIPT_NAME => ($env->{SCRIPT_NAME}||'').$cap[0],
  83         PATH_INFO => pop(@cap),
  84       };
  85       return @cap;
  86     }
  87     return;
  88   })
  89 }
  90
  91 sub match_extension {
  92   my ($extension) = @_;
  93   my $wild = (!$extension or $extension eq '*');
  94   my $re = $wild
  95              ? qr/\.(\w+)$/
  96              : qr/\.(\Q${extension}\E)$/;
  97   _matcher(sub {
  98     if ($_[0]->{PATH_INFO} =~ $re) {
  99       ($wild ? ({}, $1) : {});
 100     } else {
 101       ();
 102     }
 103    });
 104 }
 105
 106 sub match_query {
 107   _matcher(_param_matcher(query => $_[0]));
 108 }
 109
 110 sub match_body {
 111   _matcher(_param_matcher(body => $_[0]));
 112 }
 113
 114 sub match_uploads {
 115   _matcher(_param_matcher(uploads => $_[0]));
 116 }
 117
 118 sub _param_matcher {
 119   my ($type, $spec) = @_;
 120   require Web::Dispatch::ParamParser;
 121   my $unpack = Web::Dispatch::ParamParser->can("get_unpacked_${type}_from");
 122   sub {
 123     _extract_params($unpack->($_[0]), $spec)
 124   };
 125 }
 126
 127 sub _extract_params {
 128   my ($raw, $spec) = @_;
 129   foreach my $name (@{$spec->{required}||[]}) {
 130     return unless exists $raw->{$name};
 131   }
 132   my @ret = (
 133     {},
 134     map {
 135       $_->{multi} ? $raw->{$_->{name}}||[] : $raw->{$_->{name}}->[-1]
 136     } @{$spec->{positional}||[]}
 137   );
 138   # separated since 'or' is short circuit
 139   my ($named, $star) = ($spec->{named}, $spec->{star});
 140   if ($named or $star) {
 141     my %kw;
 142     if ($star) {
 143       @kw{keys %$raw} = (
 144         $star->{multi}
 145           ? values %$raw
 146           : map $_->[-1], values %$raw
 147       );
 148     }
 149     foreach my $n (@{$named||[]}) {
 150       next if !$n->{multi} and !exists $raw->{$n->{name}};
 151       $kw{$n->{name}} =
 152         $n->{multi} ? $raw->{$n->{name}}||[] : $raw->{$n->{name}}->[-1];
 153     }
 154     push @ret, \%kw;
 155   }
 156   @ret;
 157 }
 158
 159 1;