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 scheme {
 464   return exists $_[0]->attributes->{Scheme} ? $_[0]->attributes->{Scheme}[0] : undef;
 465 }
 466
 467 sub list_extra_info {
 468   my $self = shift;
 469   return {
 470     Args => $self->normalized_arg_number,
 471     CaptureArgs => $self->number_of_captures,
 472   }
 473 }
 474
 475 __PACKAGE__->meta->make_immutable;
 476
 477 1;
 478
 479 __END__
 480
 481 =head1 METHODS
 482
 483 =head2 attributes
 484
 485 The sub attributes that are set for this action, like Local, Path, Private
 486 and so on. This determines how the action is dispatched to.
 487
 488 =head2 class
 489
 490 Returns the name of the component where this action is defined.
 491 Derived by calling the L<catalyst_component_name|Catalyst::Component/catalyst_component_name>
 492 method on each component.
 493
 494 =head2 code
 495
 496 Returns a code reference to this action.
 497
 498 =head2 dispatch( $c )
 499
 500 Dispatch this action against a context.
 501
 502 =head2 execute( $controller, $c, @args )
 503
 504 Execute this action's coderef against a given controller with a given
 505 context and arguments
 506
 507 =head2 match( $c )
 508
 509 Check Args attribute, and makes sure number of args matches the setting.
 510 Always returns true if Args is omitted.
 511
 512 =head2 match_captures ($c, $captures)
 513
 514 Can be implemented by action class and action role authors. If the method
 515 exists, then it will be called with the request context and an array reference
 516 of the captures for this action.
 517
 518 Returning true from this method causes the chain match to continue, returning
 519 makes the chain not match (and alternate, less preferred chains will be attempted).
 520
 521 =head2 match_captures_constraints ($c, \@captures);
 522
 523 Does the \@captures given match any constraints (if any constraints exist).  Returns
 524 true if you ask but there are no constraints.
 525
 526 =head2 match_args($c, $args)
 527
 528 Does the Args match or not?
 529
 530 =head2 resolve_type_constraint
 531
 532 Tries to find a type constraint if you have on on a type constrained method.
 533
 534 =head2 compare
 535
 536 Compares 2 actions based on the value of the C<Args> attribute, with no C<Args>
 537 having the highest precedence.
 538
 539 =head2 namespace
 540
 541 Returns the private namespace this action lives in.
 542
 543 =head2 reverse
 544
 545 Returns the private path for this action.
 546
 547 =head2 private_path
 548
 549 Returns absolute private path for this action. Unlike C<reverse>, the
 550 C<private_path> of an action is always suitable for passing to C<forward>.
 551
 552 =head2 name
 553
 554 Returns the sub name of this action.
 555
 556 =head2 number_of_args
 557
 558 Returns the number of args this action expects. This is 0 if the action doesn't
 559 take any arguments and undef if it will take any number of arguments.
 560
 561 =head2 normalized_arg_number
 562
 563 The number of arguments (starting with zero) that the current action defines, or
 564 undefined if there is not defined number of args (which is later treated as, "
 565 as many arguments as you like").
 566
 567 =head2 comparable_arg_number
 568
 569 For the purposes of comparison we normalize 'number_of_args' so that if it is
 570 undef we mean ~0 (as many args are we can think of).
 571
 572 =head2 number_of_captures
 573
 574 Returns the number of captures this action expects for L<Chained|Catalyst::DispatchType::Chained> actions.
 575
 576 =head2 list_extra_info
 577
 578 A HashRef of key-values that an action can provide to a debugging screen
 579
 580 =head2 scheme
 581
 582 Any defined scheme for the action
 583
 584 =head2 meta
 585
 586 Provided by Moose.
 587
 588 =head1 AUTHORS
 589
 590 Catalyst Contributors, see Catalyst.pm
 591
 592 =head1 COPYRIGHT
 593
 594 This library is free software. You can redistribute it and/or modify it under
 595 the same terms as Perl itself.
 596
 597 =cut
 598
 599