view release on metacpan or  search on metacpan

lib/Acme/SubstituteSubs.pm  view on Meta::CPAN

sub set {
    shift if Devel::Caller::called_as_method;
    my $fqfunc = shift;
    my $code = shift;

    my ($packagename, $methodname) = ($fqfunc =~ m/(.*)::(.*)/, 'main', $fqfunc);

    defined $code or die 'set($qualified_function_name, $replacement_code)';

    # if code is a CODE ref, deparse it
    # XXX extra points for keeping values for lexicals
    $code = B::Deparse->new->coderef2text($code) if ref($code) and ref($code) eq 'CODE';

    if($code =~ m/^{/) {
        $code = qq<sub $code>;  # happens when B::Deparse kicks in
    } elsif($code =~ m/^\s*sub\s+{/) {
        $code =~ s/sub/sub $methodname /;  # untested codepath alert
    } elsif($code !~ m/^\s*sub/) {
        $code = qq<sub $methodname { $code }>;
    }

    # $code .= "\n" unless $code =~ m/\n$/s;

    # STDERR->print("saving updates to $RealScript\n");
    open my $fh, '>', $RealScript.'.new' or die $!;

    my $currentpackage = 'main';
    my $foundit = 0;

    my $doc = PPI::Document->new($RealScript) or die PPI::Document->errstr;

    for my $child ($doc->children) {
        if($child->isa('PPI::Statement::Sub')) {
            if(! $foundit and $child->name eq $methodname and $currentpackage eq $packagename) {
                $fh->print($code); # instead of $child->content
                $foundit = 1;
            } else {
                $fh->print($child->content);
            }
        } elsif($child->isa('PPI::Statement::Package')) {
            if(! $foundit and $currentpackage eq $packagename) {
                $fh->print($code);
                $foundit = 1;
            }
            $currentpackage = $child->namespace;
            $fh->print($child->content);
        } else {
            $fh->print($child->content) or die;
        }
    }
    if(! $foundit ) {
        # at the end of the file and still haven't found the package/sub?  just append it.
        if($currentpackage ne $packagename) {
            $fh->print(qq{\npackage $packagename;\n});
        }
        $fh->print($code);
    }
    $fh->close;

    rename $RealScript, $RealScript.'.last';
    rename $RealScript.'.new', $RealScript or do {
        warn "renaming new pl file into place as ``$RealScript'' failed: $!";
    };
}

sub list_both {
    shift if Devel::Caller::called_as_method;

    my @packages;
    my @subs;

    my $doc = PPI::Document->new($RealScript) or die PPI::Document->errstr;

    my $currentpackage = 'main::';
    push @packages, $currentpackage;
    for my $child ($doc->children) {
        if($child->isa('PPI::Statement::Sub')) {
            push @subs, $currentpackage . $child->name;
        } elsif($child->isa('PPI::Statement::Package')) {
            $currentpackage = $child->namespace . '::';
            push @packages, $currentpackage;
        }
    }

    return \@subs, \@packages;

}

sub list {
    return @{ list_both()->[0] };
}

sub list_packages {
    return @{ list_both()->[1] }; 
}

1;