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 instance => (is=>'ro', required=>0, predicate=>'has_instance');
  30 has namespace => (is => 'rw');
  31 has 'reverse' => (is => 'rw');
  32 has attributes => (is => 'rw');
  33 has name => (is => 'rw');
  34 has code => (is => 'rw');
  35 has private_path => (
  36   reader => 'private_path',
  37   isa => 'Str',
  38   lazy => 1,
  39   required => 1,
  40   default => sub { '/'.shift->reverse },
  41 );
  42
  43 has number_of_args => (
  44   is=>'ro',
  45   init_arg=>undef,
  46   isa=>'Int|Undef',
  47   required=>1,
  48   lazy=>1,
  49   builder=>'_build_number_of_args');
  50
  51   sub _build_number_of_args {
  52     my $self = shift;
  53     if( ! exists $self->attributes->{Args} ) {
  54       # When 'Args' does not exist, that means we want 'any number of args'.
  55       return undef;
  56     } elsif(!defined($self->attributes->{Args}[0])) {
  57       # When its 'Args' that internal cue for 'unlimited'
  58       return undef;
  59     } elsif(
  60       scalar(@{$self->attributes->{Args}}) == 1 &&
  61       looks_like_number($self->attributes->{Args}[0])
  62     ) {
  63       # 'Old school' numbered args (is allowed to be undef as well)
  64       return $self->attributes->{Args}[0];
  65     } else {
  66       # New hotness named arg constraints
  67       return $self->number_of_args_constraints;
  68     }
  69   }
  70
  71 sub normalized_arg_number {
  72   return $_[0]->number_of_args;
  73 }
  74
  75 sub comparable_arg_number {
  76   return defined($_[0]->number_of_args) ? $_[0]->number_of_args : ~0;
  77 }
  78
  79 has number_of_args_constraints => (
  80   is=>'ro',
  81   isa=>'Int|Undef',
  82   init_arg=>undef,
  83   required=>1,
  84   lazy=>1,
  85   builder=>'_build_number_of_args_constraints');
  86
  87   sub _build_number_of_args_constraints {
  88     my $self = shift;
  89     return unless $self->has_args_constraints;
  90
  91     # If there is one constraint and its a ref, we need to decide
  92     # if this number 'unknown' number or if the ref allows us to
  93     # determine a length.
  94
  95     if(scalar @{$self->args_constraints} == 1) {
  96       my $tc = $self->args_constraints->[0];
  97       if(
  98         $tc->can('is_strictly_a_type_of') &&
  99         $tc->is_strictly_a_type_of('Tuple'))
 100       {
 101         my @parameters = @{ $tc->parameters||[] };
 102         my $final = $parameters[-1];
 103         if ( defined $final ) {
 104           if ( blessed $final ) {
 105             # modern form of slurpy
 106             if ($final->can('is_strictly_a_type_of') && $final->is_strictly_a_type_of('Slurpy')) {
 107               return undef;
 108             }
 109           }
 110           else {
 111             # old form of slurpy
 112             if (ref $final eq 'HASH' && $final->{slurpy}) {
 113               return undef;
 114             }
 115           }
 116         }
 117         return scalar @parameters;
 118       } elsif($tc->is_a_type_of('Ref')) {
 119         return undef;
 120       } else {
 121         return 1; # Its a normal 1 arg type constraint.
 122       }
 123     } else {
 124       # We need to loop through and error on ref types.  We don't allow a ref type
 125       # in the middle.
 126       my $total = 0;
 127       foreach my $tc( @{$self->args_constraints}) {
 128         if($tc->is_a_type_of('Ref')) {
 129           die "$tc is a Ref type constraint.  You cannot mix Ref and non Ref type constraints in Args for action ${\$self->reverse}";
 130         } else {
 131           ++$total;
 132         }
 133       }
 134       return $total;
 135     }
 136   }
 137
 138 has args_constraints => (
 139   is=>'ro',
 140   init_arg=>undef,
 141   traits=>['Array'],
 142   isa=>'ArrayRef',
 143   required=>1,
 144   lazy=>1,
 145   builder=>'_build_args_constraints',
 146   handles => {
 147     has_args_constraints => 'count',
 148     args_constraint_count => 'count',
 149     all_args_constraints => 'elements',
 150   });
 151
 152   sub _build_args_constraints {
 153     my $self = shift;
 154     my @arg_protos = @{$self->attributes->{Args}||[]};
 155
 156     return [] unless scalar(@arg_protos);
 157     return [] unless defined($arg_protos[0]);
 158
 159     # If there is only one arg and it looks like a number
 160     # we assume its 'classic' and the number is the number of
 161     # constraints.
 162     my @args = ();
 163     if(
 164       scalar(@arg_protos) == 1 &&
 165       looks_like_number($arg_protos[0])
 166     ) {
 167       return \@args;
 168     } else {
 169       @args =
 170         map {  my @tc = $self->resolve_type_constraint($_); scalar(@tc) ? @tc : die "$_ is not a constraint!" }
 171         @arg_protos;
 172     }
 173     return \@args;
 174   }
 175
 176 has number_of_captures_constraints => (
 177   is=>'ro',
 178   isa=>'Int|Undef',
 179   init_arg=>undef,
 180   required=>1,
 181   lazy=>1,
 182   builder=>'_build_number_of_capture_constraints');
 183
 184   sub _build_number_of_capture_constraints {
 185     my $self = shift;
 186     return unless $self->has_captures_constraints;
 187
 188     # If there is one constraint and its a ref, we need to decide
 189     # if this number 'unknown' number or if the ref allows us to
 190     # determine a length.
 191
 192     if(scalar @{$self->captures_constraints} == 1) {
 193       my $tc = $self->captures_constraints->[0];
 194       if(
 195         $tc->can('is_strictly_a_type_of') &&
 196         $tc->is_strictly_a_type_of('Tuple'))
 197       {
 198         my @parameters = @{ $tc->parameters||[]};
 199         if( defined($parameters[-1]) and exists($parameters[-1]->{slurpy})) {
 200           return undef;
 201         } else {
 202           return my $total_params = scalar(@parameters);
 203         }
 204       } elsif($tc->is_a_type_of('Ref')) {
 205         die "You cannot use CaptureArgs($tc) in ${\$self->reverse} because we cannot determined the number of its parameters";
 206       } else {
 207         return 1; # Its a normal 1 arg type constraint.
 208       }
 209     } else {
 210       # We need to loop through and error on ref types.  We don't allow a ref type
 211       # in the middle.
 212       my $total = 0;
 213       foreach my $tc( @{$self->captures_constraints}) {
 214         if($tc->is_a_type_of('Ref')) {
 215           die "$tc is a Ref type constraint.  You cannot mix Ref and non Ref type constraints in CaptureArgs for action ${\$self->reverse}";
 216         } else {
 217           ++$total;
 218         }
 219       }
 220       return $total;
 221     }
 222   }
 223
 224 has captures_constraints => (
 225   is=>'ro',
 226   init_arg=>undef,
 227   traits=>['Array'],
 228   isa=>'ArrayRef',
 229   required=>1,
 230   lazy=>1,
 231   builder=>'_build_captures_constraints',
 232   handles => {
 233     has_captures_constraints => 'count',
 234     captures_constraints_count => 'count',
 235     all_captures_constraints => 'elements',
 236   });
 237
 238   sub _build_captures_constraints {
 239     my $self = shift;
 240     my @arg_protos = @{$self->attributes->{CaptureArgs}||[]};
 241
 242     return [] unless scalar(@arg_protos);
 243     return [] unless defined($arg_protos[0]);
 244     # If there is only one arg and it looks like a number
 245     # we assume its 'classic' and the number is the number of
 246     # constraints.
 247     my @args = ();
 248     if(
 249       scalar(@arg_protos) == 1 &&
 250       looks_like_number($arg_protos[0])
 251     ) {
 252       return \@args;
 253     } else {
 254       @args =
 255         map {  my @tc = $self->resolve_type_constraint($_); scalar(@tc) ? @tc : die "$_ is not a constraint!" }
 256         @arg_protos;
 257     }
 258
 259     return \@args;
 260   }
 261
 262 sub resolve_type_constraint {
 263   my ($self, $name) = @_;
 264
 265   if(defined($name) && blessed($name) && $name->can('check')) {
 266     # Its already a TC, good to go.
 267     return $name;
 268   }
 269
 270   # This is broken for when there is more than one constraint
 271   if($name=~m/::/) {
 272     eval "use Type::Registry; 1" || die "Can't resolve type constraint $name without installing Type::Tiny";
 273     my $tc =  Type::Registry->new->foreign_lookup($name);
 274     return defined $tc ? $tc : die "'$name' not a full namespace type constraint in ${\$self->private_path}";
 275   }
 276
 277   my @tc = grep { defined $_ } (eval("package ${\$self->class}; $name"));
 278
 279   unless(scalar @tc) {
 280     # ok... so its not defined in the package.  we need to look at all the roles
 281     # and superclasses, look for attributes and figure it out.
 282     # Superclasses take precedence;
 283
 284     my @supers = $self->class->can('meta') ? map { $_->meta } $self->class->meta->superclasses : ();
 285     my @roles = $self->class->can('meta') ? $self->class->meta->calculate_all_roles : ();
 286
 287     # So look through all the super and roles in order and return the
 288     # first type constraint found. We should probably find all matching
 289     # type constraints and try to do some sort of resolution.
 290
 291     foreach my $parent (@roles, @supers) {
 292       if(my $m = $parent->get_method($self->name)) {
 293         if($m->can('attributes')) {
 294           my ($key, $value) = map { $_ =~ /^(.*?)(?:\(\s*(.+?)\s*\))?$/ }
 295             grep { $_=~/^Args\(/ or $_=~/^CaptureArgs\(/ }
 296               @{$m->attributes};
 297           next unless $value eq $name;
 298           my @tc = eval "package ${\$parent->name}; $name";
 299           if(scalar(@tc)) {
 300             return map { ref($_) ? $_ : Moose::Util::TypeConstraints::find_or_parse_type_constraint($_) } @tc;
 301           } else {
 302             return;
 303           }
 304         }
 305       }
 306     }
 307
 308     my $classes = join(',', $self->class, @roles, @supers);
 309     die "'$name' not a type constraint in '${\$self->private_path}', Looked in: $classes";
 310   }
 311
 312   if(scalar(@tc)) {
 313     return map { ref($_) ? $_ : Moose::Util::TypeConstraints::find_or_parse_type_constraint($_) } @tc;
 314   } else {
 315     return;
 316   }
 317 }
 318
 319 has number_of_captures => (
 320   is=>'ro',
 321   init_arg=>undef,
 322   isa=>'Int',
 323   required=>1,
 324   lazy=>1,
 325   builder=>'_build_number_of_captures');
 326
 327   sub _build_number_of_captures {
 328     my $self = shift;
 329     if( ! exists $self->attributes->{CaptureArgs} ) {
 330       # If there are no defined capture args, thats considered 0.
 331       return 0;
 332     } elsif(!defined($self->attributes->{CaptureArgs}[0])) {
 333       # If you fail to give a defined value, that's also 0
 334       return 0;
 335     } elsif(
 336       scalar(@{$self->attributes->{CaptureArgs}}) == 1 &&
 337       looks_like_number($self->attributes->{CaptureArgs}[0])
 338     ) {
 339       # 'Old school' numbered captures
 340       return $self->attributes->{CaptureArgs}[0];
 341     } else {
 342       # New hotness named arg constraints
 343       return $self->number_of_captures_constraints;
 344     }
 345   }
 346
 347
 348 use overload (
 349
 350     # Stringify to reverse for debug output etc.
 351     q{""} => sub { shift->{reverse} },
 352
 353     # Codulate to execute to invoke the encapsulated action coderef
 354     '&{}' => sub { my $self = shift; sub { $self->execute(@_); }; },
 355
 356     # Make general $stuff still work
 357     fallback => 1,
 358
 359 );
 360
 361 no warnings 'recursion';
 362
 363 sub dispatch {    # Execute ourselves against a context
 364     my ( $self, $c ) = @_;
 365     if($self->has_instance) {
 366         return $c->execute( $self->instance, $self );
 367     } else {
 368         return $c->execute( $self->class, $self );
 369     }
 370 }
 371
 372 sub execute {
 373   my $self = shift;
 374   $self->code->(@_);
 375 }
 376
 377 sub match {
 378     my ( $self, $c ) = @_;
 379     return $self->match_args($c, $c->req->args);
 380 }
 381
 382 sub match_args {
 383     my ($self, $c, $args) = @_;
 384     my @args = @{$args||[]};
 385
 386     # There there are arg constraints, we must see to it that the constraints
 387     # check positive for each arg in the list.
 388     if($self->has_args_constraints) {
 389       # If there is only one type constraint, and its a Ref or subtype of Ref,
 390       # That means we expect a reference, so use the full args arrayref.
 391       if(
 392         $self->args_constraint_count == 1 &&
 393         (
 394           $self->args_constraints->[0]->is_a_type_of('Ref') ||
 395           $self->args_constraints->[0]->is_a_type_of('ClassName')
 396         )
 397       ) {
 398         # Ok, the the type constraint is a ref type, which is allowed to have
 399         # any number of args.  We need to check the arg length, if one is defined.
 400         # If we had a ref type constraint that allowed us to determine the allowed
 401         # number of args, we need to match that number.  Otherwise if there was an
 402         # undetermined number (~0) then we allow all the args.  This is more of an
 403         # Optimization since Tuple[Int, Int] would fail on 3,4,5 anyway, but this
 404         # way we can avoid calling the constraint when the arg length is incorrect.
 405         if(
 406           $self->comparable_arg_number == ~0 ||
 407           scalar( @args ) == $self->comparable_arg_number
 408         ) {
 409           return $self->args_constraints->[0]->check($args);
 410         } else {
 411           return 0;
 412         }
 413         # Removing coercion stuff for the first go
 414         #if($self->args_constraints->[0]->coercion && $self->attributes->{Coerce}) {
 415         #  my $coerced = $self->args_constraints->[0]->coerce($c) || return 0;
 416         #  $c->req->args([$coerced]);
 417         #  return 1;
 418         #}
 419       } else {
 420         # Because of the way chaining works, we can expect args that are totally not
 421         # what you'd expect length wise.  When they don't match length, thats a fail
 422         return 0 unless scalar( @args ) == $self->comparable_arg_number;
 423
 424         for my $i(0..$#args) {
 425           $self->args_constraints->[$i]->check($args[$i]) || return 0;
 426         }
 427         return 1;
 428       }
 429     } else {
 430       # If infinite args with no constraints, we always match
 431       return 1 if $self->comparable_arg_number == ~0;
 432
 433       # Otherwise, we just need to match the number of args.
 434       return scalar( @args ) == $self->comparable_arg_number;
 435     }
 436 }
 437
 438 sub match_captures {
 439   my ($self, $c, $captures) = @_;
 440   my @captures = @{$captures||[]};
 441
 442   return 1 unless scalar(@captures); # If none, just say its ok
 443   return $self->has_captures_constraints ?
 444     $self->match_captures_constraints($c, $captures) : 1;
 445
 446   return 1;
 447 }
 448
 449 sub match_captures_constraints {
 450   my ($self, $c, $captures) = @_;
 451   my @captures = @{$captures||[]};
 452
 453   # Match is positive if you don't have any.
 454   return 1 unless $self->has_captures_constraints;
 455
 456   if(
 457     $self->captures_constraints_count == 1 &&
 458     (
 459       $self->captures_constraints->[0]->is_a_type_of('Ref') ||
 460       $self->captures_constraints->[0]->is_a_type_of('ClassName')
 461     )
 462   ) {
 463     return $self->captures_constraints->[0]->check($captures);
 464   } else {
 465     for my $i(0..$#captures) {
 466       $self->captures_constraints->[$i]->check($captures[$i]) || return 0;
 467     }
 468     return 1;
 469     }
 470
 471 }
 472
 473
 474 sub compare {
 475     my ($a1, $a2) = @_;
 476     return $a1->comparable_arg_number <=> $a2->comparable_arg_number;
 477 }
 478
 479 sub equals {
 480   my ($self, $target) = @_;
 481   return $self->private_path eq $target->private_path ? $self : 0;
 482 }
 483
 484 sub scheme {
 485   return exists $_[0]->attributes->{Scheme} ? $_[0]->attributes->{Scheme}[0] : undef;
 486 }
 487
 488 sub list_extra_info {
 489   my $self = shift;
 490   return {
 491     Args => $self->normalized_arg_number,
 492     CaptureArgs => $self->number_of_captures,
 493   }
 494 }
 495
 496 __PACKAGE__->meta->make_immutable;
 497
 498 1;
 499
 500 __END__
 501
 502 =head1 METHODS
 503
 504 =head2 attributes
 505
 506 The sub attributes that are set for this action, like Local, Path, Private
 507 and so on. This determines how the action is dispatched to.
 508
 509 =head2 class
 510
 511 Returns the name of the component where this action is defined.
 512 Derived by calling the L<catalyst_component_name|Catalyst::Component/catalyst_component_name>
 513 method on each component.
 514
 515 =head2 code
 516
 517 Returns a code reference to this action.
 518
 519 =head2 dispatch( $c )
 520
 521 Dispatch this action against a context.
 522
 523 =head2 execute( $controller, $c, @args )
 524
 525 Execute this action's coderef against a given controller with a given
 526 context and arguments
 527
 528 =head2 match( $c )
 529
 530 Check Args attribute, and makes sure number of args matches the setting.
 531 Always returns true if Args is omitted.
 532
 533 =head2 match_captures ($c, $captures)
 534
 535 Can be implemented by action class and action role authors. If the method
 536 exists, then it will be called with the request context and an array reference
 537 of the captures for this action.
 538
 539 Returning true from this method causes the chain match to continue, returning
 540 makes the chain not match (and alternate, less preferred chains will be attempted).
 541
 542 =head2 match_captures_constraints ($c, \@captures);
 543
 544 Does the \@captures given match any constraints (if any constraints exist).  Returns
 545 true if you ask but there are no constraints.
 546
 547 =head2 match_args($c, $args)
 548
 549 Does the Args match or not?
 550
 551 =head2 resolve_type_constraint
 552
 553 Tries to find a type constraint if you have on on a type constrained method.
 554
 555 =head2 compare
 556
 557 Compares 2 actions based on the value of the C<Args> attribute, with no C<Args>
 558 having the highest precedence.
 559
 560 =head2 equals
 561
 562     if( $action->equal($other_action) ) { ... }
 563
 564 Returns true if the two actions are equal.
 565
 566 =head2 namespace
 567
 568 Returns the private namespace this action lives in.
 569
 570 =head2 reverse
 571
 572 Returns the private path for this action.
 573
 574 =head2 private_path
 575
 576 Returns absolute private path for this action. Unlike C<reverse>, the
 577 C<private_path> of an action is always suitable for passing to C<forward>.
 578
 579 =head2 name
 580
 581 Returns the sub name of this action.
 582
 583 =head2 number_of_args
 584
 585 Returns the number of args this action expects. This is 0 if the action doesn't
 586 take any arguments and undef if it will take any number of arguments.
 587
 588 =head2 normalized_arg_number
 589
 590 The number of arguments (starting with zero) that the current action defines, or
 591 undefined if there is not defined number of args (which is later treated as, "
 592 as many arguments as you like").
 593
 594 =head2 comparable_arg_number
 595
 596 For the purposes of comparison we normalize 'number_of_args' so that if it is
 597 undef we mean ~0 (as many args are we can think of).
 598
 599 =head2 number_of_captures
 600
 601 Returns the number of captures this action expects for L<Chained|Catalyst::DispatchType::Chained> actions.
 602
 603 =head2 list_extra_info
 604
 605 A HashRef of key-values that an action can provide to a debugging screen
 606
 607 =head2 scheme
 608
 609 Any defined scheme for the action
 610
 611 =head2 meta
 612
 613 Provided by Moose.
 614
 615 =head1 AUTHORS
 616
 617 Catalyst Contributors, see Catalyst.pm
 618
 619 =head1 COPYRIGHT
 620
 621 This library is free software. You can redistribute it and/or modify it under
 622 the same terms as Perl itself.
 623
 624 =cut
 625
 626