File Coverage

blib/lib/CGI/Application/Plugin/RunmodeDeclare.pm

Criterion	Covered	Total	%
statement	89	89	100.0
branch	16	20	80.0
condition	4	5	80.0
subroutine	21	21	100.0
pod	3	3	100.0
total	133	138	96.3

package CGI::Application::Plugin::RunmodeDeclare;
{
  $CGI::Application::Plugin::RunmodeDeclare::VERSION = '0.10';
}

use warnings;
use strict;

=head1 NAME

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

=head1 VERSION

version 0.10

=cut

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;
}

=begin pod-coverage

=over 4

=item strip_name - we hook into this to install cgiapp callbacks

=item parse_proto - proto parser

=item inject_parsed_proto - turn it into code

=back

=end pod-coverage

=cut

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");
        push @code, _php_style_default_for($sigil,"${name}","${invocant}->query") if $sigil eq '@'; # support PHP-style foo[] params
    }

    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}; ";

}

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

    my $varname = $name . '[]';
    return
          "${sigil}${name} = ${invocant}->param('${name}[]') unless "
        . " ${sigil}${name}; ";

}


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

__END__