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