lib/Catalyst/DispatchType/Regex.pm

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