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', 'blessed';
  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
 247   if(defined($name) && blessed($name) && $name->can('check')) {
 248     # Its already a TC, good to go.
 249     return $name;
 250   }
 251
 252   if($name=~m/::/) {
 253     eval "use Type::Registry; 1" || die "Can't resolve type constraint $name without installing Type::Tiny";
 254     my $tc =  Type::Registry->new->foreign_lookup($name);
 255     return defined $tc ? $tc : die "'$name' not a type constraint in ${\$self->private_path}";
 256   }
 257
 258   my @tc = eval "package ${\$self->class}; $name" or do {
 259     # ok... so its not defined in the package.  we need to look at all the roles
 260     # and superclasses, look for attributes and figure it out.
 261     # Superclasses take precedence;
 262     #
 263     my @supers = map { $_->meta } $self->class->meta->superclasses;
 264     my @roles = $self->class->meta->calculate_all_roles;
 265
 266     # So look thru all the super and roles in order and return the
 267     # first type constraint found. We should probably find all matching
 268     # type constraints and try to do some sort of resolution.
 269
 270     foreach my $parent (@roles, @supers) {
 271       if(my $m = $parent->get_method($self->name)) {
 272         if($m->can('attributes')) {
 273           my ($key, $value) = map { $_ =~ /^(.*?)(?:\(\s*(.+?)\s*\))?$/ }
 274             grep { $_=~/^Args\(/ or $_=~/^CaptureArgs\(/ }
 275               @{$m->attributes};
 276           next unless $value eq $name;
 277           my @tc = eval "package ${\$parent->name}; $name";
 278           return @tc if @tc;
 279         }
 280       }
 281     }
 282
 283     die "'$name' not a type constraint in ${\$self->private_path}";
 284   };
 285
 286   if($tc[0]) {
 287     return map { ref($_) ? $_ : Moose::Util::TypeConstraints::find_or_parse_type_constraint($_) } @tc;
 288   } else {
 289     return;
 290   }
 291 }
 292
 293 has number_of_captures => (
 294   is=>'ro',
 295   init_arg=>undef,
 296   isa=>'Int',
 297   required=>1,
 298   lazy=>1,
 299   builder=>'_build_number_of_captures');
 300
 301   sub _build_number_of_captures {
 302     my $self = shift;
 303     if( ! exists $self->attributes->{CaptureArgs} ) {
 304       # If there are no defined capture args, thats considered 0.
 305       return 0;
 306     } elsif(!defined($self->attributes->{CaptureArgs}[0])) {
 307       # If you fail to give a defined value, that's also 0
 308       return 0;
 309     } elsif(
 310       scalar(@{$self->attributes->{CaptureArgs}}) == 1 &&
 311       looks_like_number($self->attributes->{CaptureArgs}[0])
 312     ) {
 313       # 'Old school' numbered captures
 314       return $self->attributes->{CaptureArgs}[0];
 315     } else {
 316       # New hotness named arg constraints
 317       return $self->number_of_captures_constraints;
 318     }
 319   }
 320
 321
 322 use overload (
 323
 324     # Stringify to reverse for debug output etc.
 325     q{""} => sub { shift->{reverse} },
 326
 327     # Codulate to execute to invoke the encapsulated action coderef
 328     '&{}' => sub { my $self = shift; sub { $self->execute(@_); }; },
 329
 330     # Make general $stuff still work
 331     fallback => 1,
 332
 333 );
 334
 335 no warnings 'recursion';
 336
 337 sub dispatch {    # Execute ourselves against a context
 338     my ( $self, $c ) = @_;
 339     return $c->execute( $self->class, $self );
 340 }
 341
 342 sub execute {
 343   my $self = shift;
 344   $self->code->(@_);
 345 }
 346
 347 sub match {
 348     my ( $self, $c ) = @_;
 349     return $self->match_args($c, $c->req->args);
 350 }
 351
 352 sub match_args {
 353     my ($self, $c, $args) = @_;
 354     my @args = @{$args||[]};
 355
 356     # There there are arg constraints, we must see to it that the constraints
 357     # check positive for each arg in the list.
 358     if($self->has_args_constraints) {
 359       # If there is only one type constraint, and its a Ref or subtype of Ref,
 360       # That means we expect a reference, so use the full args arrayref.
 361       if(
 362         $self->args_constraint_count == 1 &&
 363         (
 364           $self->args_constraints->[0]->is_a_type_of('Ref') ||
 365           $self->args_constraints->[0]->is_a_type_of('ClassName')
 366         )
 367       ) {
 368         # Ok, the the type constraint is a ref type, which is allowed to have
 369         # any number of args.  We need to check the arg length, if one is defined.
 370         # If we had a ref type constraint that allowed us to determine the allowed
 371         # number of args, we need to match that number.  Otherwise if there was an
 372         # undetermined number (~0) then we allow all the args.  This is more of an
 373         # Optimization since Tuple[Int, Int] would fail on 3,4,5 anyway, but this
 374         # way we can avoid calling the constraint when the arg length is incorrect.
 375         if(
 376           $self->normalized_arg_number == ~0 ||
 377           scalar( @args ) == $self->normalized_arg_number
 378         ) {
 379           return $self->args_constraints->[0]->check($args);
 380         } else {
 381           return 0;
 382         }
 383         # Removing coercion stuff for the first go
 384         #if($self->args_constraints->[0]->coercion && $self->attributes->{Coerce}) {
 385         #  my $coerced = $self->args_constraints->[0]->coerce($c) || return 0;
 386         #  $c->req->args([$coerced]);
 387         #  return 1;
 388         #}
 389       } else {
 390         # Because of the way chaining works, we can expect args that are totally not
 391         # what you'd expect length wise.  When they don't match length, thats a fail
 392         return 0 unless scalar( @args ) == $self->normalized_arg_number;
 393
 394         for my $i(0..$#args) {
 395           $self->args_constraints->[$i]->check($args[$i]) || return 0;
 396         }
 397         return 1;
 398       }
 399     } else {
 400       # If infinite args with no constraints, we always match
 401       return 1 if $self->normalized_arg_number == ~0;
 402
 403       # Otherwise, we just need to match the number of args.
 404       return scalar( @args ) == $self->normalized_arg_number;
 405     }
 406 }
 407
 408 sub match_captures {
 409   my ($self, $c, $captures) = @_;
 410   my @captures = @{$captures||[]};
 411
 412   return 1 unless scalar(@captures); # If none, just say its ok
 413   return $self->has_captures_constraints ?
 414     $self->match_captures_constraints($c, $captures) : 1;
 415
 416   return 1;
 417 }
 418
 419 sub match_captures_constraints {
 420   my ($self, $c, $captures) = @_;
 421   my @captures = @{$captures||[]};
 422
 423   # Match is positive if you don't have any.
 424   return 1 unless $self->has_captures_constraints;
 425
 426   if(
 427     $self->captures_constraints_count == 1 &&
 428     (
 429       $self->captures_constraints->[0]->is_a_type_of('Ref') ||
 430       $self->captures_constraints->[0]->is_a_type_of('ClassName')
 431     )
 432   ) {
 433     return $self->captures_constraints->[0]->check($captures);
 434   } else {
 435     for my $i(0..$#captures) {
 436       $self->captures_constraints->[$i]->check($captures[$i]) || return 0;
 437     }
 438     return 1;
 439     }
 440
 441 }
 442
 443
 444 sub compare {
 445     my ($a1, $a2) = @_;
 446     return $a1->normalized_arg_number <=> $a2->normalized_arg_number;
 447 }
 448
 449 sub scheme {
 450   return exists $_[0]->attributes->{Scheme} ? $_[0]->attributes->{Scheme}[0] : undef;
 451 }
 452
 453 sub list_extra_info {
 454   my $self = shift;
 455   return {
 456     Args => $self->normalized_arg_number,
 457     CaptureArgs => $self->number_of_captures,
 458   }
 459 }
 460
 461 __PACKAGE__->meta->make_immutable;
 462
 463 1;
 464
 465 __END__
 466
 467 =head1 METHODS
 468
 469 =head2 attributes
 470
 471 The sub attributes that are set for this action, like Local, Path, Private
 472 and so on. This determines how the action is dispatched to.
 473
 474 =head2 class
 475
 476 Returns the name of the component where this action is defined.
 477 Derived by calling the L<catalyst_component_name|Catalyst::Component/catalyst_component_name>
 478 method on each component.
 479
 480 =head2 code
 481
 482 Returns a code reference to this action.
 483
 484 =head2 dispatch( $c )
 485
 486 Dispatch this action against a context.
 487
 488 =head2 execute( $controller, $c, @args )
 489
 490 Execute this action's coderef against a given controller with a given
 491 context and arguments
 492
 493 =head2 match( $c )
 494
 495 Check Args attribute, and makes sure number of args matches the setting.
 496 Always returns true if Args is omitted.
 497
 498 =head2 match_captures ($c, $captures)
 499
 500 Can be implemented by action class and action role authors. If the method
 501 exists, then it will be called with the request context and an array reference
 502 of the captures for this action.
 503
 504 Returning true from this method causes the chain match to continue, returning
 505 makes the chain not match (and alternate, less preferred chains will be attempted).
 506
 507 =head2 match_captures_constraints ($c, \@captures);
 508
 509 Does the \@captures given match any constraints (if any constraints exist).  Returns
 510 true if you ask but there are no constraints.
 511
 512 =head2 match_args($c, $args)
 513
 514 Does the Args match or not?
 515
 516 =head2 resolve_type_constraint
 517
 518 Trys to find a type constraint if you have on on a type constrained method.
 519
 520 =head2 compare
 521
 522 Compares 2 actions based on the value of the C<Args> attribute, with no C<Args>
 523 having the highest precedence.
 524
 525 =head2 namespace
 526
 527 Returns the private namespace this action lives in.
 528
 529 =head2 reverse
 530
 531 Returns the private path for this action.
 532
 533 =head2 private_path
 534
 535 Returns absolute private path for this action. Unlike C<reverse>, the
 536 C<private_path> of an action is always suitable for passing to C<forward>.
 537
 538 =head2 name
 539
 540 Returns the sub name of this action.
 541
 542 =head2 number_of_args
 543
 544 Returns the number of args this action expects. This is 0 if the action doesn't
 545 take any arguments and undef if it will take any number of arguments.
 546
 547 =head2 normalized_arg_number
 548
 549 For the purposes of comparison we normalize 'number_of_args' so that if it is
 550 undef we mean ~0 (as many args are we can think of).
 551
 552 =head2 number_of_captures
 553
 554 Returns the number of captures this action expects for L<Chained|Catalyst::DispatchType::Chained> actions.
 555
 556 =head2 list_extra_info
 557
 558 A HashRef of key-values that an action can provide to a debugging screen
 559
 560 =head2 scheme
 561
 562 Any defined scheme for the action
 563
 564 =head2 meta
 565
 566 Provided by Moose.
 567
 568 =head1 AUTHORS
 569
 570 Catalyst Contributors, see Catalyst.pm
 571
 572 =head1 COPYRIGHT
 573
 574 This library is free software. You can redistribute it and/or modify it under
 575 the same terms as Perl itself.
 576
 577 =cut
 578
 579