lib/CatalystX/Declare/Keyword/Action.pm

   1 use MooseX::Declare;
   2 use MooseX::Role::Parameterized ();
   3
   4 class CatalystX::Declare::Keyword::Action {
   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 ensure_all_roles );
  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     use constant UNDER_STACK    => '@CatalystX::Declare::SCOPE::UNDER_STACK';
  19
  20     use aliased 'CatalystX::Declare::Action::CatchValidationError';
  21     use aliased 'CatalystX::Declare::Context::StringParsing';
  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         $self->_inject_attributes($ctx, \%attributes);
 115
 116         if ($ctx->peek_next_char eq '{') {
 117             $ctx->inject_if_block($ctx->scope_injector_call . $method->injectable_code);
 118         }
 119         else {
 120             $ctx->inject_code_parts_here(
 121                 sprintf '{ %s%s }',
 122                     $ctx->scope_injector_call,
 123                     $method->injectable_code,
 124             );
 125         }
 126
 127         my $compile_attrs = sub {
 128             my $attributes = shift;;
 129             my @attributes;
 130
 131             for my $attr (keys %$attributes) {
 132                 my $value = $attributes->{ $attr };
 133
 134                 next if $attr eq 'Chained' and $value eq UNDER_VAR;
 135
 136 #                $value = sprintf "'%s'", $value
 137 #                    if grep { $attr eq $_ } qw( Chained PathPart );
 138
 139                 push @attributes,
 140                     map { sprintf '%s%s', $attr, defined($_) ? sprintf('(%s)', $_) : '' }
 141                         (ref($value) eq 'ARRAY')
 142                         ? @$value
 143                         : $value;
 144             }
 145
 146             return \@attributes;
 147         };
 148
 149         return $ctx->shadow(sub {
 150             my $class = caller;
 151             my $attrs = shift;
 152             my $body  = shift;
 153             my $name  = $attrs->{Subname};
 154
 155             $body = $attrs and $attrs = {}
 156                 if ref $attrs eq 'CODE';
 157
 158             unless ($attrs->{Private}) {
 159
 160                 $attrs->{PathPart} = $attrs->{Subname}
 161                     unless defined $attrs->{PathPart};
 162             }
 163
 164             delete $attrs->{Chained}
 165                 unless defined $attrs->{Chained};
 166
 167             defined($attrs->{ $_ }) and $attrs->{ $_ } = sprintf "'%s'", $attrs->{ $_ }
 168                 for qw( Chained PathPart );
 169
 170 #            pp \%attributes;
 171 #            pp $attrs;
 172             my %full_attrs = (%attributes, %$attrs);
 173 #            pp \%full_attrs;
 174             my $compiled_attrs = $compile_attrs->(\%full_attrs);
 175 #            pp $compiled_attrs;
 176
 177             my $real_method = $method->reify(
 178                 actual_body => $body,
 179                 attributes  => $compiled_attrs,
 180                 name        => $name,
 181             );
 182
 183             if ($modifier) {
 184
 185                 add_method_modifier $class, $modifier, [$name, $real_method];
 186             }
 187             else {
 188
 189                 my $prepare_meta = sub {
 190                     my ($meta) = @_;
 191
 192                     $meta->add_method($name, $real_method);
 193                     $meta->register_method_attributes($meta->name->can($real_method->name), $compiled_attrs);
 194                 };
 195
 196                 if ($ctx->stack->[-1] and $ctx->stack->[-1]->is_parameterized) {
 197                     my $real_meta = MooseX::Role::Parameterized->current_metaclass;
 198
 199                     $real_meta->meta->make_mutable
 200                         if $real_meta->meta->is_immutable;
 201                     ensure_all_roles $real_meta->meta, AttributeMetaRole
 202                         if $real_meta->isa('Moose::Meta::Role');
 203
 204                     $real_meta->$prepare_meta;
 205                 }
 206
 207                 $class->meta->$prepare_meta;
 208             }
 209         });
 210     }
 211
 212     method _handle_with_option (Object $ctx, HashRef $attrs) {
 213
 214         my $role = $ctx->strip_name
 215             or croak "Expected bareword role specification for action after with";
 216
 217         # we need to fish for aliases here since we are still unclean
 218         if (defined(my $alias = $self->_check_for_available_import($ctx, $role))) {
 219             $role = $alias;
 220         }
 221
 222         push @{ $attrs->{CatalystX_Declarative_ActionRoles} ||= [] }, $role;
 223
 224         return;
 225     }
 226
 227     method _handle_isa_option (Object $ctx, HashRef $attrs) {
 228
 229         my $class = $ctx->strip_name
 230             or croak "Expected bareword action class specification for action after isa";
 231
 232         if (defined(my $alias = $self->_check_for_available_import($ctx, $class))) {
 233             $class = $alias;
 234         }
 235
 236         $attrs->{CatalystX_Declarative_ActionClass} = $class;
 237
 238         return;
 239     }
 240
 241     method _check_for_available_import (Object $ctx, Str $name) {
 242
 243         if (my $code = $ctx->get_curstash_name->can($name)) {
 244             return $code->();
 245         }
 246
 247         return undef;
 248     }
 249
 250     method _handle_action_option (Object $ctx, HashRef $attrs) {
 251
 252         # action name
 253         my $name = $self->_strip_actionpath($ctx, interpolate => 1)
 254             or croak "Anonymous actions not yet supported";
 255
 256         $ctx->skipspace;
 257         my $populator;
 258
 259         if (substr($ctx->get_linestr, $ctx->offset, 2) eq '<-') {
 260             my $linestr = $ctx->get_linestr;
 261             substr($linestr, $ctx->offset, 2) = '';
 262             $ctx->set_linestr($linestr);
 263             $populator = $self->_handle_under_option($ctx, $attrs);
 264         }
 265
 266         # signature
 267         my $proto = $ctx->strip_proto || '';
 268         $proto = join(', ', 'Object $self: Object $ctx', $proto || ());
 269
 270         $attrs->{Subname}   = $name;
 271         $attrs->{Signature} = $proto;
 272         $attrs->{Action}    = [];
 273
 274         push @{ $attrs->{CatalystX_Declarative_ActionRoles} ||= [] }, CatchValidationError;
 275         $attrs->{Chained} ||= UNDER_VAR;
 276
 277         return unless $populator;
 278         return $populator;
 279     }
 280
 281     method _handle_final_option (Object $ctx, HashRef $attrs) {
 282
 283         return $self->_build_flag_populator($ctx, $attrs, 'final');
 284     }
 285
 286     method _handle_is_option (Object $ctx, HashRef $attrs) {
 287
 288         my $what = $ctx->strip_name
 289             or croak "Expected symbol token after is symbol, not " . substr($ctx->get_linestr, $ctx->offset);
 290
 291         return $self->_build_flag_populator($ctx, $attrs, $what);
 292     }
 293
 294     method _build_flag_populator (Object $ctx, HashRef $attrs, Str $what) {
 295
 296         return sub {
 297             my $method = shift;
 298
 299             if ($what eq any qw( end endpoint final )) {
 300                 $attrs->{Args} = delete $attrs->{CaptureArgs};
 301             }
 302             elsif ($what eq 'private') {
 303                 $attrs->{Private} = [];
 304             }
 305         };
 306     }
 307
 308     method _handle_under_option (Object $ctx, HashRef $attrs) {
 309
 310         my $target = $self->_strip_actionpath($ctx, interpolate => 1);
 311         $ctx->skipspace;
 312
 313         if ($ctx->peek_next_char eq '{' and $self->identifier eq 'under') {
 314             $ctx->inject_if_block(
 315                 $ctx->scope_injector_call .
 316                 sprintf ';local %s = %s;',
 317                     UNDER_VAR,
 318                     $target,
 319             );
 320             return STOP_PARSING;
 321         }
 322
 323         $attrs->{Chained} = $target;
 324
 325         return sub {
 326             my $method = shift;
 327         };
 328     }
 329
 330     method _handle_chains_option (Object $ctx, HashRef $attrs) {
 331
 332         $ctx->skipspace;
 333         $ctx->strip_name eq 'to'
 334             or croak "Expected to token after chains symbol, not " . substr($ctx->get_linestr, $ctx->offset);
 335
 336         return $self->_handle_under_option($ctx, $attrs);
 337     }
 338
 339     method _handle_as_option (Object $ctx, HashRef $attrs) {
 340
 341         $ctx->skipspace;
 342
 343         my $path = $self->_strip_actionpath($ctx, interpolate => 1);
 344         $attrs->{PathPart} = $path;
 345
 346         return;
 347     }
 348
 349     method _count_positional_arguments (Object $method) {
 350         my $signature = $method->parsed_signature;
 351
 352         if ($signature->has_positional_params) {
 353             my $count = @{ scalar($signature->positional_params) };
 354
 355             if ($count and ($signature->positional_params)[-1]->sigil eq '@') {
 356                 return undef;
 357             }
 358
 359             return $count - 1;
 360         }
 361
 362         return 0;
 363     }
 364
 365     method _inject_attributes (Object $ctx, HashRef $attrs) {
 366
 367         my @inject = qw( Chained PathPart Subname );
 368
 369         my $code = sprintf ' +{ %s }, sub ',
 370             join ', ',
 371             map  { (@$_) }
 372             map  { defined( $_->[1] ) ? $_ : [$_->[0], 'undef'] }
 373             map  { [pp($_), $attrs->{ $_ }] }
 374             grep { defined $attrs->{ $_ } }
 375             @inject;
 376
 377         $ctx->inject_code_parts_here($code);
 378         $ctx->inc_offset(length $code);
 379     }
 380
 381     method _strip_actionpath (Object $ctx, :$interpolate?) {
 382
 383         $ctx->skipspace;
 384         my $linestr = $ctx->get_linestr;
 385         my $rest    = substr($linestr, $ctx->offset);
 386         my $interp  = sub { $interpolate ? "'$_[0]'" : $_[0] };
 387
 388         if ($rest =~ /^ ( [_a-z] [_a-z0-9]* ) \b/ix) {
 389             substr($linestr, $ctx->offset, length($1)) = '';
 390             $ctx->set_linestr($linestr);
 391             return $interp->($1);
 392         }
 393         elsif ($rest =~ /^ ' ( (?:[.:;,_a-z0-9]|\/)* ) ' /ix) {
 394             substr($linestr, $ctx->offset, length($1) + 2) = '';
 395             $ctx->set_linestr($linestr);
 396             return $interp->($1);
 397         }
 398         elsif ($interpolate and my $str = $ctx->get_string) {
 399             return $str;
 400         }
 401         else {
 402             croak "Invalid syntax for action path: $rest";
 403         }
 404     }
 405
 406     with 'MooseX::Declare::Syntax::KeywordHandling';
 407
 408     around context_traits { $self->$orig, StringParsing }
 409 }
 410
 411 __END__
 412
 413 =head1 NAME
 414
 415 CatalystX::Declare::Keyword::Action - Declare Catalyst Actions
 416
 417 =head1 SYNOPSIS
 418
 419     use CatalystX::Declare;
 420
 421     controller MyApp::Web::Controller::Example {
 422
 423         # chain base action with path part setting of ''
 424         # body-less actions don't do anything by themselves
 425         action base as '' under '/';
 426
 427         # simple end-point action
 428         action controller_class is final under base {
 429             $ctx->response->body( 'controller: ' . ref $self );
 430         }
 431
 432         # chain part actions can have arguments
 433         action str (Str $string) under base {
 434
 435             $ctx->stash(chars => [split //, $string]);
 436         }
 437
 438         # and end point actions too, of course
 439         action uc_chars (Int $count) under str is final {
 440
 441             my $chars = $ctx->stash->{chars};
 442             ...
 443         }
 444
 445
 446         # you can use a shortcut for multiple actions with
 447         # a common base
 448         under base {
 449
 450             # this is an endpoint after base
 451             action normal is final;
 452
 453             # the final keyword can be used to be more
 454             # visually explicit about end-points
 455             final action some_action { ... }
 456
 457             # type dispatching works
 458             final action with_str (Str $x) as via_type;
 459             final action with_int (Int $x) as via_type;
 460         }
 461
 462         # of course you can also chain to external actions
 463         final action some_end under '/some/controller/some/action';
 464     }
 465
 466 =head1 DESCRIPTION
 467
 468 This handler class provides the user with C<action>, C<final> and C<under>
 469 keywords. There are multiple ways to define actions to allow for greater
 470 freedom of expression. While the parts of the action declaration itself do
 471 not care about their order, their syntax is rather strict.
 472
 473 You can choose to separate syntax elements via C<,> if you think it is more
 474 readable. The action declaration
 475
 476     action foo is final under base;
 477
 478 is parsed in exactly the same way if you write it as
 479
 480     action foo, is final, under base;
 481
 482 =head2 Basic Action Declaration
 483
 484 The simplest possible declaration is
 485
 486     action foo;
 487
 488 This would define a chain-part action chained to nothing with the name C<foo>
 489 and no arguments. Since it isn't followed by a block, the body of the action
 490 will be empty.
 491
 492 You will automatically be provided with two variables: C<$self> is, as you
 493 might expect, your controller instance. C<$ctx> will be the Catalyst context
 494 object. Thus, the following code would stash the value returned by the
 495 C<get_item> method:
 496
 497     action foo {
 498         $ctx->stash(item => $self->get_item);
 499     }
 500
 501 =head2 Why $ctx instead of $c
 502
 503 Some might ask why the context object is called C<$ctx> instead of the usual
 504 C<$c>. The reason is simple: It's an opinionated best practice, since C<$ctx>
 505 stands out more.
 506
 507 =head2 Setting a Path Part
 508
 509 As usual with Catalyst actions, the path part (the public name of this part of
 510 the URI, if you're not familiar with the term yet) will default to the name of
 511 the action itself (or more correctly: to whatever Catalyst defaults).
 512
 513 To change that, use the C<as> option:
 514
 515     under something {
 516         action base      as '';             # <empty>
 517         action something as 'foo/bar';      # foo/bar
 518         action barely    as bareword;       # bareword
 519     }
 520
 521 =head2 Chaining Actions
 522
 523 Currently, L<CatalystX::Declare> is completely based on the concept of
 524 L<chained actions|Catalyst::DispatchType::Chained>. Every action you declare is
 525 chained or private. You can specify the action you want to chain to with the
 526 C<under> option:
 527
 528     action foo;                     # chained to nothing
 529     action foo under '/';           # also chained to /
 530     action foo under bar;           # chained to the local bar action
 531     action foo under '/bar/baz';    # chained to baz in /bar
 532
 533 C<under> is also provided as a grouping keyword. Every action inside the block
 534 will be chained to the specified action:
 535
 536     under base {
 537         action foo { ... }
 538         action bar { ... }
 539     }
 540
 541 You can also use the C<under> keyword for a single action. This is useful if
 542 you want to highlight a single action with a significant diversion from what
 543 is to be expected:
 544
 545     action base under '/';
 546
 547     under '/the/sink' is final action foo;
 548
 549     final action bar under base;
 550
 551     final action baz under base;
 552
 553 Instead of the C<under> option declaration, you can also use a more english
 554 variant named C<chains to>. While C<under> might be nice and concise, some
 555 people might prefer this if they confuse C<under> with the specification of
 556 a public path part. The argument to C<chains to> is the same as to C<under>:
 557
 558     action foo chains to bar;
 559     action foo under bar;
 560
 561 By default all actions are chain-parts, not end-points. If you want an action
 562 to be picked up as end-point and available via a public path, you have to say
 563 so explicitely by  using the C<is final> option:
 564
 565     action base under '/';
 566     action foo under base is final;   # /base/foo
 567
 568 You can also drop the C<is> part of the C<is final> option if you want:
 569
 570     under base, final action foo { ... }
 571
 572 You can make end-points more visually distinct by using the C<final> keyword
 573 instead of the option:
 574
 575     action base under '/';
 576     final action foo under base;      # /base/foo
 577
 578 And of course, the C<final>, C<under> and C<action> keywords can be used in
 579 combination whenever needed:
 580
 581     action base as '' under '/';
 582
 583     under base {
 584
 585         final action list;          # /list
 586
 587         action load;
 588
 589         under load {
 590
 591             final action view;      # /list/load/view
 592             final action edit;      # /list/load/edit
 593         }
 594     }
 595
 596 There is also one shorthand alternative for declaring chain targets. You can
 597 specify an action after a C<E<lt>-> following the action name:
 598
 599     action base under '/';
 600     final action foo <- base;       # /base/foo
 601
 602 =head2 Arguments
 603
 604 You can use signatures like you are use to from L<MooseX::Method::Signatures>
 605 to declare action parameters. The number of positinoal arguments will be used
 606 during dispatching as well as their types.
 607
 608 The signature follows the action name:
 609
 610     # /foo/*/*/*
 611     final action foo (Int $year, Int $month, Int $day);
 612
 613 If you are using the shorthand definition, the signature follows the chain
 614 target:
 615
 616     # /foo/*
 617     final action foo <- base ($x) under '/' { ... }
 618
 619 Parameters may be specified on chain-parts and end-points:
 620
 621     # /base/*/foo/*
 622     action base (Str $lang) under '/';
 623     final action page (Int $page_num) under base;
 624
 625 Named parameters will be populated with the values in the query parameters:
 626
 627     # /view/17/?page=3
 628     final action view (Int $id, Int :$page = 1) under '/';
 629
 630 Your end-points can also take an unspecified amount of arguments by specifying
 631 an array as a variable:
 632
 633     # /find/some/deep/path/spec
 634     final action find (@path) under '/';
 635
 636 =head2 Validation
 637
 638 The signatures are now validated during dispatching-time, and an action with
 639 a non-matching signature (number of positional arguments and their types) will
 640 not be dispatched to. This means that
 641
 642     action base under '/' as '';
 643
 644     under base {
 645
 646         final as double, action double_integer (Int $x) {
 647             $ctx->response->body( $x * 2 );
 648         }
 649
 650         final as double, action double_string (Str $x) {
 651             $ctx->response->body( $x x 2 );
 652         }
 653     }
 654
 655 will return C<foofoo> when called as C</double/foo> and C<46> when called as
 656 C</double/23>.
 657
 658 =head2 Actions and Method Modifiers
 659
 660 Method modifiers can not only be applied to methods, but also to actions. There
 661 is no way yet to override the attributes of an already established action via
 662 modifiers. However, you can modify the method underlying the action.
 663
 664 The following code is an example role modifying the consuming controller's
 665 C<base> action:
 666
 667     use CatalystX::Declare;
 668
 669     controller_role MyApp::Web::ControllerRole::RichBase {
 670
 671         before base (Object $ctx) {
 672             $ctx->stash(something => $ctx->model('Item'));
 673         }
 674     }
 675
 676 Note that you have to specify the C<$ctx> argument yourself, since you are
 677 modifying a method, not an action.
 678
 679 Any controller having a C<base> action (or method, for this purpose), can now
 680 consume the C<RichBase> role declared above:
 681
 682     use CatalystX::Declare;
 683
 684     controller MyApp::Web::Controller::Foo
 685         with   MyApp::Web::Controller::RichBase {
 686
 687         action base as '' under '/';
 688
 689         action show, final under base {
 690             $ctx->response->body(
 691                 $ctx->stash->{something}->render,
 692             );
 693         }
 694     }
 695
 696 =head2 Action Classes
 697
 698 B<This option is even more experimental>
 699
 700 You might want to create an action with a different class than the usual
 701 L<Catalyst::Action>. A usual suspect here is L<Catalyst::Action::RenderView>.
 702 You can use the C<isa> option (did I mention it's experimental?) to specify
 703 what class to use:
 704
 705     controller MyApp::Web::Controller::Root {
 706
 707         $CLASS->config(namespace => '');
 708
 709         action end isa RenderView;
 710     }
 711
 712 The loaded class will be L<Moose>ified, so we are able to apply essential
 713 roles.
 714
 715 =head1 ROLES
 716
 717 =over
 718
 719 =item L<MooseX::Declare::Syntax::KeywordHandling>
 720
 721 =back
 722
 723 =head1 METHODS
 724
 725 These methods are implementation details. Unless you are extending or
 726 developing L<CatalystX::Declare>, you should not be concerned with them.
 727
 728 =head2 parse
 729
 730     Object->parse (Object $ctx, Str :$modifier?, Int :$skipped_declarator = 0)
 731
 732 A hook that will be invoked by L<MooseX::Declare> when this instance is called
 733 to handle syntax. It will parse the action declaration, prepare attributes and
 734 add the actions to the controller.
 735
 736 =head1 SEE ALSO
 737
 738 =over
 739
 740 =item L<CatalystX::Declare>
 741
 742 =item L<CatalystX::Declare::Keyword::Controller>
 743
 744 =item L<MooseX::Method::Signatures>
 745
 746 =back
 747
 748 =head1 AUTHOR
 749
 750 See L<CatalystX::Declare/AUTHOR> for author information.
 751
 752 =head1 LICENSE
 753
 754 This program is free software; you can redistribute it and/or modify it under
 755 the same terms as perl itself.
 756
 757 =cut
 758