view release on metacpan or  search on metacpan

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

    my $class = shift;
    my %args = @_;
    my $into = delete $args{into} || $caller;
    my $inv = delete $args{invocant} || '$self';

    Parse::Keyword->import( { runmode   => sub { my ($kw) = @_; parse_mode($kw, $inv); } } );
    Parse::Keyword->import( { errormode => sub { my ($kw) = @_; parse_mode($kw, $inv); } } );
    Parse::Keyword->import( { startmode => sub { my ($kw) = @_; parse_mode($kw, $inv); } } );

    for my $e(@EXPORT) {
        my $fn = $into . '::' . $e;
        no strict 'refs';
        *$fn = \&$e;
        *$fn if 0;
    }
}

sub runmode { @_ ? $_[0] : () }
sub errormode { @_ ? $_[0] : () }
sub startmode { @_ ? $_[0] : () }

my %REGISTRY;
sub _setup_runmode {
    my ($pkg, $name, $code) = @_;
    $pkg->add_callback( init => sub { $_[0]->run_modes([ $name ]) } );
}
sub _setup_startmode {
    my ($pkg, $name, $code) = @_;
    no strict 'refs'; no warnings 'uninitialized';
    # 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} = join '::', $pkg, $name;
}
sub _setup_errormode {
    my ($pkg, $name, $code) = @_;
    no strict 'refs'; no warnings 'uninitialized';
    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} = join '::', $pkg, $name;
}

=begin pod-coverage

=over 4

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

=item parse_name - identifier name parser

=item parse_signature - runmode signature parser

=item parse_attribute - parse one sub attr

=item parse_attributes - parse sub attrs

=item parse_body - parse code and inject defaults

=back

=end pod-coverage

=cut

sub parse_mode {
    my ($keyword, $invocant) = @_;

    my $name = parse_name();
    my $sig  = parse_signature($invocant);
    my $attr = parse_attributes();
    my $body = parse_body($sig) or ($@ and die);

    if (defined $name) {
        my $full_name = join('::', compiling_package, $name);
        {
            no strict 'refs';
            *$full_name = subname $full_name, $body;
            if ($attr) {
                use attributes ();
                attributes->import(compiling_package, $body, $_) for @$attr;
            }
            my $setup = '_setup_' . $keyword;
            $setup->(compiling_package, $name, $body);

        }
        return (sub {}, 1);
    }
    else {
        return (sub { $body }, 0);
    }
}

my $start_rx = qr/^[\p{ID_Start}_]$/;
my $cont_rx  = qr/^\p{ID_Continue}$/;

sub parse_name {
    my $name = '';

    lex_read_space;

    my $char_rx = $start_rx;

    while (1) {
        my $char = lex_peek;
        last unless length $char;
        if ($char =~ $char_rx) {
            $name .= $char;