view release on metacpan or  search on metacpan

lib/FP/Repl/Repl.pm  view on Meta::CPAN

    )
}

our $use_warnings = q{use warnings; use warnings FATAL => 'uninitialized';};

sub eval_code {
    my $self = shift;
    @_ == 5 or fp_croak_arity 5;
    my ($code, $in_package, $maybe_lexicals, $maybe_kept_results,
        $maybe_lexical_persistence)
        = @_;

    # merge with previous results, if any
    my $maybe_kept_results_hash = sub {
        return unless $maybe_kept_results;
        my %r;
        for (my $i = 0; $i < @$maybe_kept_results; $i++) {
            $r{ '$VAR' . ($i + 1) } = \($$maybe_kept_results[$i]);
        }
        \%r
    };
    $maybe_lexicals
        = ($maybe_lexicals && $maybe_kept_results)
        ? hashset_union($maybe_lexicals, &$maybe_kept_results_hash)
        : ($maybe_lexicals // &$maybe_kept_results_hash);

    my $use_method_signatures
        = $Method::Signatures::VERSION ? "use Method::Signatures" : "";
    my $use_functional_parameters_
        = $Function::Parameters::VERSION
        ? "use Function::Parameters ':strict'"
        : "";
    my $use_signatures = ($] >= 5.020) ? "use experimental 'signatures'" : "";
    my $use_tail    = $Sub::Call::Tail::VERSION ? "use Sub::Call::Tail" : "";
    my $use_autobox = @FP::autobox::ISA         ? "use FP::autobox"     : "";

    my $prelude
        = "package "
        . &$in_package() . ";"
        . "use strict; "
        . ($self->use_strict_vars ? "" : "no strict 'vars'; ")
        . "$use_warnings; "
        . "$use_method_signatures; $use_functional_parameters_; "
        . "$use_signatures; $use_tail; $use_autobox; ";

    if (my $lp = $maybe_lexical_persistence) {
        my $allcode = $prelude . $code;
        if (defined $maybe_lexicals) {
            $lp->lexicals(hashset_union($lp->lexicals, $maybe_lexicals))
        }
        my $context = wantarray ? "list" : "scalar";    ## no critic
        $lp->context($context);
        WithRepl_eval { $lp->eval($allcode) }
    } else {
        my @v = sort keys %{ $maybe_lexicals // {} };
        my $allcode
            = $prelude
            . (@v ? 'my (' . join(", ", @v) . '); ' : '') . 'sub {'
            . $code . "\n" . '}';
        my $thunk = &WithRepl_eval($allcode) // return;
        PadWalker::set_closed_over($thunk, $maybe_lexicals)
            if defined $maybe_lexicals;
        WithRepl_eval { &$thunk() }
    }
}

sub _completion_function {
    my ($attribs, $package, $lexicals) = @_;
    sub {
        my ($text, $line, $start, $end) = @_;
        my $part = substr($line, 0, $end);

        #reset to the default before deciding upon it:
        $attribs->{completion_append_character} = " ";

        my @matches = do {

            # arrow completion:
            my ($pre, $varnam, $brace, $alreadywritten);
            if (($pre, $varnam, $brace, $alreadywritten)
                = $part =~ /(.*)\$(\w+)\s*->\s*([{\[]\s*)?(\w*)\z/s
                or ($pre, $varnam, $brace, $alreadywritten)
                = $part =~ /(.*\$)\$(\w+)(?:\s+|(?:\s*([{\[]\s*)(\w*)))\z/s)
            {
                # need to know the class of that thing
                no strict 'refs';
                my $r;

                # try to get the value, or at least the package.
                my $val = do {
                    if (my $ref = $$lexicals{ '$' . $varnam }) {
                        $$ref
                    } else {
                        my $v = ${ $package . "::" . $varnam };
                        if (defined $v) {
                            $v
                        } else {

                            # (if I could run code side-effect free... or
                            # compile-only and disassemble....)  Try to
                            # parse the perl myself
                            if (
                                $part =~ /.* # force latest possible match (ok?)
                                (?:^|;)\s*
                                (?:(?:my|our)\s+)?
                                # ^ optional for no 'use strict'
                                \$$varnam
                                \s* = \s*
                                (?:new\w*\s+($PACKAGE)
                                |($PACKAGE)\s*->\s*new)
                                /sx
                                )
                            {
                                $r = $1;
                                1
                            } else {
                                0
                            }
                        }
                    }
                };