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::DispatchType>.
  26
  27 =head1 DESCRIPTION
  28
  29 Dispatch type managing path-matching behaviour using regexes.  For
  30 more information on dispatch types, see:
  31
  32 =over 4
  33
  34 =item * L<Catalyst::Manual::Intro> for how they affect application authors
  35
  36 =item * L<Catalyst::DispatchType> for implementation information.
  37
  38 =back
  39
  40 =head1 METHODS
  41
  42 =head2 $self->list($c)
  43
  44 Output a table of all regex actions, and their private equivalent.
  45
  46 =cut
  47
  48 sub list {
  49     my ( $self, $c ) = @_;
  50     my $avail_width = Catalyst::Utils::term_width() - 9;
  51     my $col1_width = ($avail_width * .50) < 35 ? 35 : int($avail_width * .50);
  52     my $col2_width = $avail_width - $col1_width;
  53     my $re = Text::SimpleTable->new(
  54         [ $col1_width, 'Regex' ], [ $col2_width, 'Private' ]
  55     );
  56     for my $regex ( @{ $self->_compiled } ) {
  57         my $action = $regex->{action};
  58         $re->row( $regex->{path}, "/$action" );
  59     }
  60     $c->log->debug( "Loaded Regex actions:\n" . $re->draw . "\n" )
  61       if ( @{ $self->_compiled } );
  62 }
  63
  64 =head2 $self->match( $c, $path )
  65
  66 Checks path against every compiled regex, and offers the action for any regex
  67 which matches a chance to match the request. If it succeeds, sets action,
  68 match and captures on $c->req and returns 1. If not, returns 0 without
  69 altering $c.
  70
  71 =cut
  72
  73 sub match {
  74     my ( $self, $c, $path ) = @_;
  75
  76     return if $self->SUPER::match( $c, $path );
  77
  78     # Check path against plain text first
  79
  80     foreach my $compiled ( @{ $self->_compiled } ) {
  81         if ( my @captures = ( $path =~ $compiled->{re} ) ) {
  82             next unless $compiled->{action}->match($c);
  83             $c->req->action( $compiled->{path} );
  84             $c->req->match($path);
  85             $c->req->captures( \@captures );
  86             $c->action( $compiled->{action} );
  87             $c->namespace( $compiled->{action}->namespace );
  88             return 1;
  89         }
  90     }
  91
  92     return 0;
  93 }
  94
  95 =head2 $self->register( $c, $action )
  96
  97 Registers one or more regex actions for an action object.
  98 Also registers them as literal paths.
  99
 100 Returns 1 if any regexps were registered.
 101
 102 =cut
 103
 104 sub register {
 105     my ( $self, $c, $action ) = @_;
 106     my $attrs    = $action->attributes;
 107     my @register = @{ $attrs->{'Regex'} || [] };
 108
 109     foreach my $r (@register) {
 110         $self->register_path( $c, $r, $action );
 111         $self->register_regex( $c, $r, $action );
 112     }
 113
 114     return 1 if @register;
 115     return 0;
 116 }
 117
 118 =head2 $self->register_regex($c, $re, $action)
 119
 120 Register an individual regex on the action. Usually called from the
 121 register method.
 122
 123 =cut
 124
 125 sub register_regex {
 126     my ( $self, $c, $re, $action ) = @_;
 127     push(
 128         @{ $self->_compiled },    # and compiled regex for us
 129         {
 130             re     => qr#$re#,
 131             action => $action,
 132             path   => $re,
 133         }
 134     );
 135 }
 136
 137 =head2 $self->uri_for_action($action, $captures)
 138
 139 returns a URI for this action if it can find a regex attributes that contains
 140 the correct number of () captures. Note that this may function incorrectly
 141 in the case of nested captures - if your regex does (...(..))..(..) you'll
 142 need to pass the first and third captures only.
 143
 144 =cut
 145
 146 sub uri_for_action {
 147     my ( $self, $action, $captures ) = @_;
 148
 149     if (my $regexes = $action->attributes->{Regex}) {
 150         REGEX: foreach my $orig (@$regexes) {
 151             my $re = "$orig";
 152             $re =~ s/^\^//;
 153             $re =~ s/\$$//;
 154             my $final = '/';
 155             my @captures = @$captures;
 156             while (my ($front, $rest) = split(/\(/, $re, 2)) {
 157                 last unless defined $rest;
 158                 ($rest, $re) =
 159                     Text::Balanced::extract_bracketed("(${rest}", '(');
 160                 next REGEX unless @captures;
 161                 $final .= $front.shift(@captures);
 162             }
 163             $final .= $re;
 164             next REGEX if @captures;
 165             return $final;
 166          }
 167     }
 168     return undef;
 169 }
 170
 171 =head2 $self->splice_captures_from( $c, $action, $args )
 172
 173 Iterates over the regular expressions defined for the action. Stops when
 174 the number of captures equals the number of supplied args. Replaces the
 175 list of args with a list containing an array ref of args
 176
 177 =cut
 178
 179 sub splice_captures_from {
 180     my ($self, $c, $action, $args) = @_; my $regexes;
 181
 182     return 0 unless ($regexes = $action->attributes->{Regex});
 183
 184     foreach my $orig (@{ $regexes }) {
 185         my $re = "$orig"; $re =~ s/^\^//; $re =~ s/\$$//;
 186         my $num_caps = 0;
 187
 188         while (my ($front, $rest) = split /\(/, $re, 2) {
 189             last unless (defined $rest);
 190
 191             ($rest, $re) = Text::Balanced::extract_bracketed( "(${rest}", '(');
 192             $num_caps++;
 193         }
 194
 195         next unless ($num_caps == scalar @{ $args });
 196
 197         @{ $args } = ( [ @{ $args } ] );
 198         return 1;
 199     }
 200
 201     return 1;
 202 }
 203
 204 =head1 AUTHORS
 205
 206 Catalyst Contributors, see Catalyst.pm
 207
 208 =head1 COPYRIGHT
 209
 210 This library is free software. You can redistribute it and/or modify it under
 211 the same terms as Perl itself.
 212
 213 =cut
 214
 215 __PACKAGE__->meta->make_immutable;
 216
 217 1;