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