lib/Catalyst/DispatchType/Regex.pm

   1 package Catalyst::DispatchType::Regex;
   2
   3 use Moose;
   4 extends 'Catalyst::DispatchType::Path';
   5
   6 use Text::SimpleTable;
   7 use Catalyst::Utils;
   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 $column_width = Catalyst::Utils::term_width() - 35 - 9;
  40     my $re = Text::SimpleTable->new( [ 35, 'Regex' ], [ $column_width, 'Private' ] );
  41     for my $regex ( @{ $self->_compiled } ) {
  42         my $action = $regex->{action};
  43         $re->row( $regex->{path}, "/$action" );
  44     }
  45     $c->log->debug( "Loaded Regex actions:\n" . $re->draw . "\n" )
  46       if ( @{ $self->_compiled } );
  47 }
  48
  49 =head2 $self->match( $c, $path )
  50
  51 Checks path against every compiled regex, and offers the action for any regex
  52 which matches a chance to match the request. If it succeeds, sets action,
  53 match and captures on $c->req and returns 1. If not, returns 0 without
  54 altering $c.
  55
  56 =cut
  57
  58 sub match {
  59     my ( $self, $c, $path ) = @_;
  60
  61     return if $self->SUPER::match( $c, $path );
  62
  63     # Check path against plain text first
  64
  65     foreach my $compiled ( @{ $self->_compiled } ) {
  66         if ( my @captures = ( $path =~ $compiled->{re} ) ) {
  67             next unless $compiled->{action}->match($c);
  68             $c->req->action( $compiled->{path} );
  69             $c->req->match($path);
  70             $c->req->captures( \@captures );
  71             $c->action( $compiled->{action} );
  72             $c->namespace( $compiled->{action}->namespace );
  73             return 1;
  74         }
  75     }
  76
  77     return 0;
  78 }
  79
  80 =head2 $self->register( $c, $action )
  81
  82 Registers one or more regex actions for an action object.
  83 Also registers them as literal paths.
  84
  85 Returns 1 if any regexps were registered.
  86
  87 =cut
  88
  89 sub register {
  90     my ( $self, $c, $action ) = @_;
  91     my $attrs    = $action->attributes;
  92     my @register = @{ $attrs->{'Regex'} || [] };
  93
  94     foreach my $r (@register) {
  95         $self->register_path( $c, $r, $action );
  96         $self->register_regex( $c, $r, $action );
  97     }
  98
  99     return 1 if @register;
 100     return 0;
 101 }
 102
 103 =head2 $self->register_regex($c, $re, $action)
 104
 105 Register an individual regex on the action. Usually called from the
 106 register method.
 107
 108 =cut
 109
 110 sub register_regex {
 111     my ( $self, $c, $re, $action ) = @_;
 112     push(
 113         @{ $self->_compiled },    # and compiled regex for us
 114         {
 115             re     => qr#$re#,
 116             action => $action,
 117             path   => $re,
 118         }
 119     );
 120 }
 121
 122 =head2 $self->uri_for_action($action, $captures)
 123
 124 returns a URI for this action if it can find a regex attributes that contains
 125 the correct number of () captures. Note that this may function incorrectly
 126 in the case of nested captures - if your regex does (...(..))..(..) you'll
 127 need to pass the first and third captures only.
 128
 129 =cut
 130
 131 sub uri_for_action {
 132     my ( $self, $action, $captures ) = @_;
 133
 134     if (my $regexes = $action->attributes->{Regex}) {
 135         REGEX: foreach my $orig (@$regexes) {
 136             my $re = "$orig";
 137             $re =~ s/^\^//;
 138             $re =~ s/\$$//;
 139             my $final = '/';
 140             my @captures = @$captures;
 141             while (my ($front, $rest) = split(/\(/, $re, 2)) {
 142                 ($rest, $re) =
 143                     Text::Balanced::extract_bracketed("(${rest}", '(');
 144                 next REGEX unless @captures;
 145                 $final .= $front.shift(@captures);
 146             }
 147             next REGEX if @captures;
 148             return $final;
 149          }
 150     }
 151     return undef;
 152 }
 153
 154 =head1 AUTHORS
 155
 156 Catalyst Contributors, see Catalyst.pm
 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;