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