view release on metacpan or  search on metacpan

lib/PerlX/ScopeFunction.pm  view on Meta::CPAN

package PerlX::ScopeFunction;
use v5.36;

our $VERSION = "0.05";

use Package::Stash;
use Const::Fast qw( const );
use Keyword::Simple;
use PPR;

our %STASH = ();

const our $do => \&__do;
const our $also => \&__also;
const our $tap => \&__also;

sub __parse_imports (@args) {
    my %import_as;

    my $keyword;
    while (@args) {
        my $it = shift @args;
        if (defined($keyword)) {
            if (!ref($it)) {
                $import_as{$keyword} = $keyword;
                $keyword = $it;
            } elsif (ref($it) eq 'HASH') {
                $import_as{$keyword} = $it->{'-as'} // $keyword;
                $keyword = undef;
            }
        } else {
            if (!ref($it)) {
                $keyword = $it
            }
        }
    }

    $import_as{$keyword} = $keyword if defined($keyword);

    return \%import_as;
}

sub import ($class, @args) {
    my $caller = (caller)[0];
    my %handler = (
        'let' =>[
            sub { __define_keyword( \&__rewrite_let, $_[0] ) },
            sub { __undefine_keyword( $_[0] ) },
        ],
        'with' =>[
            sub { __define_keyword( \&__rewrite_with, $_[0] ) },
            sub { __undefine_keyword( $_[0] ) },
        ],
        '$also' => [
            sub { __import_scalar_symbol(\\&__also, $_[0], $_[1]) },
            sub { __unimport_scalar_symbol($_[0], $_[1]) },
        ],
        '$tap' => [
            sub { __import_scalar_symbol(\\&__also, $_[0], $_[1]) },
            sub { __unimport_scalar_symbol($_[0], $_[1]) },
        ],
        '$do' => [
            sub { __import_scalar_symbol(\\&__do, $_[0], $_[1]) },
            sub { __unimport_scalar_symbol($_[0], $_[1]) },
        ],
    );

    my %import_as = do {
        if (@args > 0) {
            %{ __parse_imports(@args) };
        } else {
            map { $_ => $_ } keys %handler
        }
    };

    for (keys %import_as) {
        my ($importer, $unimporter) = @{$handler{$_}};
        my $as = $import_as{$_};
        $importer->($as, $caller);
        push @{ $STASH{$caller} }, sub { $unimporter->($as, $caller) };
    }
}

sub unimport ($class) {
    my $caller = (caller)[0];
    for my $unimporter (@{ $STASH{$caller} // []}) {
        $unimporter->();
    }
}

sub __do {
    my ($self, $code) = @_;
    local $_ = $self;
    return $self->$code();
}

sub __also {
    my ($self, $code) = @_;
    local $_ = $self;
    $self->$code();
    return $self;
}

sub __import_scalar_symbol ($code, $symbol, $pkg) {
    Package::Stash->new($pkg)->add_symbol($symbol, $code);
}

sub __unimport_scalar_symbol ($symbol, $pkg) {
    Package::Stash->new($pkg)->remove_symbol($symbol);
}

sub __define_keyword ($code, $keyword) {
    Keyword::Simple::define $keyword, $code;
}

sub __undefine_keyword ($keyword) {
    Keyword::Simple::undefine $keyword;
}

my $GRAMMAR = qr{
    (?(DEFINE)
        (?<LetAssignmentSequence>
            ((?&LetAssignment))
            (?: ; (?&PerlOWS) ((?&LetAssignment)))*
            (?: ; )?
        )

        (?<LetAssignmentLHS>
            (?>(?&PerlLvalue))
        )

        (?<LetAssignment>
            (?&LetAssignmentLHS) (?&PerlOWS) = (?&PerlOWS) (?&PerlExpression)
        )
    )

    $PPR::GRAMMAR
}x;

sub __comb_PerlVariable ($code) {
    map {
        s/(?&PerlOWS) $GRAMMAR//xg;
        $_
    } map {
        grep { defined } m/((?&PerlVariable)) $GRAMMAR/xsg;