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(
  59       scalar(@{$self->attributes->{Args}}) == 1 &&
  60       looks_like_number($self->attributes->{Args}[0])
  61     ) {
  62       # 'Old school' numbered args (is allowed to be undef as well)
  63       return $self->attributes->{Args}[0];
  64     } else {
  65       # New hotness named arg constraints
  66       return $self->number_of_args_constraints;
  67     }
  68   }
  69
  70 sub normalized_arg_number {
  71   return defined($_[0]->number_of_args) ? $_[0]->number_of_args : ~0;
  72 }
  73
  74 has args_constraints => (
  75   is=>'ro',
  76   init_arg=>undef,
  77   traits=>['Array'],
  78   isa=>'ArrayRef',
  79   required=>1,
  80   lazy=>1,
  81   builder=>'_build_args_constraints',
  82   handles => {
  83     has_args_constraints => 'count',
  84     number_of_args_constraints => 'count',
  85   });
  86
  87   sub _build_args_constraints {
  88     my $self = shift;
  89     my @arg_protos = @{$self->attributes->{Args}||[]};
  90
  91     return [] unless scalar(@arg_protos);
  92     # If there is only one arg and it looks like a number
  93     # we assume its 'classic' and the number is the number of
  94     # constraints.
  95     my @args = ();
  96     if(
  97       scalar(@arg_protos) == 1 &&
  98       looks_like_number($arg_protos[0])
  99     ) {
 100       return \@args;
 101     } else {
 102       @args =
 103         map {  $self->resolve_type_constraint($_) || die "$_ is not a constraint!" }
 104         @arg_protos;
 105     }
 106
 107     return \@args;
 108   }
 109
 110 has captures_constraints => (
 111   is=>'ro',
 112   init_arg=>undef,
 113   traits=>['Array'],
 114   isa=>'ArrayRef',
 115   required=>1,
 116   lazy=>1,
 117   builder=>'_build_captures_constraints',
 118   handles => {
 119     has_captures_constraints => 'count',
 120     number_of_captures_constraints => 'count',
 121   });
 122
 123   sub _build_captures_constraints {
 124     my $self = shift;
 125     my @arg_protos = @{$self->attributes->{CaptureArgs}||[]};
 126
 127     return [] unless scalar(@arg_protos);
 128     # If there is only one arg and it looks like a number
 129     # we assume its 'classic' and the number is the number of
 130     # constraints.
 131     my @args = ();
 132     if(
 133       scalar(@arg_protos) == 1 &&
 134       looks_like_number($arg_protos[0])
 135     ) {
 136       return \@args;
 137     } else {
 138       @args =
 139         map {  $self->resolve_type_constraint($_) || die "$_ is not a constraint!" }
 140         @arg_protos;
 141     }
 142
 143     return \@args;
 144   }
 145
 146 sub resolve_type_constraint {
 147   my ($self, $name) = @_;
 148   my $tc = eval "package ${\$self->class}; $name" || undef;
 149   return $tc || Moose::Util::TypeConstraints::find_or_parse_type_constraint($name);
 150 }
 151
 152 has number_of_captures => (
 153   is=>'ro',
 154   init_arg=>undef,
 155   isa=>'Int',
 156   required=>1,
 157   lazy=>1,
 158   builder=>'_build_number_of_captures');
 159
 160   sub _build_number_of_captures {
 161     my $self = shift;
 162     if( ! exists $self->attributes->{CaptureArgs} ) {
 163       # If there are no defined capture args, thats considered 0.
 164       return 0;
 165     } elsif(!defined($self->attributes->{CaptureArgs}[0])) {
 166       # If you fail to give a defined value, that's also 0
 167       return 0;
 168     } elsif(
 169       scalar(@{$self->attributes->{CaptureArgs}}) == 1 &&
 170       looks_like_number($self->attributes->{CaptureArgs}[0])
 171     ) {
 172       # 'Old school' numbered captures
 173       return $self->attributes->{CaptureArgs}[0];
 174     } else {
 175       # New hotness named arg constraints
 176       return $self->number_of_captures_constraints;
 177     }
 178   }
 179
 180
 181 use overload (
 182
 183     # Stringify to reverse for debug output etc.
 184     q{""} => sub { shift->{reverse} },
 185
 186     # Codulate to execute to invoke the encapsulated action coderef
 187     '&{}' => sub { my $self = shift; sub { $self->execute(@_); }; },
 188
 189     # Make general $stuff still work
 190     fallback => 1,
 191
 192 );
 193
 194 no warnings 'recursion';
 195
 196 sub dispatch {    # Execute ourselves against a context
 197     my ( $self, $c ) = @_;
 198     return $c->execute( $self->class, $self );
 199 }
 200
 201 sub execute {
 202   my $self = shift;
 203   $self->code->(@_);
 204 }
 205
 206 sub match {
 207     my ( $self, $c ) = @_;
 208
 209     # If infinite args, we always match
 210     return 1 if $self->normalized_arg_number == ~0;
 211
 212     # There there are arg constraints, we must see to it that the constraints
 213     # check positive for each arg in the list.
 214     if($self->has_args_constraints) {
 215       # If there is only one type constraint, and its a Ref or subtype of Ref,
 216       # That means we expect a reference, so use the full args arrayref.
 217       if(
 218         $self->number_of_args_constraints == 1 &&
 219         (
 220           $self->args_constraints->[0]->is_a_type_of('Ref') ||
 221           $self->args_constraints->[0]->is_a_type_of('ClassName')
 222         )
 223       ) {
 224         return 1 if $self->args_constraints->[0]->check($c->req->args);
 225         # Removing coercion stuff for the first go
 226         #if($self->args_constraints->[0]->coercion && $self->attributes->{Coerce}) {
 227         #  my $coerced = $self->args_constraints->[0]->coerce($c) || return 0;
 228         #  $c->req->args([$coerced]);
 229         #  return 1;
 230         #}
 231       } else {
 232         # Because of the way chaining works, we can expect args that are totally not
 233         # what you'd expect length wise.  When they don't match length, thats a fail
 234         return 0 unless scalar( @{ $c->req->args } ) == $self->normalized_arg_number;
 235
 236         for my $i(0..$#{ $c->req->args }) {
 237           $self->args_constraints->[$i]->check($c->req->args->[$i]) || return 0;
 238         }
 239         return 1;
 240       }
 241     } else {
 242       # Otherwise, we just need to match the number of args.
 243       return scalar( @{ $c->req->args } ) == $self->normalized_arg_number;
 244     }
 245 }
 246
 247 sub match_captures {
 248   my ($self, $c, $captures) = @_;
 249   my @captures = @{$captures||[]};
 250
 251   return 1 unless scalar(@captures); # If none, just say its ok
 252
 253   if($self->has_captures_constraints) {
 254     if(
 255       $self->number_of_captures_constraints == 1 &&
 256       (
 257         $self->captures_constraints->[0]->is_a_type_of('Ref') ||
 258         $self->captures_constraints->[0]->is_a_type_of('ClassName')
 259       )
 260     ) {
 261       return 1 if $self->captures_constraints->[0]->check($c->req->args);
 262     } else {
 263       for my $i(0..$#captures) {
 264         $self->captures_constraints->[$i]->check($captures[$i]) || return 0;
 265       }
 266       return 1;
 267       }
 268   } else {
 269     return 1;
 270   }
 271   return 1;
 272 }
 273
 274 sub compare {
 275     my ($a1, $a2) = @_;
 276     return $a1->normalized_arg_number <=> $a2->normalized_arg_number;
 277 }
 278
 279 sub scheme {
 280   return exists $_[0]->attributes->{Scheme} ? $_[0]->attributes->{Scheme}[0] : undef;
 281 }
 282
 283 sub list_extra_info {
 284   my $self = shift;
 285   return {
 286     Args => $self->normalized_arg_number,
 287     CaptureArgs => $self->number_of_captures,
 288   }
 289 }
 290
 291 __PACKAGE__->meta->make_immutable;
 292
 293 1;
 294
 295 __END__
 296
 297 =head1 METHODS
 298
 299 =head2 attributes
 300
 301 The sub attributes that are set for this action, like Local, Path, Private
 302 and so on. This determines how the action is dispatched to.
 303
 304 =head2 class
 305
 306 Returns the name of the component where this action is defined.
 307 Derived by calling the L<catalyst_component_name|Catalyst::Component/catalyst_component_name>
 308 method on each component.
 309
 310 =head2 code
 311
 312 Returns a code reference to this action.
 313
 314 =head2 dispatch( $c )
 315
 316 Dispatch this action against a context.
 317
 318 =head2 execute( $controller, $c, @args )
 319
 320 Execute this action's coderef against a given controller with a given
 321 context and arguments
 322
 323 =head2 match( $c )
 324
 325 Check Args attribute, and makes sure number of args matches the setting.
 326 Always returns true if Args is omitted.
 327
 328 =head2 match_captures ($c, $captures)
 329
 330 Can be implemented by action class and action role authors. If the method
 331 exists, then it will be called with the request context and an array reference
 332 of the captures for this action.
 333
 334 Returning true from this method causes the chain match to continue, returning
 335 makes the chain not match (and alternate, less preferred chains will be attempted).
 336
 337 =head2 resolve_type_constraint
 338
 339 Trys to find a type constraint if you have on on a type constrained method.
 340
 341 =head2 compare
 342
 343 Compares 2 actions based on the value of the C<Args> attribute, with no C<Args>
 344 having the highest precedence.
 345
 346 =head2 namespace
 347
 348 Returns the private namespace this action lives in.
 349
 350 =head2 reverse
 351
 352 Returns the private path for this action.
 353
 354 =head2 private_path
 355
 356 Returns absolute private path for this action. Unlike C<reverse>, the
 357 C<private_path> of an action is always suitable for passing to C<forward>.
 358
 359 =head2 name
 360
 361 Returns the sub name of this action.
 362
 363 =head2 number_of_args
 364
 365 Returns the number of args this action expects. This is 0 if the action doesn't
 366 take any arguments and undef if it will take any number of arguments.
 367
 368 =head2 normalized_arg_number
 369
 370 For the purposes of comparison we normalize 'number_of_args' so that if it is
 371 undef we mean ~0 (as many args are we can think of).
 372
 373 =head2 number_of_captures
 374
 375 Returns the number of captures this action expects for L<Chained|Catalyst::DispatchType::Chained> actions.
 376
 377 =head2 list_extra_info
 378
 379 A HashRef of key-values that an action can provide to a debugging screen
 380
 381 =head2 scheme
 382
 383 Any defined scheme for the action
 384
 385 =head2 meta
 386
 387 Provided by Moose.
 388
 389 =head1 AUTHORS
 390
 391 Catalyst Contributors, see Catalyst.pm
 392
 393 =head1 COPYRIGHT
 394
 395 This library is free software. You can redistribute it and/or modify it under
 396 the same terms as Perl itself.
 397
 398 =cut
 399
 400