view release on metacpan or  search on metacpan

lib/CGI/Application/Plugin/RunmodeDeclare.pm  view on Meta::CPAN

        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;