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
 275     # If infinite args, we always match
 276     return 1 if $self->normalized_arg_number == ~0;
 277
 278     # There there are arg constraints, we must see to it that the constraints
 279     # check positive for each arg in the list.
 280     if($self->has_args_constraints) {
 281       # If there is only one type constraint, and its a Ref or subtype of Ref,
 282       # That means we expect a reference, so use the full args arrayref.
 283       if(
 284         $self->args_constraint_count == 1 &&
 285         (
 286           $self->args_constraints->[0]->is_a_type_of('Ref') ||
 287           $self->args_constraints->[0]->is_a_type_of('ClassName')
 288         )
 289       ) {
 290         return $self->args_constraints->[0]->check($c->req->args);
 291         # Removing coercion stuff for the first go
 292         #if($self->args_constraints->[0]->coercion && $self->attributes->{Coerce}) {
 293         #  my $coerced = $self->args_constraints->[0]->coerce($c) || return 0;
 294         #  $c->req->args([$coerced]);
 295         #  return 1;
 296         #}
 297       } else {
 298         # Because of the way chaining works, we can expect args that are totally not
 299         # what you'd expect length wise.  When they don't match length, thats a fail
 300         return 0 unless scalar( @{ $c->req->args } ) == $self->normalized_arg_number;
 301
 302         for my $i(0..$#{ $c->req->args }) {
 303           $self->args_constraints->[$i]->check($c->req->args->[$i]) || return 0;
 304         }
 305         return 1;
 306       }
 307     } else {
 308       # Otherwise, we just need to match the number of args.
 309       return scalar( @{ $c->req->args } ) == $self->normalized_arg_number;
 310     }
 311 }
 312
 313 sub match_captures {
 314   my ($self, $c, $captures) = @_;
 315   my @captures = @{$captures||[]};
 316
 317   return 1 unless scalar(@captures); # If none, just say its ok
 318
 319   if($self->has_captures_constraints) {
 320     if(
 321       $self->captures_constraints_count == 1 &&
 322       (
 323         $self->captures_constraints->[0]->is_a_type_of('Ref') ||
 324         $self->captures_constraints->[0]->is_a_type_of('ClassName')
 325       )
 326     ) {
 327       return $self->captures_constraints->[0]->check($captures);
 328     } else {
 329       for my $i(0..$#captures) {
 330         $self->captures_constraints->[$i]->check($captures[$i]) || return 0;
 331       }
 332       return 1;
 333       }
 334   } else {
 335     return 1;
 336   }
 337   return 1;
 338 }
 339
 340 sub compare {
 341     my ($a1, $a2) = @_;
 342     return $a1->normalized_arg_number <=> $a2->normalized_arg_number;
 343 }
 344
 345 sub scheme {
 346   return exists $_[0]->attributes->{Scheme} ? $_[0]->attributes->{Scheme}[0] : undef;
 347 }
 348
 349 sub list_extra_info {
 350   my $self = shift;
 351   return {
 352     Args => $self->normalized_arg_number,
 353     CaptureArgs => $self->number_of_captures,
 354   }
 355 }
 356
 357 __PACKAGE__->meta->make_immutable;
 358
 359 1;
 360
 361 __END__
 362
 363 =head1 METHODS
 364
 365 =head2 attributes
 366
 367 The sub attributes that are set for this action, like Local, Path, Private
 368 and so on. This determines how the action is dispatched to.
 369
 370 =head2 class
 371
 372 Returns the name of the component where this action is defined.
 373 Derived by calling the L<catalyst_component_name|Catalyst::Component/catalyst_component_name>
 374 method on each component.
 375
 376 =head2 code
 377
 378 Returns a code reference to this action.
 379
 380 =head2 dispatch( $c )
 381
 382 Dispatch this action against a context.
 383
 384 =head2 execute( $controller, $c, @args )
 385
 386 Execute this action's coderef against a given controller with a given
 387 context and arguments
 388
 389 =head2 match( $c )
 390
 391 Check Args attribute, and makes sure number of args matches the setting.
 392 Always returns true if Args is omitted.
 393
 394 =head2 match_captures ($c, $captures)
 395
 396 Can be implemented by action class and action role authors. If the method
 397 exists, then it will be called with the request context and an array reference
 398 of the captures for this action.
 399
 400 Returning true from this method causes the chain match to continue, returning
 401 makes the chain not match (and alternate, less preferred chains will be attempted).
 402
 403 =head2 resolve_type_constraint
 404
 405 Trys to find a type constraint if you have on on a type constrained method.
 406
 407 =head2 compare
 408
 409 Compares 2 actions based on the value of the C<Args> attribute, with no C<Args>
 410 having the highest precedence.
 411
 412 =head2 namespace
 413
 414 Returns the private namespace this action lives in.
 415
 416 =head2 reverse
 417
 418 Returns the private path for this action.
 419
 420 =head2 private_path
 421
 422 Returns absolute private path for this action. Unlike C<reverse>, the
 423 C<private_path> of an action is always suitable for passing to C<forward>.
 424
 425 =head2 name
 426
 427 Returns the sub name of this action.
 428
 429 =head2 number_of_args
 430
 431 Returns the number of args this action expects. This is 0 if the action doesn't
 432 take any arguments and undef if it will take any number of arguments.
 433
 434 =head2 normalized_arg_number
 435
 436 For the purposes of comparison we normalize 'number_of_args' so that if it is
 437 undef we mean ~0 (as many args are we can think of).
 438
 439 =head2 number_of_captures
 440
 441 Returns the number of captures this action expects for L<Chained|Catalyst::DispatchType::Chained> actions.
 442
 443 =head2 list_extra_info
 444
 445 A HashRef of key-values that an action can provide to a debugging screen
 446
 447 =head2 scheme
 448
 449 Any defined scheme for the action
 450
 451 =head2 meta
 452
 453 Provided by Moose.
 454
 455 =head1 AUTHORS
 456
 457 Catalyst Contributors, see Catalyst.pm
 458
 459 =head1 COPYRIGHT
 460
 461 This library is free software. You can redistribute it and/or modify it under
 462 the same terms as Perl itself.
 463
 464 =cut
 465
 466