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