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