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