view release on metacpan or  search on metacpan

lib/Syntax/Feature/Sugar/Callbacks.pm  view on Meta::CPAN

    $class->_inject($ctx, ' sub ');
    $class->_inject($ctx, $attrs)
        if defined($attrs);
    $class->_inject($ctx, sprintf('BEGIN { %s->%s(%s) }; my (%s) = @_; (); ',
        $class,
        '_handle_scope_end',
        defined($name) ? 1 : $cb_options->{ -stmt } ? 1 : 0,
        join(', ',
            @{ $cb_options->{ -before } || [] },
            @$invocants,
            @{ $cb_options->{ -middle } || [] },
            @$parameters,
        ),
    ), 1);
    return 1;
}

sub _handle_scope_end {
    my ($class, $end_stmt) = @_;
    on_scope_end {
        my $linestr = Devel::Declare::get_linestr;
        my $offset  = Devel::Declare::get_linestr_offset;
        substr($linestr, $offset, 0) = $end_stmt ? ');' : ')';
        Devel::Declare::set_linestr($linestr);
    };
    return 1;
}

sub _inject {
    my ($class, $ctx, $code, $into_block) = @_;
    $ctx->skipspace;
    my $linestr = $ctx->get_linestr;
    my $reststr = substr $linestr, $ctx->offset;
    my $skip    = 0;
    if ($into_block) {
        croak sprintf q{Expected a block for '%s', not: %s},
                $ctx->declarator,
                $reststr,
            unless $reststr =~ m{ \A \{ }x;
        $skip = 1;
    }
    substr($reststr, $skip, 0)      = $code;
    substr($linestr, $ctx->offset)  = $reststr;
    $ctx->set_linestr($linestr);
    $ctx->inc_offset($skip + length $code);
    return 1;
}

sub _strip_signature {
    my ($class, $ctx, $options, $cb_options) = @_;
    $ctx->skipspace;
    my $invocant_option = $options->{ -invocant };
    my @invocants = length($invocant_option)
        ? ($invocant_option)
        : ();
    my @default   = @{ $cb_options->{ -default } || [] };
    my $signature = $ctx->strip_proto;
    return [@invocants], [@default]
        unless defined $signature and length $signature;
    my @parts =
        map { [ split m{ \s* , \s* }x, $_ ] }
        split m{ \s* : \s* }x, $signature;
    return  @parts == 1  ? ([@invocants], @parts)
        :   @parts == 2  ? (@parts)
        :   @parts == 0  ? ([@invocants], [])
        :   croak q{Only expected to find a single ':' in signature};
}

sub _strip_name_portion {
    my ($class, $ctx, $options) = @_;
    my $linestr = $ctx->get_linestr;
    if (my $name = $ctx->strip_name) {
        return pp($name);
    }
    if (
            substr($linestr, $ctx->offset) =~ m{ \A " }x
        and Devel::Declare::toke_scan_str $ctx->offset
    ) {
        my $string = Devel::Declare::get_lex_stuff;
        Devel::Declare::clear_lex_stuff;
        substr($linestr, $ctx->offset, 2 + length $string) = '';
        $ctx->set_linestr($linestr);
        return qq{"$string"};
    }
    else {
        return undef
            if $options->{-allow_anon};
        croak sprintf q{Expected a name after '%s' keyword},
            $ctx->declarator;
    }
}

sub _prepare_options {
    my ($class, $options) = @_;
    $options = {}
        unless defined $options;
    croak qq{Expected options for $class to be a hash ref}
        unless is_ref $options, 'HASH';
    $options->{ -invocant } = '$self'
        unless defined $options->{ -invocant };
    croak qq{Option -invocant for $class has to be filled string}
        unless is_string $options->{ -invocant };
    croak qq{Option -callbacks for $class has to be a hash ref}
        unless is_ref $options->{ -callbacks };
    return $options;
}

1;



=pod

=head1 NAME

Syntax::Feature::Sugar::Callbacks - Add sugar for declarative method callbacks

=head1 VERSION

version 0.002

=head1 SYNOPSIS