1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
|
package b_dump_strings;
use B qw(minus_c save_BEGINs peekop class walkoptree walkoptree_exec
main_start main_root cstring sv_undef);
BEGIN { open OUT, ">$ENV{OUTFILE}" }
sub B::CV::debug {
my ($sv) = @_;
B::walkoptree_exec($sv->START, "debug");
}
sub B::OP::debug {
my ($op) = @_;
# print "OP ", class($op), " ", $op->name, "\n";
eval {
if ($op->name eq 'entersub') {
$op2 = $op->first->first or return;
if ($op2->name eq 'pushmark') {
my $s = $op2->sibling->sv->PV;
my $l;
for ($l = $op2->sibling; ${$l->sibling}; $l = $l->sibling) {}
$s =~ s/"/\\"/g;
if ($l->first->sv->NAME eq '_') {
print OUT qq($::pkg N("$s")\n);
}
}
}
};
}
sub B::RV::debug {
my ($op) = @_;
$op->RV->debug;
}
sub B::SVOP::debug {
my ($op) = @_;
$op->sv->debug;
}
sub B::PV::debug {
my ($sv) = @_;
# print "STRING ", $sv->PV, "\n";
}
sub B::IV::debug {
my ($sv) = @_;
# printf "IV\t%d\n", $sv->IV;
}
sub B::NV::debug {
my ($sv) = @_;
# printf "NV\t%s\n", $sv->NV;
}
sub B::PVIV::debug {
my ($sv) = @_;
# printf "IV\t%d\n", $sv->IV;
}
sub B::PVNV::debug {
my ($sv) = @_;
# printf "NV\t%s\n", $sv->NV;
}
sub B::AV::debug {
my ($av) = @_;
# print "ARRAY\n";
}
sub B::GV::debug {
my ($gv) = @_;
# printf "GV %s::%s\n", $gv->STASH->NAME, $gv->SAFENAME;
}
sub B::NULL::debug {
# print "NUL\n";
}
sub B::SPECIAL::debug {}
sub B::SV::debug { die "SV"; }
sub B::BM::debug {
die "BM";
}
sub B::PVLV::debug { die "PVLV"; }
sub B::GV::pgv {
my ($gv) = @_;
# print $gv->NAME, "\n";
$gv->SV->debug;
$gv->HV->debug;
$gv->AV->debug;
$gv->CV->debug;
}
sub search {
foreach my $pkg (grep { /^[a-z]/ && !/^(diagnostics|strict|attributes|main)/ } grep { /\w+::$/ } keys %main::) {
$::pkg = $pkg;
foreach (keys %{$main::{$pkg}}) {
print STDERR "$pkg $_ XXXXX\n";
local *f = *{$main::{$pkg}{$_}};
B::svref_2object(\*f)->pgv;
}
}
print STDERR "DONE\n";
}
CHECK { search() }
INIT { exit 0 }
#use lib qw(. /home/pixel/gi/perl-install);
##use commands;
#require '/tmp/t.pl';
#search();
1;
|
