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 Private );
 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             # type dispatching works
 401             final action with_str (Str $x) as via_type;
 402             final action with_int (Int $x) as via_type;
 403         }
 404
 405         # of course you can also chain to external actions
 406         final action some_end under '/some/controller/some/action';
 407     }
 408
 409 =head1 DESCRIPTION
 410
 411 This handler class provides the user with C<action>, C<final> and C<under>
 412 keywords. There are multiple ways to define actions to allow for greater
 413 freedom of expression. While the parts of the action declaration itself do
 414 not care about their order, their syntax is rather strict.
 415
 416 You can choose to separate syntax elements via C<,> if you think it is more
 417 readable. The action declaration
 418
 419     action foo is final under base;
 420
 421 is parsed in exactly the same way if you write it as
 422
 423     action foo, is final, under base;
 424
 425 =head2 Basic Action Declaration
 426
 427 The simplest possible declaration is
 428
 429     action foo;
 430
 431 This would define a chain-part action chained to nothing with the name C<foo>
 432 and no arguments. Since it isn't followed by a block, the body of the action
 433 will be empty.
 434
 435 You will automatically be provided with two variables: C<$self> is, as you
 436 might expect, your controller instance. C<$ctx> will be the Catalyst context
 437 object. Thus, the following code would stash the value returned by the
 438 C<get_item> method:
 439
 440     action foo {
 441         $ctx->stash(item => $self->get_item);
 442     }
 443
 444 =head2 Why $ctx instead of $c
 445
 446 Some might ask why the context object is called C<$ctx> instead of the usual
 447 C<$c>. The reason is simple: It's an opinionated best practice, since C<$ctx>
 448 stands out more.
 449
 450 =head2 Setting a Path Part
 451
 452 As usual with Catalyst actions, the path part (the public name of this part of
 453 the URI, if you're not familiar with the term yet) will default to the name of
 454 the action itself (or more correctly: to whatever Catalyst defaults).
 455
 456 To change that, use the C<as> option:
 457
 458     under something {
 459         action base      as '';             # <empty>
 460         action something as 'foo/bar';      # foo/bar
 461         action barely    as bareword;       # bareword
 462     }
 463
 464 =head2 Chaining Actions
 465
 466 Currently, L<CatalystX::Declare> is completely based on the concept of
 467 L<chained actions|Catalyst::DispatchType::Chained>. Every action you declare is
 468 chained or private. You can specify the action you want to chain to with the
 469 C<under> option:
 470
 471     action foo;                     # chained to nothing
 472     action foo under '/';           # also chained to /
 473     action foo under bar;           # chained to the local bar action
 474     action foo under '/bar/baz';    # chained to baz in /bar
 475
 476 C<under> is also provided as a grouping keyword. Every action inside the block
 477 will be chained to the specified action:
 478
 479     under base {
 480         action foo { ... }
 481         action bar { ... }
 482     }
 483
 484 You can also use the C<under> keyword for a single action. This is useful if
 485 you want to highlight a single action with a significant diversion from what
 486 is to be expected:
 487
 488     action base under '/';
 489
 490     under '/the/sink' is final action foo;
 491
 492     final action bar under base;
 493
 494     final action baz under base;
 495
 496 Instead of the C<under> option declaration, you can also use a more english
 497 variant named C<chains to>. While C<under> might be nice and concise, some
 498 people might prefer this if they confuse C<under> with the specification of
 499 a public path part. The argument to C<chains to> is the same as to C<under>:
 500
 501     action foo chains to bar;
 502     action foo under bar;
 503
 504 By default all actions are chain-parts, not end-points. If you want an action
 505 to be picked up as end-point and available via a public path, you have to say
 506 so explicitely by  using the C<is final> option:
 507
 508     action base under '/';
 509     action foo under base is final;   # /base/foo
 510
 511 You can also drop the C<is> part of the C<is final> option if you want:
 512
 513     under base, final action foo { ... }
 514
 515 You can make end-points more visually distinct by using the C<final> keyword
 516 instead of the option:
 517
 518     action base under '/';
 519     final action foo under base;      # /base/foo
 520
 521 And of course, the C<final>, C<under> and C<action> keywords can be used in
 522 combination whenever needed:
 523
 524     action base as '' under '/';
 525
 526     under base {
 527
 528         final action list;          # /list
 529
 530         action load;
 531
 532         under load {
 533
 534             final action view;      # /list/load/view
 535             final action edit;      # /list/load/edit
 536         }
 537     }
 538
 539 There is also one shorthand alternative for declaring chain targets. You can
 540 specify an action after a C<E<lt>-> following the action name:
 541
 542     action base under '/';
 543     final action foo <- base;       # /base/foo
 544
 545 =head2 Arguments
 546
 547 You can use signatures like you are use to from L<MooseX::Method::Signatures>
 548 to declare action parameters. The number of positinoal arguments will be used
 549 during dispatching as well as their types.
 550
 551 The signature follows the action name:
 552
 553     # /foo/*/*/*
 554     final action foo (Int $year, Int $month, Int $day);
 555
 556 If you are using the shorthand definition, the signature follows the chain
 557 target:
 558
 559     # /foo/*
 560     final action foo <- base ($x) under '/' { ... }
 561
 562 Parameters may be specified on chain-parts and end-points:
 563
 564     # /base/*/foo/*
 565     action base (Str $lang) under '/';
 566     final action page (Int $page_num) under base;
 567
 568 Named parameters will be populated with the values in the query parameters:
 569
 570     # /view/17/?page=3
 571     final action view (Int $id, Int :$page = 1) under '/';
 572
 573 Your end-points can also take an unspecified amount of arguments by specifying
 574 an array as a variable:
 575
 576     # /find/some/deep/path/spec
 577     final action find (@path) under '/';
 578
 579 =head2 Validation
 580
 581 The signatures are now validated during dispatching-time, and an action with
 582 a non-matching signature (number of positional arguments and their types) will
 583 not be dispatched to. This means that
 584
 585     action base under '/' as '';
 586
 587     under base {
 588
 589         final as double, action double_string (Str $x) {
 590             $ctx->response->body( $x x 2 );
 591         }
 592
 593         final as double, action double_integer (Int $x) {
 594             $ctx->response->body( $x * 2 );
 595         }
 596     }
 597
 598 will return C<foofoo> when called as C</double/foo> and C<46> when called as
 599 C</double/23>.
 600
 601 =head2 Actions and Method Modifiers
 602
 603 Method modifiers can not only be applied to methods, but also to actions. There
 604 is no way yet to override the attributes of an already established action via
 605 modifiers. However, you can modify the method underlying the action.
 606
 607 The following code is an example role modifying the consuming controller's
 608 C<base> action:
 609
 610     use CatalystX::Declare;
 611
 612     controller_role MyApp::Web::ControllerRole::RichBase {
 613
 614         before base (Object $ctx) {
 615             $ctx->stash(something => $ctx->model('Item'));
 616         }
 617     }
 618
 619 Note that you have to specify the C<$ctx> argument yourself, since you are
 620 modifying a method, not an action.
 621
 622 Any controller having a C<base> action (or method, for this purpose), can now
 623 consume the C<RichBase> role declared above:
 624
 625     use CatalystX::Declare;
 626
 627     controller MyApp::Web::Controller::Foo
 628         with   MyApp::Web::Controller::RichBase {
 629
 630         action base as '' under '/';
 631
 632         action show, final under base {
 633             $ctx->response->body(
 634                 $ctx->stash->{something}->render,
 635             );
 636         }
 637     }
 638
 639 =head2 Action Classes
 640
 641 B<This option is even more experimental>
 642
 643 You might want to create an action with a different class than the usual
 644 L<Catalyst::Action>. A usual suspect here is L<Catalyst::Action::RenderView>.
 645 You can use the C<isa> option (did I mention it's experimental?) to specify
 646 what class to use:
 647
 648     controller MyApp::Web::Controller::Root {
 649
 650         $CLASS->config(namespace => '');
 651
 652         action end isa RenderView;
 653     }
 654
 655 The loaded class will be L<Moose>ified, so we are able to apply essential
 656 roles.
 657
 658 =head1 ROLES
 659
 660 =over
 661
 662 =item L<MooseX::Declare::Syntax::KeywordHandling>
 663
 664 =back
 665
 666 =head1 METHODS
 667
 668 These methods are implementation details. Unless you are extending or
 669 developing L<CatalystX::Declare>, you should not be concerned with them.
 670
 671 =head2 parse
 672
 673     Object->parse (Object $ctx, Str :$modifier?, Int :$skipped_declarator = 0)
 674
 675 A hook that will be invoked by L<MooseX::Declare> when this instance is called
 676 to handle syntax. It will parse the action declaration, prepare attributes and
 677 add the actions to the controller.
 678
 679 =head1 SEE ALSO
 680
 681 =over
 682
 683 =item L<CatalystX::Declare>
 684
 685 =item L<CatalystX::Declare::Keyword::Controller>
 686
 687 =item L<MooseX::Method::Signatures>
 688
 689 =back
 690
 691 =head1 AUTHOR
 692
 693 See L<CatalystX::Declare/AUTHOR> for author information.
 694
 695 =head1 LICENSE
 696
 697 This program is free software; you can redistribute it and/or modify it under
 698 the same terms as perl itself.
 699
 700 =cut
 701