CGI::Application::Plugin::RunmodeDeclare - Declare runmodes with keywords

    package My::CgiApp;

    use base 'CGI::Application';
    use CGI::Application::Plugin::RunmodeDeclare;

    startmode hello { "Hello!" }

    runmode world($name) {
        return $self->hello
        . ', '
        . $name || "World!";
    }

    errormode oops($c: $exception) {
        return "Something went wrong at "
        . $c->get_current_runmode
        . ". Exception: $exception";
    }

    perldoc CGI::Application::Plugin::RunmodeDeclare

package CGI::Application::Plugin::RunmodeDeclare;
our $VERSION = '0.09';


use warnings;
use strict;

use base 'Devel::Declare::MethodInstaller::Simple';
use Carp qw(croak);

sub import {
    my $class = shift;
    my $caller = caller;

    my %remap = (
            runmode   => runmode   =>
            startmode => startmode =>
            errormode => errormode =>
            invocant  => '$self' =>
            into      => $caller,
            @_ );

    $class->install_methodhandler(
        into         => $remap{into},
        name         => $remap{runmode},
        pre_install  => \&_setup_runmode,
        invocant     => $remap{invocant},
    );
    $class->install_methodhandler(
        into         => $remap{into},
        name         => $remap{startmode},
        pre_install  => \&_setup_startmode,
        invocant     => $remap{invocant},
    );
    $class->install_methodhandler(
        into         => $remap{into},
        name         => $remap{errormode},
        pre_install  => \&_setup_errormode,
        invocant     => $remap{invocant},
    );
}


my %REGISTRY;
# per-macro setup
sub _split {
    my $n = shift; my ($p,$l) = $n =~ /^(.*?)(?:::(\w*))?$/; return ($p, $l);
}
sub _setup_runmode {
    my ($fullname, $code) = @_;
    my ($pkg, $name) = _split($fullname);
    $pkg->add_callback( init => sub { $_[0]->run_modes([ $name ]) } );
}
sub _setup_startmode {
    my ($fullname, $code) = @_;
    no strict 'refs'; no warnings 'uninitialized';
    my ($pkg, $name) = _split($fullname);
    # compile time check
    croak "start mode redefined (from $REGISTRY{$pkg}{start_mode_installed})" if $REGISTRY{$pkg}{start_mode_installed};
    $pkg->add_callback(
        init => sub {
            # run time check
            return if exists $_[0]->{__START_MODE_SET_BY_RUNMODEDECLARE};
            $_[0]->run_modes( [$name] );
            $_[0]->start_mode($name);
            $_[0]->{__START_MODE_SET_BY_RUNMODEDECLARE} = 1;
        }
    );
    $REGISTRY{$pkg}{start_mode_installed} = $fullname;
}
sub _setup_errormode {
    my ($fullname, $code) = @_;
    no strict 'refs'; no warnings 'uninitialized';
    my ($pkg, $name) = _split($fullname);
    croak "error mode redefined (from $REGISTRY{$pkg}{error_mode_installed})" if $REGISTRY{$pkg}{error_mode_installed};
    $pkg->add_callback(
        init => sub {
            return if exists $_[0]->{__ERROR_MODE_SET_BY_RUNMODEDECLARE};
            $_[0]->error_mode($name);
            $_[0]->{__ERROR_MODE_SET_BY_RUNMODEDECLARE} = 1;
        }
    );
    $REGISTRY{$pkg}{error_mode_installed} = $fullname;
}

sub strip_name {
    my $ctx = shift;

    my $name = $ctx->SUPER::strip_name;
    $ctx->{pre_install}->($ctx->get_curstash_name . '::' . $name);

    return $name;
}

sub parse_proto {
    my $self = shift;
    my ($proto) = @_;
    $proto ||= '';
    $proto =~ s/[\r\n]/ /sg;
    $proto =~ s/^\s+//; $proto =~ s/\s+$//;

    my $invocant = $self->{invocant};
    $invocant = $1 if $proto =~ s{^(\$\w+):\s*}{};

    my @args =
        map { m{^ ([\$@%])(\w+) }x ? [$1, $2] : () }
        split /\s*,\s*/,
        $proto
    ;

    return (
        $invocant,
        $proto,
        @args,
    );
}

# Turn the parsed signature into Perl code
sub inject_parsed_proto {
    my $self      = shift;
    my ($invocant, $proto, @args) = @_;

    my @code;
    push @code, "my $invocant = shift;";
    push @code, "my ($proto) = \@_;" if defined $proto and length $proto;

    for my $sig (@args) {
        my ($sigil, $name) = @$sig;
        push @code, _default_for($sigil,$name,$invocant) if $sigil eq '$'; # CA->param only handles scalars
        push @code, _default_for($sigil,$name,"${invocant}->query");
    }

    return join ' ', @code;
}

sub _default_for
{
    my $sigil = shift;
    my $name = shift;
    my $invocant = shift;

    return
          "${sigil}${name} = ${invocant}->param('${name}') unless "
        . ( $sigil eq '$' ? 'defined' : '' )
        . " ${sigil}${name}; ";

}

1; # End of CGI::Application::Plugin::RunmodeDeclare

__END__