lib/CatalystX/Declare/Keyword/Action.pm

   1 use MooseX::Declare;
   2
   3 class CatalystX::Declare::Keyword::Action
   4     with MooseX::Declare::Syntax::KeywordHandling {
   5
   6
   7     use Carp                qw( croak );
   8     use Perl6::Junction     qw( any );
   9     use Data::Dump          qw( pp );
  10     use MooseX::Types::Util qw( has_available_type_export );
  11     use Moose::Util         qw( add_method_modifier );
  12     use Class::Inspector;
  13     use Class::MOP;
  14
  15
  16     use constant STOP_PARSING   => '__MXDECLARE_STOP_PARSING__';
  17     use constant UNDER_VAR      => '$CatalystX::Declare::SCOPE::UNDER';
  18
  19     use aliased 'CatalystX::Declare::Action::CatchValidationError';
  20     use aliased 'MooseX::Method::Signatures::Meta::Method';
  21     use aliased 'MooseX::MethodAttributes::Role::Meta::Method', 'AttributeRole';
  22
  23
  24     method parse (Object $ctx, Str :$modifier?, Int :$skipped_declarator = 0) {
  25
  26         # somewhere to put the attributes
  27         my %attributes;
  28         my @populators;
  29
  30         # parse declarations
  31         until (do { $ctx->skipspace; $ctx->peek_next_char } eq any qw( ; { } )) {
  32
  33             $ctx->skipspace;
  34
  35             # optional commas
  36             if ($ctx->peek_next_char eq ',') {
  37
  38                 my $linestr = $ctx->get_linestr;
  39                 substr($linestr, $ctx->offset, 1) = '';
  40                 $ctx->set_linestr($linestr);
  41
  42                 next;
  43             }
  44
  45             # next thing should be an option name
  46             my $option = (
  47                 $skipped_declarator
  48                 ? $ctx->strip_name
  49                 : do {
  50                     $ctx->skip_declarator;
  51                     $skipped_declarator++;
  52                     $ctx->declarator;
  53                 })
  54               or croak "Expected option token, not " . substr($ctx->get_linestr, $ctx->offset);
  55
  56             # we need to be able to handle the rest
  57             my $handler = $self->can("_handle_${option}_option")
  58                 or croak "Unknown action option: $option";
  59
  60             # call the handler
  61             my $populator = $self->$handler($ctx, \%attributes);
  62
  63             if ($populator and $populator eq STOP_PARSING) {
  64
  65                 return $ctx->shadow(sub (&) {
  66                     my ($body) = @_;
  67                     return $body->();
  68                 });
  69             }
  70
  71             push @populators, $populator
  72                 if defined $populator;
  73         }
  74
  75         croak "Need an action specification"
  76             unless exists $attributes{Signature};
  77
  78         my $name   = $attributes{Subname};
  79
  80         my $method = Method->wrap(
  81             signature       => qq{($attributes{Signature})},
  82             package_name    => $ctx->get_curstash_name,
  83             name            => $name,
  84         );
  85
  86         AttributeRole->meta->apply($method);
  87
  88         $_->($method)
  89             for @populators;
  90
  91         unless ($attributes{Private}) {
  92             $attributes{PathPart} ||= "'$name'";
  93
  94             delete $attributes{CaptureArgs}
  95                 if exists $attributes{Args};
  96
  97             $attributes{CaptureArgs} = 0
  98                 unless exists $attributes{Args}
  99                     or exists $attributes{CaptureArgs};
 100         }
 101
 102         if ($attributes{Private}) {
 103             delete $attributes{ $_ }
 104                 for qw( Args CaptureArgs Chained Signature Subname Action );
 105         }
 106
 107         if ($ctx->peek_next_char eq '{') {
 108             $ctx->inject_if_block($ctx->scope_injector_call . $method->injectable_code);
 109         }
 110         else {
 111             $ctx->inject_code_parts_here(
 112                 sprintf '{ %s%s }',
 113                     $ctx->scope_injector_call,
 114                     $method->injectable_code,
 115             );
 116         }
 117
 118         my @attributes;
 119         for my $attr (keys %attributes) {
 120             push @attributes,
 121                 map { sprintf '%s(%s)', $attr, $_ }
 122                     (ref($attributes{ $attr }) eq 'ARRAY')
 123                     ? @{ $attributes{ $attr } }
 124                     : $attributes{ $attr };
 125         }
 126
 127         return $ctx->shadow(sub (&) {
 128             my $class = caller;
 129             my $body  = shift;
 130
 131             $method->_set_actual_body($body);
 132             $method->{attributes} = \@attributes;
 133
 134             if ($modifier) {
 135
 136                 add_method_modifier $class, $modifier, [$name, $method];
 137             }
 138             else {
 139
 140                 $class->meta->add_method($name, $method);
 141                 $class->meta->register_method_attributes($class->can($method->name), \@attributes);
 142             }
 143         });
 144     }
 145
 146     method _handle_with_option (Object $ctx, HashRef $attrs) {
 147
 148         my $role = $ctx->strip_name
 149             or croak "Expected bareword role specification for action after with";
 150
 151         # we need to fish for aliases here since we are still unclean
 152         if (defined(my $alias = $self->_check_for_available_import($ctx, $role))) {
 153             $role = $alias;
 154         }
 155
 156         push @{ $attrs->{CatalystX_Declarative_ActionRoles} ||= [] }, $role;
 157
 158         return;
 159     }
 160
 161     method _handle_isa_option (Object $ctx, HashRef $attrs) {
 162
 163         my $class = $ctx->strip_name
 164             or croak "Expected bareword action class specification for action after isa";
 165
 166         if (defined(my $alias = $self->_check_for_available_import($ctx, $class))) {
 167             $class = $alias;
 168         }
 169
 170         $attrs->{CatalystX_Declarative_ActionClass} = $class;
 171
 172         return;
 173     }
 174
 175     method _check_for_available_import (Object $ctx, Str $name) {
 176
 177         if (my $code = $ctx->get_curstash_name->can($name)) {
 178             return $code->();
 179         }
 180
 181         return undef;
 182     }
 183
 184     method _handle_action_option (Object $ctx, HashRef $attrs) {
 185
 186         # action name
 187         my $name = $ctx->strip_name
 188             or croak "Anonymous actions not yet supported";
 189
 190         $ctx->skipspace;
 191         my $populator;
 192
 193         if (substr($ctx->get_linestr, $ctx->offset, 2) eq '<-') {
 194             my $linestr = $ctx->get_linestr;
 195             substr($linestr, $ctx->offset, 2) = '';
 196             $ctx->set_linestr($linestr);
 197             $populator = $self->_handle_under_option($ctx, $attrs);
 198         }
 199
 200         # signature
 201         my $proto = $ctx->strip_proto || '';
 202         $proto = join(', ', 'Object $self: Object $ctx', $proto || ());
 203
 204         $attrs->{Subname}   = $name;
 205         $attrs->{Signature} = $proto;
 206         $attrs->{Action}    = [];
 207
 208         push @{ $attrs->{CatalystX_Declarative_ActionRoles} ||= [] }, CatchValidationError;
 209
 210         if (defined $CatalystX::Declare::SCOPE::UNDER) {
 211             $attrs->{Chained} ||= $CatalystX::Declare::SCOPE::UNDER;
 212         }
 213
 214         return unless $populator;
 215         return $populator;
 216     }
 217
 218     method _handle_final_option (Object $ctx, HashRef $attrs) {
 219
 220         return $self->_build_flag_populator($ctx, $attrs, 'final');
 221     }
 222
 223     method _handle_is_option (Object $ctx, HashRef $attrs) {
 224
 225         my $what = $ctx->strip_name
 226             or croak "Expected symbol token after is symbol, not " . substr($ctx->get_linestr, $ctx->offset);
 227
 228         return $self->_build_flag_populator($ctx, $attrs, $what);
 229     }
 230
 231     method _build_flag_populator (Object $ctx, HashRef $attrs, Str $what) {
 232
 233         return sub {
 234             my $method = shift;
 235
 236             if ($what eq any qw( end endpoint final )) {
 237                 my $count = $self->_count_positional_arguments($method);
 238                 $attrs->{Args} = defined($count) ? $count : '';
 239             }
 240             elsif ($what eq 'private') {
 241                 $attrs->{Private} = [];
 242             }
 243         };
 244     }
 245
 246     method _handle_under_option (Object $ctx, HashRef $attrs) {
 247
 248         my $target = $self->_strip_actionpath($ctx);
 249         $ctx->skipspace;
 250
 251         if ($ctx->peek_next_char eq '{' and $self->identifier eq 'under') {
 252             $ctx->inject_if_block(
 253                 sprintf '%s; local %s; BEGIN { %s = qq(%s) };',
 254                     $ctx->scope_injector_call,
 255                     UNDER_VAR,
 256                     UNDER_VAR,
 257                     $target,
 258             );
 259             return STOP_PARSING;
 260         }
 261
 262         $attrs->{Chained} = "'$target'";
 263
 264         return sub {
 265             my $method = shift;
 266
 267             my $count = $self->_count_positional_arguments($method);
 268             $attrs->{CaptureArgs} = $count
 269                 if defined $count;
 270         };
 271     }
 272
 273     method _handle_chains_option (Object $ctx, HashRef $attrs) {
 274
 275         $ctx->skipspace;
 276         $ctx->strip_name eq 'to'
 277             or croak "Expected to token after chains symbol, not " . substr($ctx->get_linestr, $ctx->offset);
 278
 279         return $self->_handle_under_option($ctx, $attrs);
 280     }
 281
 282     method _handle_as_option (Object $ctx, HashRef $attrs) {
 283
 284         $ctx->skipspace;
 285
 286         my $path = $self->_strip_actionpath($ctx);
 287         $attrs->{PathPart} = "'$path'";
 288
 289         return;
 290     }
 291
 292     method _count_positional_arguments (Object $method) {
 293         my $signature = $method->_parsed_signature;
 294
 295         if ($signature->has_positional_params) {
 296             my $count = @{ scalar($signature->positional_params) };
 297
 298             if ($count and ($signature->positional_params)[-1]->sigil eq '@') {
 299                 return undef;
 300             }
 301
 302             return $count - 1;
 303         }
 304
 305         return 0;
 306     }
 307
 308     method _strip_actionpath (Object $ctx) {
 309
 310         $ctx->skipspace;
 311         my $linestr = $ctx->get_linestr;
 312         my $rest    = substr($linestr, $ctx->offset);
 313
 314         if ($rest =~ /^ ( [_a-z] [_a-z0-9]* ) \b/ix) {
 315             substr($linestr, $ctx->offset, length($1)) = '';
 316             $ctx->set_linestr($linestr);
 317             return $1;
 318         }
 319         elsif ($rest =~ /^ ' ( (?:[.:;,_a-z0-9]|\/)* ) ' /ix) {
 320             substr($linestr, $ctx->offset, length($1) + 2) = '';
 321             $ctx->set_linestr($linestr);
 322             return $1;
 323         }
 324         else {
 325             croak "Invalid syntax for action path: $rest";
 326         }
 327     }
 328 }
 329
 330 __END__
 331
 332 =head1 NAME
 333
 334 CatalystX::Declare::Keyword::Action - Declare Catalyst Actions
 335
 336 =head1 SYNOPSIS
 337
 338     use CatalystX::Declare;
 339
 340     controller MyApp::Web::Controller::Example {
 341
 342         # chain base action with path part setting of ''
 343         # body-less actions don't do anything by themselves
 344         action base as '' under '/';
 345
 346         # simple end-point action
 347         action controller_class is final under base {
 348             $ctx->response->body( 'controller: ' . ref $self );
 349         }
 350
 351         # chain part actions can have arguments
 352         action str (Str $string) under base {
 353
 354             $ctx->stash(chars => [split //, $string]);
 355         }
 356
 357         # and end point actions too, of course
 358         action uc_chars (Int $count) under str is final {
 359
 360             my $chars = $ctx->stash->{chars};
 361             ...
 362         }
 363
 364
 365         # you can use a shortcut for multiple actions with
 366         # a common base
 367         under base {
 368
 369             # this is an endpoint after base
 370             action normal is final;
 371
 372             # the final keyword can be used to be more
 373             # visually explicit about end-points
 374             final action some_action { ... }
 375         }
 376
 377         # of course you can also chain to external actions
 378         final action some_end under '/some/controller/some/action';
 379     }
 380
 381 =head1 DESCRIPTION
 382
 383 This handler class provides the user with C<action>, C<final> and C<under>
 384 keywords. There are multiple ways to define actions to allow for greater
 385 freedom of expression. While the parts of the action declaration itself do
 386 not care about their order, their syntax is rather strict.
 387
 388 You can choose to separate syntax elements via C<,> if you think it is more
 389 readable. The action declaration
 390
 391     action foo is final under base;
 392
 393 is parsed in exactly the same way if you write it as
 394
 395     action foo, is final, under base;
 396
 397 =head2 Basic Action Declaration
 398
 399 The simplest possible declaration is
 400
 401     action foo;
 402
 403 This would define a chain-part action chained to nothing with the name C<foo>
 404 and no arguments. Since it isn't followed by a block, the body of the action
 405 will be empty.
 406
 407 You will automatically be provided with two variables: C<$self> is, as you
 408 might expect, your controller instance. C<$ctx> will be the Catalyst context
 409 object. Thus, the following code would stash the value returned by the
 410 C<get_item> method:
 411
 412     action foo {
 413         $ctx->stash(item => $self->get_item);
 414     }
 415
 416 =head2 Setting a Path Part
 417
 418 As usual with Catalyst actions, the path part (the public name of this part of
 419 the URI, if you're not familiar with the term yet) will default to the name of
 420 the action itself (or more correctly: to whatever Catalyst defaults).
 421
 422 To change that, use the C<as> option:
 423
 424     under something {
 425         action base      as '';             # <empty>
 426         action something as 'foo/bar';      # foo/bar
 427         action barely    as bareword;       # bareword
 428     }
 429
 430 =head2 Chaining Actions
 431
 432 Currently, L<CatalystX::Declare> is completely based on the concept of
 433 L<chained actions|Catalyst::DispatchType::Chained>. Every action you declare is
 434 chained or private. You can specify the action you want to chain to with the
 435 C<under> option:
 436
 437     action foo;                     # chained to nothing
 438     action foo under '/';           # also chained to /
 439     action foo under bar;           # chained to the local bar action
 440     action foo under '/bar/baz';    # chained to baz in /bar
 441
 442 C<under> is also provided as a grouping keyword. Every action inside the block
 443 will be chained to the specified action:
 444
 445     under base {
 446         action foo { ... }
 447         action bar { ... }
 448     }
 449
 450 You can also use the C<under> keyword for a single action. This is useful if
 451 you want to highlight a single action with a significant diversion from what
 452 is to be expected:
 453
 454     action base under '/';
 455
 456     under '/the/sink' is final action foo;
 457
 458     final action bar under base;
 459
 460     final action baz under base;
 461
 462 Instead of the C<under> option declaration, you can also use a more english
 463 variant named C<chains to>. While C<under> might be nice and concise, some
 464 people might prefer this if they confuse C<under> with the specification of
 465 a public path part. The argument to C<chains to> is the same as to C<under>:
 466
 467     action foo chains to bar;
 468     action foo under bar;
 469
 470 By default all actions are chain-parts, not end-points. If you want an action
 471 to be picked up as end-point and available via a public path, you have to say
 472 so explicitely by  using the C<is final> option:
 473
 474     action base under '/';
 475     action foo under base is final;   # /base/foo
 476
 477 You can also drop the C<is> part of the C<is final> option if you want:
 478
 479     under base, final action foo { ... }
 480
 481 You can make end-points more visually distinct by using the C<final> keyword
 482 instead of the option:
 483
 484     action base under '/';
 485     final action foo under base;      # /base/foo
 486
 487 And of course, the C<final>, C<under> and C<action> keywords can be used in
 488 combination whenever needed:
 489
 490     action base as '' under '/';
 491
 492     under base {
 493
 494         final action list;          # /list
 495
 496         action load;
 497
 498         under load {
 499
 500             final action view;      # /list/load/view
 501             final action edit;      # /list/load/edit
 502         }
 503     }
 504
 505 There is also one shorthand alternative for declaring chain targets. You can
 506 specify an action after a C<E<lt>-> following the action name:
 507
 508     action base under '/';
 509     final action foo <- base;       # /base/foo
 510
 511 =head2 Arguments
 512
 513 You can use signatures like you are use to from L<MooseX::Method::Signatures>
 514 to declare action parameters. The number of arguments will be used during
 515 dispatching. Dispatching by type constraint is planned but not yet implemented.
 516
 517 The signature follows the action name:
 518
 519     # /foo/*/*/*
 520     final action foo (Int $year, Int $month, Int $day);
 521
 522 If you are using the shorthand definition, the signature follows the chain
 523 target:
 524
 525     # /foo/*
 526     final action foo <- base ($x) under '/' { ... }
 527
 528 Parameters may be specified on chain-parts and end-points:
 529
 530     # /base/*/foo/*
 531     action base (Str $lang) under '/';
 532     final action page (Int $page_num) under base;
 533
 534 Named parameters will be populated with the values in the query parameters:
 535
 536     # /view/17/?page=3
 537     final action view (Int $id, Int :$page = 1) under '/';
 538
 539 Your end-points can also take an unspecified amount of arguments by specifying
 540 an array as a variable:
 541
 542     # /find/some/deep/path/spec
 543     final action find (@path) under '/';
 544
 545 =head2 Validation
 546
 547 Currently, when the arguments do not fit the signature because of a L<Moose>
 548 validation error, the response body will be set to C<Bad Request> and the
 549 status to C<400>.
 550
 551 =head2 Actions and Method Modifiers
 552
 553 Method modifiers can not only be applied to methods, but also to actions. There
 554 is no way yet to override the attributes of an already established action via
 555 modifiers. However, you can modify the method underlying the action.
 556
 557 The following code is an example role modifying the consuming controller's
 558 C<base> action:
 559
 560     use CatalystX::Declare;
 561
 562     controller_role MyApp::Web::ControllerRole::RichBase {
 563
 564         before base (Object $ctx) {
 565             $ctx->stash(something => $ctx->model('Item'));
 566         }
 567     }
 568
 569 Note that you have to specify the C<$ctx> argument yourself, since you are
 570 modifying a method, not an action.
 571
 572 Any controller having a C<base> action (or method, for this purpose), can now
 573 consume the C<RichBase> role declared above:
 574
 575     use CatalystX::Declare;
 576
 577     controller MyApp::Web::Controller::Foo
 578         with   MyApp::Web::Controller::RichBase {
 579
 580         action base as '' under '/';
 581
 582         action show, final under base {
 583             $ctx->response->body(
 584                 $ctx->stash->{something}->render,
 585             );
 586         }
 587     }
 588
 589 =head1 ROLES
 590
 591 =over
 592
 593 =item L<MooseX::Declare::Syntax::KeywordHandling>
 594
 595 =back
 596
 597 =head1 METHODS
 598
 599 These methods are implementation details. Unless you are extending or
 600 developing L<CatalystX::Declare>, you should not be concerned with them.
 601
 602 =head2 parse
 603
 604     Object->parse (Object $ctx, Str :$modifier?, Int :$skipped_declarator = 0)
 605
 606 A hook that will be invoked by L<MooseX::Declare> when this instance is called
 607 to handle syntax. It will parse the action declaration, prepare attributes and
 608 add the actions to the controller.
 609
 610 =head1 SEE ALSO
 611
 612 =over
 613
 614 =item L<CatalystX::Declare>
 615
 616 =item L<CatalystX::Declare::Keyword::Controller>
 617
 618 =item L<MooseX::Method::Signatures>
 619
 620 =back
 621
 622 =head1 AUTHOR
 623
 624 See L<CatalystX::Declare/AUTHOR> for author information.
 625
 626 =head1 LICENSE
 627
 628 This program is free software; you can redistribute it and/or modify it under
 629 the same terms as perl itself.
 630
 631 =cut
 632