lib/Catalyst/DispatchType/Regex.pm

   1 package Catalyst::DispatchType::Regex;
   2
   3 use Moose;
   4 extends 'Catalyst::DispatchType::Path';
   5 use Text::SimpleTable;
   6 use Text::Balanced ();
   7
   8 has _compiled => (is => 'rw', isa => 'ArrayRef', required => 1, default => sub{[]});
   9
  10 =head1 NAME
  11
  12 Catalyst::DispatchType::Regex - Regex DispatchType
  13
  14 =head1 SYNOPSIS
  15
  16 See L<Catalyst>.
  17
  18 =head1 DESCRIPTION
  19
  20 =head1 METHODS
  21
  22 =head2 $self->list($c)
  23
  24 Output a table of all regex actions, and their private equivalent.
  25
  26 =cut
  27
  28 sub list {
  29     my ( $self, $c ) = @_;
  30     my @regexes = @{ $self->_compiled };
  31     return unless @regexes;
  32     my $re = Text::SimpleTable->new( [ 35, 'Regex' ], [ 36, 'Private' ] );
  33     for my $regex ( @regexes ) {
  34         my $action = $regex->{action};
  35         $re->row( $regex->{path}, "/$action" );
  36     }
  37     $c->log->debug( "Loaded Regex actions:\n" . $re->draw . "\n" );
  38 }
  39
  40 =head2 $self->match( $c, $path )
  41
  42 Checks path against every compiled regex, and offers the action for any regex
  43 which matches a chance to match the request. If it succeeds, sets action,
  44 match and captures on $c->req and returns 1. If not, returns 0 without
  45 altering $c.
  46
  47 =cut
  48
  49 override match => sub {
  50     my ( $self, $c, $path ) = @_;
  51
  52     return if super();
  53
  54     # Check path against plain text first
  55
  56     foreach my $compiled ( @{ $self->_compiled } ) {
  57         if ( my @captures = ( $path =~ $compiled->{re} ) ) {
  58             next unless $compiled->{action}->match($c);
  59             $c->req->action( $compiled->{path} );
  60             $c->req->match($path);
  61             $c->req->captures( \@captures );
  62             $c->action( $compiled->{action} );
  63             $c->namespace( $compiled->{action}->namespace );
  64             return 1;
  65         }
  66     }
  67
  68     return 0;
  69 };
  70
  71 =head2 $self->register( $c, $action )
  72
  73 Registers one or more regex actions for an action object.
  74 Also registers them as literal paths.
  75
  76 Returns 1 if any regexps were registered.
  77
  78 =cut
  79
  80 sub register {
  81     my ( $self, $c, $action ) = @_;
  82     my $attrs    = $action->attributes;
  83     my @register = @{ $attrs->{'Regex'} || [] };
  84
  85     foreach my $r (@register) {
  86         $self->register_path( $c, $r, $action );
  87         $self->register_regex( $c, $r, $action );
  88     }
  89
  90     return 1 if @register;
  91     return 0;
  92 }
  93
  94 =head2 $self->register_regex($c, $re, $action)
  95
  96 Register an individual regex on the action. Usually called from the
  97 register method.
  98
  99 =cut
 100
 101 sub register_regex {
 102     my ( $self, $c, $re, $action ) = @_;
 103     push(
 104         @{ $self->_compiled },    # and compiled regex for us
 105         {
 106             re     => qr#$re#,
 107             action => $action,
 108             path   => $re,
 109         }
 110     );
 111 }
 112
 113 =head2 $self->uri_for_action($action, $captures)
 114
 115 returns a URI for this action if it can find a regex attributes that contains
 116 the correct number of () captures. Note that this may function incorrectly
 117 in the case of nested captures - if your regex does (...(..))..(..) you'll
 118 need to pass the first and third captures only.
 119
 120 =cut
 121
 122 sub uri_for_action {
 123     my ( $self, $action, $captures ) = @_;
 124
 125     if (my $regexes = $action->attributes->{Regex}) {
 126         REGEX: foreach my $orig (@$regexes) {
 127             my $re = "$orig";
 128             $re =~ s/^\^//;
 129             $re =~ s/\$$//;
 130             my $final = '/';
 131             my @captures = @$captures;
 132             while (my ($front, $rest) = split(/\(/, $re, 2)) {
 133                 ($rest, $re) =
 134                     Text::Balanced::extract_bracketed("(${rest}", '(');
 135                 next REGEX unless @captures;
 136                 $final .= $front.shift(@captures);
 137             }
 138             next REGEX if @captures;
 139             return $final;
 140          }
 141     }
 142     return undef;
 143 }
 144
 145 =head1 AUTHOR
 146
 147 Matt S Trout
 148 Sebastian Riedel, C<sri@cpan.org>
 149
 150 =head1 COPYRIGHT
 151
 152 This program is free software, you can redistribute it and/or modify it under
 153 the same terms as Perl itself.
 154
 155 =cut
 156
 157 1;