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 'MooseX::Method::Signatures::Meta::Method';
  20     use aliased 'MooseX::MethodAttributes::Role::Meta::Method', 'AttributeRole';
  21
  22
  23     method parse (Object $ctx, Str :$modifier?, Int :$skipped_declarator = 0) {
  24
  25         # somewhere to put the attributes
  26         my %attributes;
  27         my @populators;
  28
  29         # parse declarations
  30         until (do { $ctx->skipspace; $ctx->peek_next_char } eq any qw( ; { } )) {
  31
  32             $ctx->skipspace;
  33
  34             # optional commas
  35             if ($ctx->peek_next_char eq ',') {
  36
  37                 my $linestr = $ctx->get_linestr;
  38                 substr($linestr, $ctx->offset, 1) = '';
  39                 $ctx->set_linestr($linestr);
  40
  41                 next;
  42             }
  43
  44             # next thing should be an option name
  45             my $option = (
  46                 $skipped_declarator
  47                 ? $ctx->strip_name
  48                 : do {
  49                     $ctx->skip_declarator;
  50                     $skipped_declarator++;
  51                     $ctx->declarator;
  52                 })
  53               or croak "Expected option token, not " . substr($ctx->get_linestr, $ctx->offset);
  54
  55             # we need to be able to handle the rest
  56             my $handler = $self->can("_handle_${option}_option")
  57                 or croak "Unknown action option: $option";
  58
  59             # call the handler
  60             my $populator = $self->$handler($ctx, \%attributes);
  61
  62             if ($populator and $populator eq STOP_PARSING) {
  63
  64                 return $ctx->shadow(sub (&) {
  65                     my ($body) = @_;
  66                     return $body->();
  67                 });
  68             }
  69
  70             push @populators, $populator
  71                 if defined $populator;
  72         }
  73
  74         croak "Need an action specification"
  75             unless exists $attributes{Signature};
  76
  77         my $name   = $attributes{Subname};
  78
  79         my $method = Method->wrap(
  80             signature       => qq{($attributes{Signature})},
  81             package_name    => $ctx->get_curstash_name,
  82             name            => $name,
  83         );
  84
  85         AttributeRole->meta->apply($method);
  86
  87         $_->($method)
  88             for @populators;
  89
  90         unless ($attributes{Private}) {
  91             $attributes{PathPart} ||= "'$name'";
  92
  93             delete $attributes{CaptureArgs}
  94                 if exists $attributes{Args};
  95
  96             $attributes{CaptureArgs} = 0
  97                 unless exists $attributes{Args}
  98                     or exists $attributes{CaptureArgs};
  99         }
 100
 101         if ($attributes{Private}) {
 102             delete $attributes{ $_ }
 103                 for qw( Args CaptureArgs Chained Signature Subname Action );
 104         }
 105
 106         if ($ctx->peek_next_char eq '{') {
 107             $ctx->inject_if_block($ctx->scope_injector_call . $method->injectable_code);
 108         }
 109         else {
 110             $ctx->inject_code_parts_here(
 111                 sprintf '{ %s%s }',
 112                     $ctx->scope_injector_call,
 113                     $method->injectable_code,
 114             );
 115         }
 116
 117         my @attributes = map {
 118             join('',
 119                 $_,
 120                 ref($attributes{ $_ }) eq 'ARRAY'
 121                 ? ( scalar(@{ $attributes{ $_ } })
 122                     ? sprintf('(%s)', join(' ', @{ $attributes{ $_ } }))
 123                     : '' )
 124                 : "($attributes{ $_ })"
 125             );
 126         } keys %attributes;
 127
 128         return $ctx->shadow(sub (&) {
 129             my $class = caller;
 130             my $body  = shift;
 131
 132             $method->_set_actual_body($body);
 133             $method->{attributes} = \@attributes;
 134
 135             if ($modifier) {
 136
 137                 add_method_modifier $class, $modifier, [$name, $method];
 138             }
 139             else {
 140
 141                 $class->meta->add_method($name, $method);
 142                 $class->meta->register_method_attributes($class->can($method->name), \@attributes);
 143             }
 144         });
 145     }
 146
 147     method _handle_with_option (Object $ctx, HashRef $attrs) {
 148
 149         my $role = $ctx->strip_name
 150             or croak "Expected bareword role specification for action after with";
 151
 152         # we need to fish for aliases here since we are still unclean
 153         if (defined(my $alias = $self->_check_for_available_import($ctx, $role))) {
 154             $role = $alias;
 155         }
 156
 157         push @{ $attrs->{CatalystX_Declarative_ActionRoles} ||= [] }, $role;
 158
 159         return;
 160     }
 161
 162     method _handle_isa_option (Object $ctx, HashRef $attrs) {
 163
 164         my $class = $ctx->strip_name
 165             or croak "Expected bareword action class specification for action after isa";
 166
 167         if (defined(my $alias = $self->_check_for_available_import($ctx, $class))) {
 168             $class = $alias;
 169         }
 170
 171         $attrs->{CatalystX_Declarative_ActionClass} = $class;
 172
 173         return;
 174     }
 175
 176     method _check_for_available_import (Object $ctx, Str $name) {
 177
 178         if (my $code = $ctx->get_curstash_name->can($name)) {
 179             return $code->();
 180         }
 181
 182         return undef;
 183     }
 184
 185     method _handle_action_option (Object $ctx, HashRef $attrs) {
 186
 187         # action name
 188         my $name = $ctx->strip_name
 189             or croak "Anonymous actions not yet supported";
 190
 191         $ctx->skipspace;
 192         my $populator;
 193
 194         if (substr($ctx->get_linestr, $ctx->offset, 2) eq '<-') {
 195             my $linestr = $ctx->get_linestr;
 196             substr($linestr, $ctx->offset, 2) = '';
 197             $ctx->set_linestr($linestr);
 198             $populator = $self->_handle_under_option($ctx, $attrs);
 199         }
 200
 201         # signature
 202         my $proto = $ctx->strip_proto || '';
 203         $proto = join(', ', 'Object $self: Object $ctx', $proto || ());
 204
 205         $attrs->{Subname}   = $name;
 206         $attrs->{Signature} = $proto;
 207         $attrs->{Action}    = [];
 208
 209         if (defined $CatalystX::Declare::SCOPE::UNDER) {
 210             $attrs->{Chained} ||= $CatalystX::Declare::SCOPE::UNDER;
 211         }
 212
 213         return unless $populator;
 214         return $populator;
 215     }
 216
 217     method _handle_final_option (Object $ctx, HashRef $attrs) {
 218
 219         return $self->_build_flag_populator($ctx, $attrs, 'final');
 220     }
 221
 222     method _handle_is_option (Object $ctx, HashRef $attrs) {
 223
 224         my $what = $ctx->strip_name
 225             or croak "Expected symbol token after is symbol, not " . substr($ctx->get_linestr, $ctx->offset);
 226
 227         return $self->_build_flag_populator($ctx, $attrs, $what);
 228     }
 229
 230     method _build_flag_populator (Object $ctx, HashRef $attrs, Str $what) {
 231
 232         return sub {
 233             my $method = shift;
 234
 235             if ($what eq any qw( end endpoint final )) {
 236                 my $count = $self->_count_positional_arguments($method);
 237                 $attrs->{Args} = defined($count) ? $count : '';
 238             }
 239             elsif ($what eq 'private') {
 240                 $attrs->{Private} = [];
 241             }
 242         };
 243     }
 244
 245     method _handle_under_option (Object $ctx, HashRef $attrs) {
 246
 247         my $target = $self->_strip_actionpath($ctx);
 248         $ctx->skipspace;
 249
 250         if ($ctx->peek_next_char eq '{' and $self->identifier eq 'under') {
 251             $ctx->inject_if_block(
 252                 sprintf '%s; local %s; BEGIN { %s = qq(%s) };',
 253                     $ctx->scope_injector_call,
 254                     UNDER_VAR,
 255                     UNDER_VAR,
 256                     $target,
 257             );
 258             return STOP_PARSING;
 259         }
 260
 261         $attrs->{Chained} = "'$target'";
 262
 263         return sub {
 264             my $method = shift;
 265
 266             my $count = $self->_count_positional_arguments($method);
 267             $attrs->{CaptureArgs} = $count
 268                 if defined $count;
 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 '';
 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 C</> 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     action base      as '';             # <empty>
 424     action something as 'foo/bar';      # foo/bar
 425     action barely    as bareword;       # bareword
 426
 427 =head2 Chaining Actions
 428
 429 Currently, L<CatalystX::Declare> is completely based on the concept of
 430 L<chained actions|Catalyst::DispatchType::Chained>. Every action you declare is
 431 chained to something. No base specification means you chain to the root. You
 432 can specify the action you want to chain to with the C<under> option:
 433
 434     action foo;                     # chained to /
 435     action foo under '/';           # also chained to /
 436     action foo under bar;           # chained to the local bar action
 437     action foo under '/bar/baz';    # chained to baz in /bar
 438
 439 C<under> is also provided as a grouping keyword. Every action inside the block
 440 will be chained to the specified action:
 441
 442     under base {
 443         action foo { ... }
 444         action bar { ... }
 445     }
 446
 447 You can also use the C<under> keyword for a single action. This is useful if
 448 you want to highlight a single action with a significant diversion from what
 449 is to be expected:
 450
 451     action base;
 452
 453     under '/the/sink' is final action foo;
 454
 455     final action bar under base;
 456
 457     final action baz under base;
 458
 459 Instead of the C<under> option declaration, you can also use a more english
 460 variant named C<chains to>. While C<under> might be nice and concise, some
 461 people might prefer this if they confuse C<under> with the specification of
 462 a public path part. The argument to C<chains to> is the same as to C<under>:
 463
 464     action foo chains to bar;
 465     action foo under bar;
 466
 467 By default all actions are chain-parts, not end-points. If you want an action
 468 to be picked up as end-point and available via a public path, you have to say
 469 so explicitely by  using the C<is final> option:
 470
 471     action base;
 472     action foo under base is final;   # /base/foo
 473
 474 You can also drop the C<is> part of the C<is final> option if you want:
 475
 476     under base, final action foo { ... }
 477
 478 You can make end-points more visually distinct by using the C<final> keyword
 479 instead of the option:
 480
 481     action base;
 482     final action foo under base;      # /base/foo
 483
 484 And of course, the C<final>, C<under> and C<action> keywords can be used in
 485 combination whenever needed:
 486
 487     action base as '';
 488
 489     under base {
 490
 491         final action list;          # /list
 492
 493         action load;
 494
 495         under load {
 496
 497             final action view;      # /list/load/view
 498             final action edit;      # /list/load/edit
 499         }
 500     }
 501
 502 There is also one shorthand alternative for declaring chain targets. You can
 503 specify an action after a C<E<lt>-> following the action name:
 504
 505     action base;
 506     final action foo <- base;       # /base/foo
 507
 508 =head2 Arguments
 509
 510 You can use signatures like you are use to from L<MooseX::Method::Signatures>
 511 to declare action parameters. The number of arguments will be used during
 512 dispatching. Dispatching by type constraint is planned but not yet implemented.
 513
 514 The signature follows the action name:
 515
 516     # /foo/*/*/*
 517     final action foo (Int $year, Int $month, Int $day);
 518
 519 If you are using the shorthand definition, the signature follows the chain
 520 target:
 521
 522     # /foo/*
 523     final action foo <- base ($x) { ... }
 524
 525 Parameters may be specified on chain-parts and end-points:
 526
 527     # /base/*/foo/*
 528     action base (Str $lang);
 529     final action page (Int $page_num) under base;
 530
 531 Named parameters will be populated with the values in the query parameters:
 532
 533     # /view/17/?page=3
 534     final action view (Int $id, Int :$page = 1);
 535
 536 Your end-points can also take an unspecified amount of arguments by specifying
 537 an array as a variable:
 538
 539     # /find/some/deep/path/spec
 540     final action find (@path);
 541
 542 =head2 Actions and Method Modifiers
 543
 544 Method modifiers can not only be applied to methods, but also to actions. There
 545 is no way yet to override the attributes of an already established action via
 546 modifiers. However, you can modify the method underlying the action.
 547
 548 The following code is an example role modifying the consuming controller's
 549 C<base> action:
 550
 551     use CatalystX::Declare;
 552
 553     controller_role MyApp::Web::ControllerRole::RichBase {
 554
 555         before base (Object $ctx) {
 556             $ctx->stash(something => $ctx->model('Item'));
 557         }
 558     }
 559
 560 Note that you have to specify the C<$ctx> argument yourself, since you are
 561 modifying a method, not an action.
 562
 563 Any controller having a C<base> action (or method, for this purpose), can now
 564 consume the C<RichBase> role declared above:
 565
 566     use CatalystX::Declare;
 567
 568     controller MyApp::Web::Controller::Foo
 569         with   MyApp::Web::Controller::RichBase {
 570
 571         action base as '';
 572
 573         action show, final under base {
 574             $ctx->response->body(
 575                 $ctx->stash->{something}->render,
 576             );
 577         }
 578     }
 579
 580 =head1 ROLES
 581
 582 =over
 583
 584 =item L<MooseX::Declare::Syntax::KeywordHandling>
 585
 586 =back
 587
 588 =head1 METHODS
 589
 590 These methods are implementation details. Unless you are extending or
 591 developing L<CatalystX::Declare>, you should not be concerned with them.
 592
 593 =head2 parse
 594
 595     Object->parse (Object $ctx, Str :$modifier?, Int :$skipped_declarator = 0)
 596
 597 A hook that will be invoked by L<MooseX::Declare> when this instance is called
 598 to handle syntax. It will parse the action declaration, prepare attributes and
 599 add the actions to the controller.
 600
 601 =head1 SEE ALSO
 602
 603 =over
 604
 605 =item L<CatalystX::Declare>
 606
 607 =item L<CatalystX::Declare::Keyword::Controller>
 608
 609 =item L<MooseX::Method::Signatures>
 610
 611 =back
 612
 613 =head1 AUTHOR
 614
 615 See L<CatalystX::Declare/AUTHOR> for author information.
 616
 617 =head1 LICENSE
 618
 619 This program is free software; you can redistribute it and/or modify it under
 620 the same terms as perl itself.
 621
 622 =cut
 623