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
   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 _extract_params {
 105   my ($raw, $spec) = @_;
 106   foreach my $name (@{$spec->{required}||[]}) {
 107     return unless exists $raw->{$name};
 108   }
 109   my @ret = (
 110     {},
 111     map {
 112       $_->{multi} ? $raw->{$_->{name}}||[] : $raw->{$_->{name}}->[-1]
 113     } @{$spec->{positional}||[]}
 114   );
 115   # separated since 'or' is short circuit
 116   my ($named, $star) = ($spec->{named}, $spec->{star});
 117   if ($named or $star) {
 118     my %kw;
 119     if ($star) {
 120       @kw{keys %$raw} = (
 121         $star->{multi}
 122           ? values %$raw
 123           : map $_->[-1], values %$raw
 124       );
 125     }
 126     foreach my $n (@{$named||[]}) {
 127       next if !$n->{multi} and !exists $raw->{$n->{name}};
 128       $kw{$n->{name}} =
 129         $n->{multi} ? $raw->{$n->{name}}||[] : $raw->{$n->{name}}->[-1];
 130     }
 131     push @ret, \%kw;
 132   }
 133   @ret;
 134 }
 135
 136 1;