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