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
   9 );
  10
  11 sub match_and {
  12   my @match = @_;
  13   sub {
  14     my ($env) = @_;
  15     my $my_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   my $spec = shift;
 106   require Web::Dispatch::ParamParser;
 107   sub {
 108     _extract_params(
 109       Web::Dispatch::ParamParser::get_unpacked_query_from($_[0]),
 110       $spec
 111     )
 112   };
 113 }
 114
 115 sub match_body {
 116   my $spec = shift;
 117   require Web::Dispatch::ParamParser;
 118   sub {
 119     _extract_params(
 120       Web::Dispatch::ParamParser::get_unpacked_body_from($_[0]),
 121       $spec
 122     )
 123   };
 124 }
 125
 126 sub _extract_params {
 127   my ($raw, $spec) = @_;
 128   foreach my $name (@{$spec->{required}||[]}) {
 129     return unless exists $raw->{$name};
 130   }
 131   my @ret = (
 132     {},
 133     map {
 134       $_->{multi} ? $raw->{$_->{name}}||[] : $raw->{$_->{name}}->[-1]
 135     } @{$spec->{positional}||[]}
 136   );
 137   # separated since 'or' is short circuit
 138   my ($named, $star) = ($spec->{named}, $spec->{star});
 139   if ($named or $star) {
 140     my %kw;
 141     if ($star) {
 142       @kw{keys %$raw} = (
 143         $star->{multi}
 144           ? values %$raw
 145           : map $_->[-1], values %$raw
 146       );
 147     }
 148     foreach my $n (@{$named||[]}) {
 149       next if !$n->{multi} and !exists $raw->{$n->{name}};
 150       $kw{$n->{name}} =
 151         $n->{multi} ? $raw->{$n->{name}}||[] : $raw->{$n->{name}}->[-1];
 152     }
 153     push @ret, \%kw;
 154   }
 155   @ret;
 156 }
 157
 158 1;