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