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(match_and match_or match_method match_path match_path_strip);
   7
   8 sub match_and {
   9   my @match = @_;
  10   sub {
  11     my ($env) = @_;
  12     my $my_env = { %$env };
  13     my $new_env;
  14     my @got;
  15     foreach my $match (@match) {
  16       if (my @this_got = $match->($my_env)) {
  17         my %change_env = %{shift(@this_got)};
  18         @{$my_env}{keys %change_env} = values %change_env;
  19         @{$new_env}{keys %change_env} = values %change_env;
  20         push @got, @this_got;
  21       } else {
  22         return;
  23       }
  24     }
  25     return ($new_env, @got);
  26   }
  27 }
  28
  29 sub match_or {
  30   my @match = @_;
  31   sub {
  32     foreach my $try (@match) {
  33       if (my @ret = $try->(@_)) {
  34         return @ret;
  35       }
  36     }
  37     return;
  38   }
  39 }
  40
  41 sub match_method {
  42   my ($method) = @_;
  43   sub {
  44     my ($env) = @_;
  45     $env->{REQUEST_METHOD} eq $method ? {} : ()
  46   }
  47 }
  48
  49 sub match_path {
  50   my ($re) = @_;
  51   sub {
  52     my ($env) = @_;
  53     if (my @cap = ($env->{PATH_INFO} =~ /$re/)) {
  54       $cap[0] = {}; return @cap;
  55     }
  56     return;
  57   }
  58 }
  59
  60 sub match_path_strip {
  61   my ($re) = @_;
  62   sub {
  63     my ($env) = @_;
  64     if (my @cap = ($env->{PATH_INFO} =~ /$re/)) {
  65       $cap[0] = {
  66         SCRIPT_NAME => ($env->{SCRIPT_NAME}||'').$cap[0],
  67         PATH_INFO => pop(@cap),
  68       };
  69       return @cap;
  70     }
  71     return;
  72   }
  73 }
  74
  75 1;