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