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   return $self->has_captures_constraints ?
 375     $self->match_captures_constraints($c, $captures) : 1;
 376
 377   return 1;
 378 }
 379
 380 sub match_captures_constraints {
 381   my ($self, $c, $captures) = @_;
 382   my @captures = @{$captures||[]};
 383
 384   # Match is positive if you don't have any.
 385   return 1 unless $self->has_captures_constraints;
 386
 387   if(
 388     $self->captures_constraints_count == 1 &&
 389     (
 390       $self->captures_constraints->[0]->is_a_type_of('Ref') ||
 391       $self->captures_constraints->[0]->is_a_type_of('ClassName')
 392     )
 393   ) {
 394     return $self->captures_constraints->[0]->check($captures);
 395   } else {
 396     for my $i(0..$#captures) {
 397       $self->captures_constraints->[$i]->check($captures[$i]) || return 0;
 398     }
 399     return 1;
 400     }
 401
 402 }
 403
 404
 405 sub compare {
 406     my ($a1, $a2) = @_;
 407     return $a1->normalized_arg_number <=> $a2->normalized_arg_number;
 408 }
 409
 410 sub scheme {
 411   return exists $_[0]->attributes->{Scheme} ? $_[0]->attributes->{Scheme}[0] : undef;
 412 }
 413
 414 sub list_extra_info {
 415   my $self = shift;
 416   return {
 417     Args => $self->normalized_arg_number,
 418     CaptureArgs => $self->number_of_captures,
 419   }
 420 }
 421
 422 __PACKAGE__->meta->make_immutable;
 423
 424 1;
 425
 426 __END__
 427
 428 =head1 METHODS
 429
 430 =head2 attributes
 431
 432 The sub attributes that are set for this action, like Local, Path, Private
 433 and so on. This determines how the action is dispatched to.
 434
 435 =head2 class
 436
 437 Returns the name of the component where this action is defined.
 438 Derived by calling the L<catalyst_component_name|Catalyst::Component/catalyst_component_name>
 439 method on each component.
 440
 441 =head2 code
 442
 443 Returns a code reference to this action.
 444
 445 =head2 dispatch( $c )
 446
 447 Dispatch this action against a context.
 448
 449 =head2 execute( $controller, $c, @args )
 450
 451 Execute this action's coderef against a given controller with a given
 452 context and arguments
 453
 454 =head2 match( $c )
 455
 456 Check Args attribute, and makes sure number of args matches the setting.
 457 Always returns true if Args is omitted.
 458
 459 =head2 match_captures ($c, $captures)
 460
 461 Can be implemented by action class and action role authors. If the method
 462 exists, then it will be called with the request context and an array reference
 463 of the captures for this action.
 464
 465 Returning true from this method causes the chain match to continue, returning
 466 makes the chain not match (and alternate, less preferred chains will be attempted).
 467
 468 =head2 match_captures_constraints ($c, \@captures);
 469
 470 Does the \@captures given match any constraints (if any constraints exist).  Returns
 471 true if you ask but there are no constraints.
 472
 473 =head2 match_args($c, $args)
 474
 475 Does the Args match or not?
 476
 477 =head2 resolve_type_constraint
 478
 479 Trys to find a type constraint if you have on on a type constrained method.
 480
 481 =head2 compare
 482
 483 Compares 2 actions based on the value of the C<Args> attribute, with no C<Args>
 484 having the highest precedence.
 485
 486 =head2 namespace
 487
 488 Returns the private namespace this action lives in.
 489
 490 =head2 reverse
 491
 492 Returns the private path for this action.
 493
 494 =head2 private_path
 495
 496 Returns absolute private path for this action. Unlike C<reverse>, the
 497 C<private_path> of an action is always suitable for passing to C<forward>.
 498
 499 =head2 name
 500
 501 Returns the sub name of this action.
 502
 503 =head2 number_of_args
 504
 505 Returns the number of args this action expects. This is 0 if the action doesn't
 506 take any arguments and undef if it will take any number of arguments.
 507
 508 =head2 normalized_arg_number
 509
 510 For the purposes of comparison we normalize 'number_of_args' so that if it is
 511 undef we mean ~0 (as many args are we can think of).
 512
 513 =head2 number_of_captures
 514
 515 Returns the number of captures this action expects for L<Chained|Catalyst::DispatchType::Chained> actions.
 516
 517 =head2 list_extra_info
 518
 519 A HashRef of key-values that an action can provide to a debugging screen
 520
 521 =head2 scheme
 522
 523 Any defined scheme for the action
 524
 525 =head2 meta
 526
 527 Provided by Moose.
 528
 529 =head1 AUTHORS
 530
 531 Catalyst Contributors, see Catalyst.pm
 532
 533 =head1 COPYRIGHT
 534
 535 This library is free software. You can redistribute it and/or modify it under
 536 the same terms as Perl itself.
 537
 538 =cut
 539
 540