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';
  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     my $total = 0;
  87     foreach my $tc( @{$self->args_constraints}) {
  88       if($tc->is_a_type_of('Ref')) {
  89         if($tc->can('parameters') && $tc->has_parameters) {
  90           my $total_params = scalar(@{ $tc->parameters||[] });
  91           $total = $total + $total_params;
  92         } else {
  93           # Its a Reftype but we don't know the number of params it
  94           # actually validates.
  95           warn "Your type constraint '$tc' is a reference type but I cannot determine its number of parameters in action ${\$self->private_path}";
  96           return undef;
  97         }
  98       } else {
  99         $total++;
 100       }
 101     }
 102
 103     return $total;
 104   }
 105
 106 has args_constraints => (
 107   is=>'ro',
 108   init_arg=>undef,
 109   traits=>['Array'],
 110   isa=>'ArrayRef',
 111   required=>1,
 112   lazy=>1,
 113   builder=>'_build_args_constraints',
 114   handles => {
 115     has_args_constraints => 'count',
 116     args_constraint_count => 'count',
 117   });
 118
 119   sub _build_args_constraints {
 120     my $self = shift;
 121     my @arg_protos = @{$self->attributes->{Args}||[]};
 122
 123     return [] unless scalar(@arg_protos);
 124     return [] unless defined($arg_protos[0]);
 125
 126     # If there is only one arg and it looks like a number
 127     # we assume its 'classic' and the number is the number of
 128     # constraints.
 129     my @args = ();
 130     if(
 131       scalar(@arg_protos) == 1 &&
 132       looks_like_number($arg_protos[0])
 133     ) {
 134       return \@args;
 135     } else {
 136       @args =
 137         map {  my @tc = $self->resolve_type_constraint($_); scalar(@tc) ? @tc : die "$_ is not a constraint!" }
 138         @arg_protos;
 139     }
 140     return \@args;
 141   }
 142
 143 has number_of_captures_constraints => (
 144   is=>'ro',
 145   isa=>'Int|Undef',
 146   init_arg=>undef,
 147   required=>1,
 148   lazy=>1,
 149   builder=>'_build_number_of_capture_constraints');
 150
 151   sub _build_number_of_capture_constraints {
 152     my $self = shift;
 153     return unless $self->has_captures_constraints;
 154
 155     my $total = 0;
 156     foreach my $tc( @{$self->captures_constraints}) {
 157       if($tc->is_a_type_of('Ref')) {
 158         if($tc->can('parameters') && $tc->has_parameters) {
 159           my $total_params = scalar(@{ $tc->parameters||[] });
 160           $total = $total + $total_params;
 161         } else {
 162           # Its a Reftype but we don't know the number of params it
 163           # actually validates.  This is not currently permitted in
 164           # a capture...
 165           die "You cannot use CaptureArgs($tc) in ${\$self->reverse} because we cannot determined the number of its parameters";
 166         }
 167       } else {
 168         $total++;
 169       }
 170     }
 171
 172     return $total;
 173   }
 174
 175 has captures_constraints => (
 176   is=>'ro',
 177   init_arg=>undef,
 178   traits=>['Array'],
 179   isa=>'ArrayRef',
 180   required=>1,
 181   lazy=>1,
 182   builder=>'_build_captures_constraints',
 183   handles => {
 184     has_captures_constraints => 'count',
 185     captures_constraints_count => 'count',
 186   });
 187
 188   sub _build_captures_constraints {
 189     my $self = shift;
 190     my @arg_protos = @{$self->attributes->{CaptureArgs}||[]};
 191
 192     return [] unless scalar(@arg_protos);
 193     return [] unless defined($arg_protos[0]);
 194     # If there is only one arg and it looks like a number
 195     # we assume its 'classic' and the number is the number of
 196     # constraints.
 197     my @args = ();
 198     if(
 199       scalar(@arg_protos) == 1 &&
 200       looks_like_number($arg_protos[0])
 201     ) {
 202       return \@args;
 203     } else {
 204       @args =
 205         map {  my @tc = $self->resolve_type_constraint($_); scalar(@tc) ? @tc : die "$_ is not a constraint!" }
 206         @arg_protos;
 207     }
 208
 209     return \@args;
 210   }
 211
 212 sub resolve_type_constraint {
 213   my ($self, $name) = @_;
 214   my @tc = eval "package ${\$self->class}; $name";
 215   if($tc[0]) {
 216     return map { ref($_) ? $_ : Moose::Util::TypeConstraints::find_or_parse_type_constraint($_) } @tc;
 217   } else {
 218     return;
 219   }
 220 }
 221
 222 has number_of_captures => (
 223   is=>'ro',
 224   init_arg=>undef,
 225   isa=>'Int',
 226   required=>1,
 227   lazy=>1,
 228   builder=>'_build_number_of_captures');
 229
 230   sub _build_number_of_captures {
 231     my $self = shift;
 232     if( ! exists $self->attributes->{CaptureArgs} ) {
 233       # If there are no defined capture args, thats considered 0.
 234       return 0;
 235     } elsif(!defined($self->attributes->{CaptureArgs}[0])) {
 236       # If you fail to give a defined value, that's also 0
 237       return 0;
 238     } elsif(
 239       scalar(@{$self->attributes->{CaptureArgs}}) == 1 &&
 240       looks_like_number($self->attributes->{CaptureArgs}[0])
 241     ) {
 242       # 'Old school' numbered captures
 243       return $self->attributes->{CaptureArgs}[0];
 244     } else {
 245       # New hotness named arg constraints
 246       return $self->number_of_captures_constraints;
 247     }
 248   }
 249
 250
 251 use overload (
 252
 253     # Stringify to reverse for debug output etc.
 254     q{""} => sub { shift->{reverse} },
 255
 256     # Codulate to execute to invoke the encapsulated action coderef
 257     '&{}' => sub { my $self = shift; sub { $self->execute(@_); }; },
 258
 259     # Make general $stuff still work
 260     fallback => 1,
 261
 262 );
 263
 264 no warnings 'recursion';
 265
 266 sub dispatch {    # Execute ourselves against a context
 267     my ( $self, $c ) = @_;
 268     return $c->execute( $self->class, $self );
 269 }
 270
 271 sub execute {
 272   my $self = shift;
 273   $self->code->(@_);
 274 }
 275
 276 sub match {
 277     my ( $self, $c ) = @_;
 278     return $self->match_args($c, $c->req->args);
 279 }
 280
 281 sub match_args {
 282     my ($self, $c, $args) = @_;
 283     my @args = @{$args||[]};
 284
 285     # If infinite args, we always match
 286     return 1 if $self->normalized_arg_number == ~0;
 287
 288     # There there are arg constraints, we must see to it that the constraints
 289     # check positive for each arg in the list.
 290     if($self->has_args_constraints) {
 291       # If there is only one type constraint, and its a Ref or subtype of Ref,
 292       # That means we expect a reference, so use the full args arrayref.
 293       if(
 294         $self->args_constraint_count == 1 &&
 295         (
 296           $self->args_constraints->[0]->is_a_type_of('Ref') ||
 297           $self->args_constraints->[0]->is_a_type_of('ClassName')
 298         )
 299       ) {
 300         return $self->args_constraints->[0]->check($args);
 301         # Removing coercion stuff for the first go
 302         #if($self->args_constraints->[0]->coercion && $self->attributes->{Coerce}) {
 303         #  my $coerced = $self->args_constraints->[0]->coerce($c) || return 0;
 304         #  $c->req->args([$coerced]);
 305         #  return 1;
 306         #}
 307       } else {
 308         # Because of the way chaining works, we can expect args that are totally not
 309         # what you'd expect length wise.  When they don't match length, thats a fail
 310         return 0 unless scalar( @args ) == $self->normalized_arg_number;
 311
 312         for my $i(0..$#args) {
 313           $self->args_constraints->[$i]->check($args[$i]) || return 0;
 314         }
 315         return 1;
 316       }
 317     } else {
 318       # Otherwise, we just need to match the number of args.
 319       return scalar( @args ) == $self->normalized_arg_number;
 320     }
 321 }
 322
 323 sub match_captures {
 324   my ($self, $c, $captures) = @_;
 325   my @captures = @{$captures||[]};
 326
 327   return 1 unless scalar(@captures); # If none, just say its ok
 328
 329   if($self->has_captures_constraints) {
 330     if(
 331       $self->captures_constraints_count == 1 &&
 332       (
 333         $self->captures_constraints->[0]->is_a_type_of('Ref') ||
 334         $self->captures_constraints->[0]->is_a_type_of('ClassName')
 335       )
 336     ) {
 337       return $self->captures_constraints->[0]->check($captures);
 338     } else {
 339       for my $i(0..$#captures) {
 340         $self->captures_constraints->[$i]->check($captures[$i]) || return 0;
 341       }
 342       return 1;
 343       }
 344   } else {
 345     return 1;
 346   }
 347   return 1;
 348 }
 349
 350 sub compare {
 351     my ($a1, $a2) = @_;
 352     return $a1->normalized_arg_number <=> $a2->normalized_arg_number;
 353 }
 354
 355 sub scheme {
 356   return exists $_[0]->attributes->{Scheme} ? $_[0]->attributes->{Scheme}[0] : undef;
 357 }
 358
 359 sub list_extra_info {
 360   my $self = shift;
 361   return {
 362     Args => $self->normalized_arg_number,
 363     CaptureArgs => $self->number_of_captures,
 364   }
 365 }
 366
 367 __PACKAGE__->meta->make_immutable;
 368
 369 1;
 370
 371 __END__
 372
 373 =head1 METHODS
 374
 375 =head2 attributes
 376
 377 The sub attributes that are set for this action, like Local, Path, Private
 378 and so on. This determines how the action is dispatched to.
 379
 380 =head2 class
 381
 382 Returns the name of the component where this action is defined.
 383 Derived by calling the L<catalyst_component_name|Catalyst::Component/catalyst_component_name>
 384 method on each component.
 385
 386 =head2 code
 387
 388 Returns a code reference to this action.
 389
 390 =head2 dispatch( $c )
 391
 392 Dispatch this action against a context.
 393
 394 =head2 execute( $controller, $c, @args )
 395
 396 Execute this action's coderef against a given controller with a given
 397 context and arguments
 398
 399 =head2 match( $c )
 400
 401 Check Args attribute, and makes sure number of args matches the setting.
 402 Always returns true if Args is omitted.
 403
 404 =head2 match_captures ($c, $captures)
 405
 406 Can be implemented by action class and action role authors. If the method
 407 exists, then it will be called with the request context and an array reference
 408 of the captures for this action.
 409
 410 Returning true from this method causes the chain match to continue, returning
 411 makes the chain not match (and alternate, less preferred chains will be attempted).
 412
 413 =head2 match_args($c, $args)
 414
 415 Does the Args match or not?
 416
 417 =head2 resolve_type_constraint
 418
 419 Trys to find a type constraint if you have on on a type constrained method.
 420
 421 =head2 compare
 422
 423 Compares 2 actions based on the value of the C<Args> attribute, with no C<Args>
 424 having the highest precedence.
 425
 426 =head2 namespace
 427
 428 Returns the private namespace this action lives in.
 429
 430 =head2 reverse
 431
 432 Returns the private path for this action.
 433
 434 =head2 private_path
 435
 436 Returns absolute private path for this action. Unlike C<reverse>, the
 437 C<private_path> of an action is always suitable for passing to C<forward>.
 438
 439 =head2 name
 440
 441 Returns the sub name of this action.
 442
 443 =head2 number_of_args
 444
 445 Returns the number of args this action expects. This is 0 if the action doesn't
 446 take any arguments and undef if it will take any number of arguments.
 447
 448 =head2 normalized_arg_number
 449
 450 For the purposes of comparison we normalize 'number_of_args' so that if it is
 451 undef we mean ~0 (as many args are we can think of).
 452
 453 =head2 number_of_captures
 454
 455 Returns the number of captures this action expects for L<Chained|Catalyst::DispatchType::Chained> actions.
 456
 457 =head2 list_extra_info
 458
 459 A HashRef of key-values that an action can provide to a debugging screen
 460
 461 =head2 scheme
 462
 463 Any defined scheme for the action
 464
 465 =head2 meta
 466
 467 Provided by Moose.
 468
 469 =head1 AUTHORS
 470
 471 Catalyst Contributors, see Catalyst.pm
 472
 473 =head1 COPYRIGHT
 474
 475 This library is free software. You can redistribute it and/or modify it under
 476 the same terms as Perl itself.
 477
 478 =cut
 479
 480