perl - 当前包声明的子程序列表

Question

需要收集当前包本身声明的子例程列表 - 没有导入。
我看过 Package::Stash，但它列出了导入的名称(当然)。

想出了以下内容，但我不喜欢将包含内容移动到文件底部。

有人看到我如何收集相同的列表，但仍将我的包含内容保持在顶部附近吗？

package Foo;
use common::sense;
use Function::Parameters;
        # Must import at least "fun" and "method" first for them to work.
        # See bottom of file for rest of includes.


our %package_functions;

say join q{, }, sort keys %package_functions;


sub    foo_1    { ; }
fun    foo_2 () { ; }
method foo_3 () { ; }

BEGIN {
        # This block must be kept *after* the sub declarations, and *before* imports.
        no strict 'refs';
        %package_functions = map { $_ => 1 }                 # Hash offers more convenient lookups when/if checked often.
                grep { !/^(can|fun|method)$|^_/ }            # Exclude certain names or name patterns.
                grep { ref __PACKAGE__->can($_) eq 'CODE' }  # Pick out only CODEREFs.
                keys %{__PACKAGE__ . '::'};                  # Any functions above should have their names here.
}

use JSON;
use Data::Dumper;
# use ...

1;

输出(使用“perl”-E 'use Foo;'):

foo_1, foo_2, foo_3

如果 BEGIN 在其他包含之后移动，我们会看到 Dumper、encode_json 等。

Answer 1

Deparse from core 完全可以做到这一点，所以你可以做 B::Deparse.pm 正在做的事情，即使用 B 模块来窥探 perl 的内部结构:

# usage: for_subs 'package', sub { my ($sub_name, $pkg, $type, $cv) = @_; ... }
sub for_subs {
    my ($pkg, $sub) = (@_, sub { printf "%-15s %-15s %-15s%.0s\n", @_ });
    use B (); no strict 'refs';
    my %stash = B::svref_2object(\%{$pkg.'::'})->ARRAY;
    while(my($k, $v) = each %stash){
        if($v->FLAGS & B::SVf_ROK){
            my $cv = $v->RV;
            if($cv->isa('B::CV')){
                $sub->($k, $pkg, sub => $cv);
            }elsif(!$cv->isa('B::SPECIAL') and $cv->FLAGS & B::SVs_PADTMP){
                $sub->($k, $pkg, const => $cv);
            }
        }elsif($v->FLAGS & B::SVf_POK){
            $sub->($k, $pkg, proto => $v->PV);
        }elsif($v->FLAGS & B::SVf_IOK){
            $sub->($k, $pkg, proto => '');
        }elsif($v->isa('B::GV')){
            my $cv = $v->CV;
            next if $cv->isa('B::SPECIAL');
            next if ${$cv->GV} != $$v;
            $sub->($k, $pkg, sub => $cv);
        }
    }
}

示例用法:

package P::Q { sub foo {}; sub bar; sub baz(){ 13 } }
for_subs 'P::Q';
sub foo {}; sub bar; sub baz(){ 13 }
for_subs __PACKAGE__;

应该导致:

foo             P::Q            sub
bar             P::Q            proto
baz             P::Q            sub
baz             main            const
for_subs        main            sub
bar             main            proto
foo             main            sub

---

如果您对包感兴趣is not main，您不关心空原型(prototype)(如上面示例中的 bar)，您只需要一个名称列表，您可以将其剪切为:

# usage: @subs = get_subs 'package'
sub get_subs {
    my @subs;
    use B (); no strict 'refs';
    my %stash = B::svref_2object(\%{shift.'::'})->ARRAY;
    while(my($k, $v) = each %stash){
        next unless $v->isa('B::GV');
        my $cv = $v->CV;
        next if $cv->isa('B::SPECIAL');
        next if ${$cv->GV} != $$v;
        push @subs, $k;
    }
    @subs
}