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_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_method {
  45   my ($method) = @_;
  46   sub {
  47     my ($env) = @_;
  48     $env->{REQUEST_METHOD} eq $method ? {} : ()
  49   }
  50 }
  51
  52 sub match_path {
  53   my ($re) = @_;
  54   sub {
  55     my ($env) = @_;
  56     if (my @cap = ($env->{PATH_INFO} =~ /$re/)) {
  57       $cap[0] = {}; return @cap;
  58     }
  59     return;
  60   }
  61 }
  62
  63 sub match_path_strip {
  64   my ($re) = @_;
  65   sub {
  66     my ($env) = @_;
  67     if (my @cap = ($env->{PATH_INFO} =~ /$re/)) {
  68       $cap[0] = {
  69         SCRIPT_NAME => ($env->{SCRIPT_NAME}||'').$cap[0],
  70         PATH_INFO => pop(@cap),
  71       };
  72       return @cap;
  73     }
  74     return;
  75   }
  76 }
  77
  78 sub match_extension {
  79   my ($extension) = @_;
  80   my $wild = (!$extension or $extension eq '*');
  81   my $re = $wild
  82              ? qr/\.(\w+)$/
  83              : qr/\.(\Q${extension}\E)$/;
  84   sub {
  85     if ($_[0]->{PATH_INFO} =~ $re) {
  86       ($wild ? ({}, $1) : {});
  87     } else {
  88       ();
  89     }
  90   };
  91 }
  92
  93 1;