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 number_of_args_constraints => (
  75   is=>'ro',
  76   isa=>'Int|Undef',
  77   init_arg=>undef,
  78   required=>1,
  79   lazy=>1,
  80   builder=>'_build_number_of_args_constraints');
  81
  82   sub _build_number_of_args_constraints {
  83     my $self = shift;
  84     return unless $self->has_args_constraints;
  85
  86     # If there is one constraint and its a ref, we need to decide
  87     # if this number 'unknown' number or if the ref allows us to
  88     # determine a length.
  89
  90     if(scalar @{$self->args_constraints} == 1) {
  91       my $tc = $self->args_constraints->[0];
  92       if(
  93         $tc->can('is_strictly_a_type_of') &&
  94         $tc->is_strictly_a_type_of('Tuple'))
  95       {
  96         my @parameters = @{ $tc->parameters||[]};
  97         if( defined($parameters[-1]) and exists($parameters[-1]->{slurpy})) {
  98           return undef;
  99         } else {
 100           return my $total_params = scalar(@parameters);
 101         }
 102       } elsif($tc->is_a_type_of('Ref')) {
 103         return undef;
 104       } else {
 105         return 1; # Its a normal 1 arg type constraint.
 106       }
 107     } else {
 108       # We need to loop thru and error on ref types.  We don't allow a ref type
 109       # in the middle.
 110       my $total = 0;
 111       foreach my $tc( @{$self->args_constraints}) {
 112         if($tc->is_a_type_of('Ref')) {
 113           die "$tc is a Ref type constraint.  You cannot mix Ref and non Ref type constraints in Args for action ${\$self->reverse}";
 114         } else {
 115           ++$total;
 116         }
 117       }
 118       return $total;
 119     }
 120   }
 121
 122 has args_constraints => (
 123   is=>'ro',
 124   init_arg=>undef,
 125   traits=>['Array'],
 126   isa=>'ArrayRef',
 127   required=>1,
 128   lazy=>1,
 129   builder=>'_build_args_constraints',
 130   handles => {
 131     has_args_constraints => 'count',
 132     args_constraint_count => 'count',
 133   });
 134
 135   sub _build_args_constraints {
 136     my $self = shift;
 137     my @arg_protos = @{$self->attributes->{Args}||[]};
 138
 139     return [] unless scalar(@arg_protos);
 140     return [] unless defined($arg_protos[0]);
 141
 142     # If there is only one arg and it looks like a number
 143     # we assume its 'classic' and the number is the number of
 144     # constraints.
 145     my @args = ();
 146     if(
 147       scalar(@arg_protos) == 1 &&
 148       looks_like_number($arg_protos[0])
 149     ) {
 150       return \@args;
 151     } else {
 152       @args =
 153         map {  my @tc = $self->resolve_type_constraint($_); scalar(@tc) ? @tc : die "$_ is not a constraint!" }
 154         @arg_protos;
 155     }
 156     return \@args;
 157   }
 158
 159 has number_of_captures_constraints => (
 160   is=>'ro',
 161   isa=>'Int|Undef',
 162   init_arg=>undef,
 163   required=>1,
 164   lazy=>1,
 165   builder=>'_build_number_of_capture_constraints');
 166
 167   sub _build_number_of_capture_constraints {
 168     my $self = shift;
 169     return unless $self->has_captures_constraints;
 170
 171     # If there is one constraint and its a ref, we need to decide
 172     # if this number 'unknown' number or if the ref allows us to
 173     # determine a length.
 174
 175     if(scalar @{$self->captures_constraints} == 1) {
 176       my $tc = $self->captures_constraints->[0];
 177       if(
 178         $tc->can('is_strictly_a_type_of') &&
 179         $tc->is_strictly_a_type_of('Tuple'))
 180       {
 181         my @parameters = @{ $tc->parameters||[]};
 182         if( defined($parameters[-1]) and exists($parameters[-1]->{slurpy})) {
 183           return undef;
 184         } else {
 185           return my $total_params = scalar(@parameters);
 186         }
 187       } elsif($tc->is_a_type_of('Ref')) {
 188         die "You cannot use CaptureArgs($tc) in ${\$self->reverse} because we cannot determined the number of its parameters";
 189       } else {
 190         return 1; # Its a normal 1 arg type constraint.
 191       }
 192     } else {
 193       # We need to loop thru and error on ref types.  We don't allow a ref type
 194       # in the middle.
 195       my $total = 0;
 196       foreach my $tc( @{$self->captures_constraints}) {
 197         if($tc->is_a_type_of('Ref')) {
 198           die "$tc is a Ref type constraint.  You cannot mix Ref and non Ref type constraints in CaptureArgs for action ${\$self->reverse}";
 199         } else {
 200           ++$total;
 201         }
 202       }
 203       return $total;
 204     }
 205   }
 206
 207 has captures_constraints => (
 208   is=>'ro',
 209   init_arg=>undef,
 210   traits=>['Array'],
 211   isa=>'ArrayRef',
 212   required=>1,
 213   lazy=>1,
 214   builder=>'_build_captures_constraints',
 215   handles => {
 216     has_captures_constraints => 'count',
 217     captures_constraints_count => 'count',
 218   });
 219
 220   sub _build_captures_constraints {
 221     my $self = shift;
 222     my @arg_protos = @{$self->attributes->{CaptureArgs}||[]};
 223
 224     return [] unless scalar(@arg_protos);
 225     return [] unless defined($arg_protos[0]);
 226     # If there is only one arg and it looks like a number
 227     # we assume its 'classic' and the number is the number of
 228     # constraints.
 229     my @args = ();
 230     if(
 231       scalar(@arg_protos) == 1 &&
 232       looks_like_number($arg_protos[0])
 233     ) {
 234       return \@args;
 235     } else {
 236       @args =
 237         map {  my @tc = $self->resolve_type_constraint($_); scalar(@tc) ? @tc : die "$_ is not a constraint!" }
 238         @arg_protos;
 239     }
 240
 241     return \@args;
 242   }
 243
 244 sub resolve_type_constraint {
 245   my ($self, $name) = @_;
 246   my @tc = eval "package ${\$self->class}; $name" or die "'$name' not a type constraint in ${\$self->private_path}";
 247   if($tc[0]) {
 248     return map { ref($_) ? $_ : Moose::Util::TypeConstraints::find_or_parse_type_constraint($_) } @tc;
 249   } else {
 250     return;
 251   }
 252 }
 253
 254 has number_of_captures => (
 255   is=>'ro',
 256   init_arg=>undef,
 257   isa=>'Int',
 258   required=>1,
 259   lazy=>1,
 260   builder=>'_build_number_of_captures');
 261
 262   sub _build_number_of_captures {
 263     my $self = shift;
 264     if( ! exists $self->attributes->{CaptureArgs} ) {
 265       # If there are no defined capture args, thats considered 0.
 266       return 0;
 267     } elsif(!defined($self->attributes->{CaptureArgs}[0])) {
 268       # If you fail to give a defined value, that's also 0
 269       return 0;
 270     } elsif(
 271       scalar(@{$self->attributes->{CaptureArgs}}) == 1 &&
 272       looks_like_number($self->attributes->{CaptureArgs}[0])
 273     ) {
 274       # 'Old school' numbered captures
 275       return $self->attributes->{CaptureArgs}[0];
 276     } else {
 277       # New hotness named arg constraints
 278       return $self->number_of_captures_constraints;
 279     }
 280   }
 281
 282
 283 use overload (
 284
 285     # Stringify to reverse for debug output etc.
 286     q{""} => sub { shift->{reverse} },
 287
 288     # Codulate to execute to invoke the encapsulated action coderef
 289     '&{}' => sub { my $self = shift; sub { $self->execute(@_); }; },
 290
 291     # Make general $stuff still work
 292     fallback => 1,
 293
 294 );
 295
 296 no warnings 'recursion';
 297
 298 sub dispatch {    # Execute ourselves against a context
 299     my ( $self, $c ) = @_;
 300     return $c->execute( $self->class, $self );
 301 }
 302
 303 sub execute {
 304   my $self = shift;
 305   $self->code->(@_);
 306 }
 307
 308 sub match {
 309     my ( $self, $c ) = @_;
 310     return $self->match_args($c, $c->req->args);
 311 }
 312
 313 sub match_args {
 314     my ($self, $c, $args) = @_;
 315     my @args = @{$args||[]};
 316
 317     # There there are arg constraints, we must see to it that the constraints
 318     # check positive for each arg in the list.
 319     if($self->has_args_constraints) {
 320       # If there is only one type constraint, and its a Ref or subtype of Ref,
 321       # That means we expect a reference, so use the full args arrayref.
 322       if(
 323         $self->args_constraint_count == 1 &&
 324         (
 325           $self->args_constraints->[0]->is_a_type_of('Ref') ||
 326           $self->args_constraints->[0]->is_a_type_of('ClassName')
 327         )
 328       ) {
 329         # Ok, the the type constraint is a ref type, which is allowed to have
 330         # any number of args.  We need to check the arg length, if one is defined.
 331         # If we had a ref type constraint that allowed us to determine the allowed
 332         # number of args, we need to match that number.  Otherwise if there was an
 333         # undetermined number (~0) then we allow all the args.  This is more of an
 334         # Optimization since Tuple[Int, Int] would fail on 3,4,5 anyway, but this
 335         # way we can avoid calling the constraint when the arg length is incorrect.
 336         if(
 337           $self->normalized_arg_number == ~0 ||
 338           scalar( @args ) == $self->normalized_arg_number
 339         ) {
 340           return $self->args_constraints->[0]->check($args);
 341         } else {
 342           return 0;
 343         }
 344         # Removing coercion stuff for the first go
 345         #if($self->args_constraints->[0]->coercion && $self->attributes->{Coerce}) {
 346         #  my $coerced = $self->args_constraints->[0]->coerce($c) || return 0;
 347         #  $c->req->args([$coerced]);
 348         #  return 1;
 349         #}
 350       } else {
 351         # Because of the way chaining works, we can expect args that are totally not
 352         # what you'd expect length wise.  When they don't match length, thats a fail
 353         return 0 unless scalar( @args ) == $self->normalized_arg_number;
 354
 355         for my $i(0..$#args) {
 356           $self->args_constraints->[$i]->check($args[$i]) || return 0;
 357         }
 358         return 1;
 359       }
 360     } else {
 361       # If infinite args with no constraints, we always match
 362       return 1 if $self->normalized_arg_number == ~0;
 363
 364       # Otherwise, we just need to match the number of args.
 365       return scalar( @args ) == $self->normalized_arg_number;
 366     }
 367 }
 368
 369 sub match_captures {
 370   my ($self, $c, $captures) = @_;
 371   my @captures = @{$captures||[]};
 372
 373   return 1 unless scalar(@captures); # If none, just say its ok
 374
 375   if($self->has_captures_constraints) {
 376     if(
 377       $self->captures_constraints_count == 1 &&
 378       (
 379         $self->captures_constraints->[0]->is_a_type_of('Ref') ||
 380         $self->captures_constraints->[0]->is_a_type_of('ClassName')
 381       )
 382     ) {
 383       return $self->captures_constraints->[0]->check($captures);
 384     } else {
 385       for my $i(0..$#captures) {
 386         $self->captures_constraints->[$i]->check($captures[$i]) || return 0;
 387       }
 388       return 1;
 389       }
 390   } else {
 391     return 1;
 392   }
 393   return 1;
 394 }
 395
 396 sub compare {
 397     my ($a1, $a2) = @_;
 398     return $a1->normalized_arg_number <=> $a2->normalized_arg_number;
 399 }
 400
 401 sub scheme {
 402   return exists $_[0]->attributes->{Scheme} ? $_[0]->attributes->{Scheme}[0] : undef;
 403 }
 404
 405 sub list_extra_info {
 406   my $self = shift;
 407   return {
 408     Args => $self->normalized_arg_number,
 409     CaptureArgs => $self->number_of_captures,
 410   }
 411 }
 412
 413 __PACKAGE__->meta->make_immutable;
 414
 415 1;
 416
 417 __END__
 418
 419 =head1 METHODS
 420
 421 =head2 attributes
 422
 423 The sub attributes that are set for this action, like Local, Path, Private
 424 and so on. This determines how the action is dispatched to.
 425
 426 =head2 class
 427
 428 Returns the name of the component where this action is defined.
 429 Derived by calling the L<catalyst_component_name|Catalyst::Component/catalyst_component_name>
 430 method on each component.
 431
 432 =head2 code
 433
 434 Returns a code reference to this action.
 435
 436 =head2 dispatch( $c )
 437
 438 Dispatch this action against a context.
 439
 440 =head2 execute( $controller, $c, @args )
 441
 442 Execute this action's coderef against a given controller with a given
 443 context and arguments
 444
 445 =head2 match( $c )
 446
 447 Check Args attribute, and makes sure number of args matches the setting.
 448 Always returns true if Args is omitted.
 449
 450 =head2 match_captures ($c, $captures)
 451
 452 Can be implemented by action class and action role authors. If the method
 453 exists, then it will be called with the request context and an array reference
 454 of the captures for this action.
 455
 456 Returning true from this method causes the chain match to continue, returning
 457 makes the chain not match (and alternate, less preferred chains will be attempted).
 458
 459 =head2 match_args($c, $args)
 460
 461 Does the Args match or not?
 462
 463 =head2 resolve_type_constraint
 464
 465 Trys to find a type constraint if you have on on a type constrained method.
 466
 467 =head2 compare
 468
 469 Compares 2 actions based on the value of the C<Args> attribute, with no C<Args>
 470 having the highest precedence.
 471
 472 =head2 namespace
 473
 474 Returns the private namespace this action lives in.
 475
 476 =head2 reverse
 477
 478 Returns the private path for this action.
 479
 480 =head2 private_path
 481
 482 Returns absolute private path for this action. Unlike C<reverse>, the
 483 C<private_path> of an action is always suitable for passing to C<forward>.
 484
 485 =head2 name
 486
 487 Returns the sub name of this action.
 488
 489 =head2 number_of_args
 490
 491 Returns the number of args this action expects. This is 0 if the action doesn't
 492 take any arguments and undef if it will take any number of arguments.
 493
 494 =head2 normalized_arg_number
 495
 496 For the purposes of comparison we normalize 'number_of_args' so that if it is
 497 undef we mean ~0 (as many args are we can think of).
 498
 499 =head2 number_of_captures
 500
 501 Returns the number of captures this action expects for L<Chained|Catalyst::DispatchType::Chained> actions.
 502
 503 =head2 list_extra_info
 504
 505 A HashRef of key-values that an action can provide to a debugging screen
 506
 507 =head2 scheme
 508
 509 Any defined scheme for the action
 510
 511 =head2 meta
 512
 513 Provided by Moose.
 514
 515 =head1 AUTHORS
 516
 517 Catalyst Contributors, see Catalyst.pm
 518
 519 =head1 COPYRIGHT
 520
 521 This library is free software. You can redistribute it and/or modify it under
 522 the same terms as Perl itself.
 523
 524 =cut
 525
 526