lib/Catalyst/Action.pm

   1 package Catalyst::Action;
   2
   3 =head1 NAME
   4
   5 Catalyst::Action - Catalyst Action
   6
   7 =head1 SYNOPSIS
   8
   9     <form action="[%c.uri_for(c.action)%]">
  10
  11     $c->forward( $action->private_path );
  12
  13 =head1 DESCRIPTION
  14
  15 This class represents a Catalyst Action. You can access the object for the
  16 currently dispatched action via $c->action. See the L<Catalyst::Dispatcher>
  17 for more information on how actions are dispatched. Actions are defined in
  18 L<Catalyst::Controller> subclasses.
  19
  20 =cut
  21
  22 use Moose;
  23 use Scalar::Util 'looks_like_number';
  24 use Moose::Util::TypeConstraints ();
  25 with 'MooseX::Emulate::Class::Accessor::Fast';
  26 use namespace::clean -except => 'meta';
  27
  28 has class => (is => 'rw');
  29 has namespace => (is => 'rw');
  30 has 'reverse' => (is => 'rw');
  31 has attributes => (is => 'rw');
  32 has name => (is => 'rw');
  33 has code => (is => 'rw');
  34 has private_path => (
  35   reader => 'private_path',
  36   isa => 'Str',
  37   lazy => 1,
  38   required => 1,
  39   default => sub { '/'.shift->reverse },
  40 );
  41
  42 has number_of_args => (
  43   is=>'ro',
  44   init_arg=>undef,
  45   isa=>'Int|Undef',
  46   required=>1,
  47   lazy=>1,
  48   builder=>'_build_number_of_args');
  49
  50   sub _build_number_of_args {
  51     my $self = shift;
  52     if( ! exists $self->attributes->{Args} ) {
  53       # When 'Args' does not exist, that means we want 'any number of args'.
  54       return undef;
  55     } elsif(!defined($self->attributes->{Args}[0])) {
  56       # When its 'Args' that internal cue for 'unlimited'
  57       return undef;
  58     } elsif(looks_like_number($self->attributes->{Args}[0])) {
  59       # 'Old school' numberd args (is allowed to be undef as well)
  60       return $self->attributes->{Args}[0];
  61     } else {
  62       # New hotness named arg constraints
  63       return $self->number_of_args_constraints;
  64     }
  65   }
  66
  67 sub normalized_arg_number {
  68   return defined($_[0]->number_of_args) ? $_[0]->number_of_args : ~0;
  69 }
  70
  71 has args_constraints => (
  72   is=>'ro',
  73   init_arg=>undef,
  74   traits=>['Array'],
  75   isa=>'ArrayRef',
  76   required=>1,
  77   lazy=>1,
  78   builder=>'_build_args_constraints',
  79   handles => {
  80     has_args_constraints => 'count',
  81     number_of_args_constraints => 'count',
  82   });
  83
  84   sub _build_args_constraints {
  85     my $self = shift;
  86     my @arg_protos = @{$self->attributes->{Args}||[]};
  87
  88     return [] unless scalar(@arg_protos);
  89     # If there is only one arg and it looks like a number
  90     # we assume its 'classic' and the number is the number of
  91     # constraints.
  92     my @args = ();
  93     if(
  94       scalar(@arg_protos) == 1 &&
  95       looks_like_number($arg_protos[0])
  96     ) {
  97       return \@args;
  98     } else {
  99       @args = map { Moose::Util::TypeConstraints::find_or_parse_type_constraint($_) || die "$_ is not a constraint!" } @arg_protos;
 100     }
 101
 102     return \@args;
 103   }
 104
 105 use overload (
 106
 107     # Stringify to reverse for debug output etc.
 108     q{""} => sub { shift->{reverse} },
 109
 110     # Codulate to execute to invoke the encapsulated action coderef
 111     '&{}' => sub { my $self = shift; sub { $self->execute(@_); }; },
 112
 113     # Make general $stuff still work
 114     fallback => 1,
 115
 116 );
 117
 118 no warnings 'recursion';
 119
 120 sub dispatch {    # Execute ourselves against a context
 121     my ( $self, $c ) = @_;
 122     return $c->execute( $self->class, $self );
 123 }
 124
 125 sub execute {
 126   my $self = shift;
 127   $self->code->(@_);
 128 }
 129
 130 sub match {
 131     my ( $self, $c ) = @_;
 132
 133     # If infinite args, we always match
 134     return 1 if $self->normalized_arg_number == ~0;
 135
 136     # There there are arg constraints, we must see to it that the constraints
 137     # check positive for each arg in the list.
 138     if($self->has_args_constraints) {
 139       for my $i($#{ $c->req->args }) {
 140         $self->args_constraints->[$i]->check($c->req->args->[$i]) || return 0;
 141       }
 142       return 1;
 143     } else {
 144       # Otherwise, we just need to match the number of args.
 145       return scalar( @{ $c->req->args } ) == $self->normalized_arg_number;
 146     }
 147 }
 148
 149 sub match_captures { 1 }
 150
 151 sub compare {
 152     my ($a1, $a2) = @_;
 153     return $a1->normalized_arg_number <=> $a2->normalized_arg_number;
 154 }
 155
 156 sub number_of_captures {
 157     my ( $self ) = @_;
 158
 159     return 0 unless exists $self->attributes->{CaptureArgs};
 160     return $self->attributes->{CaptureArgs}[0] || 0;
 161 }
 162
 163 sub scheme {
 164   return exists $_[0]->attributes->{Scheme} ? $_[0]->attributes->{Scheme}[0] : undef;
 165 }
 166
 167 sub list_extra_info {
 168   my $self = shift;
 169   return {
 170     Args => $self->attributes->{Args}[0],
 171     CaptureArgs => $self->number_of_captures,
 172   }
 173 }
 174
 175 __PACKAGE__->meta->make_immutable;
 176
 177 1;
 178
 179 __END__
 180
 181 =head1 METHODS
 182
 183 =head2 attributes
 184
 185 The sub attributes that are set for this action, like Local, Path, Private
 186 and so on. This determines how the action is dispatched to.
 187
 188 =head2 class
 189
 190 Returns the name of the component where this action is defined.
 191 Derived by calling the L<catalyst_component_name|Catalyst::Component/catalyst_component_name>
 192 method on each component.
 193
 194 =head2 code
 195
 196 Returns a code reference to this action.
 197
 198 =head2 dispatch( $c )
 199
 200 Dispatch this action against a context.
 201
 202 =head2 execute( $controller, $c, @args )
 203
 204 Execute this action's coderef against a given controller with a given
 205 context and arguments
 206
 207 =head2 match( $c )
 208
 209 Check Args attribute, and makes sure number of args matches the setting.
 210 Always returns true if Args is omitted.
 211
 212 =head2 match_captures ($c, $captures)
 213
 214 Can be implemented by action class and action role authors. If the method
 215 exists, then it will be called with the request context and an array reference
 216 of the captures for this action.
 217
 218 Returning true from this method causes the chain match to continue, returning
 219 makes the chain not match (and alternate, less preferred chains will be attempted).
 220
 221
 222 =head2 compare
 223
 224 Compares 2 actions based on the value of the C<Args> attribute, with no C<Args>
 225 having the highest precedence.
 226
 227 =head2 namespace
 228
 229 Returns the private namespace this action lives in.
 230
 231 =head2 reverse
 232
 233 Returns the private path for this action.
 234
 235 =head2 private_path
 236
 237 Returns absolute private path for this action. Unlike C<reverse>, the
 238 C<private_path> of an action is always suitable for passing to C<forward>.
 239
 240 =head2 name
 241
 242 Returns the sub name of this action.
 243
 244 =head2 number_of_args
 245
 246 Returns the number of args this action expects. This is 0 if the action doesn't
 247 take any arguments and undef if it will take any number of arguments.
 248
 249 =head2 normalized_arg_number
 250
 251 For the purposes of comparison we normalize 'number_of_args' so that if it is
 252 undef we mean ~0 (as many args are we can think of).
 253
 254 =head2 number_of_captures
 255
 256 Returns the number of captures this action expects for L<Chained|Catalyst::DispatchType::Chained> actions.
 257
 258 =head2 list_extra_info
 259
 260 A HashRef of key-values that an action can provide to a debugging screen
 261
 262 =head2 scheme
 263
 264 Any defined scheme for the action
 265
 266 =head2 meta
 267
 268 Provided by Moose.
 269
 270 =head1 AUTHORS
 271
 272 Catalyst Contributors, see Catalyst.pm
 273
 274 =head1 COPYRIGHT
 275
 276 This library is free software. You can redistribute it and/or modify it under
 277 the same terms as Perl itself.
 278
 279 =cut
 280
 281