lib/CatalystX/Declare/Keyword/Action.pm

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