Data-Peek-0.53/0000755000031300001440000000000014736724470012447 5ustar00merijnusersData-Peek-0.53/t/0000755000031300001440000000000014736724470012712 5ustar00merijnusersData-Peek-0.53/t/22_DHexDump.t0000644000031300001440000000273714027400241015045 0ustar00merijnusers#!/usr/bin/perl
use strict;
use warnings;
use Test::More;
use Test::Warnings;
use Config;
use Data::Peek;
my $is_ebcdic = ($Config{ebcdic} || "undef") eq "define" ? 1 : 0;
is (DHexDump (undef), undef, 'undef');
is (DHexDump (""), "", '""');
for (split m/##\n/ => test_data ()) {
my ($desc, $in, @out) = split m/\n-\n/, $_, 4;
my $out = $out[$is_ebcdic];
$out =~ s/\n*\z/\n/;
if ($in =~ s/\t(\d+)$//) {
is (scalar DHexDump ($in, $1), $out, "HexDump $desc");
}
else {
is (scalar DHexDump ($in), $out, "HexDump $desc");
}
}
done_testing;
sub test_data {
return <<"EOTD";
Single 0
-
0
-
0000 30 0
-
0000 f0 0
##
Documentation example
-
abc\x{0a}de\x{20ac}fg
-
0000 61 62 63 0a 64 65 e2 82 ac 66 67 abc.de...fg
-
0000 81 82 83 0a 84 85 ca 46 53 86 87 abc.de...fg
##
Documentation example with length
-
abc\x{0a}de\x{20ac}fg 6
-
0000 61 62 63 0a 64 65 abc.de
-
0000 81 82 83 0a 84 85 abc.de
##
Binary data
-
\x01Great wide open space\x02\x{20ac}\n
-
0000 01 47 72 65 61 74 20 77 69 64 65 20 6f 70 65 6e .Great wide open
0010 20 73 70 61 63 65 02 e2 82 ac 0a space.....
-
0000 01 c7 99 85 81 a3 40 a6 89 84 85 40 96 97 85 95 .Great wide open
0010 40 a2 97 81 83 85 02 ca 46 53 15 space.....
##
EOTD
} # test_data
Data-Peek-0.53/t/30_DDump-s.t0000644000031300001440000000605014027400241014627 0ustar00merijnusers#!/usr/bin/perl
use strict;
use warnings;
# I would like more tests, but contents change over every perl version
use Test::More;
use Test::Warnings;
use Data::Peek;
$Data::Peek::has_perlio = $Data::Peek::has_perlio = 0;
ok (1, "DDump () NOT using PerlIO");
my @tests;
{ local $/ = "==\n";
chomp (@tests = );
}
# Determine what newlines this perl generates in sv_peek
my @nl = ("\\n") x 2;
my $var = "";
foreach my $test (@tests) {
my ($in, $expect) = split m/\n--\n/ => $test;
$in eq "" and next;
SKIP: {
my $dump;
if ($in eq "DEFSV") {
$_ = undef;
$_ = "DEFSV";
$dump = DDump;
}
else {
eval "\$var = $in;";
$dump = DDump ($var);
}
if ($in =~ m/20ac/) {
@nl = ($dump =~ m/PV = 0x\w+ "([^"]+)".*"([^"]+)"/);
diag "# This perl dumps \\n as (@nl)";
# Catch differences in \n
$dump =~ s/"ab\Q$nl[0]\E(.*?)"ab\Q$nl[1]\E/"ab\\n$1"ab\\n/g;
}
$dump =~ s/\b0x[0-9a-f]+\b/0x****/g;
$dump =~ s/\b(REFCNT =) [0-9]{4,}/$1 -1/g;
$dump =~ s/\bLEN = (?:[1-9]|1[0-6])\b/LEN = 8/g; # aligned at long long?
$dump =~ s/\bPADBUSY\b,?//g if $] < 5.010;
my @expect = split m/(?<=\n)\|(?:\s*#.*)?\n+/ => $expect;
$in =~ s/[\s\n]+/ /g;
if (my @match = grep { $dump eq $_ } @expect) {
is ($dump, $match[0], "DDump ($in)");
}
else {
my $match = pop @expect;
is ($dump, $match, "DDump ($in)");
diag ("DDump ($in) neither matches\n$_") for @expect;
}
}
}
done_testing;
1;
__END__
undef
--
SV = PV(0x****) at 0x****
REFCNT = 1
FLAGS = (PADMY)
PV = 0x**** ""\0
CUR = 0
LEN = 8
| # as of 5.19.3
SV = PV(0x****) at 0x****
REFCNT = 1
FLAGS = (PADMY)
PV = 0
| # as of 5.21.5
SV = PV(0x****) at 0x****
REFCNT = 1
FLAGS = ()
PV = 0
==
0
--
SV = PVIV(0x****) at 0x****
REFCNT = 1
FLAGS = (PADMY,IOK,pIOK)
IV = 0
PV = 0x**** ""\0
CUR = 0
LEN = 8
| # as of 5.19.3
SV = PVIV(0x****) at 0x****
REFCNT = 1
FLAGS = (PADMY,IOK,pIOK)
IV = 0
PV = 0
| # as of 5.21.5
SV = PVIV(0x****) at 0x****
REFCNT = 1
FLAGS = (IOK,pIOK)
IV = 0
PV = 0
==
1
--
SV = PVIV(0x****) at 0x****
REFCNT = 1
FLAGS = (PADMY,IOK,pIOK)
IV = 1
PV = 0x**** ""\0
CUR = 0
LEN = 8
| # as of 5.19.3
SV = PVIV(0x****) at 0x****
REFCNT = 1
FLAGS = (PADMY,IOK,pIOK)
IV = 1
PV = 0
| # as of 5.21.5
SV = PVIV(0x****) at 0x****
REFCNT = 1
FLAGS = (IOK,pIOK)
IV = 1
PV = 0
==
""
--
SV = PVIV(0x****) at 0x****
REFCNT = 1
FLAGS = (PADMY,POK,pPOK)
IV = 1
PV = 0x**** ""\0
CUR = 0
LEN = 8
| # as of 5.19.3
SV = PVIV(0x****) at 0x****
REFCNT = 1
FLAGS = (PADMY,POK,IsCOW,pPOK)
IV = 1
PV = 0x**** ""\0
CUR = 0
LEN = 8
COW_REFCNT = 0
| # as of 5.21.5
SV = PVIV(0x****) at 0x****
REFCNT = 1
FLAGS = (POK,IsCOW,pPOK)
IV = 1
PV = 0x**** ""\0
CUR = 0
LEN = 8
COW_REFCNT = 0
==
DEFSV
--
SV = PV(0x****) at 0x****
REFCNT = 1
FLAGS = (POK,pPOK)
PV = 0x**** "DEFSV"\0
CUR = 5
LEN = 8
| # as of 5.19.3
SV = PV(0x****) at 0x****
REFCNT = 1
FLAGS = (POK,IsCOW,pPOK)
PV = 0x**** "DEFSV"\0
CUR = 5
LEN = 8
COW_REFCNT = 1
Data-Peek-0.53/t/01_pod.t0000644000031300001440000000035414027400241014137 0ustar00merijnusers#!/usr/bin/perl
use strict;
$^W = 1;
use Test::More;
eval "use Test::Pod::Coverage tests => 1";
plan skip_all => "Test::Pod::Covarage required for testing POD Coverage" if $@;
pod_coverage_ok ("Data::Peek", "Data::Peek is covered");
Data-Peek-0.53/t/41_DDump-h.t0000644000031300001440000000026414027400241014617 0ustar00merijnusers#!/usr/bin/perl
use strict;
use warnings;
use Test::More;
use Test::Warnings;
use Data::Peek;
ok (1, "Here com tests for DDump () returning hash using IO");
done_testing;
1;
Data-Peek-0.53/t/52_DGrow.t0000644000031300001440000000163314027400241014406 0ustar00merijnusers#!/usr/bin/perl
use strict;
use warnings;
use Test::More;
use Test::Warnings;
use Data::Peek qw( DGrow DDump );
my $x = "";
is (length ($x), 0, "Initial length = 0");
my %dd = DDump $x;
ok ($dd{LEN} <= 16);
my $len = 10240;
ok (my $l = DGrow ($x, $len), "Set to $len");
is (length ($x), 0, "Variable content");
ok ($l >= $len, "returned LEN >= $len");
my $limit = 4 * $len;
ok ($l <= $limit, "returned LEN <= $limit");
%dd = DDump $x;
ok ($dd{LEN} >= $len, "LEN in variable >= $len");
ok ($dd{LEN} <= $limit, "LEN in variable <= limit");
ok ($l = DGrow (\$x, $limit), "Set to $limit");
ok ($l >= $limit, "LEN in variable >= $limit");
($len, $limit) = ($limit, 4 * $limit);
ok ($l <= $limit, "LEN in variable <= $limit");
%dd = DDump $x;
ok ($dd{LEN} >= $len, "LEN in variable >= $len");
ok ($dd{LEN} <= $limit, "LEN in variable <= $limit");
is (DGrow ($x, 20), $l, "Don't shrink");
done_testing;
1;
Data-Peek-0.53/t/11_DDumper.t0000644000031300001440000000254214027400241014717 0ustar00merijnusers#!/usr/bin/perl
use strict;
use warnings;
use Test::More;
use Test::Warnings;
BEGIN {
eval q{use Perl::Tidy};
# Version is also checked in Peek.pm
if ($@ || $Perl::Tidy::VERSION <= 20120714) {
diag "A usable Perl::Tidy is not available";
done_testing;
exit 0;
}
use_ok ("Data::Peek", ":tidy");
die "Cannot load Data::Peek\n" if $@;
}
my ($dump, $var) = ("", "");
while () {
chomp;
my ($v, $exp, $re) = split m/\t+ */;
if ($v eq "--") {
ok (1, "** $exp");
next;
}
$v =~ s/^S:([^:]*):// and DDsort ($1), $v =~ m/^()/; # And reset $1 for below
unless ($v eq "") {
eval "\$var = $v";
ok ($dump = DDumper ($var), "DDumper ($v)");
$dump =~ s/\A\$VAR1 = //;
$dump =~ s/;?\n\Z//;
}
if ($re) {
like ($dump, qr{$exp}ms, ".. content $re");
$1 and diag "# '$1' (", length ($1), ")\n";
}
else {
is ($dump, $exp, ".. content");
}
}
unlink "perltidy.LOG", "perltidy.ERR";
done_testing;
1;
__END__
-- Basic values
undef undef
1 1
"" ''
"\xa8" '�'
1.24 '1.24'
\undef \undef
\1 \1
\"" \''
\"\xa8" \'�'
(0, 1) 1
\(0, 1) \1
-- Structures
[0] \A\[\s*0\s*]\s*\Z tidy array 1
[0, 1] \A\[\s*0\s*,\s*1\s*]\s*\Z tidy array 2
[0,1,2] \A\[\s*0\s*,\s*1\s*,\s*2\s*]\s*\Z tidy array 3
[[0],{foo=>1}] \A\[\s*\[\s*0\s*]\s*,\s*\{\s*'foo'\s*=>\s*1\s*}\s*]\s*\Z structure
Data-Peek-0.53/t/12_DDsort.t0000644000031300001440000000173514027400241014562 0ustar00merijnusers#!/usr/bin/perl
use strict;
use warnings;
use Test::More;
use Test::Warnings;
use Data::Peek;
my %hash = (1, 100, 2, 150, 30, 25, 200, 12, 4, 4);
is (DDsort (0), 0, "Sort type 0");
my $out = DDumper \%hash;
like ($out, qr{\b200\s+=>\s+12\b}, "Unsorted"); # Random order
sub dsort {
my ($sk, $exp) = @_;
ok (DDsort ($sk), "Sort type $sk");
$out = DDumper \%hash;
$out =~ s{\s+}{ }g;
$out =~ s{\s+$}{};
is ($out, $exp, "Sorted by $sk");
} # dsort
dsort (1 => "{ 1 => 100, 2 => 150, 200 => 12, 30 => 25, 4 => 4 }");
dsort (R => "{ 4 => 4, 30 => 25, 200 => 12, 2 => 150, 1 => 100 }");
dsort (N => "{ 1 => 100, 2 => 150, 4 => 4, 30 => 25, 200 => 12 }");
dsort (NR => "{ 200 => 12, 30 => 25, 4 => 4, 2 => 150, 1 => 100 }");
dsort (V => "{ 1 => 100, 200 => 12, 2 => 150, 30 => 25, 4 => 4 }");
dsort (VR => "{ 4 => 4, 30 => 25, 2 => 150, 200 => 12, 1 => 100 }");
dsort (VNR => "{ 2 => 150, 1 => 100, 30 => 25, 200 => 12, 4 => 4 }");
done_testing;
1;
Data-Peek-0.53/t/51_triplevar.t0000644000031300001440000000073014027400241015370 0ustar00merijnusers#!/usr/bin/perl
use strict;
use warnings;
use Test::More;
use Test::Warnings;
use Data::Peek qw( DDual DPeek triplevar );
foreach my $iv (undef, 3 ) {
foreach my $nv (undef, 3.1415) {
foreach my $pv (undef, "\x{03c0}") {
my $tv = triplevar ($pv, $iv, $nv);
ok (my @tv = DDual ($tv), "Get tv");
is ($tv[0], $pv, "Check pv");
is ($tv[1], $iv, "Check iv");
is ($tv[2], $nv, "Check nv");
}
}
}
done_testing;
1;
Data-Peek-0.53/t/40_DDump-h.t0000644000031300001440000000026414027400241014616 0ustar00merijnusers#!/usr/bin/perl
use strict;
use warnings;
use Test::More;
use Test::Warnings;
use Data::Peek;
ok (1, "Here com tests for DDump () returning hash using XS");
done_testing;
1;
Data-Peek-0.53/t/21_DDisplay.t0000644000031300001440000000103214027400241015062 0ustar00merijnusers#!/usr/bin/perl
use strict;
use warnings;
use Test::More;
use Test::Warnings;
use Data::Peek;
is (DDisplay (undef), '', 'undef has no PV');
is (DDisplay (0), '', '0 has no PV');
is (DDisplay (\undef), '', '\undef has no PV');
is (DDisplay (\0), '', '\0 has no PV');
is (DDisplay (sub {}), '', 'code has no PV');
is (DDisplay (""), '""', 'empty string');
is (DDisplay ("a"), '"a"', '"a"');
is (DDisplay ("\n"), '"\n"', '"\n"');
is (DDisplay ("\x{20ac}"), '"\x{20ac}"', '"\n"');
done_testing;
1;
Data-Peek-0.53/t/10_DDumper.t0000644000031300001440000000336214027400241014717 0ustar00merijnusers#!/usr/bin/perl
use strict;
use warnings;
use Test::More;
use Test::Warnings;
BEGIN {
use_ok "Data::Peek";
die "Cannot load Data::Peek\n" if $@; # BAIL_OUT not avail in old Test::More
}
my ($dump, $var) = ("", "");
while () {
chomp;
my ($v, $exp, $re) = split m/\t+ */;
if ($v eq "--") {
ok (1, "** $exp");
next;
}
$v =~ s/^S:([^:]*):// and DDsort ($1), $v =~ m/^()/; # And reset $1 for below
unless ($v eq "") {
eval "\$var = $v";
ok ($dump = DDumper ($var), "DDumper ($v)");
$dump =~ s/\A\$VAR1 = //;
$dump =~ s/;?\n\Z//;
}
if ($re) {
like ($dump, qr{$exp}ms, ".. content $re");
$1 and diag "# '$1' (", length ($1), ")\n";
}
else {
is ($dump, $exp, ".. content");
}
}
done_testing;
1;
__END__
-- Basic values
undef undef
1 1
"" ''
"\xb6" '�'
1.24 '1.24'
\undef \undef
\1 \1
\"" \''
\"\xb6" \'�'
(0, 1) 1
\(0, 1) \1
-- Structures
[0, 1] ^\[ 0,\n line 1
^ 1\n line 2
^ ]\Z line 3
[0,1,2] \A\[\s+0,\n\s+1,\n\s+2\n\s+]\Z line splitting
-- Indentation
[0] \A\[ 0\n ]\Z single indent
[[0],{foo=>1}] ^\[\n outer list
^ {4}\[ 0\n {8}],\n {4} inner list
^ {4}\{ foo {14}=> 1\n {8}}\n inner hash
^ {4}]\Z outer list end
[[0],{foo=>1}] \A\[\n {4}\[ 0\n {8}],\n {4}\{ foo {14}=> 1\n {8}}\n {4}]\Z full struct
-- Sorting
S:1:{ab=>1,bc=>2,cd=>3,de=>13} ab.*bc.*cd.*de default sort
S:R:{ab=>1,bc=>2,cd=>3,de=>13} de.*cd.*bc.*ab reverse sort
S:V:{ab=>1,bc=>2,cd=>3,de=>13} 1.*13.*2.*3 sort by value
S:VR:{ab=>1,bc=>2,cd=>3,de=>13} 3.*2.*13.*1 reverse sort by value
S:VN:{ab=>1,bc=>2,cd=>3,de=>13} 1.*2.*3.*13 sort by value numeric
S:VNR:{ab=>1,bc=>2,cd=>3,d=>13} 13.*3.*2.*1 reverse sort by value numeric
Data-Peek-0.53/t/50_DDual.t0000644000031300001440000000402314027400241014347 0ustar00merijnusers#!/usr/bin/perl
use strict;
use warnings;
use Test::More;
use Test::Warnings;
use Data::Peek;
my %special = ( 9 => "\\t", 10 => "\\n", 13 => "\\r" );
sub neat
{
my $neat = $_[0];
defined $neat or return "undef";
my $ref = ref $neat ? "\\" : "" and $neat = $$neat;
join "", $ref, map {
my $cp = ord $_;
$cp >= 0x20 && $cp <= 0x7e
? $_
: $special{$cp} || sprintf "\\x{%02x}", $cp
} split m//, $neat;
} # neat
foreach my $test (
[ undef, undef, undef, undef, undef, 0, undef ],
[ 0, undef, 0, undef, undef, 0, undef ],
[ 1, undef, 1, undef, undef, 0, undef ],
[ 0.5, undef, undef, 0.5, undef, 0, 0 ],
[ "", "", undef, undef, undef, 0, 0 ],
[ \0, undef, undef, undef, 0, 0, undef ],
[ \"a", undef, undef, undef, "a", 0, undef ],
) {
(undef, my @exp) = @$test;
my $in = neat ($test->[0]);
ok (my @v = DDual ($test->[0]), "DDual ($in)");
is (scalar @v, 5, "5 elements");
is ($v[0], $exp[0], "PV $in ".DPeek ($v[0]));
is ($v[1], $exp[1], "IV $in ".DPeek ($v[1]));
is ($v[2], $exp[2], "NV $in ".DPeek ($v[2]));
is ($v[3], $exp[3], "RV $in ".DPeek ($v[3]));
is ($v[4], $exp[4], "MG $in ".DPeek ($v[4]));
defined $v[1] and next;
{ no warnings;
my $x = 0 + $test->[0];
}
TODO: { local $TODO = "Do all perl versions upgrade?";
ok (@v = DDual ($test->[0]), "DDual ($in + 0)");
is ($v[1], $exp[5], "IV $in ".DPeek ($v[1]));
}
}
TODO: { local $TODO = "How magic is \$? accross perl versions?";
my @m = DDual ($?);
is ($m[4], 3, "\$? has magic");
is ($m[0], undef, "PV \$? w/o get");
is ($m[1], undef, "IV \$? w/o get");
is ($m[2], undef, "NV \$? w/o get");
is ($m[3], undef, "RV \$? w/o get");
}
TODO: { local $TODO = "How magic is \$? accross perl versions?";
my @m = DDual ($?, 1);
is ($m[4], 3, "\$? has magic");
is ($m[0], undef, "PV \$? w/ get");
is ($m[1], 0, "IV \$? w/ get");
is ($m[2], undef, "NV \$? w/ get");
is ($m[3], undef, "RV \$? w/ get");
}
done_testing;
1;
Data-Peek-0.53/t/31_DDump-s.t0000644000031300001440000000026614027400241014633 0ustar00merijnusers#!/usr/bin/perl
use strict;
use warnings;
use Test::More;
use Test::Warnings;
use Data::Peek;
ok (1, "Here com tests for DDump () returning string using IO");
done_testing;
1;
Data-Peek-0.53/t/00_pod.t0000644000031300001440000000025214027400241014133 0ustar00merijnusers#!/usr/bin/perl
use strict;
$^W = 1;
use Test::More;
eval "use Test::Pod 1.00";
plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
all_pod_files_ok ();
Data-Peek-0.53/t/20_DPeek.t0000644000031300001440000000576114354602760014372 0ustar00merijnusers#!/usr/bin/perl
use strict;
use warnings;
use Test::More;
use Test::Warnings;
use Data::Peek;
$| = 1;
my $peek = DPeek (0);
SKIP: {
$peek =~ m/^Your perl did not/ and skip ($peek, 49);
like (DPeek ($/), qr'^PVMG\("\\(n|12)"\\0\)', '$/');
is (DPeek ($\), 'PVMG()', '$\\');
like (DPeek ($.), qr'^PVMG\(0?\)$', '$.');
like (DPeek ($,), qr'^PVMG\((""\\0)?\)|^UNDEF$','$,');
is (DPeek ($;), 'PV("\34"\0)', '$;');
is (DPeek ($"), 'PV(" "\0)', '$"');
like (DPeek ($:), qr'^PVMG\(" \\(n|12)-"\\0\)', '$:');
is (DPeek ($~), 'PVMG()', '$~');
is (DPeek ($^), 'PVMG()', '$^');
is (DPeek ($=), 'PVMG()', '$=');
is (DPeek ($-), 'PVMG()', '$-');
is (DPeek ($|), 'PVMG(1)', '$|');
like (DPeek ($?), qr'^PV(MG|LV)\(0?\)', '$?');
like (DPeek ($!), qr'^PVMG\(""|\)', '$!');
"abc" =~ m/(b)/; # Don't know why these magic vars have this content
like (DPeek ($1), qr'^PVMG\("', ' $1');
is (DPeek ($`), 'PVMG()', ' $`');
is (DPeek ($&), 'PVMG()', ' $&');
is (DPeek ($'), 'PVMG()', " \$'");
is (DPeek (undef), 'SV_UNDEF', 'undef');
is (DPeek (1), 'IV(1)', 'constant 1');
is (DPeek (""), 'PV(""\0)', 'constant ""');
is (DPeek (1.), 'NV(1)', 'constant 1.');
is (DPeek (\1), '\IV(1)', 'constant \1');
is (DPeek (\\1), '\\\IV(1)', 'constant \\\1');
is (DPeek (\@ARGV), '\AV()', '\@ARGV');
is (DPeek (\@INC), '\AV()', '\@INC');
is (DPeek (\%INC), '\HV()', '\%INC');
is (DPeek (*STDOUT), 'GV()', '*STDOUT');
is (DPeek (sub {}), '\CV(__ANON__)', 'sub {}');
{ our ($VAR, @VAR, %VAR);
open VAR, ">VAR.txt";
sub VAR {}
format VAR =
.
END { unlink "VAR.txt" };
is (DPeek ( $VAR), 'UNDEF', ' $VAR undef');
is (DPeek (\$VAR), '\UNDEF', '\$VAR undef');
$VAR = 1;
is (DPeek ($VAR), 'IV(1)', ' $VAR 1');
is (DPeek (\$VAR), '\IV(1)', '\$VAR 1');
$VAR = "";
is (DPeek ($VAR), 'PVIV(""\0)', ' $VAR ""');
is (DPeek (\$VAR), '\PVIV(""\0)', '\$VAR ""');
$VAR = "\xb6";
is (DPeek ($VAR), 'PVIV("\266"\0)', ' $VAR "\xb6"');
is (DPeek (\$VAR), '\PVIV("\266"\0)', '\$VAR "\xb6"');
SKIP: {
$] <= 5.008001 and skip "UTF8 tests useless in this ancient perl version", 1;
$VAR = "a\x0a\x{20ac}";
like (DPeek ($VAR), qr'^PVIV\("a\\(n|12)(?:\\342\\202\\254|\\312\\106\\123)"\\0\) \[UTF8 "a\\?(?:n|x\{a\})\\x\{20ac}"\]',
' $VAR "a\x0a\x{20ac}"');
}
$VAR = sub { "VAR" };
is (DPeek ($VAR), '\CV(__ANON__)', ' $VAR sub { "VAR" }');
is (DPeek (\$VAR), '\\\CV(__ANON__)', '\$VAR sub { "VAR" }');
$VAR = 0;
is (DPeek (\&VAR), '\CV(VAR)', '\&VAR');
is (DPeek ( *VAR), 'GV()', ' *VAR');
is (DPeek (*VAR{GLOB}), '\GV()', ' *VAR{GLOB}');
like (DPeek (*VAR{SCALAR}), qr'\\PV(IV|MG)\(0\)',' *VAR{SCALAR}');
is (DPeek (*VAR{ARRAY}), '\AV()', ' *VAR{ARRAY}');
is (DPeek (*VAR{HASH}), '\HV()', ' *VAR{HASH}');
is (DPeek (*VAR{CODE}), '\CV(VAR)', ' *VAR{CODE}');
is (DPeek (*VAR{IO}), '\IO()', ' *VAR{IO}');
is (DPeek (*VAR{FORMAT}), '\FM()', ' *VAR{FORMAT}');
}
}
done_testing;
1;
Data-Peek-0.53/Peek.xs0000644000031300001440000000767514736722031013715 0ustar00merijnusers/* Copyright (c) 2008-2025 H.Merijn Brand. All rights reserved.
* This program is free software; you can redistribute it and/or
* modify it under the same terms as Perl itself.
*/
#ifdef __cplusplus
extern "C" {
#endif
#define PERL_NO_GET_CONTEXT
#include
#include
#include
#define NEED_pv_pretty
#define NEED_pv_escape
#define NEED_my_snprintf
#define NEED_utf8_to_uvchr_buf
#include "ppport.h"
#ifdef __cplusplus
}
#endif
SV *_DDump (pTHX_ SV *sv)
{
int err[3], n;
char buf[128];
SV *dd;
if (pipe (err)) return (NULL);
dd = sv_newmortal ();
err[2] = dup (2);
close (2);
if (dup (err[1]) == 2)
sv_dump (sv);
close (err[1]);
close (2);
err[1] = dup (err[2]);
close (err[2]);
sv_setpvn (dd, "", 0);
while ((n = read (err[0], buf, 128)) > 0)
sv_catpvn_flags (dd, buf, n, SV_GMAGIC);
return (dd);
} /* _DDump */
SV *_DPeek (pTHX_ int items, SV *sv)
{
#ifdef NO_SV_PEEK
return newSVpv ("Your perl did not export Perl_sv_peek ()", 0);
#else
return newSVpv (sv_peek (items ? sv : DEFSV), 0);
#endif
} /* _DPeek */
void _Dump_Dual (pTHX_ SV *sv, SV *pv, SV *iv, SV *nv, SV *rv)
{
#ifndef NO_SV_PEEK
warn ("%s\n PV: %s\n IV: %s\n NV: %s\n RV: %s\n",
sv_peek (sv), sv_peek (pv), sv_peek (iv), sv_peek (nv), sv_peek (rv));
#endif
} /* _Dump_Dual */
MODULE = Data::Peek PACKAGE = Data::Peek
void
DPeek (...)
PROTOTYPE: ;$
PPCODE:
I32 gimme = GIMME_V;
SV *sv = items ? ST (0) : DEFSV;
if (items == 0) EXTEND (SP, 1);
ST (0) = _DPeek (aTHX_ items, sv);
if (gimme == G_VOID) warn ("%s\n", SvPVX (ST (0)));
XSRETURN (1);
/* XS DPeek */
void
DDisplay (...)
PROTOTYPE: ;$
PPCODE:
I32 gimme = GIMME_V;
SV *sv = items ? ST (0) : DEFSV;
SV *dsp = newSVpv ("", 0);
if (SvPOK (sv) || SvPOKp (sv))
pv_pretty (dsp, SvPVX (sv), SvCUR (sv), 0,
NULL, NULL,
(PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_UNI_DETECT));
if (items == 0) EXTEND (SP, 1);
ST (0) = dsp;
if (gimme == G_VOID) warn ("%s\n", SvPVX (ST (0)));
XSRETURN (1);
/* XS DDisplay */
void
triplevar (pv, iv, nv)
SV *pv
SV *iv
SV *nv
PROTOTYPE: $$$
PPCODE:
SV *tv = newSVpvs ("");
SvUPGRADE (tv, SVt_PVNV);
if (SvPOK (pv) || SvPOKp (pv)) {
sv_setpvn (tv, SvPVX (pv), SvCUR (pv));
if (SvUTF8 (pv)) SvUTF8_on (tv);
}
else
sv_setpvn (tv, NULL, 0);
if (SvNOK (nv) || SvNOKp (nv)) {
SvNV_set (tv, SvNV (nv));
SvNOK_on (tv);
}
if (SvIOK (iv) || SvIOKp (iv)) {
SvIV_set (tv, SvIV (iv));
SvIOK_on (tv);
}
ST (0) = tv;
XSRETURN (1);
/* XS triplevar */
void
DDual (sv, ...)
SV *sv
PROTOTYPE: $;$
PPCODE:
I32 gimme = GIMME_V;
if (items > 1 && SvGMAGICAL (sv) && SvTRUE (ST (1)))
mg_get (sv);
EXTEND (SP, 5);
if (SvPOK (sv) || SvPOKp (sv)) {
SV *xv = newSVpv (SvPVX (sv), 0);
if (SvUTF8 (sv)) SvUTF8_on (xv);
mPUSHs (xv);
}
else
PUSHs (&PL_sv_undef);
if (SvIOK (sv) || SvIOKp (sv))
mPUSHi (SvIV (sv));
else
PUSHs (&PL_sv_undef);
if (SvNOK (sv) || SvNOKp (sv))
mPUSHn (SvNV (sv));
else
PUSHs (&PL_sv_undef);
if (SvROK (sv)) {
SV *xv = newSVsv (SvRV (sv));
mPUSHs (xv);
}
else
PUSHs (&PL_sv_undef);
mPUSHi (SvMAGICAL (sv) >> 21);
if (gimme == G_VOID) _Dump_Dual (aTHX_ sv, ST (0), ST (1), ST (2), ST (3));
/* XS DDual */
void
DGrow (sv, size)
SV *sv
IV size
PROTOTYPE: $$
PPCODE:
if (SvROK (sv))
sv = SvRV (sv);
if (!SvPOK (sv))
sv_setpvn (sv, "", 0);
SvGROW (sv, size);
EXTEND (SP, 1);
mPUSHi (SvLEN (sv));
/* XS DGrow */
void
DDump_XS (sv)
SV *sv
PROTOTYPE: $
PPCODE:
SV *dd = _DDump (aTHX_ sv);
if (dd) {
ST (0) = dd;
XSRETURN (1);
}
XSRETURN (0);
/* XS DDump */
void
DDump_IO (io, sv, level)
PerlIO *io
SV *sv
IV level
PPCODE:
do_sv_dump (0, io, sv, 1, level, 1, 0);
XSRETURN (1);
/* XS DDump */
Data-Peek-0.53/examples/0000755000031300001440000000000014736724470014265 5ustar00merijnusersData-Peek-0.53/examples/ddumper.pl0000644000031300001440000000116214027400241016236 0ustar00merijnusers#!/pro/bin/perl
use strict;
use warnings;
use Data::Peek;
my %hash = (
foo => "bar\x{0a}baz",
bar => [ 1, "mars", \@ARGV ],
);
print DPeek for DDual ($!, 1);
print "DDumper (\\%hash)\n";
print DDumper \%hash;
print "\$str = DDump (%hash)\n";
my $str = DDump \%hash;
print $str;
print "\%hsh = DDump (%hash)\n";
my %hsh = DDump \%hash;
print DDumper \%hsh;
print "DDump \\%hash\n";
DDump \%hash;
print "\$str = DDump (%hash, 5)\n";
my $str = DDump (\%hash, 1);
print $str;
print "\%hsh = DDump (%hash, 5)\n";
my %hsh = DDump (\%hash, 1);
print DDumper \%hsh;
print "DDump \\%hash, 5\n";
DDump (\%hash, 1);
Data-Peek-0.53/CONTRIBUTING.md0000644000031300001440000000202414027400241014652 0ustar00merijnusers# General
I am always open to improvements and suggestions.
Use [issues](https://github.com/Tux/Data-Peek/issues)
# Style
I will never accept pull request that do not strictly conform to my
style, however you might hate it. You can read the reasoning behind
my [preferences](http://tux.nl/style.html).
I really do not care about mixed spaces and tabs in (leading) whitespace
Perl::Tidy will help getting the code in shape, but as all software, it
is not perfect. You can find my preferences for these in
[.perltidy](https://github.com/Tux/Release-Checklist/blob/master/.perltidyrc) and
[.perlcritic](https://github.com/Tux/Release-Checklist/blob/master/.perlcriticrc).
# Mail
Please, please, please, do *NOT* use HTML mail.
[Plain text](https://useplaintext.email)
[without](http://www.goldmark.org/jeff/stupid-disclaimers/)
[disclaimers](https://www.economist.com/business/2011/04/07/spare-us-the-e-mail-yada-yada)
will do fine!
# Requirements
The minimum version required to use this module is stated in
[Makefile.PL](./Makefile.PL)
Data-Peek-0.53/Makefile.PL0000644000031300001440000000776714736724436014444 0ustar00merijnusers#!/usr/bin/perl
# Copyright PROCURA B.V. (c) 2008-2025 H.Merijn Brand
require 5.008001; # <- also see postamble at the bottom for META.yml
use strict;
if ($ENV{PERLBREW_HOME} and $ENV{PERLBREW_HOME} eq "/home/njh/.perlbrew") {
warn "Your smokers have been blocked because of consistent failures that\n";
warn " are all caused by the smoking setup and not by module errors. I you\n";
warn " have fixed that all, please inform the authors, so this block can\n";
warn " be lifted again.\n";
exit 0;
}
use ExtUtils::MakeMaker;
my %wm = (
NAME => "Data::Peek",
DISTNAME => "Data-Peek",
ABSTRACT => "Extended/Modified debugging utilities",
AUTHOR => "H.Merijn Brand ",
VERSION_FROM => "Peek.pm",
PREREQ_PM => { "XSLoader" => 0,
"Data::Dumper" => 0,
"Test::More" => 0.90,
"Test::Warnings" => 0,
},
clean => { FILES => join " ", qw(
Peek.c.gcov
Peek.gcda
Peek.gcno
Peek.xs.gcov
cover_db
valgrind.log
)
},
macro => { TARFLAGS => "--format=ustar -c -v -f",
},
);
$ExtUtils::MakeMaker::VERSION > 6.30 and $wm{LICENSE} = "perl";
unless (exists $ENV{AUTOMATED_TESTING} and $ENV{AUTOMATED_TESTING} == 1) {
my $dp_ok = 1;
eval {
require DP;
$dp_ok = 0;
if ($INC{"DP.pm"} and open my $fh, "<", $INC{"DP.pm"}) {
my $line1 = <$fh>;
$line1 =~ m/^use Data::Peek;/ and $dp_ok = 1;
close $fh;
}
};
if ($dp_ok and prompt ("Do you want to install module DP as a shortcut for Data::Peek ?", "y") =~ m/[yY]/) {
local $/;
open my $pm, "<", "Peek.pm" or die "Cannot read Peek.pm: $!\n";
my $vsn = do { <$pm> =~ m/^\$VERSION\s*=\s*"([0-9._]+)/m; $1 };
close $pm;
(my $dp = ) =~ s/::VERSION::/"$vsn"/;
open my $fh, ">", "DP.pm" or die "Cannot open DP.pm: $!\n";
print $fh $dp;
close $fh;
$wm{PM} = {
"Peek.pm" => '$(INST_LIB)/Data/Peek.pm',
"DP.pm" => '$(INST_LIB)/DP.pm',
};
$wm{clean}{FILES} .= " DP.pm";
}
}
$ENV{NO_SV_PEEK} and $wm{DEFINE} = "-DNO_SV_PEEK";
my $rv = WriteMakefile (%wm);
1;
package MY;
sub postamble {
my $valgrind = join " ", qw(
PERL_DESTRUCT_LEVEL=2 PERL_DL_NONLAZY=1
valgrind
--suppressions=sandbox/perl.supp
--leak-check=yes
--leak-resolution=high
--show-reachable=yes
--num-callers=50
--log-fd=3
$(FULLPERLRUN) "-MExtUtils::Command::MM" "-e"
"test_harness($(TEST_VERBOSE), '$(INST_LIB)', '$(INST_ARCHLIB)')"
$(TEST_FILES) 3>valgrind.log
);
my $min_vsn = ($] >= 5.010 && -d "xt" && ($ENV{AUTOMATED_TESTING} || 0) != 1)
? join "\n" =>
'test ::',
' -@env TEST_FILES="xt/*.t" make -e test_dynamic',
''
: "";
join "\n" =>
'cover test_cover:',
' ccache -C',
' cover -test',
'',
'leakcheck:',
" $valgrind",
' -@tail -5 valgrind.log',
'',
'leaktest:',
q{ sandbox/leaktest $(FULLPERLRUN) "test_harness($(TEST_VERBOSE), '$(INST_LIB)', '$(INST_ARCHLIB)')" $(TEST_FILES)},
'',
'spellcheck:',
' pod-spell-check --aspell --ispell',
'',
'checkmeta: spellcheck',
' perl sandbox/genPPPort_h.pl',
' perl sandbox/genMETA.pl -c',
'',
'fixmeta: distmeta',
' perl sandbox/genMETA.pl',
'',
'tgzdist: doc checkmeta fixmeta $(DISTVNAME).tar.gz distcheck',
' -@mv -f $(DISTVNAME).tar.gz $(DISTVNAME).tgz',
' -@cpants_lint.pl $(DISTVNAME).tgz',
' -@rm -f Debian_CPANTS.txt',
'',
'doc docs: doc/Peek.md doc/Peek.html doc/Peek.3 doc/Peek.man',
'doc/Peek.md: Peek.pm',
' perl doc/make-doc.pl',
'',
$min_vsn;
} # postamble
__END__
use Data::Peek;
use strict;
use warnings;
BEGIN { *DP:: = \%Data::Peek:: }
our $VERSION = ::VERSION::;
1;
=head1 NAME
DP - Alias for Data::Peek
=head1 SYNOPSIS
perl -MDP -wle'print DPeek for DDual ($?, 1)'
=head1 DESCRIPTION
See L.
=head1 AUTHOR
H.Merijn Brand
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2008-2025 H.Merijn Brand
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut
Data-Peek-0.53/Peek.pm0000644000031300001440000004677414736724067013715 0ustar00merijnuserspackage Data::Peek;
use strict;
use warnings;
use XSLoader;
use vars qw( $VERSION @ISA @EXPORT @EXPORT_OK );
$VERSION = "0.53";
@ISA = qw( Exporter );
@EXPORT = qw( DDumper DTidy DDsort DPeek DDisplay DDump DHexDump
DDual DGrow );
@EXPORT_OK = qw( triplevar :tidy );
push @EXPORT, "DDump_IO";
XSLoader::load ("Data::Peek", $VERSION);
our $has_perlio;
our $has_perltidy;
BEGIN {
use Config;
$has_perlio = ($Config{'useperlio'} || "undef") eq "define";
$has_perltidy = eval { require Perl::Tidy; $Perl::Tidy::VERSION };
}
### ############# DDumper () ##################################################
use Data::Dumper;
my %sk = (
undef => 0,
"" => 0,
0 => 0,
1 => 1,
'R' => sub { # Sort reverse
my $r = shift;
[ reverse sort keys %{$r} ];
},
'N' => sub { # Sort by key numerical
my $r = shift;
[ sort { $a <=> $b } keys %{$r} ];
},
'NR' => sub { # Sort by key numerical reverse
my $r = shift;
[ sort { $b <=> $a } keys %{$r} ];
},
'V' => sub { # Sort by value
my $r = shift;
[ sort { $r->{$a} cmp $r->{$b} } keys %{$r} ];
},
'VN' => sub { # Sort by value numeric
my $r = shift;
[ sort { $r->{$a} <=> $r->{$b} } keys %{$r} ];
},
'VNR' => sub { # Sort by value numeric reverse
my $r = shift;
[ sort { $r->{$b} <=> $r->{$a} } keys %{$r} ];
},
'VR' => sub { # Sort by value reverse
my $r = shift;
[ sort { $r->{$b} cmp $r->{$a} } keys %{$r} ];
},
);
my $_sortkeys = 1;
our $_perltidy = 0;
my %pmap = map {( $_ => $_ )} map {( split //, $_ )}
q{ !""#$%&'()*+,-./0123456789:;<=>},
q{@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^},
q{`abcdefghijklmnopqrstuvwxyz|~}, "{}";
$pmap{$_} = "." for grep { !exists $pmap{$_} } map { chr } 0 .. 255;
sub DDsort {
@_ or return;
$_sortkeys = exists $sk{$_[0]} ? $sk{$_[0]} : $_[0];
} # DDsort
sub import {
my @exp = @_;
my @etl;
foreach my $p (@exp) {
exists $sk{$p} and DDsort ($p), next;
if ($p eq ":tidy") {
$_perltidy = $has_perltidy;
next;
}
push @etl, $p;
}
__PACKAGE__->export_to_level (1, @etl);
} # import
sub DDumper {
$_perltidy and goto \&DTidy;
local $Data::Dumper::Sortkeys = $_sortkeys;
local $Data::Dumper::Indent = 1;
local $Data::Dumper::Quotekeys = 0;
local $Data::Dumper::Deparse = 1;
local $Data::Dumper::Terse = 1;
local $Data::Dumper::Purity = 1;
local $Data::Dumper::Useqq = 0; # I want unicode visible
my $s = Data::Dumper::Dumper (@_);
$s =~ s/^(\s*)(.*?)\s*=>/sprintf "%s%-16s =>", $1, $2/gme; # Align =>
$s =~ s/\bbless\s*\(\s*/bless (/gm and $s =~ s/\s+\)([;,])$/)$1/gm;
$s =~ s/^(?=\s*[]}](?:[;,]|$))/ /gm;
$s =~ s/^(\s*[{[]) *\n *(?=\S)(?![{[])/$1 /gm;
$s =~ s/^(\s+)/$1$1/gm;
defined wantarray or warn $s;
return $s;
} # DDumper
sub DTidy {
$has_perltidy or goto \&DDumper;
local $Data::Dumper::Sortkeys = $_sortkeys;
local $Data::Dumper::Indent = 1;
local $Data::Dumper::Quotekeys = 1;
local $Data::Dumper::Deparse = 1;
local $Data::Dumper::Terse = 1;
local $Data::Dumper::Purity = 1;
local $Data::Dumper::Useqq = 0;
my $s = Data::Dumper::Dumper (@_);
my $t;
my @opts = (
# Disable stupid options in ~/.perltidyrc
# people do so, even for root
"--no-backup-and-modify-in-place",
"--no-check-syntax",
"--no-standard-output",
"--no-warning-output",
);
# RT#99514 - Perl::Tidy memoizes .perltidyrc incorrectly
$has_perltidy > 20120714 and push @opts => "--no-memoize";
Perl::Tidy::perltidy ('source' => \$s, 'destination' => \$t, 'argv' => \@opts);
$s = $t;
defined wantarray or warn $s;
return $s;
} # DTidy
### ############# DDump () ####################################################
sub _DDump_ref {
my (undef, $down) = (@_, 0);
my $ref = ref $_[0];
if ($ref eq "SCALAR" || $ref eq "REF") {
my %hash = DDump (${$_[0]}, $down);
return { %hash };
}
if ($ref eq "ARRAY") {
my @list;
foreach my $list (@{$_[0]}) {
my %hash = DDump ($list, $down);
push @list, { %hash };
}
return [ @list ];
}
if ($ref eq "HASH") {
my %hash;
foreach my $key (sort keys %{$_[0]}) {
$hash{DPeek ($key)} = { DDump ($_[0]->{$key}, $down) };
}
return { %hash };
}
undef;
} # _DDump_ref
sub _DDump {
my (undef, $down, $dump, $fh) = (@_, "");
if ($has_perlio and open $fh, ">", \$dump) {
#print STDERR "Using DDump_IO\n";
DDump_IO ($fh, $_[0], $down);
close $fh;
}
else {
#print STDERR "Using DDump_XS\n";
$dump = DDump_XS ($_[0]);
}
return $dump;
} # _DDump
sub DDump {
my $down = @_ > 1 ? $_[1] : 0;
my @dump = split m/[\r\n]+/, _DDump (@_ ? $_[0] : $_, wantarray || $down) or return;
if (wantarray) {
my %hash;
($hash{'sv'} = $dump[0]) =~ s/^SV\s*=\s*//;
m/^\s+(\w+)\s*=\s*(.*)/ and $hash{$1} = $2 for @dump;
if (exists $hash{'FLAGS'}) {
$hash{'FLAGS'} =~ tr/()//d;
$hash{'FLAGS'} = { map {( $_ => 1 )} split m/,/ => $hash{'FLAGS'} };
}
$down && ref $_[0] and
$hash{'RV'} = _DDump_ref ($_[0], $down - 1) || $_[0];
return %hash;
}
my $dump = join "\n", @dump, "";
defined wantarray and return $dump;
warn $dump;
} # DDump
sub DHexDump {
use bytes;
my $off = 0;
my @out;
my $var = @_ ? $_[0] : $_;
defined $var or return;
my $fmt = @_ > 1 && $_[1] < length ($var) ? "A$_[1]" : "A*";
my $str = pack $fmt, $var; # force stringification
for (unpack "(A32)*", unpack "H*", $str) {
my @b = unpack "(A2)*", $_;
my $out = sprintf "%04x ", $off;
$out .= " ".($b[$_]||" ") for 0 .. 7;
$out .= " ";
$out .= " ".($b[$_]||" ") for 8 .. 15;
$out .= " ";
$out .= $pmap{$_} for map { chr hex $_ } @b;
push @out, $out."\n";
$off += 16;
}
wantarray and return @out;
defined wantarray and return join "", @out;
warn join "", @out;
} # DHexDump
"Indent";
__END__
=head1 NAME
Data::Peek - A collection of low-level debug facilities
=head1 SYNOPSIS
use Data::Peek;
print DDumper \%hash; # Same syntax as Data::Dumper
DTidy { ref => $ref };
print DPeek \$var;
my ($pv, $iv, $nv, $rv, $magic) = DDual ($var [, 1]);
print DPeek for DDual ($!, 1);
print DDisplay ("ab\nc\x{20ac}\rdef\n");
print DHexDump ("ab\nc\x{20ac}\rdef\n");
my $dump = DDump $var;
my %hash = DDump \@list;
DDump \%hash;
my %hash = DDump (\%hash, 5); # dig 5 levels deep
my $dump;
open my $fh, ">", \$dump;
DDump_IO ($fh, \%hash, 6);
close $fh;
print $dump;
# Imports
use Data::Peek qw( :tidy VNR DGrow triplevar );
my $x = ""; DGrow ($x, 10000);
my $tv = triplevar ("\N{GREEK SMALL LETTER PI}", 3, "3.1415");
DDsort ("R");
DDumper [ $x ]; # use of :tidy makes DDumper behave like DTidy
=head1 DESCRIPTION
Data::Peek started off as C being a wrapper module over
L, but grew out to be a set of low-level data
introspection utilities that no other module provided yet, using the
lowest level of the perl internals API as possible.
=head2 DDumper ($var, ...)
Not liking the default output of Data::Dumper, and always feeling the need
to set C<$Data::Dumper::Sortkeys = 1;>, and not liking any of the default
layouts, this function is just a wrapper around Data::Dumper::Dumper with
everything set as I like it.
$Data::Dumper::Sortkeys = 1;
$Data::Dumper::Indent = 1;
If C is C