lib/Catalyst/DispatchType/Regex.pm

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