multiarch.req


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;