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