#!perl
use
5.010_000;
my
$VALID_POINTER
= 7;
my
$SV_SIZE
= 64;
my
$CV_SIZE
= 3000;
my
%out
;
GetOptions(
help
=>
sub
{
die
'pod2usage( -verbose => 2 )'
},
'sv_size=i'
=> \
$SV_SIZE
,
'CV_SIZE=i'
=> \
$CV_SIZE
,
'valid_pointer=i'
=> \
$VALID_POINTER
,
'in=s'
=> \
my
(
$in_file
),
'dir=s'
=> \
my
(
$out_dir
),
map
{;
"$_=s"
=> \
$out
{
$_
}{name} }
qw( contains type file name stash size shares function vertex )
,
)
or
die
'pod2usage( -verbose => 2 )'
;
if
(
$out_dir
) {
$out
{
$_
}{name} //= catfile(
$out_dir
,
"frame.$_"
)
for
keys
%out
;
}
if
( !
$in_file
) {
die
'pod2usage( -verbose => 2 )'
;
}
if
(
$out_dir
) {
}
elsif
(
my
@missing
=
grep
{ !
$out
{
$_
}{name} }
@out
{
qw( contains type file name stash size shares function )
}
) {
die
"Missing: @missing"
;
}
open
my
(
$in
),
'<'
,
$in_file
or
die
"Can't open $in_file: $!"
;
for
my
$nm
(
sort
keys
%out
) {
open
$out
{
$nm
}{fh},
'>'
,
$out
{
$nm
}{name}
or
die
"Can't open $out{$nm}{name} for writing: $!"
;
}
type( 0,
''
);
my
$self
;
my
$type
;
while
(
my
$line
= <
$in
>) {
given
(
$line
) {
when
( /^SV = (\w+)\S+ at 0x([[:xdigit:]]+)/ ) {
$type
=
"$1"
;
$self
=
"$2"
;
vertex(
$self
);
type(
$self
,
$type
);
}
when
( !
defined
$type
) {
}
default
{
given
(
$type
) {
when
(
'PV'
) {
given
(
$line
) {
when
(/^\s+LEN\s+=\s+(\d+)/) {
my
$len
= 0 + $1;
my
$size
=
$SV_SIZE
+
$len
;
size(
$self
,
$size
);
}
}
}
when
(
'PVCV'
) {
given
(
$line
) {
when
(/^\s+REFCNT/) {
size(
$self
,
$CV_SIZE
);
}
when
(/^\s+PADLIST\s+=\s+0x([[:xdigit:]]+)/ ) {
contains(
$self
, $1 );
}
when
( /^\s+GVGV::GV = [^
"]*"
(.+)
" :: "
(.+)"/ ) {
my
$packaged
=
"$1"
;
my
$function
=
"$2"
;
function(
$self
,
"\Q$packaged"
,
"\Q$function"
);
}
when
( /^\s+FILE =
"(.+)"
/ ) {
my
$file
=
"$1"
;
file(
$self
,
"\Q$file"
);
}
}
}
when
(
'PVGV'
) {
given
(
$line
) {
when
(/^\s+(?:MG_OBJ|SV|IO|FORM|AV|HV|CV|)\s+=\s+0x([[:xdigit:]]+)/) {
contains(
$self
,
"$1"
);
}
when
(/^\s+NAME =
"(.+)"
/) {
name(
$self
,
"\Q$1"
);
}
when
(/^\s+GvSTASH = 0x[[:xdigit:]]+\s*
"(.+)"
/ ) {
stash(
$self
,
"\Q$1"
);
}
}
}
when
(
'PVHV'
) {
given
(
$line
) {
when
( /^\s+MAX\s+=(\d+)/ ) {
my
$size
=
$SV_SIZE
* $1;
size(
$self
,
$size
);
}
when
(/^\s+\[0x([[:xdigit:]]+)\s+
".+"
\]\s+=>\s+0x([[:xdigit:]]+)/){
my
$ptr1
=
"$1"
;
my
$ptr2
=
"$2"
;
shares(
$self
,
$ptr1
);
contains(
$self
,
$ptr2
);
}
}
}
when
(
'NULL'
) {
given
(
$line
) {
when
(/^\s+REFCNT/) {
size(
$self
,
$SV_SIZE
);
}
}
}
when
(
'PVAV'
) {
given
(
$line
) {
when
(/^ MAX = (\d+)/) {
size(
$self
, (
$SV_SIZE
* 3 + 4*$1) );
}
when
(/^AvARRAY\(+0x[[:xdigit:]]+\) = \{+/ ) {
pos
() = $-[0];
while
(/0x([[:xdigit:]]+)/g) {
contains(
$self
,
"$1"
);
}
}
}
}
when
(
'IV'
) {
given
(
$line
) {
when
(/^\s+REFCNT/) {
size(
$self
,
$SV_SIZE
);
}
}
}
when
(
'RV'
) {
given
(
$line
) {
when
(/^\s+RV\s+=\s+0x([[:xdigit:]]+)/) {
contains(
$self
,
"$1"
);
size(
$self
,
$SV_SIZE
);
}
}
}
when
(/^PV(?:IV|NV|MG)\z/) {
given
(
$line
) {
when
(/^\s+LEN\s+=\s+(\d+)/) {
size(
$self
,
$SV_SIZE
+ $1 );
}
}
}
}
}
}
}
for
my
$nm
(
sort
keys
%out
) {
close
$out
{
$nm
}{fh}
or
warn
"Can't flush $out{$nm}{name}: $!"
;
say
"Wrote $out{$nm}{name} (@{[ pretty_size( -s $out{$nm}{name} ) ]})"
;
}
sub
function;
sub
file;
sub
name;
sub
stash;
sub
size;
sub
shares;
sub
vertex;
BEGIN {
for
my
$nm
(
qw( function file name stash size shares vertex )
) {
no
strict
'refs'
;
*$nm
=
sub
{
local
$" =
','
;
say
{
$out
{
$nm
}{fh} }
"$nm(@_)."
;
};
}
}
sub
type {
say
{
$out
{type}{fh}}
"type($_[0],'$_[1]')."
;
}
sub
contains {
if
(
$VALID_POINTER
<=
length
$_
[1] ) {
local
$" =
','
;
say
{
$out
{contains}{fh} }
"contains(@_)."
;
}
return
;
}