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
|
#!/usr/bin/perl
use v5.14;
use warnings;
use utf8;
use Test2::V0;
use Devel::MAT::Dumper;
use Devel::MAT;
use Scalar::Util qw( refaddr );
my $DUMPFILE = __FILE__ =~ s/\.t/\.pmat/r;
our %HASH = (
array => [ my $SCALAR = \"foobar" ],
);
Devel::MAT::Dumper::dump( $DUMPFILE );
END { unlink $DUMPFILE; }
my $pmat = Devel::MAT->load( $DUMPFILE );
ok ( scalar( grep { $_ eq "Identify" } $pmat->available_tools ), 'Identify tool is available' );
$pmat->load_tool( "Identify" );
my $graph = $pmat->inref_graph( $pmat->dumpfile->sv_at( refaddr $SCALAR ),
strong => 1,
direct => 1,
elide => 1,
);
my $got = "";
no warnings 'once';
local *Devel::MAT::Cmd::printf = sub {
shift;
my ( $fmt, @args ) = @_;
$got .= sprintf $fmt, @args;
};
Devel::MAT::Tool::Identify->walk_graph( $graph, "" );
# Due to ordering within walk_graph this string should be relatively stable
# Different output on thready vs. non-thready perls
my $want_thready = <<'EOR';
├─(via RV) element [0] of ARRAY(1) at _ADDR_, which is:
│ └─(via RV) value {array} of HASH(1) at _ADDR_, which is:
│ └─the symbol '%main::HASH'
├─(via RV) pad temporary _NUM_ at depth 1 of CODE() at _ADDR_=main_cv, which is:
│ └─the main code
└─(via RV) the lexical $SCALAR at depth 1 of CODE() at _ADDR_=main_cv, which is:
└─the main code
EOR
my $want_nonthready = <<'EOR';
├─(via RV) a constant of CODE() at _ADDR_=main_cv, which is:
│ └─the main code
├─(via RV) element [0] of ARRAY(1) at _ADDR_, which is:
│ └─(via RV) value {array} of HASH(1) at _ADDR_, which is:
│ └─the symbol '%main::HASH'
└─(via RV) the lexical $SCALAR at depth 1 of CODE() at _ADDR_=main_cv, which is:
└─the main code
EOR
my $want = $pmat->dumpfile->ithreads ? $want_thready : $want_nonthready;
chomp $want;
$want = quotemeta $want;
$want =~ s/_ADDR_/0x[0-9a-f]+/g;
$want =~ s/_NUM_/\\d+/g;
# Various versions of perl internals might sometimes end up leaving one of
# these in PL_tmpsv. In order not to upset the exact match of this test, just
# trim them out
$got =~ s/=tmpsv//g;
like( $got, qr/^$want$/, 'string from walk_graph' );
done_testing;
|
