lib/CatalystX/Declare/Keyword/Action.pm

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