lib/CGI/Application/Plugin/RunmodeDeclare.pm

   1 package CGI::Application::Plugin::RunmodeDeclare;
   2
   3 use warnings;
   4 use strict;
   5
   6 our $VERSION = '0.06';
   7
   8 =head1 NAME
   9
  10 CGI::Application::Plugin::RunmodeDeclare - Declare runmodes with keywords
  11
  12 =head1 VERSION
  13
  14 Version 0.06
  15
  16 =cut
  17
  18 use base 'Devel::Declare::MethodInstaller::Simple';
  19 use Carp qw(croak);
  20
  21 sub import {
  22     my $class = shift;
  23     my $caller = caller;
  24
  25     my %remap = (
  26             runmode   => runmode   =>
  27             startmode => startmode =>
  28             errormode => errormode =>
  29             invocant  => '$self' =>
  30             into      => $caller,
  31             @_ );
  32
  33     $class->install_methodhandler(
  34         into         => $remap{into},
  35         name         => $remap{runmode},
  36         pre_install  => \&_setup_runmode,
  37         invocant     => $remap{invocant},
  38     );
  39     $class->install_methodhandler(
  40         into         => $remap{into},
  41         name         => $remap{startmode},
  42         pre_install  => \&_setup_startmode,
  43         invocant     => $remap{invocant},
  44     );
  45     $class->install_methodhandler(
  46         into         => $remap{into},
  47         name         => $remap{errormode},
  48         pre_install  => \&_setup_errormode,
  49         invocant     => $remap{invocant},
  50     );
  51 }
  52
  53
  54 my %REGISTRY;
  55 # per-macro setup
  56 sub _split {
  57     my $n = shift; my ($p,$l) = $n =~ /^(.*?)(?:::(\w*))?$/; return ($p, $l);
  58 }
  59 sub _setup_runmode {
  60     my ($fullname, $code) = @_;
  61     my ($pkg, $name) = _split($fullname);
  62     $pkg->add_callback( init => sub { $_[0]->run_modes([ $name ]) } );
  63 }
  64 sub _setup_startmode {
  65     my ($fullname, $code) = @_;
  66     no strict 'refs'; no warnings 'uninitialized';
  67     my ($pkg, $name) = _split($fullname);
  68     # compile time check
  69     croak "start mode redefined (from $REGISTRY{$pkg}{start_mode_installed})" if $REGISTRY{$pkg}{start_mode_installed};
  70     $pkg->add_callback(
  71         init => sub {
  72             # run time check
  73             return if exists $_[0]->{__START_MODE_SET_BY_RUNMODEDECLARE};
  74             $_[0]->run_modes( [$name] );
  75             $_[0]->start_mode($name);
  76             $_[0]->{__START_MODE_SET_BY_RUNMODEDECLARE} = 1;
  77         }
  78     );
  79     $REGISTRY{$pkg}{start_mode_installed} = $fullname;
  80 }
  81 sub _setup_errormode {
  82     my ($fullname, $code) = @_;
  83     no strict 'refs'; no warnings 'uninitialized';
  84     my ($pkg, $name) = _split($fullname);
  85     croak "error mode redefined (from $REGISTRY{$pkg}{error_mode_installed})" if $REGISTRY{$pkg}{error_mode_installed};
  86     $pkg->add_callback(
  87         init => sub {
  88             return if exists $_[0]->{__ERROR_MODE_SET_BY_RUNMODEDECLARE};
  89             $_[0]->error_mode($name);
  90             $_[0]->{__ERROR_MODE_SET_BY_RUNMODEDECLARE} = 1;
  91         }
  92     );
  93     $REGISTRY{$pkg}{error_mode_installed} = $fullname;
  94 }
  95
  96 =begin pod-coverage
  97
  98 =over 4
  99
 100 =item strip_name - we hook into this to install cgiapp callbacks
 101
 102 =item parse_proto - proto parser
 103
 104 =item inject_parsed_proto - turn it into code
 105
 106 =back
 107
 108 =end pod-coverage
 109
 110 =cut
 111
 112 sub strip_name {
 113     my $ctx = shift;
 114
 115     my $name = $ctx->SUPER::strip_name;
 116     $ctx->{pre_install}->($ctx->get_curstash_name . '::' . $name);
 117
 118     return $name;
 119 }
 120
 121 sub parse_proto {
 122     my $self = shift;
 123     my ($proto) = @_;
 124     $proto ||= '';
 125
 126     my $invocant = $self->{invocant};
 127     $invocant = $1 if $proto =~ s{^(\$\w+):\s*}{};
 128
 129     my @args =
 130         map { m{^ ([\$@%])(\w+) }x ? [$1, $2] : () }
 131         split /\s*,\s*/,
 132         $proto
 133     ;
 134
 135     return (
 136         $invocant,
 137         $proto,
 138         @args,
 139     );
 140 }
 141
 142 # Turn the parsed signature into Perl code
 143 sub inject_parsed_proto {
 144     my $self      = shift;
 145     my ($invocant, $proto, @args) = @_;
 146
 147     my @code;
 148     push @code, "my $invocant = shift;";
 149     push @code, "my ($proto) = \@_;" if defined $proto and length $proto;
 150
 151     for my $sig (@args) {
 152         my ($sigil, $name) = @$sig;
 153         push @code, _default_for($sigil,$name,$invocant);
 154         push @code, _default_for($sigil,$name,"${invocant}->query");
 155     }
 156
 157     return join ' ', @code;
 158 }
 159
 160 sub _default_for
 161 {
 162     my $sigil = shift;
 163     my $name = shift;
 164     my $invocant = shift;
 165
 166     return
 167           "${sigil}${name} = ${invocant}->param('${name}') unless "
 168         . ( $sigil eq '$' ? 'defined' : '' )
 169         . " ${sigil}${name}; ";
 170
 171 }
 172
 173 1; # End of CGI::Application::Plugin::RunmodeDeclare
 174
 175 __END__
 176
 177 =head1 SYNOPSIS
 178
 179     package My::CgiApp;
 180
 181     use base 'CGI::Application';
 182     use CGI::Application::Plugin::RunmodeDeclare;
 183
 184     startmode hello { "Hello!" }
 185
 186     runmode world($name) {
 187         return $self->hello
 188         . ', '
 189         . $name || "World!";
 190     }
 191
 192     errormode oops($c: $exception) {
 193         return "Something went wrong at "
 194         . $c->get_current_runmode
 195         . ". Exception: $exception";
 196     }
 197
 198 =head1 DESCRIPTION
 199
 200 This module allows you to declare run modes with a simple keyword. It provides
 201 the same features as L<Method::Signatures::Simple>.
 202
 203 It respects inheritance: run modes defined in the superclass are also available
 204 in the subclass.
 205
 206 Beyond automatically registering the run mode, and providing C<$self>, it also
 207 optionally pulls named parameters from C<< $self->query->param >> or
 208 C<< $self->param >>.
 209
 210 =over 4
 211
 212 =item * Basic example
 213
 214     runmode foo { $self->bar }
 215
 216 This declares the run mode "foo". Notice how C<$self> is ready for use.
 217
 218 =item * Rename invocant
 219
 220     runmode bar ($c:) { $c->baz }
 221
 222 Same as above, only use C<$c> instead of C<$self>.
 223
 224     use CGI::Application::Plugin::RunmodeDeclare invocant => '$c';
 225     runmode baz { $c->quux }
 226
 227 Same as above, but every runmode gets C<$c> by default. You can still say C<runmode ($self:)>
 228 to rename the invocant.
 229
 230 =item * With a parameter list
 231
 232     runmode baz ( $id, $name ) {
 233         return $self->wibble("I received $id and $name from a form submission
 234                               or a method invocation.");
 235     }
 236
 237 Here, we specify that the method expects two parameters, C<$id> and C<$name>.
 238 Values can be supplied through a method call (e.g. C<< $self->baz(1, "me") >>),
 239 or from the cgiapp object (e.g. C<< $self->param( id => 42 ) >>), or from the
 240 query object (e.g. from C</script?id=42;name=me>).
 241
 242 =item * Code attributes
 243
 244     runmode secret :Auth { ... }
 245
 246 Code attributes are supported as well.
 247
 248 =item * Combining with other ways to set run modes
 249
 250 This all works:
 251
 252     sub setup {
 253         my $self = shift;
 254         $self->run_modes([ qw/ foo / ]);
 255     }
 256
 257     sub foo {
 258         my $self = shift;
 259         return $self->other;
 260     }
 261
 262     runmode bar {
 263         return $self->other;
 264     }
 265
 266     sub other : Runmode {
 267         my $self = shift;
 268         return $self->param('other');
 269     }
 270
 271 So you can still use the classic way of setting up run modes, and you can
 272 still use L<CGI::Application::Plugin::AutoRunmode>, *and* you can mix and match.
 273
 274 =back
 275
 276 =head1 EXPORT
 277
 278 =over 4
 279
 280 =item * errormode
 281
 282 Define the run mode that serves as C<< $self->error_mode >>. You can only declare one
 283 C<errormode> per package.
 284
 285 =item * startmode
 286
 287 Define the run mode that serves as C<< $self->start_mode >>. You can only declare one
 288 C<startmode> per package.
 289
 290 =item * runmode
 291
 292 Define run mode.
 293
 294 =back
 295
 296 =head1 AUTHOR
 297
 298 Rhesa Rozendaal, C<< <rhesa at cpan.org> >>
 299
 300 =head1 DIAGNOSTICS
 301
 302 =over 4
 303
 304 =item * error mode redefined (from %s) at %s line %s
 305
 306 You tried to install another errormode. Placeholders are filled with
 307
 308  * fully qualified name of existing errormode
 309  * file name
 310  * line number
 311
 312 =item * start mode redefined (from %s) at %s line %s
 313
 314 You tried to install another startmode. Placeholders are filled with
 315
 316  * fully qualified name of existing startmode
 317  * file name
 318  * line number
 319
 320 =back
 321
 322 =head1 BUGS
 323
 324 Please report any bugs or feature requests to
 325 C<bug-cgi-application-plugin-runmodedeclare at rt.cpan.org>, or through the web
 326 interface at
 327 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CGI-Application-Plugin-RunmodeDeclare>.
 328 I will be notified, and then you'll automatically be notified of progress on
 329 your bug as I make changes.
 330
 331
 332
 333
 334 =head1 SUPPORT
 335
 336 You can find documentation for this module with the perldoc command.
 337
 338     perldoc CGI::Application::Plugin::RunmodeDeclare
 339
 340
 341 You can also look for information at:
 342
 343 =over 4
 344
 345 =item * RT: CPAN's request tracker
 346
 347 L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=CGI-Application-Plugin-RunmodeDeclare>
 348
 349 =item * AnnoCPAN: Annotated CPAN documentation
 350
 351 L<http://annocpan.org/dist/CGI-Application-Plugin-RunmodeDeclare>
 352
 353 =item * CPAN Ratings
 354
 355 L<http://cpanratings.perl.org/d/CGI-Application-Plugin-RunmodeDeclare>
 356
 357 =item * Search CPAN
 358
 359 L<http://search.cpan.org/dist/CGI-Application-Plugin-RunmodeDeclare>
 360
 361 =back
 362
 363
 364 =head1 ACKNOWLEDGEMENTS
 365
 366 Matt S. Trout for L<Devel::Declare>, and Michael G. Schwern for providing
 367 the inspiration with L<Method::Signatures>.
 368
 369 =head1 COPYRIGHT & LICENSE
 370
 371 Copyright 2008 Rhesa Rozendaal, all rights reserved.
 372
 373 This program is free software; you can redistribute it and/or modify it
 374 under the same terms as Perl itself.
 375
 376
 377 =cut
 378