├── typemap ├── sandbox ├── perl.supp ├── leaktest ├── test-dd.pl ├── ebcdic.pl ├── genout.pl ├── genPPPort_h.pl ├── genMETA.pl ├── used-by.pl └── genMETA.pm ├── t ├── 10_DDumper.t ├── 11_DDumper.t ├── 00_pod.t ├── 31_DDump-s.t ├── 40_DDump-h.t ├── 41_DDump-h.t ├── 01_pod.t ├── 51_triplevar.t ├── 21_DDisplay.t ├── 52_DGrow.t ├── 12_DDsort.t ├── 22_DHexDump.t ├── 50_DDual.t ├── 20_DPeek.t └── 30_DDump-s.t ├── .whitesource ├── .aspell.local.pws ├── xt ├── 50_manifest.t ├── 10_perm.t ├── 02_pod.t ├── 00_perlversion.t └── 20_kwalitee.t ├── .gitignore ├── MANIFEST.SKIP ├── doc ├── DP.md ├── DP.man ├── DP.html ├── DP.3 ├── make-doc.pl ├── Data-Peek.md ├── Data-Peek.man ├── Data-Peek.html └── Data-Peek.3 ├── .travis.yml ├── cpanfile ├── examples └── ddumper.pl ├── CONTRIBUTING.md ├── MANIFEST ├── README ├── SECURITY.md ├── Makefile.PL ├── Peek.xs ├── ChangeLog └── Peek.pm /typemap: -------------------------------------------------------------------------------- 1 | PerlIO * T_INOUT 2 | -------------------------------------------------------------------------------- /sandbox/perl.supp: -------------------------------------------------------------------------------- 1 | /pro/3gl/CPAN/perl/t/perl.supp -------------------------------------------------------------------------------- /t/10_DDumper.t: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tux/Data-Peek/master/t/10_DDumper.t -------------------------------------------------------------------------------- /t/11_DDumper.t: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tux/Data-Peek/master/t/11_DDumper.t -------------------------------------------------------------------------------- /.whitesource: -------------------------------------------------------------------------------- 1 | { 2 | "generalSettings": { 3 | "shouldScanRepo": true 4 | }, 5 | "checkRunSettings": { 6 | "vulnerableCheckRunConclusionLevel": "failure" 7 | } 8 | } 9 | -------------------------------------------------------------------------------- /t/00_pod.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | $^W = 1; 5 | 6 | use Test::More; 7 | 8 | eval "use Test::Pod 1.00"; 9 | plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; 10 | all_pod_files_ok (); 11 | -------------------------------------------------------------------------------- /.aspell.local.pws: -------------------------------------------------------------------------------- 1 | personal_ws-1.1 en 20 2 | AIX 3 | API 4 | DDisplay 5 | DDsort 6 | DDual 7 | DDump 8 | DDumper 9 | DGrow 10 | DHexDump 11 | DPeek 12 | DTidy 13 | proven 14 | PV 15 | STDERR 16 | SV 17 | triplevar 18 | UTF 19 | VN 20 | VNR 21 | VR 22 | -------------------------------------------------------------------------------- /xt/50_manifest.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | 7 | eval "use Test::DistManifest"; 8 | plan skip_all => "Test::DistManifest required for testing MANIFEST" if $@; 9 | manifest_ok (); 10 | done_testing; 11 | -------------------------------------------------------------------------------- /t/31_DDump-s.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Warnings; 8 | 9 | use Data::Peek; 10 | 11 | ok (1, "Here com tests for DDump () returning string using IO"); 12 | 13 | done_testing; 14 | 15 | 1; 16 | -------------------------------------------------------------------------------- /t/40_DDump-h.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Warnings; 8 | 9 | use Data::Peek; 10 | 11 | ok (1, "Here com tests for DDump () returning hash using XS"); 12 | 13 | done_testing; 14 | 15 | 1; 16 | -------------------------------------------------------------------------------- /t/41_DDump-h.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Warnings; 8 | 9 | use Data::Peek; 10 | 11 | ok (1, "Here com tests for DDump () returning hash using IO"); 12 | 13 | done_testing; 14 | 15 | 1; 16 | -------------------------------------------------------------------------------- /xt/10_perm.t: -------------------------------------------------------------------------------- 1 | eval "use Test::PAUSE::Permissions"; 2 | 3 | if ($@ || $] < 5.018) { 4 | print "1..0 # No perl permission check for old releases\n"; 5 | exit 0; 6 | } 7 | 8 | BEGIN { $ENV{RELEASE_TESTING} = 1; } 9 | 10 | all_permissions_ok ("HMBRAND"); 11 | -------------------------------------------------------------------------------- /sandbox/leaktest: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | PERL=$1 4 | HRNS=$2 5 | shift ; shift 6 | 7 | export PERL_DL_NONLAZY=1 8 | export PERL_DESTRUCT_LEVEL=2 9 | 10 | for t in $@ ; do 11 | echo $PERL $t 12 | $PERL -MExtUtils::Command::MM -e "$HRNS" -MTest::Valgrind $t 13 | done 14 | -------------------------------------------------------------------------------- /t/01_pod.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | $^W = 1; 5 | 6 | use Test::More; 7 | 8 | eval "use Test::Pod::Coverage tests => 1"; 9 | plan skip_all => "Test::Pod::Covarage required for testing POD Coverage" if $@; 10 | pod_coverage_ok ("Data::Peek", "Data::Peek is covered"); 11 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | blib 2 | cover_db 3 | Makefile 4 | META.json 5 | META.yml 6 | MYMETA.json 7 | MYMETA.yml 8 | pm_to_blib 9 | *.tar.gz 10 | *.tgz 11 | *.old 12 | *.o 13 | *.c 14 | *.bs 15 | *.gcov 16 | *.gcda 17 | *.gcno 18 | *.tmp 19 | Data-Peek-* 20 | DP.pm 21 | xx* 22 | .releaserc 23 | valgrind.log 24 | tmp/* 25 | sandbox/test.sh 26 | -------------------------------------------------------------------------------- /xt/02_pod.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use Test::More; 4 | 5 | eval "use Test::Pod::Links"; 6 | plan skip_all => "Test::Pod::Links required for testing POD Links" if $@; 7 | eval { 8 | no warnings "redefine"; 9 | no warnings "once"; 10 | *Test::XTFiles::all_files = sub { sort glob "*.pm"; }; 11 | }; 12 | Test::Pod::Links->new->all_pod_files_ok; 13 | -------------------------------------------------------------------------------- /MANIFEST.SKIP: -------------------------------------------------------------------------------- 1 | \.[oc]$ 2 | \.bs$ 3 | \.tgz$ 4 | \.tar\.gz$ 5 | \.git 6 | \.gcov$ 7 | \.gcda$ 8 | \.gcno$ 9 | \.tmp$ 10 | \.travis.yml 11 | \.whitesource 12 | blib/ 13 | cover_db/ 14 | DP\.pm$ 15 | Makefile$ 16 | MANIFEST\.SKIP 17 | MYMETA\. 18 | pm_to_blib 19 | sandbox/ 20 | tmp/ 21 | \.releaserc 22 | ^xx 23 | valgrind.log 24 | \.aspell\.local\.pws 25 | t/02_load.t 26 | xt/ 27 | doc/ 28 | -------------------------------------------------------------------------------- /doc/DP.md: -------------------------------------------------------------------------------- 1 | # NAME 2 | 3 | DP - Alias for Data::Peek 4 | 5 | # SYNOPSIS 6 | 7 | perl -MDP -wle'print DPeek for DDual ($?, 1)' 8 | 9 | # DESCRIPTION 10 | 11 | See [Data::Peek](https://metacpan.org/pod/Data%3A%3APeek). 12 | 13 | # AUTHOR 14 | 15 | H.Merijn Brand 16 | 17 | # COPYRIGHT AND LICENSE 18 | 19 | Copyright (C) 2008-2025 H.Merijn Brand 20 | 21 | This library is free software; you can redistribute it and/or modify it 22 | under the same terms as Perl itself. 23 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: perl 2 | os: 3 | - linux 4 | dist: trusty 5 | perl: 6 | - "5.30" 7 | - "5.28" 8 | - "5.26" 9 | - "5.26-shrplib" 10 | - "5.24" 11 | - "5.22" 12 | - "5.20" 13 | - "5.18" 14 | - "5.16" 15 | - "5.14" 16 | - "5.12" 17 | - "5.10" 18 | - "5.8" 19 | env: 20 | global: 21 | - AUTOMATED_TESTING=1 22 | install: 23 | - cpanm --quiet --installdeps --with-all-features --notest . || true 24 | notifications: 25 | irc: 26 | channels: 27 | - "irc.perl.org#csv" 28 | on_success: always 29 | on_failure: always 30 | -------------------------------------------------------------------------------- /cpanfile: -------------------------------------------------------------------------------- 1 | requires "Data::Dumper"; 2 | requires "XSLoader"; 3 | 4 | recommends "Data::Dumper" => "2.189"; 5 | recommends "Perl::Tidy"; 6 | 7 | on "configure" => sub { 8 | requires "ExtUtils::MakeMaker"; 9 | 10 | recommends "ExtUtils::MakeMaker" => "7.22"; 11 | 12 | suggests "ExtUtils::MakeMaker" => "7.72"; 13 | }; 14 | 15 | on "test" => sub { 16 | requires "Test::More" => "0.90"; 17 | requires "Test::Warnings"; 18 | 19 | recommends "Test::More" => "1.302209"; 20 | }; 21 | -------------------------------------------------------------------------------- /xt/00_perlversion.t: -------------------------------------------------------------------------------- 1 | #!/pro/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | eval "use Test::More 0.93"; 7 | if ($@ || $] < 5.010) { 8 | print "1..0 # perl-5.10.0 + Test::More 0.93 required for version checks\n"; 9 | exit 0; 10 | } 11 | eval "use Test::MinimumVersion"; 12 | if ($@) { 13 | print "1..0 # Test::MinimumVersion required for compatability tests\n"; 14 | exit 0; 15 | } 16 | 17 | 18 | all_minimum_version_ok ("5.008.001", { paths => [ 19 | glob ("t/*"), glob ("xt/*"), glob ("*.pm"), glob ("*.PL"), 20 | ]}); 21 | 22 | done_testing (); 23 | -------------------------------------------------------------------------------- /t/51_triplevar.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Warnings; 8 | 9 | use Data::Peek qw( DDual DPeek triplevar ); 10 | 11 | foreach my $iv (undef, 3 ) { 12 | foreach my $nv (undef, 3.1415) { 13 | foreach my $pv (undef, "\x{03c0}") { 14 | my $tv = triplevar ($pv, $iv, $nv); 15 | ok (my @tv = DDual ($tv), "Get tv"); 16 | is ($tv[0], $pv, "Check pv"); 17 | is ($tv[1], $iv, "Check iv"); 18 | is ($tv[2], $nv, "Check nv"); 19 | } 20 | } 21 | } 22 | 23 | done_testing; 24 | 25 | 1; 26 | -------------------------------------------------------------------------------- /doc/DP.man: -------------------------------------------------------------------------------- 1 | DP(3) User Contributed Perl Documentation DP(3) 2 | 3 | NAME 4 | DP - Alias for Data::Peek 5 | 6 | SYNOPSIS 7 | perl -MDP -wle'print DPeek for DDual ($?, 1)' 8 | 9 | DESCRIPTION 10 | See Data::Peek. 11 | 12 | AUTHOR 13 | H.Merijn Brand 14 | 15 | COPYRIGHT AND LICENSE 16 | Copyright (C) 2008-2025 H.Merijn Brand 17 | 18 | This library is free software; you can redistribute it and/or modify it 19 | under the same terms as Perl itself. 20 | 21 | perl v5.40.1 2025-03-17 DP(3) 22 | -------------------------------------------------------------------------------- /t/21_DDisplay.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Warnings; 8 | 9 | use Data::Peek; 10 | 11 | is (DDisplay (undef), '', 'undef has no PV'); 12 | is (DDisplay (0), '', '0 has no PV'); 13 | is (DDisplay (\undef), '', '\undef has no PV'); 14 | is (DDisplay (\0), '', '\0 has no PV'); 15 | is (DDisplay (sub {}), '', 'code has no PV'); 16 | 17 | is (DDisplay (""), '""', 'empty string'); 18 | is (DDisplay ("a"), '"a"', '"a"'); 19 | is (DDisplay ("\n"), '"\n"', '"\n"'); 20 | is (DDisplay ("\x{20ac}"), '"\x{20ac}"', '"\n"'); 21 | 22 | done_testing; 23 | 24 | 1; 25 | -------------------------------------------------------------------------------- /sandbox/test-dd.pl: -------------------------------------------------------------------------------- 1 | #!/pro/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Data::Dumper; 7 | 8 | sub DDumper 9 | { 10 | my ($f, @a) = @_; 11 | 12 | # $Data::Dumper::Sortkeys = $_sortkeys; 13 | $Data::Dumper::Indent = $f & 0x01; 14 | $Data::Dumper::Quotekeys = $f & 0x02; 15 | # $Data::Dumper::Deparse = $f & 0x04; 16 | $Data::Dumper::Terse = $f & 0x08; 17 | # $Data::Dumper::Useqq = $f & 0x10; 18 | 19 | printf "0x%02x\n", $f; 20 | my $s = Data::Dumper::Dumper @_; 21 | return $s; 22 | } # DDumper 23 | 24 | my %hash = ( 25 | SV => 1, 26 | GLB => *STDERR, 27 | IO => *{$::{STDERR}}{IO}, 28 | FMT => *{$::{STDOUT}}{FORMAT}, 29 | ); 30 | 31 | DDumper $_, \%hash for 0 .. 0x1f; 32 | -------------------------------------------------------------------------------- /examples/ddumper.pl: -------------------------------------------------------------------------------- 1 | #!/pro/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Data::Peek; 7 | 8 | my %hash = ( 9 | foo => "bar\x{0a}baz", 10 | bar => [ 1, "mars", \@ARGV ], 11 | ); 12 | 13 | print DPeek for DDual ($!, 1); 14 | 15 | print "DDumper (\\%hash)\n"; 16 | print DDumper \%hash; 17 | 18 | print "\$str = DDump (%hash)\n"; 19 | my $str = DDump \%hash; 20 | print $str; 21 | print "\%hsh = DDump (%hash)\n"; 22 | my %hsh = DDump \%hash; 23 | print DDumper \%hsh; 24 | 25 | print "DDump \\%hash\n"; 26 | DDump \%hash; 27 | 28 | print "\$str = DDump (%hash, 5)\n"; 29 | my $str = DDump (\%hash, 1); 30 | print $str; 31 | print "\%hsh = DDump (%hash, 5)\n"; 32 | my %hsh = DDump (\%hash, 1); 33 | print DDumper \%hsh; 34 | 35 | print "DDump \\%hash, 5\n"; 36 | DDump (\%hash, 1); 37 | -------------------------------------------------------------------------------- /sandbox/ebcdic.pl: -------------------------------------------------------------------------------- 1 | #!/pro/bin/perl 2 | 3 | use 5.18.2; 4 | use warnings; 5 | 6 | use Data::Peek; 7 | use Encode qw( from_to ); 8 | 9 | # In EBCDIC 1047, only these bytes map to the same character as in ASCII: 10 | # \x00..\x03, \x0b..\x13, \x18, \x19, \x1c..\x1f, \xb6 11 | my $ascii = pack "C*" => 0..255; 12 | 13 | DHexDump $ascii; 14 | 15 | my $ebcdic = $ascii; 16 | from_to ($ebcdic, "latin1", "cp1047"); 17 | 18 | DHexDump $ebcdic; 19 | 20 | my @ascii = unpack "C*" => $ascii; 21 | my @ebcdic = unpack "C*" => $ebcdic; 22 | 23 | for (0..255) { 24 | my $ba = $ascii[$_]; 25 | my $be = $ebcdic[$_]; 26 | my $ca = chr $ba; 27 | my $ce = chr $be; 28 | my $pa = $ba >= 0x20 && $ba < 0x7F ? $ca : "."; 29 | my $pe = $be >= 0x20 && $be < 0x7F ? $ce : "."; 30 | printf "%3d %02x %03o %s -> %s %02x %03o %s\n", 31 | $_, $_, $_, $pa, $pe, $be, $be, $ba == $be ? "==" : ""; 32 | } 33 | -------------------------------------------------------------------------------- /sandbox/genout.pl: -------------------------------------------------------------------------------- 1 | #!/pro/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | BEGIN { unshift @INC, qw( blib/lib blib/arch ) } 7 | 8 | use Data::Peek; 9 | use Data::Dumper; 10 | $Data::Dumper::Sortkeys = 1; 11 | $Data::Dumper::Indent = 1; 12 | 13 | my ($use_perlio, $dump_hash) = (@ARGV, 0, 0); 14 | $dump_hash or $Data::Peek::has_perlio = $Data::Peek::has_perlio = $use_perlio; 15 | 16 | my $var = ""; 17 | foreach my $ref ("", "\\") { 18 | foreach my $in ( 19 | 'undef', 0, 1, 20 | '""', '"\xa8"', '"ab\x0a\x{20ac}"', 21 | ) { 22 | eval "\$var = $ref$in;"; 23 | my $dump; 24 | if ($dump_hash) { 25 | my %hash = DDump ($var); 26 | $dump = Dumper (\%hash); 27 | } 28 | else { 29 | $dump = DDump ($var); 30 | } 31 | $dump =~ s/\b0x[0-9a-f]+\b/0x****/g; 32 | $dump =~ s/\bab(\\n|\\12|n)/ab\\n/g; 33 | $dump =~ s/\b(REFCNT'?\s+=>?\s*) ('?)[0-9]{4,}\2/$1 $2-1$2/g; 34 | print "$ref$in\n--\n$dump==\n"; 35 | } 36 | } 37 | -------------------------------------------------------------------------------- /t/52_DGrow.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Warnings; 8 | 9 | use Data::Peek qw( DGrow DDump ); 10 | 11 | my $x = ""; 12 | is (length ($x), 0, "Initial length = 0"); 13 | my %dd = DDump $x; 14 | ok ($dd{LEN} <= 16); 15 | my $len = 10240; 16 | ok (my $l = DGrow ($x, $len), "Set to $len"); 17 | is (length ($x), 0, "Variable content"); 18 | ok ($l >= $len, "returned LEN >= $len"); 19 | my $limit = 4 * $len; 20 | ok ($l <= $limit, "returned LEN <= $limit"); 21 | %dd = DDump $x; 22 | ok ($dd{LEN} >= $len, "LEN in variable >= $len"); 23 | ok ($dd{LEN} <= $limit, "LEN in variable <= limit"); 24 | ok ($l = DGrow (\$x, $limit), "Set to $limit"); 25 | ok ($l >= $limit, "LEN in variable >= $limit"); 26 | ($len, $limit) = ($limit, 4 * $limit); 27 | ok ($l <= $limit, "LEN in variable <= $limit"); 28 | %dd = DDump $x; 29 | ok ($dd{LEN} >= $len, "LEN in variable >= $len"); 30 | ok ($dd{LEN} <= $limit, "LEN in variable <= $limit"); 31 | is (DGrow ($x, 20), $l, "Don't shrink"); 32 | 33 | done_testing; 34 | 35 | 1; 36 | -------------------------------------------------------------------------------- /xt/20_kwalitee.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | 7 | BEGIN { $ENV{AUTHOR_TESTING} = 1; } 8 | eval "use Test::Kwalitee qw( kwalitee_ok );"; 9 | if ($@) { 10 | print "1..0 # Test::Kwalitee required for this test\n"; 11 | exit 0; 12 | } 13 | 14 | kwalitee_ok (qw( 15 | -has_meta_yml 16 | -metayml_conforms_spec_current 17 | -metayml_conforms_to_known_spec 18 | -metayml_declares_perl_version 19 | -metayml_has_license 20 | -metayml_has_provides 21 | -metayml_is_parsable 22 | -no_symlinks 23 | )); 24 | 25 | my @experimental = qw( 26 | no_stdin_for_prompting 27 | prereq_matches_use 28 | has_test_pod 29 | has_test_pod_coverage 30 | use_warnings 31 | 32 | build_prereq_matches_use 33 | easily_repackageable 34 | easily_repackageable_by_debian 35 | easily_repackageable_by_fedora 36 | fits_fedora_license 37 | has_license_in_source_file 38 | has_version_in_each_file 39 | has_version_in_each_file 40 | uses_test_nowarnings 41 | ); 42 | 43 | done_testing (); 44 | -------------------------------------------------------------------------------- /t/12_DDsort.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Warnings; 8 | 9 | use Data::Peek; 10 | 11 | my %hash = (1, 100, 2, 150, 30, 25, 200, 12, 4, 4); 12 | 13 | is (DDsort (0), 0, "Sort type 0"); 14 | my $out = DDumper \%hash; 15 | like ($out, qr{\b200\s+=>\s+12\b}, "Unsorted"); # Random order 16 | 17 | sub dsort { 18 | my ($sk, $exp) = @_; 19 | ok (DDsort ($sk), "Sort type $sk"); 20 | $out = DDumper \%hash; 21 | $out =~ s{\s+}{ }g; 22 | $out =~ s{\s+$}{}; 23 | is ($out, $exp, "Sorted by $sk"); 24 | } # dsort 25 | 26 | dsort (1 => "{ 1 => 100, 2 => 150, 200 => 12, 30 => 25, 4 => 4 }"); 27 | dsort (R => "{ 4 => 4, 30 => 25, 200 => 12, 2 => 150, 1 => 100 }"); 28 | dsort (N => "{ 1 => 100, 2 => 150, 4 => 4, 30 => 25, 200 => 12 }"); 29 | dsort (NR => "{ 200 => 12, 30 => 25, 4 => 4, 2 => 150, 1 => 100 }"); 30 | dsort (V => "{ 1 => 100, 200 => 12, 2 => 150, 30 => 25, 4 => 4 }"); 31 | dsort (VR => "{ 4 => 4, 30 => 25, 2 => 150, 200 => 12, 1 => 100 }"); 32 | dsort (VNR => "{ 2 => 150, 1 => 100, 30 => 25, 200 => 12, 4 => 4 }"); 33 | 34 | done_testing; 35 | 36 | 1; 37 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # General 2 | 3 | I am always open to improvements and suggestions. 4 | Use [issues](https://github.com/Tux/Data-Peek/issues) 5 | 6 | # Style 7 | 8 | I will never accept pull request that do not strictly conform to my 9 | style, however you might hate it. You can read the reasoning behind 10 | my [preferences](http://tux.nl/style.html). 11 | 12 | I really do not care about mixed spaces and tabs in (leading) whitespace 13 | 14 | Perl::Tidy will help getting the code in shape, but as all software, it 15 | is not perfect. You can find my preferences for these in 16 | [.perltidy](https://github.com/Tux/Release-Checklist/blob/master/.perltidyrc) and 17 | [.perlcritic](https://github.com/Tux/Release-Checklist/blob/master/.perlcriticrc). 18 | 19 | # Mail 20 | 21 | Please, please, please, do *NOT* use HTML mail. 22 | [Plain text](https://useplaintext.email) 23 | [without](http://www.goldmark.org/jeff/stupid-disclaimers/) 24 | [disclaimers](https://www.economist.com/business/2011/04/07/spare-us-the-e-mail-yada-yada) 25 | will do fine! 26 | 27 | # Requirements 28 | 29 | The minimum version required to use this module is stated in 30 | [Makefile.PL](./Makefile.PL) 31 | -------------------------------------------------------------------------------- /MANIFEST: -------------------------------------------------------------------------------- 1 | ChangeLog Change history 2 | README Docs 3 | cpanfile Dependency list for cpan/cpanm 4 | MANIFEST This file 5 | CONTRIBUTING.md Guide in how to contribute 6 | SECURITY.md Guide for reporting security issues 7 | Peek.pm Perl part of the module 8 | Peek.xs C part of the module 9 | Makefile.PL Makefile generator 10 | ppport.h Compatability layer 11 | typemap Define PerlIO for non-PerlIO perl 12 | t/00_pod.t Check if pod is valid 13 | t/01_pod.t Check if pod covers all 14 | t/10_DDumper.t Tests for DDumper () 15 | t/11_DDumper.t Tests for DDumper () using Perl::Tidy 16 | t/12_DDsort.t Tests for DDsort () i.c.w. DDumper () 17 | t/20_DPeek.t Tests for DPeek () 18 | t/21_DDisplay.t Tests for DDisplay () 19 | t/22_DHexDump.t Tests for DHexDump () 20 | t/30_DDump-s.t Tests for DDump () returning string using _XS 21 | t/31_DDump-s.t Tests for DDump () returning string using _IO 22 | t/40_DDump-h.t Tests for DDump () returning hash using _XS 23 | t/41_DDump-h.t Tests for DDump () returning hash using _IO 24 | t/50_DDual.t Tests for DDual () 25 | t/51_triplevar.t Tests for triplevar () 26 | t/52_DGrow.t Tests for DGrow () 27 | examples/ddumper.pl show the use 28 | -------------------------------------------------------------------------------- /sandbox/genPPPort_h.pl: -------------------------------------------------------------------------------- 1 | #!/pro/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Devel::PPPort; 7 | use File::Copy; 8 | 9 | # Check to see if ppport needs updating 10 | my $ph = "ppport.h"; 11 | 12 | if (-f $ph) { 13 | my ($cv) = (qx{perl $ph --version} =~ m{\b([0-9]\.\w+)}); 14 | if ($Devel::PPPort::VERSION lt $cv) { 15 | warn "Your $ph is newer than Devel::PPPort. Update skipped\n"; 16 | } 17 | else { 18 | my $old = do { local (@ARGV, $/) = ($ph); <> }; 19 | move $ph, "$ph.bkp"; 20 | 21 | Devel::PPPort::WriteFile ($ph); 22 | 23 | my $new = do { local (@ARGV, $/) = ($ph); <> }; 24 | 25 | if ($old ne $new) { 26 | warn "$ph updated to $Devel::PPPort::VERSION\n"; 27 | unlink "$ph.bkp"; 28 | } 29 | else { 30 | unlink $ph; 31 | move "$ph.bkp", $ph; 32 | } 33 | } 34 | } 35 | else { 36 | Devel::PPPort::WriteFile ($ph); 37 | warn "Installed new $ph $Devel::PPPort::VERSION\n"; 38 | } 39 | 40 | my $ppp = qx{perl $ph --compat-version=5.8.0 --quiet Peek.xs}; 41 | 42 | $ppp or exit 0; 43 | warn "Devel::PPPort suggests the following change:\n--8<---\n", 44 | $ppp, "-->9---\n", 45 | "run 'perl $ph --compat-version=5.8.0 Peek.xs' to see why\n"; 46 | -------------------------------------------------------------------------------- /doc/DP.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | DP - Alias for Data::Peek 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 21 | 22 |

NAME

23 | 24 |

DP - Alias for Data::Peek

25 | 26 |

SYNOPSIS

27 | 28 | 
perl -MDP -wle'print DPeek for DDual ($?, 1)'
29 | 30 |

DESCRIPTION

31 | 32 |

See Data::Peek.

33 | 34 |

AUTHOR

35 | 36 |

H.Merijn Brand <hmbrand@cpan.org>

37 | 38 |

COPYRIGHT AND LICENSE

39 | 40 |

Copyright (C) 2008-2025 H.Merijn Brand

41 | 42 |

This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself.

43 | 44 | 45 | 46 | 47 | 48 | -------------------------------------------------------------------------------- /t/22_DHexDump.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Warnings; 8 | 9 | use Config; 10 | use Data::Peek; 11 | 12 | my $is_ebcdic = ($Config{ebcdic} || "undef") eq "define" ? 1 : 0; 13 | 14 | is (DHexDump (undef), undef, 'undef'); 15 | is (DHexDump (""), "", '""'); 16 | 17 | for (split m/##\n/ => test_data ()) { 18 | my ($desc, $in, @out) = split m/\n-\n/, $_, 4; 19 | my $out = $out[$is_ebcdic]; 20 | $out =~ s/\n*\z/\n/; 21 | 22 | if ($in =~ s/\t(\d+)$//) { 23 | is (scalar DHexDump ($in, $1), $out, "HexDump $desc"); 24 | } 25 | else { 26 | is (scalar DHexDump ($in), $out, "HexDump $desc"); 27 | } 28 | } 29 | 30 | done_testing; 31 | 32 | sub test_data { 33 | return <<"EOTD"; 34 | Single 0 35 | - 36 | 0 37 | - 38 | 0000 30 0 39 | - 40 | 0000 f0 0 41 | ## 42 | Documentation example 43 | - 44 | abc\x{0a}de\x{20ac}fg 45 | - 46 | 0000 61 62 63 0a 64 65 e2 82 ac 66 67 abc.de...fg 47 | - 48 | 0000 81 82 83 0a 84 85 ca 46 53 86 87 abc.de...fg 49 | ## 50 | Documentation example with length 51 | - 52 | abc\x{0a}de\x{20ac}fg 6 53 | - 54 | 0000 61 62 63 0a 64 65 abc.de 55 | - 56 | 0000 81 82 83 0a 84 85 abc.de 57 | ## 58 | Binary data 59 | - 60 | \x01Great wide open space\x02\x{20ac}\n 61 | - 62 | 0000 01 47 72 65 61 74 20 77 69 64 65 20 6f 70 65 6e .Great wide open 63 | 0010 20 73 70 61 63 65 02 e2 82 ac 0a space..... 64 | - 65 | 0000 01 c7 99 85 81 a3 40 a6 89 84 85 40 96 97 85 95 .Great wide open 66 | 0010 40 a2 97 81 83 85 02 ca 46 53 15 space..... 67 | ## 68 | EOTD 69 | } # test_data 70 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | =head1 NAME 2 | 3 | Data::Peek - A collection of low-level debug functions 4 | 5 | =head1 Description 6 | 7 | Modified and extended wrapper functions to make debugging more 8 | pleasurable. 9 | 10 | DDumper () is a wrapper around Data::Dumper with always sorted keys. 11 | The output is however reflowed and not parsable anymore (in most 12 | cases) as the quotation around the keys is removed. 13 | 14 | DDump () is a wrapper around perl's core function sv_dump (), which 15 | should enable you to use the output instead of the default behavior 16 | that only prints to STDERR. 17 | 18 | DPeek () is a wrapper around internals Perl_sv_peek 19 | 20 | DDump_IO () is a wrapper around perl's core function do_sv_dump (), 21 | which acts like sv_dump (), but to a PerlIO stream. 22 | 23 | =head1 PREREQUISITES 24 | 25 | Perl 5.8.0 and up. 26 | Some versions of perl on some operating system(s) might not have 27 | exported the internals (yet). This module won't build then. 28 | 29 | If you run a perl that did not export Perl_sv_peek (), DPeek will 30 | not be available. If you happen to encounter that problem, most 31 | likely on Windows or AIX, C will make the 32 | build and test pass (I hope) 33 | 34 | =head1 INSTALLATION 35 | 36 | $ perl Makefile.PL 37 | $ make 38 | $ make test 39 | $ make install 40 | 41 | Recent changes can be (re)viewed in the public GIT repository at 42 | https://github.com/Tux/Data-Peek 43 | 44 | Feel free to clone your own copy: 45 | 46 | $ git clone https://github.com/Tux/Data-Peek Data-Peek 47 | 48 | or get it as a tgz: 49 | 50 | $ wget --output-document=Data-Peek-git.tgz \ 51 | https://github.com/Tux/Data-Peek/archive/master.tar.gz 52 | 53 | =head1 AUTHOR 54 | 55 | H.Merijn Brand 56 | 57 | =head1 COPYRIGHT AND LICENSE 58 | 59 | Copyright (c) 2008-2025 H.Merijn Brand. All rights reserved. 60 | 61 | This program is free software; you can redistribute it and/or modify 62 | it under the same terms as Perl itself. 63 | 64 | =cut 65 | -------------------------------------------------------------------------------- /sandbox/genMETA.pl: -------------------------------------------------------------------------------- 1 | #!/pro/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Getopt::Long qw(:config bundling nopermute); 7 | GetOptions ( 8 | "c|check" => \ my $check, 9 | "u|update!" => \ my $update, 10 | "v|verbose:1" => \(my $opt_v = 0), 11 | ) or die "usage: $0 [--check]\n"; 12 | 13 | use lib "sandbox"; 14 | use genMETA; 15 | my $meta = genMETA->new ( 16 | from => "Peek.pm", 17 | verbose => $opt_v, 18 | ); 19 | 20 | $meta->from_data (); 21 | $meta->security_md ($update); 22 | $meta->gen_cpanfile (); 23 | 24 | if ($check) { 25 | $meta->check_encoding (); 26 | $meta->check_required (); 27 | $meta->check_minimum ([ "examples" ]); 28 | $meta->done_testing (); 29 | } 30 | elsif ($opt_v) { 31 | $meta->print_yaml (); 32 | } 33 | else { 34 | $meta->fix_meta (); 35 | } 36 | 37 | __END__ 38 | --- #YAML:1.0 39 | name: Data-Peek 40 | version: VERSION 41 | abstract: Modified and extended debugging facilities 42 | license: perl 43 | author: 44 | - H.Merijn Brand 45 | generated_by: Author 46 | distribution_type: module 47 | provides: 48 | Data::Peek: 49 | file: Peek.pm 50 | version: VERSION 51 | requires: 52 | perl: 5.008001 53 | XSLoader: 0 54 | Data::Dumper: 0 55 | configure_requires: 56 | ExtUtils::MakeMaker: 0 57 | configure_recommends: 58 | ExtUtils::MakeMaker: 7.22 59 | configure_suggests: 60 | ExtUtils::MakeMaker: 7.72 61 | build_requires: 62 | perl: 5.008001 63 | test_requires: 64 | Test::More: 0.90 65 | Test::Warnings: 0 66 | recommends: 67 | Data::Dumper: 2.189 68 | Perl::Tidy: 0 69 | test_recommends: 70 | Test::More: 1.302209 71 | resources: 72 | license: http://dev.perl.org/licenses/ 73 | repository: https://github.com/Tux/Data-Peek 74 | bugtracker: https://github.com/Tux/Data-Peek/issues 75 | IRC: irc://irc.perl.org/#csv 76 | meta-spec: 77 | version: 1.4 78 | url: http://module-build.sourceforge.net/META-spec-v1.4.html 79 | -------------------------------------------------------------------------------- /t/50_DDual.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Warnings; 8 | 9 | use Data::Peek; 10 | 11 | my %special = ( 9 => "\\t", 10 => "\\n", 13 => "\\r" ); 12 | sub neat 13 | { 14 | my $neat = $_[0]; 15 | defined $neat or return "undef"; 16 | my $ref = ref $neat ? "\\" : "" and $neat = $$neat; 17 | join "", $ref, map { 18 | my $cp = ord $_; 19 | $cp >= 0x20 && $cp <= 0x7e 20 | ? $_ 21 | : $special{$cp} || sprintf "\\x{%02x}", $cp 22 | } split m//, $neat; 23 | } # neat 24 | 25 | foreach my $test ( 26 | [ undef, undef, undef, undef, undef, 0, undef ], 27 | [ 0, undef, 0, undef, undef, 0, undef ], 28 | [ 1, undef, 1, undef, undef, 0, undef ], 29 | [ 0.5, undef, undef, 0.5, undef, 0, 0 ], 30 | [ "", "", undef, undef, undef, 0, 0 ], 31 | [ \0, undef, undef, undef, 0, 0, undef ], 32 | [ \"a", undef, undef, undef, "a", 0, undef ], 33 | ) { 34 | (undef, my @exp) = @$test; 35 | my $in = neat ($test->[0]); 36 | ok (my @v = DDual ($test->[0]), "DDual ($in)"); 37 | is (scalar @v, 5, "5 elements"); 38 | is ($v[0], $exp[0], "PV $in ".DPeek ($v[0])); 39 | is ($v[1], $exp[1], "IV $in ".DPeek ($v[1])); 40 | is ($v[2], $exp[2], "NV $in ".DPeek ($v[2])); 41 | is ($v[3], $exp[3], "RV $in ".DPeek ($v[3])); 42 | is ($v[4], $exp[4], "MG $in ".DPeek ($v[4])); 43 | 44 | defined $v[1] and next; 45 | { no warnings; 46 | my $x = 0 + $test->[0]; 47 | } 48 | TODO: { local $TODO = "Do all perl versions upgrade?"; 49 | ok (@v = DDual ($test->[0]), "DDual ($in + 0)"); 50 | is ($v[1], $exp[5], "IV $in ".DPeek ($v[1])); 51 | } 52 | } 53 | 54 | TODO: { local $TODO = "How magic is \$? accross perl versions?"; 55 | my @m = DDual ($?); 56 | is ($m[4], 3, "\$? has magic"); 57 | is ($m[0], undef, "PV \$? w/o get"); 58 | is ($m[1], undef, "IV \$? w/o get"); 59 | is ($m[2], undef, "NV \$? w/o get"); 60 | is ($m[3], undef, "RV \$? w/o get"); 61 | } 62 | 63 | TODO: { local $TODO = "How magic is \$? accross perl versions?"; 64 | my @m = DDual ($?, 1); 65 | is ($m[4], 3, "\$? has magic"); 66 | is ($m[0], undef, "PV \$? w/ get"); 67 | is ($m[1], 0, "IV \$? w/ get"); 68 | is ($m[2], undef, "NV \$? w/ get"); 69 | is ($m[3], undef, "RV \$? w/ get"); 70 | } 71 | 72 | done_testing; 73 | 74 | 1; 75 | -------------------------------------------------------------------------------- /doc/DP.3: -------------------------------------------------------------------------------- 1 | .\" -*- mode: troff; coding: utf-8 -*- 2 | .\" Automatically generated by Pod::Man v6.0.2 (Pod::Simple 3.45) 3 | .\" 4 | .\" Standard preamble: 5 | .\" ======================================================================== 6 | .de Sp \" Vertical space (when we can't use .PP) 7 | .if t .sp .5v 8 | .if n .sp 9 | .. 10 | .de Vb \" Begin verbatim text 11 | .ft CW 12 | .nf 13 | .ne \\$1 14 | .. 15 | .de Ve \" End verbatim text 16 | .ft R 17 | .fi 18 | .. 19 | .\" \*(C` and \*(C' are quotes in nroff, nothing in troff, for use with C<>. 20 | .ie n \{\ 21 | . ds C` "" 22 | . ds C' "" 23 | 'br\} 24 | .el\{\ 25 | . ds C` 26 | . ds C' 27 | 'br\} 28 | .\" 29 | .\" Escape single quotes in literal strings from groff's Unicode transform. 30 | .ie \n(.g .ds Aq \(aq 31 | .el .ds Aq ' 32 | .\" 33 | .\" If the F register is >0, we'll generate index entries on stderr for 34 | .\" titles (.TH), headers (.SH), subsections (.SS), items (.Ip), and index 35 | .\" entries marked with X<> in POD. Of course, you'll have to process the 36 | .\" output yourself in some meaningful fashion. 37 | .\" 38 | .\" Avoid warning from groff about undefined register 'F'. 39 | .de IX 40 | .. 41 | .nr rF 0 42 | .if \n(.g .if rF .nr rF 1 43 | .if (\n(rF:(\n(.g==0)) \{\ 44 | . if \nF \{\ 45 | . de IX 46 | . tm Index:\\$1\t\\n%\t"\\$2" 47 | .. 48 | . if !\nF==2 \{\ 49 | . nr % 0 50 | . nr F 2 51 | . \} 52 | . \} 53 | .\} 54 | .rr rF 55 | .\" 56 | .\" Required to disable full justification in groff 1.23.0. 57 | .if n .ds AD l 58 | .\" ======================================================================== 59 | .\" 60 | .IX Title "DP 3" 61 | .TH DP 3 2025-03-17 "perl v5.40.1" "User Contributed Perl Documentation" 62 | .\" For nroff, turn off justification. Always turn off hyphenation; it makes 63 | .\" way too many mistakes in technical documents. 64 | .if n .ad l 65 | .nh 66 | .SH NAME 67 | DP \- Alias for Data::Peek 68 | .SH SYNOPSIS 69 | .IX Header "SYNOPSIS" 70 | .Vb 1 71 | \& perl \-MDP \-wle\*(Aqprint DPeek for DDual ($?, 1)\*(Aq 72 | .Ve 73 | .SH DESCRIPTION 74 | .IX Header "DESCRIPTION" 75 | See Data::Peek. 76 | .SH AUTHOR 77 | .IX Header "AUTHOR" 78 | H.Merijn Brand 79 | .SH "COPYRIGHT AND LICENSE" 80 | .IX Header "COPYRIGHT AND LICENSE" 81 | Copyright (C) 2008\-2025 H.Merijn Brand 82 | .PP 83 | This library is free software; you can redistribute it and/or modify it 84 | under the same terms as Perl itself. 85 | -------------------------------------------------------------------------------- /t/20_DPeek.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Warnings; 8 | 9 | use Data::Peek; 10 | 11 | $| = 1; 12 | 13 | my $peek = DPeek (0); 14 | SKIP: { 15 | $peek =~ m/^Your perl did not/ and skip ($peek, 49); 16 | 17 | like (DPeek ($/), qr'^PVMG\("\\(n|12)"\\0\)', '$/'); 18 | is (DPeek ($\), 'PVMG()', '$\\'); 19 | like (DPeek ($.), qr'^PVMG\(0?\)$', '$.'); 20 | like (DPeek ($,), qr'^PVMG\((""\\0)?\)|^UNDEF$','$,'); 21 | is (DPeek ($;), 'PV("\34"\0)', '$;'); 22 | is (DPeek ($"), 'PV(" "\0)', '$"'); 23 | like (DPeek ($:), qr'^PVMG\(" \\(n|12)-"\\0\)', '$:'); 24 | is (DPeek ($~), 'PVMG()', '$~'); 25 | is (DPeek ($^), 'PVMG()', '$^'); 26 | is (DPeek ($=), 'PVMG()', '$='); 27 | is (DPeek ($-), 'PVMG()', '$-'); 28 | is (DPeek ($|), 'PVMG(1)', '$|'); 29 | like (DPeek ($?), qr'^PV(MG|LV)\(0?\)', '$?'); 30 | like (DPeek ($!), qr'^PVMG\(""|\)', '$!'); 31 | 32 | "abc" =~ m/(b)/; # Don't know why these magic vars have this content 33 | like (DPeek ($1), qr'^PVMG\("', ' $1'); 34 | is (DPeek ($`), 'PVMG()', ' $`'); 35 | is (DPeek ($&), 'PVMG()', ' $&'); 36 | is (DPeek ($'), 'PVMG()', " \$'"); 37 | 38 | is (DPeek (undef), 'SV_UNDEF', 'undef'); 39 | is (DPeek (1), 'IV(1)', 'constant 1'); 40 | is (DPeek (""), 'PV(""\0)', 'constant ""'); 41 | is (DPeek (1.), 'NV(1)', 'constant 1.'); 42 | is (DPeek (\1), '\IV(1)', 'constant \1'); 43 | is (DPeek (\\1), '\\\IV(1)', 'constant \\\1'); 44 | 45 | is (DPeek (\@ARGV), '\AV()', '\@ARGV'); 46 | is (DPeek (\@INC), '\AV()', '\@INC'); 47 | is (DPeek (\%INC), '\HV()', '\%INC'); 48 | is (DPeek (*STDOUT), 'GV()', '*STDOUT'); 49 | is (DPeek (sub {}), '\CV(__ANON__)', 'sub {}'); 50 | 51 | { our ($VAR, @VAR, %VAR); 52 | open VAR, ">VAR.txt"; 53 | sub VAR {} 54 | format VAR = 55 | . 56 | END { unlink "VAR.txt" }; 57 | 58 | is (DPeek ( $VAR), 'UNDEF', ' $VAR undef'); 59 | is (DPeek (\$VAR), '\UNDEF', '\$VAR undef'); 60 | $VAR = 1; 61 | is (DPeek ($VAR), 'IV(1)', ' $VAR 1'); 62 | is (DPeek (\$VAR), '\IV(1)', '\$VAR 1'); 63 | $VAR = ""; 64 | is (DPeek ($VAR), 'PVIV(""\0)', ' $VAR ""'); 65 | is (DPeek (\$VAR), '\PVIV(""\0)', '\$VAR ""'); 66 | $VAR = "\xb6"; 67 | is (DPeek ($VAR), 'PVIV("\266"\0)', ' $VAR "\xb6"'); 68 | is (DPeek (\$VAR), '\PVIV("\266"\0)', '\$VAR "\xb6"'); 69 | SKIP: { 70 | $] <= 5.008001 and skip "UTF8 tests useless in this ancient perl version", 1; 71 | $VAR = "a\x0a\x{20ac}"; 72 | like (DPeek ($VAR), qr'^PVIV\("a\\(n|12)(?:\\342\\202\\254|\\312\\106\\123)"\\0\) \[UTF8 "a\\?(?:n|x\{a\})\\x\{20ac}"\]', 73 | ' $VAR "a\x0a\x{20ac}"'); 74 | } 75 | $VAR = sub { "VAR" }; 76 | is (DPeek ($VAR), '\CV(__ANON__)', ' $VAR sub { "VAR" }'); 77 | is (DPeek (\$VAR), '\\\CV(__ANON__)', '\$VAR sub { "VAR" }'); 78 | $VAR = 0; 79 | 80 | is (DPeek (\&VAR), '\CV(VAR)', '\&VAR'); 81 | is (DPeek ( *VAR), 'GV()', ' *VAR'); 82 | 83 | is (DPeek (*VAR{GLOB}), '\GV()', ' *VAR{GLOB}'); 84 | like (DPeek (*VAR{SCALAR}), qr'\\PV(IV|MG)\(0\)',' *VAR{SCALAR}'); 85 | is (DPeek (*VAR{ARRAY}), '\AV()', ' *VAR{ARRAY}'); 86 | is (DPeek (*VAR{HASH}), '\HV()', ' *VAR{HASH}'); 87 | is (DPeek (*VAR{CODE}), '\CV(VAR)', ' *VAR{CODE}'); 88 | is (DPeek (*VAR{IO}), '\IO()', ' *VAR{IO}'); 89 | is (DPeek (*VAR{FORMAT}), '\FM()', ' *VAR{FORMAT}'); 90 | } 91 | } 92 | 93 | done_testing; 94 | 95 | 1; 96 | -------------------------------------------------------------------------------- /t/30_DDump-s.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | # I would like more tests, but contents change over every perl version 7 | use Test::More; 8 | use Test::Warnings; 9 | 10 | use Data::Peek; 11 | 12 | $Data::Peek::has_perlio = $Data::Peek::has_perlio = 0; 13 | 14 | ok (1, "DDump () NOT using PerlIO"); 15 | 16 | my @tests; 17 | { local $/ = "==\n"; 18 | chomp (@tests = ); 19 | } 20 | 21 | # Determine what newlines this perl generates in sv_peek 22 | my @nl = ("\\n") x 2; 23 | 24 | my $var = ""; 25 | 26 | foreach my $test (@tests) { 27 | my ($in, $expect) = split m/\n--\n/ => $test; 28 | $in eq "" and next; 29 | SKIP: { 30 | my $dump; 31 | if ($in eq "DEFSV") { 32 | $_ = undef; 33 | $_ = "DEFSV"; 34 | $dump = DDump; 35 | } 36 | else { 37 | eval "\$var = $in;"; 38 | $dump = DDump ($var); 39 | } 40 | 41 | if ($in =~ m/20ac/) { 42 | @nl = ($dump =~ m/PV = 0x\w+ "([^"]+)".*"([^"]+)"/); 43 | diag "# This perl dumps \\n as (@nl)"; 44 | # Catch differences in \n 45 | $dump =~ s/"ab\Q$nl[0]\E(.*?)"ab\Q$nl[1]\E/"ab\\n$1"ab\\n/g; 46 | } 47 | 48 | $dump =~ s/\b0x[0-9a-f]+\b/0x****/g; 49 | $dump =~ s/\b(REFCNT =) [0-9]{4,}/$1 -1/g; 50 | 51 | $dump =~ s/\bLEN = (?:[1-9]|1[0-6])\b/LEN = 8/g; # aligned at long long? 52 | 53 | $dump =~ s/\bPADBUSY\b,?//g if $] < 5.010; 54 | 55 | my @expect = split m/(?<=\n)\|(?:\s*#.*)?\n+/ => $expect; 56 | 57 | $in =~ s/[\s\n]+/ /g; 58 | 59 | if (my @match = grep { $dump eq $_ } @expect) { 60 | is ($dump, $match[0], "DDump ($in)"); 61 | } 62 | else { 63 | my $match = pop @expect; 64 | is ($dump, $match, "DDump ($in)"); 65 | diag ("DDump ($in) neither matches\n$_") for @expect; 66 | } 67 | } 68 | } 69 | 70 | done_testing; 71 | 72 | 1; 73 | 74 | __END__ 75 | undef 76 | -- 77 | SV = PV(0x****) at 0x**** 78 | REFCNT = 1 79 | FLAGS = (PADMY) 80 | PV = 0x**** ""\0 81 | CUR = 0 82 | LEN = 8 83 | | # as of 5.19.3 84 | SV = PV(0x****) at 0x**** 85 | REFCNT = 1 86 | FLAGS = (PADMY) 87 | PV = 0 88 | | # as of 5.21.5 89 | SV = PV(0x****) at 0x**** 90 | REFCNT = 1 91 | FLAGS = () 92 | PV = 0 93 | == 94 | 0 95 | -- 96 | SV = PVIV(0x****) at 0x**** 97 | REFCNT = 1 98 | FLAGS = (PADMY,IOK,pIOK) 99 | IV = 0 100 | PV = 0x**** ""\0 101 | CUR = 0 102 | LEN = 8 103 | | # as of 5.19.3 104 | SV = PVIV(0x****) at 0x**** 105 | REFCNT = 1 106 | FLAGS = (PADMY,IOK,pIOK) 107 | IV = 0 108 | PV = 0 109 | | # as of 5.21.5 110 | SV = PVIV(0x****) at 0x**** 111 | REFCNT = 1 112 | FLAGS = (IOK,pIOK) 113 | IV = 0 114 | PV = 0 115 | == 116 | 1 117 | -- 118 | SV = PVIV(0x****) at 0x**** 119 | REFCNT = 1 120 | FLAGS = (PADMY,IOK,pIOK) 121 | IV = 1 122 | PV = 0x**** ""\0 123 | CUR = 0 124 | LEN = 8 125 | | # as of 5.19.3 126 | SV = PVIV(0x****) at 0x**** 127 | REFCNT = 1 128 | FLAGS = (PADMY,IOK,pIOK) 129 | IV = 1 130 | PV = 0 131 | | # as of 5.21.5 132 | SV = PVIV(0x****) at 0x**** 133 | REFCNT = 1 134 | FLAGS = (IOK,pIOK) 135 | IV = 1 136 | PV = 0 137 | == 138 | "" 139 | -- 140 | SV = PVIV(0x****) at 0x**** 141 | REFCNT = 1 142 | FLAGS = (PADMY,POK,pPOK) 143 | IV = 1 144 | PV = 0x**** ""\0 145 | CUR = 0 146 | LEN = 8 147 | | # as of 5.19.3 148 | SV = PVIV(0x****) at 0x**** 149 | REFCNT = 1 150 | FLAGS = (PADMY,POK,IsCOW,pPOK) 151 | IV = 1 152 | PV = 0x**** ""\0 153 | CUR = 0 154 | LEN = 8 155 | COW_REFCNT = 0 156 | | # as of 5.21.5 157 | SV = PVIV(0x****) at 0x**** 158 | REFCNT = 1 159 | FLAGS = (POK,IsCOW,pPOK) 160 | IV = 1 161 | PV = 0x**** ""\0 162 | CUR = 0 163 | LEN = 8 164 | COW_REFCNT = 0 165 | == 166 | DEFSV 167 | -- 168 | SV = PV(0x****) at 0x**** 169 | REFCNT = 1 170 | FLAGS = (POK,pPOK) 171 | PV = 0x**** "DEFSV"\0 172 | CUR = 5 173 | LEN = 8 174 | | # as of 5.19.3 175 | SV = PV(0x****) at 0x**** 176 | REFCNT = 1 177 | FLAGS = (POK,IsCOW,pPOK) 178 | PV = 0x**** "DEFSV"\0 179 | CUR = 5 180 | LEN = 8 181 | COW_REFCNT = 1 182 | -------------------------------------------------------------------------------- /SECURITY.md: -------------------------------------------------------------------------------- 1 | # Security Policy for the Data::Peek distribution. 2 | 3 | Report issues via email at: H.Merijn Brand . 4 | 5 | 6 | This is the Security Policy for Data::Peek. 7 | 8 | The latest version of the Security Policy can be found in the 9 | [git repository for Data::Peek](https://github.com/Tux/Data-Peek). 10 | 11 | This text is based on the CPAN Security Group's Guidelines for Adding 12 | a Security Policy to Perl Distributions (version 1.0.0) 13 | https://security.metacpan.org/docs/guides/security-policy-for-authors.html 14 | 15 | # How to Report a Security Vulnerability 16 | 17 | Security vulnerabilities can be reported by e-mail to the current 18 | project maintainers at H.Merijn Brand . 19 | 20 | Please include as many details as possible, including code samples 21 | or test cases, so that we can reproduce the issue. Check that your 22 | report does not expose any sensitive data, such as passwords, 23 | tokens, or personal information. 24 | 25 | If you would like any help with triaging the issue, or if the issue 26 | is being actively exploited, please copy the report to the CPAN 27 | Security Group (CPANSec) at . 28 | 29 | Please *do not* use the public issue reporting system on RT or 30 | GitHub issues for reporting security vulnerabilities. 31 | 32 | Please do not disclose the security vulnerability in public forums 33 | until past any proposed date for public disclosure, or it has been 34 | made public by the maintainers or CPANSec. That includes patches or 35 | pull requests. 36 | 37 | For more information, see 38 | [Report a Security Issue](https://security.metacpan.org/docs/report.html) 39 | on the CPANSec website. 40 | 41 | ## Response to Reports 42 | 43 | The maintainer(s) aim to acknowledge your security report as soon as 44 | possible. However, this project is maintained by a single person in 45 | their spare time, and they cannot guarantee a rapid response. If you 46 | have not received a response from them within 10 days, then 47 | please send a reminder to them and copy the report to CPANSec at 48 | . 49 | 50 | Please note that the initial response to your report will be an 51 | acknowledgement, with a possible query for more information. It 52 | will not necessarily include any fixes for the issue. 53 | 54 | The project maintainer(s) may forward this issue to the security 55 | contacts for other projects where we believe it is relevant. This 56 | may include embedded libraries, system libraries, prerequisite 57 | modules or downstream software that uses this software. 58 | 59 | They may also forward this issue to CPANSec. 60 | 61 | # Which Software This Policy Applies To 62 | 63 | Any security vulnerabilities in Data::Peek are covered by this policy. 64 | 65 | Security vulnerabilities are considered anything that allows users 66 | to execute unauthorised code, access unauthorised resources, or to 67 | have an adverse impact on accessibility or performance of a system. 68 | 69 | Security vulnerabilities in upstream software (embedded libraries, 70 | prerequisite modules or system libraries, or in Perl), are not 71 | covered by this policy unless they affect Data::Peek, or Data::Peek can 72 | be used to exploit vulnerabilities in them. 73 | 74 | Security vulnerabilities in downstream software (any software that 75 | uses Data::Peek, or plugins to it that are not included with the 76 | Data::Peek distribution) are not covered by this policy. 77 | 78 | ## Supported Versions of Data::Peek 79 | 80 | The maintainer(s) will only commit to releasing security fixes for 81 | the latest version of Data::Peek. 82 | 83 | Note that the Data::Peek project only supports major versions of Perl 84 | released in the past 5 years, even though Data::Peek will run on 85 | older versions of Perl. If a security fix requires us to increase 86 | the minimum version of Perl that is supported, then we may do so. 87 | 88 | # Installation and Usage Issues 89 | 90 | The distribution metadata specifies minimum versions of 91 | prerequisites that are required for Data::Peek to work. However, some 92 | of these prerequisites may have security vulnerabilities, and you 93 | should ensure that you are using up-to-date versions of these 94 | prerequisites. 95 | 96 | Where security vulnerabilities are known, the metadata may indicate 97 | newer versions as recommended. 98 | 99 | ## Usage 100 | 101 | Please see the software documentation for further information. 102 | -------------------------------------------------------------------------------- /Makefile.PL: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright PROCURA B.V. (c) 2008-2025 H.Merijn Brand 4 | 5 | require 5.008001; # <- also see postamble at the bottom for META.yml 6 | use strict; 7 | 8 | if ($ENV{PERLBREW_HOME} and $ENV{PERLBREW_HOME} eq "/home/njh/.perlbrew") { 9 | warn "Your smokers have been blocked because of consistent failures that\n"; 10 | warn " are all caused by the smoking setup and not by module errors. I you\n"; 11 | warn " have fixed that all, please inform the authors, so this block can\n"; 12 | warn " be lifted again.\n"; 13 | exit 0; 14 | } 15 | 16 | use ExtUtils::MakeMaker; 17 | 18 | my %wm = ( 19 | NAME => "Data::Peek", 20 | DISTNAME => "Data-Peek", 21 | ABSTRACT => "Extended/Modified debugging utilities", 22 | AUTHOR => "H.Merijn Brand ", 23 | VERSION_FROM => "Peek.pm", 24 | PREREQ_PM => { "XSLoader" => 0, 25 | "Data::Dumper" => 0, 26 | "Test::More" => 0.90, 27 | "Test::Warnings" => 0, 28 | }, 29 | clean => { FILES => join " ", qw( 30 | Peek.c.gcov 31 | Peek.gcda 32 | Peek.gcno 33 | Peek.xs.gcov 34 | cover_db 35 | valgrind.log 36 | ) 37 | }, 38 | macro => { TARFLAGS => "--format=ustar -c -v -f", 39 | }, 40 | ); 41 | $ExtUtils::MakeMaker::VERSION > 6.30 and $wm{LICENSE} = "perl"; 42 | 43 | unless (exists $ENV{AUTOMATED_TESTING} and $ENV{AUTOMATED_TESTING} == 1) { 44 | my $dp_ok = 1; 45 | eval { 46 | require DP; 47 | $dp_ok = 0; 48 | if ($INC{"DP.pm"} and open my $fh, "<", $INC{"DP.pm"}) { 49 | my $line1 = <$fh>; 50 | $line1 =~ m/^use Data::Peek;/ and $dp_ok = 1; 51 | close $fh; 52 | } 53 | }; 54 | 55 | if ($dp_ok and prompt ("Do you want to install module DP as a shortcut for Data::Peek ?", "y") =~ m/[yY]/) { 56 | local $/; 57 | open my $pm, "<", "Peek.pm" or die "Cannot read Peek.pm: $!\n"; 58 | my $vsn = do { <$pm> =~ m/^\$VERSION\s*=\s*"([0-9._]+)/m; $1 }; 59 | close $pm; 60 | 61 | (my $dp = ) =~ s/::VERSION::/"$vsn"/; 62 | open my $fh, ">", "DP.pm" or die "Cannot open DP.pm: $!\n"; 63 | print $fh $dp; 64 | close $fh; 65 | $wm{PM} = { 66 | "Peek.pm" => '$(INST_LIB)/Data/Peek.pm', 67 | "DP.pm" => '$(INST_LIB)/DP.pm', 68 | }; 69 | $wm{clean}{FILES} .= " DP.pm"; 70 | } 71 | } 72 | 73 | $ENV{NO_SV_PEEK} and $wm{DEFINE} = "-DNO_SV_PEEK"; 74 | 75 | my $rv = WriteMakefile (%wm); 76 | 77 | 1; 78 | 79 | package MY; 80 | 81 | sub postamble { 82 | my $valgrind = join " ", qw( 83 | PERL_DESTRUCT_LEVEL=2 PERL_DL_NONLAZY=1 84 | valgrind 85 | --suppressions=sandbox/perl.supp 86 | --leak-check=yes 87 | --leak-resolution=high 88 | --show-reachable=yes 89 | --num-callers=50 90 | --log-fd=3 91 | $(FULLPERLRUN) "-MExtUtils::Command::MM" "-e" 92 | "test_harness($(TEST_VERBOSE), '$(INST_LIB)', '$(INST_ARCHLIB)')" 93 | $(TEST_FILES) 3>valgrind.log 94 | ); 95 | 96 | my $min_vsn = ($] >= 5.010 && -d "xt" && ($ENV{AUTOMATED_TESTING} || 0) != 1) 97 | ? join "\n" => 98 | 'test ::', 99 | ' -@env TEST_FILES="xt/*.t" make -e test_dynamic', 100 | '' 101 | : ""; 102 | join "\n" => 103 | 'cover test_cover:', 104 | ' ccache -C', 105 | ' cover -test', 106 | '', 107 | 'leakcheck:', 108 | " $valgrind", 109 | ' -@tail -5 valgrind.log', 110 | '', 111 | 'leaktest:', 112 | q{ sandbox/leaktest $(FULLPERLRUN) "test_harness($(TEST_VERBOSE), '$(INST_LIB)', '$(INST_ARCHLIB)')" $(TEST_FILES)}, 113 | '', 114 | 'spellcheck:', 115 | ' pod-spell-check --aspell --ispell', 116 | '', 117 | 'checkmeta: spellcheck', 118 | ' perl sandbox/genPPPort_h.pl', 119 | ' perl sandbox/genMETA.pl -c', 120 | '', 121 | 'fixmeta: distmeta', 122 | ' perl sandbox/genMETA.pl', 123 | '', 124 | 'tgzdist: doc checkmeta fixmeta $(DISTVNAME).tar.gz distcheck', 125 | ' -@mv -f $(DISTVNAME).tar.gz $(DISTVNAME).tgz', 126 | ' -@cpants_lint.pl $(DISTVNAME).tgz', 127 | ' -@rm -f Debian_CPANTS.txt', 128 | '', 129 | 'doc docs: doc/Data-Peek.md doc/Data-Peek.html doc/Data-Peek.3 doc/Data-Peek.man', 130 | 'doc/Data-Peek.md: Peek.pm', 131 | ' perl doc/make-doc.pl', 132 | '', 133 | $min_vsn; 134 | } # postamble 135 | 136 | __END__ 137 | use Data::Peek; 138 | 139 | use strict; 140 | use warnings; 141 | 142 | BEGIN { *DP:: = \%Data::Peek:: } 143 | our $VERSION = ::VERSION::; 144 | 145 | 1; 146 | 147 | =head1 NAME 148 | 149 | DP - Alias for Data::Peek 150 | 151 | =head1 SYNOPSIS 152 | 153 | perl -MDP -wle'print DPeek for DDual ($?, 1)' 154 | 155 | =head1 DESCRIPTION 156 | 157 | See L. 158 | 159 | =head1 AUTHOR 160 | 161 | H.Merijn Brand 162 | 163 | =head1 COPYRIGHT AND LICENSE 164 | 165 | Copyright (C) 2008-2025 H.Merijn Brand 166 | 167 | This library is free software; you can redistribute it and/or modify it 168 | under the same terms as Perl itself. 169 | 170 | =cut 171 | -------------------------------------------------------------------------------- /Peek.xs: -------------------------------------------------------------------------------- 1 | /* Copyright (c) 2008-2025 H.Merijn Brand. All rights reserved. 2 | * This program is free software; you can redistribute it and/or 3 | * modify it under the same terms as Perl itself. 4 | */ 5 | 6 | #ifdef __cplusplus 7 | extern "C" { 8 | #endif 9 | #define PERL_NO_GET_CONTEXT 10 | #include 11 | #include 12 | #include 13 | #define NEED_pv_pretty 14 | #define NEED_pv_escape 15 | #define NEED_my_snprintf 16 | #define NEED_utf8_to_uvchr_buf 17 | #include "ppport.h" 18 | #ifdef __cplusplus 19 | } 20 | #endif 21 | 22 | SV *_DDump (pTHX_ SV *sv) 23 | { 24 | int err[3], n; 25 | char buf[128]; 26 | SV *dd; 27 | 28 | if (pipe (err)) return (NULL); 29 | 30 | dd = sv_newmortal (); 31 | err[2] = dup (2); 32 | close (2); 33 | if (dup (err[1]) == 2) 34 | sv_dump (sv); 35 | close (err[1]); 36 | close (2); 37 | err[1] = dup (err[2]); 38 | close (err[2]); 39 | 40 | sv_setpvn (dd, "", 0); 41 | while ((n = read (err[0], buf, 128)) > 0) 42 | sv_catpvn_flags (dd, buf, n, SV_GMAGIC); 43 | return (dd); 44 | } /* _DDump */ 45 | 46 | SV *_DPeek (pTHX_ int items, SV *sv) 47 | { 48 | #ifdef NO_SV_PEEK 49 | return newSVpv ("Your perl did not export Perl_sv_peek ()", 0); 50 | #else 51 | return newSVpv (sv_peek (items ? sv : DEFSV), 0); 52 | #endif 53 | } /* _DPeek */ 54 | 55 | void _Dump_Dual (pTHX_ SV *sv, SV *pv, SV *iv, SV *nv, SV *rv) 56 | { 57 | #ifndef NO_SV_PEEK 58 | warn ("%s\n PV: %s\n IV: %s\n NV: %s\n RV: %s\n", 59 | sv_peek (sv), sv_peek (pv), sv_peek (iv), sv_peek (nv), sv_peek (rv)); 60 | #endif 61 | } /* _Dump_Dual */ 62 | 63 | MODULE = Data::Peek PACKAGE = Data::Peek 64 | 65 | void 66 | DPeek (...) 67 | PROTOTYPE: ;$ 68 | PPCODE: 69 | I32 gimme = GIMME_V; 70 | SV *sv = items ? ST (0) : DEFSV; 71 | if (items == 0) EXTEND (SP, 1); 72 | ST (0) = _DPeek (aTHX_ items, sv); 73 | if (gimme == G_VOID) warn ("%s\n", SvPVX (ST (0))); 74 | XSRETURN (1); 75 | /* XS DPeek */ 76 | 77 | void 78 | DDisplay (...) 79 | PROTOTYPE: ;$ 80 | PPCODE: 81 | I32 gimme = GIMME_V; 82 | SV *sv = items ? ST (0) : DEFSV; 83 | SV *dsp = newSVpv ("", 0); 84 | if (SvPOK (sv) || SvPOKp (sv)) 85 | pv_pretty (dsp, SvPVX (sv), SvCUR (sv), 0, 86 | NULL, NULL, 87 | (PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_UNI_DETECT)); 88 | if (items == 0) EXTEND (SP, 1); 89 | ST (0) = dsp; 90 | if (gimme == G_VOID) warn ("%s\n", SvPVX (ST (0))); 91 | XSRETURN (1); 92 | /* XS DDisplay */ 93 | 94 | void 95 | triplevar (pv, iv, nv) 96 | SV *pv 97 | SV *iv 98 | SV *nv 99 | 100 | PROTOTYPE: $$$ 101 | PPCODE: 102 | SV *tv = newSVpvs (""); 103 | SvUPGRADE (tv, SVt_PVNV); 104 | 105 | if (SvPOK (pv) || SvPOKp (pv)) { 106 | sv_setpvn (tv, SvPVX (pv), SvCUR (pv)); 107 | if (SvUTF8 (pv)) SvUTF8_on (tv); 108 | } 109 | else 110 | sv_setpvn (tv, NULL, 0); 111 | 112 | if (SvNOK (nv) || SvNOKp (nv)) { 113 | SvNV_set (tv, SvNV (nv)); 114 | SvNOK_on (tv); 115 | } 116 | 117 | if (SvIOK (iv) || SvIOKp (iv)) { 118 | SvIV_set (tv, SvIV (iv)); 119 | SvIOK_on (tv); 120 | } 121 | 122 | ST (0) = tv; 123 | XSRETURN (1); 124 | /* XS triplevar */ 125 | 126 | void 127 | DDual (sv, ...) 128 | SV *sv 129 | 130 | PROTOTYPE: $;$ 131 | PPCODE: 132 | I32 gimme = GIMME_V; 133 | 134 | if (items > 1 && SvGMAGICAL (sv) && SvTRUE (ST (1))) 135 | mg_get (sv); 136 | 137 | EXTEND (SP, 5); 138 | if (SvPOK (sv) || SvPOKp (sv)) { 139 | SV *xv = newSVpv (SvPVX (sv), 0); 140 | if (SvUTF8 (sv)) SvUTF8_on (xv); 141 | mPUSHs (xv); 142 | } 143 | else 144 | PUSHs (&PL_sv_undef); 145 | 146 | if (SvIOK (sv) || SvIOKp (sv)) 147 | mPUSHi (SvIV (sv)); 148 | else 149 | PUSHs (&PL_sv_undef); 150 | 151 | if (SvNOK (sv) || SvNOKp (sv)) 152 | mPUSHn (SvNV (sv)); 153 | else 154 | PUSHs (&PL_sv_undef); 155 | 156 | if (SvROK (sv)) { 157 | SV *xv = newSVsv (SvRV (sv)); 158 | mPUSHs (xv); 159 | } 160 | else 161 | PUSHs (&PL_sv_undef); 162 | 163 | mPUSHi (SvMAGICAL (sv) >> 21); 164 | 165 | if (gimme == G_VOID) _Dump_Dual (aTHX_ sv, ST (0), ST (1), ST (2), ST (3)); 166 | /* XS DDual */ 167 | 168 | void 169 | DGrow (sv, size) 170 | SV *sv 171 | IV size 172 | 173 | PROTOTYPE: $$ 174 | PPCODE: 175 | if (SvROK (sv)) 176 | sv = SvRV (sv); 177 | if (!SvPOK (sv)) 178 | sv_setpvn (sv, "", 0); 179 | SvGROW (sv, size); 180 | EXTEND (SP, 1); 181 | mPUSHi (SvLEN (sv)); 182 | /* XS DGrow */ 183 | 184 | void 185 | DDump_XS (sv) 186 | SV *sv 187 | 188 | PROTOTYPE: $ 189 | PPCODE: 190 | SV *dd = _DDump (aTHX_ sv); 191 | 192 | if (dd) { 193 | ST (0) = dd; 194 | XSRETURN (1); 195 | } 196 | 197 | XSRETURN (0); 198 | /* XS DDump */ 199 | 200 | void 201 | DDump_IO (io, sv, level) 202 | PerlIO *io 203 | SV *sv 204 | IV level 205 | 206 | PPCODE: 207 | do_sv_dump (0, io, sv, 1, level, 1, 0); 208 | XSRETURN (1); 209 | /* XS DDump */ 210 | -------------------------------------------------------------------------------- /doc/make-doc.pl: -------------------------------------------------------------------------------- 1 | #!/pro/bin/perl 2 | 3 | use 5.038002; 4 | use warnings; 5 | 6 | our $VERSION = "0.05 - 20250116"; 7 | our $CMD = $0 =~ s{.*/}{}r; 8 | 9 | sub usage { 10 | my $err = shift and select STDERR; 11 | say "usage: $CMD [-v[#]] [--pod]"; 12 | exit $err; 13 | } # usage 14 | 15 | use Cwd; 16 | use Pod::Text; 17 | use File::Find; 18 | use List::Util qw( first ); 19 | use Encode qw( encode decode ); 20 | use Getopt::Long qw(:config bundling); 21 | GetOptions ( 22 | "help|?" => sub { usage (0); }, 23 | "V|version" => sub { say "$CMD [$VERSION]"; exit 0; }, 24 | 25 | "p|pod!" => \ my $pod, 26 | 27 | "v|verbose:1" => \(my $opt_v = 0), 28 | ) or usage (1); 29 | 30 | -d "doc" or mkdir "doc", 0775; 31 | 32 | my @pm; # Do *NOT* scan t/ 33 | -d "lib" and find (sub { m/\.pm$/ and push @pm => $File::Find::name }, "lib"); 34 | @pm or @pm = sort glob "*.pm"; 35 | if (@pm == 0 and open my $fh, "<", "Makefile.PL") { 36 | my @mpl = <$fh>; 37 | close $fh; 38 | if (my @vf = grep m/\bVERSION_FROM\s*=>\s*(.*)/) { 39 | push @pm => $vf[0] =~ s/["']//gr; 40 | last; 41 | } 42 | if (my @ef = grep m/\bEXE_FILES\s*=>\s*\[(.*)\]/) { 43 | push @pm => eval qq{($1)}; 44 | last; 45 | } 46 | } 47 | 48 | push @pm => @ARGV; 49 | @pm = sort grep { ! -l $_ } @pm; 50 | @pm or die "No documentation source files found\n"; 51 | 52 | if ($opt_v) { 53 | say "Using these sources for static documentation:"; 54 | say " $_" for @pm; 55 | } 56 | 57 | sub dext { 58 | my ($pm, $ext) = @_; 59 | my $fn = $pm =~ s{^lib/}{}r 60 | =~ s{^(?:App|scripts|examples)/}{}r 61 | =~ s{/}{-}gr 62 | =~ s{(?:\.pm)?$}{.$ext}r # examples, scripts 63 | =~ s{^(?=CSV_XS\.)}{Text-}r 64 | =~ s{^(?=Peek\.)} {Data-}r 65 | =~ s{^(?=Read\.)} {Spreadsheet-}r 66 | =~ s{^(SpeedTest)} {\L$1}ri 67 | =~ s{^}{doc/}r; 68 | getcwd =~ m/Config-Perl/ and 69 | $fn =~ s{doc/\K}{Config-Perl-}; 70 | $fn; 71 | } # dext 72 | 73 | my %enc; 74 | my %pod; 75 | { # Check if file had pod at all 76 | foreach my $pm (@pm) { 77 | open my $fh, ">", \$pod{$pm}; 78 | Pod::Text->new->parse_from_file ($pm, $fh); 79 | close $fh; 80 | 81 | $pod && $pod{$pm} and link $pm => dext ($pm, "pod"); 82 | } 83 | } 84 | 85 | eval { require Pod::Checker; }; 86 | if ($@) { 87 | warn "Cannot convert pod to markdown: $@\n"; 88 | } 89 | else { 90 | my $fail = 0; 91 | my %ignore_empty = ( 92 | "lib/DBI/ProfileData.pm" => 7, 93 | "Peek.pm" => 4, 94 | "Read.pm" => 5, 95 | ); 96 | foreach my $pm (@pm) { 97 | open my $eh, ">", \my $err; 98 | my $pc = Pod::Checker->new (); 99 | my $ok = $pc->parse_from_file ($pm, $eh); 100 | close $eh; 101 | $enc{$pm} = $pc->{encoding}; 102 | $err && $err =~ m/\S/ or next; 103 | # Ignore warnings here on empty previous paragraphs as it 104 | # uses =head2 for all possible invocation alternatives 105 | if (my $ni = $ignore_empty{$pm}) { 106 | my $pat = qr{ WARNING: empty section }; 107 | my @err = split m/\n+/ => $err; 108 | my @wrn = grep m/$pat/ => @err; 109 | @wrn == $ni and $err = join "\n" => grep !m/$pat/ => @err; 110 | $err =~ m/\S/ or next; 111 | } 112 | say $pm; 113 | say $err; 114 | $err =~ m/ ERROR:/ and $fail++; 115 | } 116 | $fail and die "POD has errors. Fix them first!\n"; 117 | } 118 | 119 | eval { require Pod::Markdown; }; 120 | if ($@) { 121 | warn "Cannot convert pod to markdown: $@\n"; 122 | } 123 | else { 124 | foreach my $pm (@pm) { 125 | my $md = dext ($pm, "md"); 126 | my $enc = $enc{$pm} ? "encoding($enc{$pm})" : "bytes"; 127 | printf STDERR "%-43s <- %s (%s)\n", $md, $pm, $enc if $opt_v; 128 | open my $ph, "<:$enc", $pm; 129 | my $p = Pod::Markdown->new (); 130 | $p->output_string (\my $m); 131 | $p->parse_file ($ph); 132 | close $ph; 133 | 134 | $m && $m =~ m/\S/ or next; 135 | if (open my $old, "<:encoding(utf-8)", $md) { 136 | local $/; 137 | $m eq scalar <$old> and next; 138 | } 139 | $opt_v and say "Writing $md (", length $m, ")"; 140 | open my $oh, ">:encoding(utf-8)", $md or die "$md: $!\n"; 141 | print $oh $m; 142 | close $oh; 143 | } 144 | } 145 | 146 | eval { require Pod::Html; }; 147 | if ($@) { 148 | warn "Cannot convert pod to HTML: $@\n"; 149 | } 150 | else { 151 | foreach my $pm (@pm) { 152 | $pod{$pm} or next; # Skip HTML for files without pod 153 | my $html = dext ($pm, "html"); 154 | printf STDERR "%-43s <- %s (%s)\n", $html, $pm, $enc{$pm} // "-" if $opt_v; 155 | my $tf = "x_$$.html"; 156 | unlink $tf if -e $tf; 157 | Pod::Html::pod2html ("--infile=$pm", "--outfile=$tf", "--quiet"); 158 | my $h = do { local (@ARGV, $/) = ($tf); <> } =~ s/[\r\n\s]+\z/\n/r; 159 | unlink $tf if -e $tf; 160 | $h && $h =~ m/\S/ or next; 161 | if (open my $old, "<:encoding(utf-8)", $html) { 162 | local $/; 163 | $h eq scalar <$old> and next; 164 | } 165 | $opt_v and say "Writing $html (", length $h, ")"; 166 | open my $oh, ">:encoding(utf-8)", $html or die "$html: $!\n"; 167 | print $oh $h; 168 | close $oh; 169 | } 170 | unlink "pod2htmd.tmp"; 171 | } 172 | 173 | eval { require Pod::Man; }; 174 | if ($@) { 175 | warn "Cannot convert pod to man: $@\n"; 176 | } 177 | else { 178 | my $nrf = first { -x } 179 | map { "$_/nroff" } 180 | grep { length and -d } 181 | split m/:+/ => $ENV{PATH}; 182 | $opt_v and say $nrf; 183 | foreach my $pm (@pm) { 184 | my $man = dext ($pm, "3"); 185 | printf STDERR "%-43s <- %s\n", $man, $pm if $opt_v; 186 | open my $fh, ">", \my $p; 187 | Pod::Man->new (section => 3)->parse_from_file ($pm, $fh); 188 | close $fh; 189 | $p && $p =~ m/\S/ or next; 190 | $p = decode ("utf-8", $p); 191 | if (open my $old, "<:encoding(utf-8)", $man) { 192 | local $/; 193 | $p eq scalar <$old> and next; 194 | } 195 | $opt_v and say "Writing $man (", length $p, ")"; 196 | open my $oh, ">:encoding(utf-8)", $man or die "$man: $!\n"; 197 | print $oh $p; 198 | close $oh; 199 | $nrf or next; 200 | if (open my $fh, "-|", $nrf, "-mandoc", "-T", "utf8", $man) { 201 | local $/; 202 | $p = <$fh>; 203 | close $fh; 204 | $p = decode ("utf-8", $p 205 | =~ s{(?:\x{02dc}|\xcb\x9c )}{~}grx # ~ 206 | =~ s{(?:\x{02c6}|\xcb\x86 )}{^}grx # ^ 207 | =~ s{(?:\x{2018}|\xe2\x80\x98 208 | |\x{2019}|\xe2\x80\x99 )}{'}grx # ' 209 | =~ s{(?:\x{201c}|\xe2\x80\x9c 210 | |\x{201d}|\xe2\x80\x9d )}{"}grx # " 211 | =~ s{(?:\x{2212}|\xe2\x88\x92 212 | |\x{2010}|\xe2\x80\x90 )}{-}grx # - 213 | =~ s{(?:\x{2022}|\xe2\x80\xa2 )}{*}grx # BULLET 214 | =~ s{(?:\e\[|\x9b)[0-9;]*m} {}grx); # colors 215 | } 216 | 217 | my $mfn = $man =~ s/3$/man/r; 218 | if (open my $mh, "<:encoding(utf-8)", $mfn) { 219 | local $/; 220 | $p eq <$mh> and next; 221 | } 222 | $opt_v and say "Writing $mfn (", length $p, ")"; 223 | open $oh, ">:encoding(utf-8)", $mfn or die "$mfn: $!\n"; 224 | # nroff / troff / grotty cause double-encoding 225 | print $oh encode ("iso-8859-1", decode ("utf-8", $p)); 226 | close $oh; 227 | } 228 | } 229 | -------------------------------------------------------------------------------- /ChangeLog: -------------------------------------------------------------------------------- 1 | 0.54 - 2025-03-17, H.Merijn Brand 2 | * 3 | 4 | 0.53 - 2025-01-06, H.Merijn Brand 5 | * Requirements updated based on CVE's 6 | * Update to Devel::PPPort-3.72 7 | * Update doc for groff-1.24 8 | * It's 2024 9 | * Tested with perl-5.40 10 | * Added SECURITY.md 11 | * It's 2025 12 | 13 | 0.52 - 2023-01-03, H.Merijn Brand 14 | * Tested with perl-5.36.0 15 | * Update to Devel::PPPort-3.68 16 | * It's 2023 17 | 18 | 0.51 - 2022-01-01, H.Merijn Brand 19 | * It's 2021 20 | * Update to Devel::PPPort-3.63 21 | * It's 2022 22 | 23 | 0.50 - 2020-12-21, H.Merijn Brand 24 | * Update to Devel::PPPort-3.58 25 | * Prevent false negative CPANTESTERS fail reports 26 | * Prepare for perl7 27 | * Move to XSLoader 28 | * Update to Devel::PPPort-3.61 29 | * Update to Devel::PPPort-3.62 30 | * Fix META for bugtracker 31 | 32 | 0.49 - 2020-01-31, H.Merijn Brand 33 | * Add sort types N and NR 34 | * Add tests for sorting 35 | * Use DDual in void context for triplevar example 36 | * Update to Devel::PPPort-3.43 37 | * It's 2019 38 | * Update to Devel::PPPort-3.48 39 | * Changed Test::NoWarnings to Test::Warnings 40 | * Raised minimum perl to 5.8.1 41 | * Provide cpanfile 42 | * Make DHexdump work on EBCDIC/1047 (OS/390) too 43 | * Add Data::Dumper::Purity = 1 44 | * It's 2020 45 | * Update to Devel::PPPort-3.56 46 | * Add generated preformatted docs for github 47 | * Tested with 127 versions/configurations of perl: 5.8.1 .. 5.31.8 48 | 49 | 0.48 - 2018-02-26, H.Merijn Brand 50 | * Some doc cleanup 51 | * It's 2018 52 | * DDump now defaults to $_ 53 | * DP shortcut uses strict 54 | * Remove META.yml from MANIFEST.skip 55 | 56 | 0.47 - 2017-07-24, H.Merijn Brand 57 | * It's 2017 58 | * Update ppport.h to Devel::PPPort-3.36 59 | * Reserve stack space if required 60 | 61 | 0.46 - 2016-05-12, H.Merijn Brand 62 | * Skip nomemoize in old Perl::Tidy (RT#113433, Slaven) 63 | * Test with perl-5.24.0 64 | 65 | 0.45 - 2016-02-16, H.Merijn Brand 66 | * Add CONTRIBUTING.md 67 | * It's 2016 68 | * Test::More with Test2 does not preserve $! and $? 69 | 70 | 0.44 - 2015-03-25, H.Merijn Brand 71 | * DDisplay in void context consistency 72 | 73 | 0.43 - 2015-02-11, H.Merijn Brand 74 | * Move repo to github 75 | * Remove perl recommendation from META as it breaks cpan clients 76 | 77 | 0.42 - 2015-01-02, H.Merijn Brand 78 | * Prevent caching of .perltidyrc (RT#99514) 79 | * Upped copyright to 2015 80 | 81 | 0.41 - 2014-09-27, H.Merijn Brand 82 | * Add alternative test results for 5.21.5 and up (PADMY) 83 | 84 | 0.40 - 2014-02-27, H.Merijn Brand 85 | * Upped copyright to 2014 86 | * Guard Perl::Tidy against stupid user options in .perltidyrc 87 | 88 | 0.39 - 2013-08-17, H.Merijn Brand 89 | * Upped copyright to 2013 90 | * Add alternative test results for 5.19.3 and up (COW and no PV for IV) 91 | 92 | 0.38 - 2012-05-29, H.Merijn Brand 93 | * Backslashed { in regex in test to satisfy perl-5.17 94 | 95 | 0.37 - 2012-04-16, H.Merijn Brand 96 | * Upped copyright to 2012 97 | * Allow length for DHexDump () 98 | 99 | 0.36 - 2011-09-07, H.Merijn Brand 100 | * NAME / DISTNAME in Makefile.PL 101 | 102 | 0.35 - 2011-09-07, H.Merijn Brand 103 | * More cross-checks for META data 104 | 105 | 0.34 - 2011-09-01, H.Merijn Brand 106 | * Tests require Test::More-0.88 or up (RT#70538) 107 | * Tested on perl-5.14.1 and 5.15.1 108 | 109 | 0.33 - 2011-02-16, H.Merijn Brand 110 | * Added DTidy (): stream DDumper output through Perl::Tidy 111 | * Upped copyright to 2011 112 | 113 | 0.32 - 2010-11-21, H.Merijn Brand 114 | * Require perl 5.8.0 115 | * DGrow tests for bigger gap 116 | * Spell checking 117 | * Add DHexDump () 118 | 119 | 0.31 - 2010-03-16, H.Merijn Brand 120 | * Dropped YAML spec to 1.0 121 | 122 | 0.30 - 2010-02-14, H.Merijn Brand 123 | * Use $Data::Dumper::Quotekeys = 0; instead of removing the quotes myself 124 | * Put first hash element after opening lonely brace 125 | * Upped copyright to 2010 126 | * Use warn () instead of print STDERR 127 | 128 | 0.29 - 2009-11-09, H.Merijn Brand 129 | * Use skip instead of skip_all for builds that have no DPeek () 130 | * Be more lenient towards the allocated space 131 | 132 | 0.28 - 2009-11-06, H.Merijn Brand 133 | * DDump () now dumps the variable itself, instead of a copy (Zefram) 134 | * Add DGrow () 135 | 136 | 0.27 - 2009-06-03, H.Merijn Brand 137 | * void context behaviour for DPeek () 138 | * void context behaviour for DDual () 139 | 140 | 0.26 - 2009-06-03, H.Merijn Brand 141 | * Upped copyright to 2009 142 | * Corrected paren placement for bless (...) 143 | * Documentation fixes 144 | * Added Test::NoWarnings 145 | * Added DDsort () 146 | 147 | 0.25 - 2008-11-24, H.Merijn Brand 148 | * Wrong e-mail in META.yml 149 | * #34831 fixed tied $, 150 | 151 | 0.24 - 2008-10-31, H.Merijn Brand 152 | * Implement DDisplay () 153 | * Implement triplevar () 154 | * Update ppport.h to 3.14_05 (mhx++) 155 | * 5.6.x DDisplay ()'s UTF8 different 156 | * make leaktest/leakcheck enabled and executed 157 | 158 | 0.23 - 2008-10-21, H.Merijn Brand 159 | * Selecting to install DP did not install Data::Peek 160 | 161 | 0.22 - 2008-10-20, H.Merijn Brand 162 | * Updated to ppport-3.14_01 163 | * YAML declared 1.4 (META.yml) instead of 1.1 (YAML) 164 | * DP.pm gets version from Peek.pm 165 | * DP.pm should not be installed in Data namespace 166 | 167 | 0.21 - 2008-10-13, H.Merijn Brand 168 | * Typo in pod (Joshua Juran) 169 | * MSwin doesn't use plain \n (RT#39916) 170 | * Some MSWin (ActivePerl) and AIX builds do not have 171 | Perl_sv_peek () exported (RT#39916) 172 | 173 | 0.20 - 2008-10-08, H.Merijn Brand 174 | * Renamed DDumper to Data::Peek 175 | * Default argument for DPeek is $_ 176 | * Optionally install DP as shortcut for Data::Peek 177 | * Public git repo set up 178 | 179 | 0.16 - 2008-10-07, H.Merijn Brand 180 | * Allocated length for PV's depends on arch (upped test to 8) 181 | * Released on Amsterdam.pm 182 | 183 | 0.15 - 2008-09-26, H.Merijn Brand 184 | * Start writing tests for DDump () 185 | * Added DDual () 186 | 187 | 0.11 - 2008-09-25, H.Merijn Brand 188 | * PerlIO is only available in 5.8 and up 189 | * Perl 5.6 is a minimal requirement for 'use warnings' 190 | * Tests for DPeek () 191 | * 5.8.0 did not export Perl_sv_catpvn () 192 | * Tested for 5.6.2, 5.8.0, 5.8.7, 5.8.8, 5.10.0, and devel 193 | * Tests for DDumper () 194 | * Doc changes 195 | * In void context DDumper prints to STDERR 196 | 197 | 0.10 - 2008-09-24, H.Merijn Brand 198 | * Initial attempt 199 | -------------------------------------------------------------------------------- /sandbox/used-by.pl: -------------------------------------------------------------------------------- 1 | #!/pro/bin/perl 2 | 3 | use 5.016002; 4 | use warnings; 5 | 6 | our $VERSION = "1.03 - 20180301"; 7 | 8 | sub usage { 9 | my $err = shift and select STDERR; 10 | say "usage: $0 [--list]"; 11 | exit $err; 12 | } # usage 13 | 14 | use blib; 15 | use Cwd; 16 | use LWP; 17 | use LWP::UserAgent; 18 | use HTML::TreeBuilder; 19 | use CPAN; 20 | use Capture::Tiny qw( :all ); 21 | use Term::ANSIColor qw(:constants :constants256); 22 | use Test::More; 23 | 24 | use Getopt::Long qw(:config bundling passthrough); 25 | GetOptions ( 26 | "help|?" => sub { usage (0); }, 27 | "V|version" => sub { say $0 =~ s{.*/}{}r, " [$VERSION]"; exit 0; }, 28 | "a|all!" => \my $opt_a, # Also build for known FAIL (they might have fixed it) 29 | "l|list!" => \my $opt_l, 30 | ) or usage (1); 31 | 32 | my $tm = shift // do { 33 | (my $d = getcwd) =~ s{.*CPAN/([^/]+)(?:/.*)?}{$1}; 34 | $d; 35 | } or die "No module to check\n"; 36 | 37 | diag ("Testing used-by for $tm\n"); 38 | my %tm = map { $_ => 1 } qw( ); 39 | 40 | $| = 1; 41 | $ENV{AUTOMATED_TESTING} = 1; 42 | $ENV{PERL_USE_UNSAFE_INC} = 1; # My modules are not responsible 43 | # Skip all dists that 44 | # - are FAIL not due to the mudule being tested (e.g. POD or signature mismatch) 45 | # - that require interaction (not dealt with in distroprefs or %ENV) 46 | # - are not proper dists (cannot use CPAN's ->test) 47 | # - require external connections or special devices 48 | my %skip = $opt_a ? () : map { $_ => 1 } @{{ 49 | "Data-Peek" => [ 50 | "GSM-Gnokii", # External device 51 | ], 52 | "DBD-CSV" => [ 53 | "ASNMTAP", 54 | "Gtk2-Ex-DBITableFilter", # Unmet prerequisites 55 | ], 56 | "Text-CSV_XS" => [ 57 | "ACME-QuoteDB", # ::CSV Possible precedence issues 58 | "App-Framework", # Questions 59 | "ASNMTAP", # Questions 60 | "Business-Shipping-DataTools", # Questions and unmet prereqs 61 | "Catalyst-TraitFor-Model-DBIC-Schema-QueryLog-AdoptPlack", # maint/Maker.pm 62 | "CGI-Application-Framework", # Unmet prerequisites 63 | "chart", # Questions (in Apache-Wyrd) 64 | "CohortExplorer", # Unmet prerequisites 65 | "Connector", # No Makefile.PL (in Annelidous) 66 | "DBIx-Class-DigestColumns", # unmet prereqs 67 | "DBIx-Class-FilterColumn-ByType", # ::CSV - unmet prereqs 68 | "DBIx-Class-FormTools", # ::CSV POD 69 | "DBIx-Class-FromSledge", # ::CSV Spelling 70 | "DBIx-Class-Graph", # won't build at all 71 | "DBIx-Class-InflateColumn-Serializer-CompressJSON", # ::CSV POD 72 | "DBIx-Class-Loader", # ::CSV Deprecated 73 | "DBIx-Class-QueryProfiler", # ::CSV - Kwalitee test (2011) 74 | "DBIx-Class-RDBOHelpers", # ::CSV - Unmet prereqs 75 | "DBIx-Class-Schema-Slave", # ::CSV - Tests br0ken 76 | "DBIx-Class-Snowflake", # ::CSV - Bad tests. SQLite fail 77 | "DBIx-Class-StorageReadOnly", # ::CSV - POD coverage 78 | "DBIx-NoSQL", # ::CSV - Syntax 79 | "DBIx-Patcher", # ::CSV - Own tests fail 80 | "dbMan", # Questions 81 | "Finance-Bank-DE-NetBank", # Module signatures 82 | "FormValidator-Nested", # ::CSV - Questions 83 | "FreeRADIUS-Database", # ::CSV - Questions 84 | "Fsdb", # ::CSV - 85 | "Geo-USCensus-Geocoding", # '302 Found' 86 | "Gtk2-Ex-DBITableFilter", # Unmet prerequisites 87 | "Gtk2-Ex-Threads-DBI", # Distribution is incomplete 88 | "hwd", # Own tests fail 89 | "Iterator-BreakOn", # ::CSV - Syntax, POD, badness 90 | "Mail-Karmasphere-Client", # ::CSV - No karmaclient 91 | "Module-CPANTS-ProcessCPAN", # ::CSV - Questions 92 | "Module-CPANTS-Site", # ::CSV - Unmet prerequisites 93 | "Net-IPFromZip", # Missing zip file(s) 94 | "Parse-CSV-Colnames", # ::CSV - Fails because of Parse::CSV 95 | "Plack-Middleware-DBIC-QueryLog", # maint/Maker.pm 96 | "Plack-Middleware-Debug-DBIC-QueryLog", # maint/Maker.pm 97 | "RDF-RDB2RDF", # ::CSV - Bad tests 98 | "RT-Extension-Assets-Import-CSV", # Questions 99 | "RT-View-ConciseSpreadsheet", # Questions 100 | "Serge", # Questions in Build.PL ? 101 | "Test-DBIC", # ::CSV - Insecure -T in C3 102 | # "Text-CSV-Encoded", # ::CSV - Encoding, patch filed at RT 103 | "Text-CSV_PP-Simple", # ::CSV - Syntax errors, bad archive 104 | # "Text-CSV-Track", # Encoding, patch filed at RT 105 | "Text-ECSV", # POD, spelling 106 | "Text-MeCab", # Questions 107 | "Text-TEI-Collate", # Unmet prerequisites 108 | "Text-Tradition", # Unmet prerequisites 109 | "Text-xSV-Slurp", # 5.26 incompat, unmaintained 110 | "Tripletail", # Makefile.PL broken 111 | "VANAMBURG-SEMPROG-SimpleGraph", # Own tests fail 112 | "WebService-FuncNet", # ::CSV - WSDL 404, POD 113 | "Webservice-InterMine", # Unmet prerequisites 114 | "WWW-Analytics-MultiTouch", # Unmet prerequisites 115 | "XAS", # ::CSV - No STOMP MQ 116 | "XAS-Model", # ::CSV - No STOMP MQ 117 | "XAS-Spooler", # ::CSV - No STOMP MQ 118 | "xDash", # Questions 119 | # "xls2csv", 120 | "Xymon-DB-Schema", # ::CSV - Bad prereqs 121 | "Xymon-Server-ExcelOutages", # ::CSV - Questions 122 | "YamlTime", # Unmet prerequisites 123 | ], 124 | }->{$tm} // []}; 125 | my %add = ( 126 | "Text-CSV_XS" => [ # Using Text::CSV, thus 127 | "Text-CSV-Auto", # optionally _XS 128 | "Text-CSV-R", 129 | "Text-CSV-Slurp", 130 | ], 131 | ); 132 | 133 | my $ua = LWP::UserAgent->new (agent => "Opera/12.15"); 134 | 135 | sub get_from_cpantesters { 136 | my $m = shift // $tm; 137 | warn "Get from cpantesters ...\n"; 138 | my @h; 139 | foreach my $url ( 140 | "http://deps.cpantesters.org/depended-on-by.pl?dist=$m", 141 | "http://deps.cpantesters.org/depended-on-by.pl?module=$m", 142 | ) { 143 | my $rsp = $ua->request (HTTP::Request->new (GET => $url)); 144 | unless ($rsp->is_success) { 145 | warn "deps failed: ", $rsp->status_line, "\n"; 146 | next; 147 | } 148 | my $tree = HTML::TreeBuilder->new; 149 | $tree->parse_content ($rsp->content); 150 | foreach my $a ($tree->look_down (_tag => "a", href => qr{query=})) { 151 | (my $h = $a->attr ("href")) =~ s{.*=}{}; 152 | push @h, $h; 153 | } 154 | } 155 | return @h; 156 | } # get_from_cpantesters 157 | 158 | sub get_from_cpants { 159 | my $m = shift // $tm; 160 | warn "Get from cpants ...\n"; 161 | my $url = "http://cpants.cpanauthors.org/dist/$m/used_by"; 162 | my $rsp = $ua->request (HTTP::Request->new (GET => $url)); 163 | unless ($rsp->is_success) { 164 | warn "cpants failed: ", $rsp->status_line, "\n"; 165 | return; 166 | } 167 | my $tree = HTML::TreeBuilder->new; 168 | $tree->parse_content ($rsp->content); 169 | my @h; 170 | foreach my $a ($tree->look_down (_tag => "a", href => qr{/dist/})) { 171 | (my $h = $a->attr ("href")) =~ s{.*dist/}{}; 172 | $h =~ m{^$m\b} and next; 173 | push @h, $h; 174 | } 175 | @h or diag ("$url might be rebuilding"); 176 | return @h; 177 | } # get_from_cpants 178 | 179 | sub get_from_meta { 180 | my $m = shift // $tm; 181 | warn "Get from meta ...\n"; 182 | my $url = "https://metacpan.org/requires/distribution/$m"; 183 | my $rsp = $ua->request (HTTP::Request->new (GET => $url)); 184 | unless ($rsp->is_success) { 185 | warn "meta failed: ", $rsp->status_line, "\n"; 186 | return; 187 | } 188 | my $tree = HTML::TreeBuilder->new; 189 | $tree->parse_content ($rsp->content); 190 | my @h; 191 | foreach my $a ($tree->look_down (_tag => "a", class => "ellipsis", 192 | href => qr{/release/})) { 193 | (my $h = $a->attr ("href")) =~ s{.*release/}{}; 194 | $h =~ m{^$m\b} and next; 195 | push @h, $h; 196 | } 197 | return @h; 198 | } # get_from_meta 199 | 200 | sub get_from_sandbox { 201 | open my $fh, "<", "sandbox/used-by.txt" or return; 202 | map { chomp; $_ } <$fh>; 203 | } # get_from_sandbox 204 | 205 | my @h = ( get_from_cpants (), 206 | get_from_cpantesters (), 207 | get_from_meta (), 208 | get_from_sandbox (), 209 | @{$add{$tm} || []}); 210 | 211 | $tm eq "Text-CSV_XS" and push @h, 212 | get_from_cpants ("Text-CSV"), 213 | get_from_cpantesters ("Text-CSV"), 214 | get_from_meta ("Text-CSV"); 215 | 216 | foreach my $h (@h) { 217 | exists $skip{$h} || $h =~ m{^( $tm (?: $ | / ) 218 | | Task- 219 | | Bundle- 220 | | Win32- 221 | )\b}x and next; 222 | (my $m = $h) =~ s/-/::/g; 223 | $tm{$m} = 1; 224 | } 225 | 226 | warn "fetched ", scalar keys %tm, " keys\n"; 227 | 228 | unless (keys %tm) { 229 | ok (1, "No dependents found"); 230 | done_testing; 231 | exit 0; 232 | } 233 | 234 | if ($opt_l) { 235 | ok (1, $_) for sort keys %tm; 236 | done_testing; 237 | exit 0; 238 | } 239 | 240 | my %rslt; 241 | foreach my $m (sort keys %tm) { 242 | my $mod = CPAN::Shell->expand ("Module", "/$m/") or next; 243 | # diag $m; 244 | $rslt{$m} = [ [], capture { $mod->test } ]; 245 | $rslt{$m}[0] = [ $?, $!, $@ ]; 246 | # say $? ? RED."FAIL".RESET : GREEN."PASS".RESET; 247 | is ($?, 0, $m); 248 | } 249 | 250 | done_testing; 251 | -------------------------------------------------------------------------------- /doc/Data-Peek.md: -------------------------------------------------------------------------------- 1 | # NAME 2 | 3 | Data::Peek - A collection of low-level debug facilities 4 | 5 | # SYNOPSIS 6 | 7 | use Data::Peek; 8 | 9 | print DDumper \%hash; # Same syntax as Data::Dumper 10 | DTidy { ref => $ref }; 11 | 12 | print DPeek \$var; 13 | my ($pv, $iv, $nv, $rv, $magic) = DDual ($var [, 1]); 14 | print DPeek for DDual ($!, 1); 15 | print DDisplay ("ab\nc\x{20ac}\rdef\n"); 16 | print DHexDump ("ab\nc\x{20ac}\rdef\n"); 17 | 18 | my $dump = DDump $var; 19 | my %hash = DDump \@list; 20 | DDump \%hash; 21 | 22 | my %hash = DDump (\%hash, 5); # dig 5 levels deep 23 | 24 | my $dump; 25 | open my $fh, ">", \$dump; 26 | DDump_IO ($fh, \%hash, 6); 27 | close $fh; 28 | print $dump; 29 | 30 | # Imports 31 | use Data::Peek qw( :tidy VNR DGrow triplevar ); 32 | my $x = ""; DGrow ($x, 10000); 33 | my $tv = triplevar ("\N{GREEK SMALL LETTER PI}", 3, "3.1415"); 34 | DDsort ("R"); 35 | DDumper [ $x ]; # use of :tidy makes DDumper behave like DTidy 36 | 37 | # DESCRIPTION 38 | 39 | Data::Peek started off as `DDumper` being a wrapper module over 40 | [Data::Dumper](https://metacpan.org/pod/Data%3A%3ADumper), but grew out to be a set of low-level data 41 | introspection utilities that no other module provided yet, using the 42 | lowest level of the perl internals API as possible. 43 | 44 | ## DDumper ($var, ...) 45 | 46 | Not liking the default output of Data::Dumper, and always feeling the need 47 | to set `$Data::Dumper::Sortkeys = 1;`, and not liking any of the default 48 | layouts, this function is just a wrapper around Data::Dumper::Dumper with 49 | everything set as I like it. 50 | 51 | $Data::Dumper::Sortkeys = 1; 52 | $Data::Dumper::Indent = 1; 53 | 54 | If `Data::Peek` is `use`d with import argument `:tidy`, the result is 55 | formatted according to [Perl::Tidy](https://metacpan.org/pod/Perl%3A%3ATidy), see [DTidy](https://metacpan.org/pod/DTidy) below, otherwise the 56 | result is further beautified to meet my needs: 57 | 58 | * quotation of hash keys has been removed (with the disadvantage 59 | that the output might not be parseable again). 60 | * arrows for hashes are aligned at 16 (longer keys don't align) 61 | * closing braces and brackets are now correctly aligned 62 | 63 | In void context, `DDumper` `warn`'s. 64 | 65 | Example 66 | 67 | $ perl -MDP \ 68 | -e'DDumper { ape => 1, foo => "egg", bar => [ 2, "baz", undef ]};' 69 | 70 | { ape => 1, 71 | bar => [ 72 | 2, 73 | 'baz', 74 | undef 75 | ], 76 | foo => 'egg' 77 | }; 78 | 79 | ## DTidy ($var, ...) 80 | 81 | `DTidy` is an alternative to `DDumper`, where the output of `DDumper` 82 | is formatted using `Perl::Tidy` (if available) according to your 83 | `.perltidyrc` instead of the default behavior, maybe somewhat like (YMMV): 84 | 85 | $ perl -MDP=:tidy \ 86 | -we'DDumper { ape => 1, foo => "egg", bar => [ 2, "baz", undef ]};' 87 | { 'ape' => 1, 88 | 'bar' => [2, 'baz', undef], 89 | 'foo' => 'egg' 90 | } 91 | 92 | If `Data::Peek` is `use`d with import argument `:tidy`, this is the 93 | default output method for `DDumper`. 94 | 95 | If [Perl::Tidy](https://metacpan.org/pod/Perl%3A%3ATidy) is not available, `DTidy` will fallback to `DDumper`. 96 | 97 | This idea was shamelessly copied from John McNamara's [Data::Dumper::Perltidy](https://metacpan.org/pod/Data%3A%3ADumper%3A%3APerltidy). 98 | 99 | ## DDsort ( 0 | 1 | R | N | NR | V | VR | VN | VNR ) 100 | 101 | Set the hash sort algorithm for DDumper. The default is to sort by key value. 102 | 103 | 0 - Do not sort 104 | 1 - Sort by key 105 | R - Reverse sort by key 106 | N - Sort by key numerical 107 | NR - Sort by key numerical descending 108 | V - Sort by value 109 | VR - Reverse sort by value 110 | VN - Sort by value numerical 111 | VNR - Reverse sort by value numerical 112 | 113 | These can also be passed to import: 114 | 115 | $ perl -MDP=VNR \ 116 | -we'DDumper { foo => 1, bar => 2, zap => 3, gum => 13 }' 117 | { gum => 13, 118 | zap => 3, 119 | bar => 2, 120 | foo => 1 121 | }; 122 | $ perl -MDP=V \ 123 | -we'DDumper { foo => 1, bar => 2, zap => 3, gum => 13 }' 124 | { foo => 1, 125 | gum => 13, 126 | bar => 2, 127 | zap => 3 128 | }; 129 | 130 | ## DPeek 131 | 132 | ## DPeek ($var) 133 | 134 | Playing with `sv_dump`, I found `Perl_sv_peek`, and it might be very 135 | useful for simple checks. If `$var` is omitted, uses $\_. 136 | 137 | Example 138 | 139 | print DPeek "abc\x{0a}de\x{20ac}fg"; 140 | 141 | PV("abc\nde\342\202\254fg"\0) [UTF8 "abc\nde\x{20ac}fg"] 142 | 143 | In void context, `DPeek` prints to `STDERR` plus a newline. 144 | 145 | ## DDisplay 146 | 147 | ## DDisplay ($var) 148 | 149 | Show the PV content of a scalar the way perl debugging would have done. 150 | UTF-8 detection is on, so this is effectively the same as returning the 151 | first part the `DPeek` returns for non-UTF8 PV's or the second part for 152 | UTF-8 PV's. `DDisplay` returns the empty string for scalars that no 153 | have a valid PV. 154 | 155 | Example 156 | 157 | print DDisplay "abc\x{0a}de\x{20ac}fg"; 158 | 159 | "abc\nde\x{20ac}fg" 160 | 161 | In void context, `DDisplay` uses `warn` to display the result. 162 | 163 | ## DHexDump 164 | 165 | ## DHexDump ($var) 166 | 167 | ## DHexDump ($var, $length) 168 | 169 | Show the (stringified) content of a scalar as a hex-dump. If `$var` 170 | is omitted, `$_` is dumped. Returns `undef` or an empty list if 171 | `$var` (or `$_`) is undefined. If `$length` is given and is lower than 172 | the length of the stringified `$var`, only <$length> bytes are dumped. 173 | 174 | In void context, the dump is done to STDERR. In scalar context, the 175 | complete dump is returned as a single string. In list context, the dump 176 | is returned as lines. 177 | 178 | Example 179 | 180 | print DHexDump "abc\x{0a}de\x{20ac}fg"; 181 | 182 | 0000 61 62 63 0a 64 65 e2 82 ac 66 67 abc.de...fg 183 | 184 | ## my ($pv, $iv, $nv, $rv, $hm) = DDual ($var \[, $getmagic\]) 185 | 186 | DDual will return the basic elements in a variable, guaranteeing that no 187 | conversion takes place. This is very useful for dual-var variables, or 188 | when checking is a variable has defined entries for a certain type of 189 | scalar. For each String (PV), Integer (IV), Double (NV), and Reference (RV), 190 | the current value of `$var` is returned or undef if it is not set (yet). 191 | The 5th element is an indicator if `$var` has magic, which is **not** invoked 192 | in the returned values, unless explicitly asked for with a true optional 193 | second argument. 194 | 195 | Example 196 | 197 | print DPeek for DDual ($!, 1); 198 | 199 | In void context, DDual does the equivalent of 200 | 201 | { my @d = DDual ($!, 1); 202 | print STDERR 203 | DPeek ($!), "\n", 204 | " PV: ", DPeek ($d[0]), "\n", 205 | " IV: ", DPeek ($d[1]), "\n", 206 | " NV: ", DPeek ($d[2]), "\n", 207 | " RV: ", DPeek ($d[3]), "\n"; 208 | } 209 | 210 | ## my $len = DGrow ($pv, $size) 211 | 212 | Fastest way to preallocate space for a PV scalar. Returns the allocated 213 | length. If $size is smaller than the already allocated space, it will 214 | not shrink. 215 | 216 | cmpthese (-2, { 217 | pack => q{my $x = ""; $x = pack "x20000"; $x = "";}, 218 | op_x => q{my $x = ""; $x = "x" x 20000; $x = "";}, 219 | grow => q{my $x = ""; DGrow ($x, 20000); $x = "";}, 220 | }); 221 | 222 | Rate op_x pack grow 5.8.9 5.10.1 5.12.4 5.14.2 223 | op_x 62127/s -- -59% -96% 118606/s 119730/s 352255/s 362605/s 224 | pack 152046/s 145% -- -91% 380075/s 355666/s 347247/s 387349/s 225 | grow 1622943/s 2512% 967% -- 2818380/s 2918783/s 2672340/s 2886787/s 226 | 227 | ## my $tp = triplevar ($pv, $iv, $nv) 228 | 229 | When making `DDual` I wondered if it were possible to create triple-val 230 | scalar variables. [Scalar::Util](https://metacpan.org/pod/Scalar%3A%3AUtil) already gives us `dualvar`, that creates 231 | you a scalar with different numeric and string values that return different 232 | values in different context. Not that `triplevar` would be very useful, 233 | compared to `dualvar`, but at least this shows that it is possible. 234 | 235 | `triplevar` is not exported by default. 236 | 237 | Example: 238 | 239 | DDual Data::Peek::triplevar ("\N{GREEK SMALL LETTER PI}", 3, 3.1415); 240 | 241 | PVNV("\317\200"\0) [UTF8 "\x{3c0}"] 242 | PV: PV("\317\200"\0) [UTF8 "\x{3c0}"] 243 | IV: IV(3) 244 | NV: NV(3.1415) 245 | RV: SV_UNDEF 246 | 247 | ## DDump (\[$var \[, $dig\_level\]\]) 248 | 249 | A very useful module when debugging is `Devel::Peek`, but is has one big 250 | disadvantage: it only prints to STDERR, which is not very handy when your 251 | code wants to inspect variables at a low level. 252 | 253 | Perl itself has `sv_dump`, which does something similar, but still prints 254 | to STDERR, and only one level deep. 255 | 256 | `DDump` is an attempt to make the innards available to the script level 257 | with a reasonable level of compatibility. `DDump` is context sensitive. 258 | 259 | In void context, it behaves exactly like `Perl_sv_dump`. 260 | 261 | In scalar context, it returns what `Perl_sv_dump` would have printed. 262 | 263 | The default for the first argument is `$_`. 264 | 265 | In list context, it returns a hash of the variable's properties. In this mode 266 | you can pass an optional second argument that determines the depth of digging. 267 | 268 | Example 269 | 270 | print scalar DDump "abc\x{0a}de\x{20ac}fg" 271 | 272 | SV = PV(0x723250) at 0x8432b0 273 | REFCNT = 1 274 | FLAGS = (PADBUSY,PADMY,POK,pPOK,UTF8) 275 | PV = 0x731ac0 "abc\nde\342\202\254fg"\0 [UTF8 "abc\nde\x{20ac}fg"] 276 | CUR = 11 277 | LEN = 16 278 | 279 | my %h = DDump "abc\x{0a}de\x{20ac}fg"; 280 | print DDumper \%h; 281 | 282 | { CUR => '11', 283 | FLAGS => { 284 | PADBUSY => 1, 285 | PADMY => 1, 286 | POK => 1, 287 | UTF8 => 1, 288 | pPOK => 1 289 | }, 290 | LEN => '16', 291 | PV => '0x731ac0 "abc\\nde\\342\\202\\254fg"\\0 [UTF8 "abc\\nde\\x{20ac}fg"]', 292 | REFCNT => '1', 293 | sv => 'PV(0x723250) at 0x8432c0' 294 | }; 295 | 296 | my %h = DDump { 297 | ape => 1, 298 | foo => "egg", 299 | bar => [ 2, "baz", undef ], 300 | }, 1; 301 | print DDumper \%h; 302 | 303 | { FLAGS => { 304 | PADBUSY => 1, 305 | PADMY => 1, 306 | ROK => 1 307 | }, 308 | REFCNT => '1', 309 | RV => { 310 | PVIV("ape") => { 311 | FLAGS => { 312 | IOK => 1, 313 | PADBUSY => 1, 314 | PADMY => 1, 315 | pIOK => 1 316 | }, 317 | IV => '1', 318 | REFCNT => '1', 319 | sv => 'IV(0x747020) at 0x843a10' 320 | }, 321 | PVIV("bar") => { 322 | CUR => '0', 323 | FLAGS => { 324 | PADBUSY => 1, 325 | PADMY => 1, 326 | ROK => 1 327 | }, 328 | IV => '1', 329 | LEN => '0', 330 | PV => '0x720210 ""', 331 | REFCNT => '1', 332 | RV => '0x720210', 333 | sv => 'PVIV(0x7223e0) at 0x843a10' 334 | }, 335 | PVIV("foo") => { 336 | CUR => '3', 337 | FLAGS => { 338 | PADBUSY => 1, 339 | PADMY => 1, 340 | POK => 1, 341 | pPOK => 1 342 | }, 343 | IV => '1', 344 | LEN => '8', 345 | PV => '0x7496c0 "egg"\\0', 346 | REFCNT => '1', 347 | sv => 'PVIV(0x7223e0) at 0x843a10' 348 | } 349 | }, 350 | sv => 'RV(0x79d058) at 0x843310' 351 | }; 352 | 353 | ## DDump\_IO ($io, $var \[, $dig\_level\]) 354 | 355 | A wrapper function around perl's internal `Perl_do_sv_dump`, which 356 | makes `Devel::Peek` completely superfluous. 357 | 358 | Example 359 | 360 | my $dump; 361 | open my $eh, ">", \$dump; 362 | DDump_IO ($eh, { 3 => 4, ape => [5..8]}, 6); 363 | close $eh; 364 | print $dump; 365 | 366 | SV = RV(0x79d9e0) at 0x843f00 367 | REFCNT = 1 368 | FLAGS = (TEMP,ROK) 369 | RV = 0x741090 370 | SV = PVHV(0x79c948) at 0x741090 371 | REFCNT = 1 372 | FLAGS = (SHAREKEYS) 373 | IV = 2 374 | NV = 0 375 | ARRAY = 0x748ff0 (0:7, 2:1) 376 | hash quality = 62.5% 377 | KEYS = 2 378 | FILL = 1 379 | MAX = 7 380 | RITER = -1 381 | EITER = 0x0 382 | Elt "ape" HASH = 0x97623e03 383 | SV = RV(0x79d9d8) at 0x8440e0 384 | REFCNT = 1 385 | FLAGS = (ROK) 386 | RV = 0x741470 387 | SV = PVAV(0x7264b0) at 0x741470 388 | REFCNT = 2 389 | FLAGS = () 390 | IV = 0 391 | NV = 0 392 | ARRAY = 0x822f70 393 | FILL = 3 394 | MAX = 3 395 | ARYLEN = 0x0 396 | FLAGS = (REAL) 397 | Elt No. 0 398 | SV = IV(0x7467c8) at 0x7c1aa0 399 | REFCNT = 1 400 | FLAGS = (IOK,pIOK) 401 | IV = 5 402 | Elt No. 1 403 | SV = IV(0x7467b0) at 0x8440f0 404 | REFCNT = 1 405 | FLAGS = (IOK,pIOK) 406 | IV = 6 407 | Elt No. 2 408 | SV = IV(0x746810) at 0x75be00 409 | REFCNT = 1 410 | FLAGS = (IOK,pIOK) 411 | IV = 7 412 | Elt No. 3 413 | SV = IV(0x746d38) at 0x7799d0 414 | REFCNT = 1 415 | FLAGS = (IOK,pIOK) 416 | IV = 8 417 | Elt "3" HASH = 0xa400c7f3 418 | SV = IV(0x746fd0) at 0x7200e0 419 | REFCNT = 1 420 | FLAGS = (IOK,pIOK) 421 | IV = 4 422 | 423 | # INTERNALS 424 | 425 | `DDump` uses an XS wrapper around `Perl_sv_dump` where the STDERR is 426 | temporarily caught to a pipe. The internal XS helper functions are not 427 | meant for user space 428 | 429 | ## DDump\_XS (SV \*sv) 430 | 431 | Base interface to internals for `DDump`. 432 | 433 | # BUGS 434 | 435 | Windows and AIX might be using a build where not all symbols that were 436 | supposed to be exported in the public API are not. `Perl_pv_peek` is 437 | one of them. 438 | 439 | Not all types of references are supported. 440 | 441 | No idea how far back this goes in perl support, but Devel::PPPort has 442 | proven to be a big help. 443 | 444 | # SEE ALSO 445 | 446 | [Devel::Peek](https://metacpan.org/pod/Devel%3A%3APeek), [Data::Dumper](https://metacpan.org/pod/Data%3A%3ADumper), [Data::Dump](https://metacpan.org/pod/Data%3A%3ADump), [Devel::Dumpvar](https://metacpan.org/pod/Devel%3A%3ADumpvar), 447 | [Data::Dump::Streamer](https://metacpan.org/pod/Data%3A%3ADump%3A%3AStreamer), [Data::Dumper::Perltidy](https://metacpan.org/pod/Data%3A%3ADumper%3A%3APerltidy), [Perl::Tidy](https://metacpan.org/pod/Perl%3A%3ATidy). 448 | 449 | # AUTHOR 450 | 451 | H.Merijn Brand 452 | 453 | # COPYRIGHT AND LICENSE 454 | 455 | Copyright (C) 2008-2025 H.Merijn Brand 456 | 457 | This library is free software; you can redistribute it and/or modify 458 | it under the same terms as Perl itself. 459 | -------------------------------------------------------------------------------- /doc/Data-Peek.man: -------------------------------------------------------------------------------- 1 | Peek(3) User Contributed Perl Documentation Peek(3) 2 | 3 | NAME 4 | Data::Peek - A collection of low-level debug facilities 5 | 6 | SYNOPSIS 7 | use Data::Peek; 8 | 9 | print DDumper \%hash; # Same syntax as Data::Dumper 10 | DTidy { ref => $ref }; 11 | 12 | print DPeek \$var; 13 | my ($pv, $iv, $nv, $rv, $magic) = DDual ($var [, 1]); 14 | print DPeek for DDual ($!, 1); 15 | print DDisplay ("ab\nc\x{20ac}\rdef\n"); 16 | print DHexDump ("ab\nc\x{20ac}\rdef\n"); 17 | 18 | my $dump = DDump $var; 19 | my %hash = DDump \@list; 20 | DDump \%hash; 21 | 22 | my %hash = DDump (\%hash, 5); # dig 5 levels deep 23 | 24 | my $dump; 25 | open my $fh, ">", \$dump; 26 | DDump_IO ($fh, \%hash, 6); 27 | close $fh; 28 | print $dump; 29 | 30 | # Imports 31 | use Data::Peek qw( :tidy VNR DGrow triplevar ); 32 | my $x = ""; DGrow ($x, 10000); 33 | my $tv = triplevar ("\N{GREEK SMALL LETTER PI}", 3, "3.1415"); 34 | DDsort ("R"); 35 | DDumper [ $x ]; # use of :tidy makes DDumper behave like DTidy 36 | 37 | DESCRIPTION 38 | Data::Peek started off as "DDumper" being a wrapper module over 39 | Data::Dumper, but grew out to be a set of low-level data introspection 40 | utilities that no other module provided yet, using the lowest level of 41 | the perl internals API as possible. 42 | 43 | DDumper ($var, ...) 44 | Not liking the default output of Data::Dumper, and always feeling the 45 | need to set "$Data::Dumper::Sortkeys = 1;", and not liking any of the 46 | default layouts, this function is just a wrapper around 47 | Data::Dumper::Dumper with everything set as I like it. 48 | 49 | $Data::Dumper::Sortkeys = 1; 50 | $Data::Dumper::Indent = 1; 51 | 52 | If "Data::Peek" is "use"d with import argument ":tidy", the result is 53 | formatted according to Perl::Tidy, see DTidy below, otherwise the 54 | result is further beautified to meet my needs: 55 | 56 | * quotation of hash keys has been removed (with the disadvantage 57 | that the output might not be parseable again). 58 | * arrows for hashes are aligned at 16 (longer keys don't align) 59 | * closing braces and brackets are now correctly aligned 60 | 61 | In void context, "DDumper" "warn"'s. 62 | 63 | Example 64 | 65 | $ perl -MDP \ 66 | -e'DDumper { ape => 1, foo => "egg", bar => [ 2, "baz", undef ]};' 67 | 68 | { ape => 1, 69 | bar => [ 70 | 2, 71 | 'baz', 72 | undef 73 | ], 74 | foo => 'egg' 75 | }; 76 | 77 | DTidy ($var, ...) 78 | "DTidy" is an alternative to "DDumper", where the output of "DDumper" 79 | is formatted using "Perl::Tidy" (if available) according to your 80 | ".perltidyrc" instead of the default behavior, maybe somewhat like 81 | (YMMV): 82 | 83 | $ perl -MDP=:tidy \ 84 | -we'DDumper { ape => 1, foo => "egg", bar => [ 2, "baz", undef ]};' 85 | { 'ape' => 1, 86 | 'bar' => [2, 'baz', undef], 87 | 'foo' => 'egg' 88 | } 89 | 90 | If "Data::Peek" is "use"d with import argument ":tidy", this is the 91 | default output method for "DDumper". 92 | 93 | If Perl::Tidy is not available, "DTidy" will fallback to "DDumper". 94 | 95 | This idea was shamelessly copied from John McNamara's 96 | Data::Dumper::Perltidy. 97 | 98 | DDsort ( 0 | 1 | R | N | NR | V | VR | VN | VNR ) 99 | Set the hash sort algorithm for DDumper. The default is to sort by key 100 | value. 101 | 102 | 0 - Do not sort 103 | 1 - Sort by key 104 | R - Reverse sort by key 105 | N - Sort by key numerical 106 | NR - Sort by key numerical descending 107 | V - Sort by value 108 | VR - Reverse sort by value 109 | VN - Sort by value numerical 110 | VNR - Reverse sort by value numerical 111 | 112 | These can also be passed to import: 113 | 114 | $ perl -MDP=VNR \ 115 | -we'DDumper { foo => 1, bar => 2, zap => 3, gum => 13 }' 116 | { gum => 13, 117 | zap => 3, 118 | bar => 2, 119 | foo => 1 120 | }; 121 | $ perl -MDP=V \ 122 | -we'DDumper { foo => 1, bar => 2, zap => 3, gum => 13 }' 123 | { foo => 1, 124 | gum => 13, 125 | bar => 2, 126 | zap => 3 127 | }; 128 | 129 | DPeek 130 | DPeek ($var) 131 | Playing with "sv_dump", I found "Perl_sv_peek", and it might be very 132 | useful for simple checks. If $var is omitted, uses $_. 133 | 134 | Example 135 | 136 | print DPeek "abc\x{0a}de\x{20ac}fg"; 137 | 138 | PV("abc\nde\342\202\254fg"\0) [UTF8 "abc\nde\x{20ac}fg"] 139 | 140 | In void context, "DPeek" prints to "STDERR" plus a newline. 141 | 142 | DDisplay 143 | DDisplay ($var) 144 | Show the PV content of a scalar the way perl debugging would have done. 145 | UTF-8 detection is on, so this is effectively the same as returning the 146 | first part the "DPeek" returns for non-UTF8 PV's or the second part for 147 | UTF-8 PV's. "DDisplay" returns the empty string for scalars that no 148 | have a valid PV. 149 | 150 | Example 151 | 152 | print DDisplay "abc\x{0a}de\x{20ac}fg"; 153 | 154 | "abc\nde\x{20ac}fg" 155 | 156 | In void context, "DDisplay" uses "warn" to display the result. 157 | 158 | DHexDump 159 | DHexDump ($var) 160 | DHexDump ($var, $length) 161 | Show the (stringified) content of a scalar as a hex-dump. If $var is 162 | omitted, $_ is dumped. Returns "undef" or an empty list if $var (or $_) 163 | is undefined. If $length is given and is lower than the length of the 164 | stringified $var, only <$length> bytes are dumped. 165 | 166 | In void context, the dump is done to STDERR. In scalar context, the 167 | complete dump is returned as a single string. In list context, the dump 168 | is returned as lines. 169 | 170 | Example 171 | 172 | print DHexDump "abc\x{0a}de\x{20ac}fg"; 173 | 174 | 0000 61 62 63 0a 64 65 e2 82 ac 66 67 abc.de...fg 175 | 176 | my ($pv, $iv, $nv, $rv, $hm) = DDual ($var [, $getmagic]) 177 | DDual will return the basic elements in a variable, guaranteeing that 178 | no conversion takes place. This is very useful for dual-var variables, 179 | or when checking is a variable has defined entries for a certain type 180 | of scalar. For each String (PV), Integer (IV), Double (NV), and 181 | Reference (RV), the current value of $var is returned or undef if it is 182 | not set (yet). The 5th element is an indicator if $var has magic, 183 | which is not invoked in the returned values, unless explicitly asked 184 | for with a true optional second argument. 185 | 186 | Example 187 | 188 | print DPeek for DDual ($!, 1); 189 | 190 | In void context, DDual does the equivalent of 191 | 192 | { my @d = DDual ($!, 1); 193 | print STDERR 194 | DPeek ($!), "\n", 195 | " PV: ", DPeek ($d[0]), "\n", 196 | " IV: ", DPeek ($d[1]), "\n", 197 | " NV: ", DPeek ($d[2]), "\n", 198 | " RV: ", DPeek ($d[3]), "\n"; 199 | } 200 | 201 | my $len = DGrow ($pv, $size) 202 | Fastest way to preallocate space for a PV scalar. Returns the allocated 203 | length. If $size is smaller than the already allocated space, it will 204 | not shrink. 205 | 206 | cmpthese (-2, { 207 | pack => q{my $x = ""; $x = pack "x20000"; $x = "";}, 208 | op_x => q{my $x = ""; $x = "x" x 20000; $x = "";}, 209 | grow => q{my $x = ""; DGrow ($x, 20000); $x = "";}, 210 | }); 211 | 212 | Rate op_x pack grow 5.8.9 5.10.1 5.12.4 5.14.2 213 | op_x 62127/s -- -59% -96% 118606/s 119730/s 352255/s 362605/s 214 | pack 152046/s 145% -- -91% 380075/s 355666/s 347247/s 387349/s 215 | grow 1622943/s 2512% 967% -- 2818380/s 2918783/s 2672340/s 2886787/s 216 | 217 | my $tp = triplevar ($pv, $iv, $nv) 218 | When making "DDual" I wondered if it were possible to create triple-val 219 | scalar variables. Scalar::Util already gives us "dualvar", that creates 220 | you a scalar with different numeric and string values that return 221 | different values in different context. Not that "triplevar" would be 222 | very useful, compared to "dualvar", but at least this shows that it is 223 | possible. 224 | 225 | "triplevar" is not exported by default. 226 | 227 | Example: 228 | 229 | DDual Data::Peek::triplevar ("\N{GREEK SMALL LETTER PI}", 3, 3.1415); 230 | 231 | PVNV("\317\200"\0) [UTF8 "\x{3c0}"] 232 | PV: PV("\317\200"\0) [UTF8 "\x{3c0}"] 233 | IV: IV(3) 234 | NV: NV(3.1415) 235 | RV: SV_UNDEF 236 | 237 | DDump ([$var [, $dig_level]]) 238 | A very useful module when debugging is "Devel::Peek", but is has one 239 | big disadvantage: it only prints to STDERR, which is not very handy 240 | when your code wants to inspect variables at a low level. 241 | 242 | Perl itself has "sv_dump", which does something similar, but still 243 | prints to STDERR, and only one level deep. 244 | 245 | "DDump" is an attempt to make the innards available to the script level 246 | with a reasonable level of compatibility. "DDump" is context sensitive. 247 | 248 | In void context, it behaves exactly like "Perl_sv_dump". 249 | 250 | In scalar context, it returns what "Perl_sv_dump" would have printed. 251 | 252 | The default for the first argument is $_. 253 | 254 | In list context, it returns a hash of the variable's properties. In 255 | this mode you can pass an optional second argument that determines the 256 | depth of digging. 257 | 258 | Example 259 | 260 | print scalar DDump "abc\x{0a}de\x{20ac}fg" 261 | 262 | SV = PV(0x723250) at 0x8432b0 263 | REFCNT = 1 264 | FLAGS = (PADBUSY,PADMY,POK,pPOK,UTF8) 265 | PV = 0x731ac0 "abc\nde\342\202\254fg"\0 [UTF8 "abc\nde\x{20ac}fg"] 266 | CUR = 11 267 | LEN = 16 268 | 269 | my %h = DDump "abc\x{0a}de\x{20ac}fg"; 270 | print DDumper \%h; 271 | 272 | { CUR => '11', 273 | FLAGS => { 274 | PADBUSY => 1, 275 | PADMY => 1, 276 | POK => 1, 277 | UTF8 => 1, 278 | pPOK => 1 279 | }, 280 | LEN => '16', 281 | PV => '0x731ac0 "abc\\nde\\342\\202\\254fg"\\0 [UTF8 "abc\\nde\\x{20ac}fg"]', 282 | REFCNT => '1', 283 | sv => 'PV(0x723250) at 0x8432c0' 284 | }; 285 | 286 | my %h = DDump { 287 | ape => 1, 288 | foo => "egg", 289 | bar => [ 2, "baz", undef ], 290 | }, 1; 291 | print DDumper \%h; 292 | 293 | { FLAGS => { 294 | PADBUSY => 1, 295 | PADMY => 1, 296 | ROK => 1 297 | }, 298 | REFCNT => '1', 299 | RV => { 300 | PVIV("ape") => { 301 | FLAGS => { 302 | IOK => 1, 303 | PADBUSY => 1, 304 | PADMY => 1, 305 | pIOK => 1 306 | }, 307 | IV => '1', 308 | REFCNT => '1', 309 | sv => 'IV(0x747020) at 0x843a10' 310 | }, 311 | PVIV("bar") => { 312 | CUR => '0', 313 | FLAGS => { 314 | PADBUSY => 1, 315 | PADMY => 1, 316 | ROK => 1 317 | }, 318 | IV => '1', 319 | LEN => '0', 320 | PV => '0x720210 ""', 321 | REFCNT => '1', 322 | RV => '0x720210', 323 | sv => 'PVIV(0x7223e0) at 0x843a10' 324 | }, 325 | PVIV("foo") => { 326 | CUR => '3', 327 | FLAGS => { 328 | PADBUSY => 1, 329 | PADMY => 1, 330 | POK => 1, 331 | pPOK => 1 332 | }, 333 | IV => '1', 334 | LEN => '8', 335 | PV => '0x7496c0 "egg"\\0', 336 | REFCNT => '1', 337 | sv => 'PVIV(0x7223e0) at 0x843a10' 338 | } 339 | }, 340 | sv => 'RV(0x79d058) at 0x843310' 341 | }; 342 | 343 | DDump_IO ($io, $var [, $dig_level]) 344 | A wrapper function around perl's internal "Perl_do_sv_dump", which 345 | makes "Devel::Peek" completely superfluous. 346 | 347 | Example 348 | 349 | my $dump; 350 | open my $eh, ">", \$dump; 351 | DDump_IO ($eh, { 3 => 4, ape => [5..8]}, 6); 352 | close $eh; 353 | print $dump; 354 | 355 | SV = RV(0x79d9e0) at 0x843f00 356 | REFCNT = 1 357 | FLAGS = (TEMP,ROK) 358 | RV = 0x741090 359 | SV = PVHV(0x79c948) at 0x741090 360 | REFCNT = 1 361 | FLAGS = (SHAREKEYS) 362 | IV = 2 363 | NV = 0 364 | ARRAY = 0x748ff0 (0:7, 2:1) 365 | hash quality = 62.5% 366 | KEYS = 2 367 | FILL = 1 368 | MAX = 7 369 | RITER = -1 370 | EITER = 0x0 371 | Elt "ape" HASH = 0x97623e03 372 | SV = RV(0x79d9d8) at 0x8440e0 373 | REFCNT = 1 374 | FLAGS = (ROK) 375 | RV = 0x741470 376 | SV = PVAV(0x7264b0) at 0x741470 377 | REFCNT = 2 378 | FLAGS = () 379 | IV = 0 380 | NV = 0 381 | ARRAY = 0x822f70 382 | FILL = 3 383 | MAX = 3 384 | ARYLEN = 0x0 385 | FLAGS = (REAL) 386 | Elt No. 0 387 | SV = IV(0x7467c8) at 0x7c1aa0 388 | REFCNT = 1 389 | FLAGS = (IOK,pIOK) 390 | IV = 5 391 | Elt No. 1 392 | SV = IV(0x7467b0) at 0x8440f0 393 | REFCNT = 1 394 | FLAGS = (IOK,pIOK) 395 | IV = 6 396 | Elt No. 2 397 | SV = IV(0x746810) at 0x75be00 398 | REFCNT = 1 399 | FLAGS = (IOK,pIOK) 400 | IV = 7 401 | Elt No. 3 402 | SV = IV(0x746d38) at 0x7799d0 403 | REFCNT = 1 404 | FLAGS = (IOK,pIOK) 405 | IV = 8 406 | Elt "3" HASH = 0xa400c7f3 407 | SV = IV(0x746fd0) at 0x7200e0 408 | REFCNT = 1 409 | FLAGS = (IOK,pIOK) 410 | IV = 4 411 | 412 | INTERNALS 413 | "DDump" uses an XS wrapper around "Perl_sv_dump" where the STDERR is 414 | temporarily caught to a pipe. The internal XS helper functions are not 415 | meant for user space 416 | 417 | DDump_XS (SV *sv) 418 | Base interface to internals for "DDump". 419 | 420 | BUGS 421 | Windows and AIX might be using a build where not all symbols that were 422 | supposed to be exported in the public API are not. "Perl_pv_peek" is 423 | one of them. 424 | 425 | Not all types of references are supported. 426 | 427 | No idea how far back this goes in perl support, but Devel::PPPort has 428 | proven to be a big help. 429 | 430 | SEE ALSO 431 | Devel::Peek, Data::Dumper, Data::Dump, Devel::Dumpvar, 432 | Data::Dump::Streamer, Data::Dumper::Perltidy, Perl::Tidy. 433 | 434 | AUTHOR 435 | H.Merijn Brand 436 | 437 | COPYRIGHT AND LICENSE 438 | Copyright (C) 2008-2025 H.Merijn Brand 439 | 440 | This library is free software; you can redistribute it and/or modify it 441 | under the same terms as Perl itself. 442 | 443 | perl v5.40.1 2025-01-06 Peek(3) 444 | -------------------------------------------------------------------------------- /doc/Data-Peek.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | Data::Peek - A collection of low-level debug facilities 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 46 | 47 |

NAME

48 | 49 |

Data::Peek - A collection of low-level debug facilities

50 | 51 |

SYNOPSIS

52 | 53 | 
use Data::Peek;
 54 | 
 55 | print DDumper \%hash;    # Same syntax as Data::Dumper
 56 | DTidy { ref => $ref };
 57 | 
 58 | print DPeek \$var;
 59 | my ($pv, $iv, $nv, $rv, $magic) = DDual ($var [, 1]);
 60 | print DPeek for DDual ($!, 1);
 61 | print DDisplay ("ab\nc\x{20ac}\rdef\n");
 62 | print DHexDump ("ab\nc\x{20ac}\rdef\n");
 63 | 
 64 | my $dump = DDump $var;
 65 | my %hash = DDump \@list;
 66 | DDump \%hash;
 67 | 
 68 | my %hash = DDump (\%hash, 5);  # dig 5 levels deep
 69 | 
 70 | my $dump;
 71 | open my $fh, ">", \$dump;
 72 | DDump_IO ($fh, \%hash, 6);
 73 | close $fh;
 74 | print $dump;
 75 | 
 76 | # Imports
 77 | use Data::Peek qw( :tidy VNR DGrow triplevar );
 78 | my $x = ""; DGrow ($x, 10000);
 79 | my $tv = triplevar ("\N{GREEK SMALL LETTER PI}", 3, "3.1415");
 80 | DDsort ("R");
 81 | DDumper [ $x ]; # use of :tidy makes DDumper behave like DTidy
82 | 83 |

DESCRIPTION

84 | 85 |

Data::Peek started off as DDumper being a wrapper module over Data::Dumper, 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.

86 | 87 |

DDumper ($var, ...)

88 | 89 |

Not liking the default output of Data::Dumper, and always feeling the need to set $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.

90 | 91 | 
$Data::Dumper::Sortkeys = 1;
 92 | $Data::Dumper::Indent   = 1;
93 | 94 |

If Data::Peek is used with import argument :tidy, the result is formatted according to Perl::Tidy, see DTidy below, otherwise the result is further beautified to meet my needs:

95 | 96 | 
* quotation of hash keys has been removed (with the disadvantage
 97 |   that the output might not be parseable again).
 98 | * arrows for hashes are aligned at 16 (longer keys don't align)
 99 | * closing braces and brackets are now correctly aligned
100 | 101 |

In void context, DDumper warn's.

102 | 103 |

Example

104 | 105 | 
$ perl -MDP \
106 |   -e'DDumper { ape => 1, foo => "egg", bar => [ 2, "baz", undef ]};'
107 | 
108 | {   ape              => 1,
109 |     bar              => [
110 |         2,
111 |         'baz',
112 |         undef
113 |         ],
114 |     foo              => 'egg'
115 |     };
116 | 117 |

DTidy ($var, ...)

118 | 119 |

DTidy is an alternative to DDumper, where the output of DDumper is formatted using Perl::Tidy (if available) according to your .perltidyrc instead of the default behavior, maybe somewhat like (YMMV):

120 | 121 | 
$ perl -MDP=:tidy \
122 |   -we'DDumper { ape => 1, foo => "egg", bar => [ 2, "baz", undef ]};'
123 | {   'ape' => 1,
124 |     'bar' => [2, 'baz', undef],
125 |     'foo' => 'egg'
126 |     }
127 | 128 |

If Data::Peek is used with import argument :tidy, this is the default output method for DDumper.

129 | 130 |

If Perl::Tidy is not available, DTidy will fallback to DDumper.

131 | 132 |

This idea was shamelessly copied from John McNamara's Data::Dumper::Perltidy.

133 | 134 |

DDsort ( 0 | 1 | R | N | NR | V | VR | VN | VNR )

135 | 136 |

Set the hash sort algorithm for DDumper. The default is to sort by key value.

137 | 138 | 
0   - Do not sort
139 | 1   - Sort by key
140 | R   - Reverse sort by key
141 | N   - Sort by key numerical
142 | NR  - Sort by key numerical descending
143 | V   - Sort by value
144 | VR  - Reverse sort by value
145 | VN  - Sort by value numerical
146 | VNR - Reverse sort by value numerical
147 | 148 |

These can also be passed to import:

149 | 150 | 
$ perl -MDP=VNR \
151 |   -we'DDumper { foo => 1, bar => 2, zap => 3, gum => 13 }'
152 | {   gum              => 13,
153 |     zap              => 3,
154 |     bar              => 2,
155 |     foo              => 1
156 |     };
157 | $ perl -MDP=V \
158 |   -we'DDumper { foo => 1, bar => 2, zap => 3, gum => 13 }'
159 | {   foo              => 1,
160 |     gum              => 13,
161 |     bar              => 2,
162 |     zap              => 3
163 |     };
164 | 165 |

DPeek

166 | 167 |

DPeek ($var)

168 | 169 |

Playing with sv_dump, I found Perl_sv_peek, and it might be very useful for simple checks. If $var is omitted, uses $_.

170 | 171 |

Example

172 | 173 | 
print DPeek "abc\x{0a}de\x{20ac}fg";
174 | 
175 | PV("abc\nde\342\202\254fg"\0) [UTF8 "abc\nde\x{20ac}fg"]
176 | 177 |

In void context, DPeek prints to STDERR plus a newline.

178 | 179 |

DDisplay

180 | 181 |

DDisplay ($var)

182 | 183 |

Show the PV content of a scalar the way perl debugging would have done. UTF-8 detection is on, so this is effectively the same as returning the first part the DPeek returns for non-UTF8 PV's or the second part for UTF-8 PV's. DDisplay returns the empty string for scalars that no have a valid PV.

184 | 185 |

Example

186 | 187 | 
print DDisplay "abc\x{0a}de\x{20ac}fg";
188 | 
189 | "abc\nde\x{20ac}fg"
190 | 191 |

In void context, DDisplay uses warn to display the result.

192 | 193 |

DHexDump

194 | 195 |

DHexDump ($var)

196 | 197 |

DHexDump ($var, $length)

198 | 199 |

Show the (stringified) content of a scalar as a hex-dump. If $var is omitted, $_ is dumped. Returns undef or an empty list if $var (or $_) is undefined. If $length is given and is lower than the length of the stringified $var, only <$length> bytes are dumped.

200 | 201 |

In void context, the dump is done to STDERR. In scalar context, the complete dump is returned as a single string. In list context, the dump is returned as lines.

202 | 203 |

Example

204 | 205 | 
print DHexDump "abc\x{0a}de\x{20ac}fg";
206 | 
207 | 0000  61 62 63 0a 64 65 e2 82  ac 66 67                 abc.de...fg
208 | 209 |

my ($pv, $iv, $nv, $rv, $hm) = DDual ($var [, $getmagic])

210 | 211 |

DDual will return the basic elements in a variable, guaranteeing that no conversion takes place. This is very useful for dual-var variables, or when checking is a variable has defined entries for a certain type of scalar. For each String (PV), Integer (IV), Double (NV), and Reference (RV), the current value of $var is returned or undef if it is not set (yet). The 5th element is an indicator if $var has magic, which is not invoked in the returned values, unless explicitly asked for with a true optional second argument.

212 | 213 |

Example

214 | 215 | 
print DPeek for DDual ($!, 1);
216 | 217 |

In void context, DDual does the equivalent of

218 | 219 | 
{ my @d = DDual ($!, 1);
220 |   print STDERR
221 |     DPeek ($!), "\n",
222 |     "  PV: ", DPeek ($d[0]), "\n",
223 |     "  IV: ", DPeek ($d[1]), "\n",
224 |     "  NV: ", DPeek ($d[2]), "\n",
225 |     "  RV: ", DPeek ($d[3]), "\n";
226 |   }
227 | 228 |

my $len = DGrow ($pv, $size)

229 | 230 |

Fastest way to preallocate space for a PV scalar. Returns the allocated length. If $size is smaller than the already allocated space, it will not shrink.

231 | 232 | 
cmpthese (-2, {
233 |     pack => q{my $x = ""; $x = pack "x20000"; $x = "";},
234 |     op_x => q{my $x = ""; $x = "x"  x 20000;  $x = "";},
235 |     grow => q{my $x = ""; DGrow ($x,  20000); $x = "";},
236 |     });
237 | 
238 |           Rate  op_x  pack  grow      5.8.9    5.10.1    5.12.4    5.14.2
239 | op_x   62127/s    --  -59%  -96%   118606/s  119730/s  352255/s  362605/s
240 | pack  152046/s  145%    --  -91%   380075/s  355666/s  347247/s  387349/s
241 | grow 1622943/s 2512%  967%    --  2818380/s 2918783/s 2672340/s 2886787/s
242 | 243 |

my $tp = triplevar ($pv, $iv, $nv)

244 | 245 |

When making DDual I wondered if it were possible to create triple-val scalar variables. Scalar::Util already gives us dualvar, that creates you a scalar with different numeric and string values that return different values in different context. Not that triplevar would be very useful, compared to dualvar, but at least this shows that it is possible.

246 | 247 |

triplevar is not exported by default.

248 | 249 |

Example:

250 | 251 | 
DDual Data::Peek::triplevar ("\N{GREEK SMALL LETTER PI}", 3, 3.1415);
252 | 
253 | PVNV("\317\200"\0) [UTF8 "\x{3c0}"]
254 |   PV: PV("\317\200"\0) [UTF8 "\x{3c0}"]
255 |   IV: IV(3)
256 |   NV: NV(3.1415)
257 |   RV: SV_UNDEF
258 | 259 |

DDump ([$var [, $dig_level]])

260 | 261 |

A very useful module when debugging is Devel::Peek, but is has one big disadvantage: it only prints to STDERR, which is not very handy when your code wants to inspect variables at a low level.

262 | 263 |

Perl itself has sv_dump, which does something similar, but still prints to STDERR, and only one level deep.

264 | 265 |

DDump is an attempt to make the innards available to the script level with a reasonable level of compatibility. DDump is context sensitive.

266 | 267 |

In void context, it behaves exactly like Perl_sv_dump.

268 | 269 |

In scalar context, it returns what Perl_sv_dump would have printed.

270 | 271 |

The default for the first argument is $_.

272 | 273 |

In list context, it returns a hash of the variable's properties. In this mode you can pass an optional second argument that determines the depth of digging.

274 | 275 |

Example

276 | 277 | 
print scalar DDump "abc\x{0a}de\x{20ac}fg"
278 | 
279 | SV = PV(0x723250) at 0x8432b0
280 |   REFCNT = 1
281 |   FLAGS = (PADBUSY,PADMY,POK,pPOK,UTF8)
282 |   PV = 0x731ac0 "abc\nde\342\202\254fg"\0 [UTF8 "abc\nde\x{20ac}fg"]
283 |   CUR = 11
284 |   LEN = 16
285 | 
286 | my %h = DDump "abc\x{0a}de\x{20ac}fg";
287 | print DDumper \%h;
288 | 
289 | {   CUR              => '11',
290 |     FLAGS            => {
291 |         PADBUSY          => 1,
292 |         PADMY            => 1,
293 |         POK              => 1,
294 |         UTF8             => 1,
295 |         pPOK             => 1
296 |         },
297 |     LEN              => '16',
298 |     PV               => '0x731ac0 "abc\\nde\\342\\202\\254fg"\\0 [UTF8 "abc\\nde\\x{20ac}fg"]',
299 |     REFCNT           => '1',
300 |     sv               => 'PV(0x723250) at 0x8432c0'
301 |     };
302 | 
303 | my %h = DDump {
304 |     ape => 1,
305 |     foo => "egg",
306 |     bar => [ 2, "baz", undef ],
307 |     }, 1;
308 | print DDumper \%h;
309 | 
310 | {   FLAGS            => {
311 |         PADBUSY          => 1,
312 |         PADMY            => 1,
313 |         ROK              => 1
314 |         },
315 |     REFCNT           => '1',
316 |     RV               => {
317 |         PVIV("ape")      => {
318 |             FLAGS            => {
319 |                 IOK              => 1,
320 |                 PADBUSY          => 1,
321 |                 PADMY            => 1,
322 |                 pIOK             => 1
323 |                 },
324 |             IV               => '1',
325 |             REFCNT           => '1',
326 |             sv               => 'IV(0x747020) at 0x843a10'
327 |             },
328 |         PVIV("bar")      => {
329 |             CUR              => '0',
330 |             FLAGS            => {
331 |                 PADBUSY          => 1,
332 |                 PADMY            => 1,
333 |                 ROK              => 1
334 |                 },
335 |             IV               => '1',
336 |             LEN              => '0',
337 |             PV               => '0x720210 ""',
338 |             REFCNT           => '1',
339 |             RV               => '0x720210',
340 |             sv               => 'PVIV(0x7223e0) at 0x843a10'
341 |             },
342 |         PVIV("foo")      => {
343 |             CUR              => '3',
344 |             FLAGS            => {
345 |                 PADBUSY          => 1,
346 |                 PADMY            => 1,
347 |                 POK              => 1,
348 |                 pPOK             => 1
349 |                 },
350 |             IV               => '1',
351 |             LEN              => '8',
352 |             PV               => '0x7496c0 "egg"\\0',
353 |             REFCNT           => '1',
354 |             sv               => 'PVIV(0x7223e0) at 0x843a10'
355 |             }
356 |         },
357 |     sv               => 'RV(0x79d058) at 0x843310'
358 |     };
359 | 360 |

DDump_IO ($io, $var [, $dig_level])

361 | 362 |

A wrapper function around perl's internal Perl_do_sv_dump, which makes Devel::Peek completely superfluous.

363 | 364 |

Example

365 | 366 | 
my $dump;
367 | open my $eh, ">", \$dump;
368 | DDump_IO ($eh, { 3 => 4, ape => [5..8]}, 6);
369 | close $eh;
370 | print $dump;
371 | 
372 | SV = RV(0x79d9e0) at 0x843f00
373 |   REFCNT = 1
374 |   FLAGS = (TEMP,ROK)
375 |   RV = 0x741090
376 |     SV = PVHV(0x79c948) at 0x741090
377 |       REFCNT = 1
378 |       FLAGS = (SHAREKEYS)
379 |       IV = 2
380 |       NV = 0
381 |       ARRAY = 0x748ff0  (0:7, 2:1)
382 |       hash quality = 62.5%
383 |       KEYS = 2
384 |       FILL = 1
385 |       MAX = 7
386 |       RITER = -1
387 |       EITER = 0x0
388 |         Elt "ape" HASH = 0x97623e03
389 |         SV = RV(0x79d9d8) at 0x8440e0
390 |           REFCNT = 1
391 |           FLAGS = (ROK)
392 |           RV = 0x741470
393 |             SV = PVAV(0x7264b0) at 0x741470
394 |               REFCNT = 2
395 |               FLAGS = ()
396 |               IV = 0
397 |               NV = 0
398 |               ARRAY = 0x822f70
399 |               FILL = 3
400 |               MAX = 3
401 |               ARYLEN = 0x0
402 |               FLAGS = (REAL)
403 |                 Elt No. 0
404 |                 SV = IV(0x7467c8) at 0x7c1aa0
405 |                   REFCNT = 1
406 |                   FLAGS = (IOK,pIOK)
407 |                   IV = 5
408 |                 Elt No. 1
409 |                 SV = IV(0x7467b0) at 0x8440f0
410 |                   REFCNT = 1
411 |                   FLAGS = (IOK,pIOK)
412 |                   IV = 6
413 |                 Elt No. 2
414 |                 SV = IV(0x746810) at 0x75be00
415 |                   REFCNT = 1
416 |                   FLAGS = (IOK,pIOK)
417 |                   IV = 7
418 |                 Elt No. 3
419 |                 SV = IV(0x746d38) at 0x7799d0
420 |                   REFCNT = 1
421 |                   FLAGS = (IOK,pIOK)
422 |                   IV = 8
423 |         Elt "3" HASH = 0xa400c7f3
424 |         SV = IV(0x746fd0) at 0x7200e0
425 |           REFCNT = 1
426 |           FLAGS = (IOK,pIOK)
427 |           IV = 4
428 | 429 |

INTERNALS

430 | 431 |

DDump uses an XS wrapper around Perl_sv_dump where the STDERR is temporarily caught to a pipe. The internal XS helper functions are not meant for user space

432 | 433 |

DDump_XS (SV *sv)

434 | 435 |

Base interface to internals for DDump.

436 | 437 |

BUGS

438 | 439 |

Windows and AIX might be using a build where not all symbols that were supposed to be exported in the public API are not. Perl_pv_peek is one of them.

440 | 441 |

Not all types of references are supported.

442 | 443 |

No idea how far back this goes in perl support, but Devel::PPPort has proven to be a big help.

444 | 445 |

SEE ALSO

446 | 447 |

Devel::Peek, Data::Dumper, Data::Dump, Devel::Dumpvar, Data::Dump::Streamer, Data::Dumper::Perltidy, Perl::Tidy.

448 | 449 |

AUTHOR

450 | 451 |

H.Merijn Brand <hmbrand@cpan.org>

452 | 453 |

COPYRIGHT AND LICENSE

454 | 455 |

Copyright (C) 2008-2025 H.Merijn Brand

456 | 457 |

This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself.

458 | 459 | 460 | 461 | 462 | 463 | -------------------------------------------------------------------------------- /doc/Data-Peek.3: -------------------------------------------------------------------------------- 1 | .\" -*- mode: troff; coding: utf-8 -*- 2 | .\" Automatically generated by Pod::Man v6.0.2 (Pod::Simple 3.45) 3 | .\" 4 | .\" Standard preamble: 5 | .\" ======================================================================== 6 | .de Sp \" Vertical space (when we can't use .PP) 7 | .if t .sp .5v 8 | .if n .sp 9 | .. 10 | .de Vb \" Begin verbatim text 11 | .ft CW 12 | .nf 13 | .ne \\$1 14 | .. 15 | .de Ve \" End verbatim text 16 | .ft R 17 | .fi 18 | .. 19 | .\" \*(C` and \*(C' are quotes in nroff, nothing in troff, for use with C<>. 20 | .ie n \{\ 21 | . ds C` "" 22 | . ds C' "" 23 | 'br\} 24 | .el\{\ 25 | . ds C` 26 | . ds C' 27 | 'br\} 28 | .\" 29 | .\" Escape single quotes in literal strings from groff's Unicode transform. 30 | .ie \n(.g .ds Aq \(aq 31 | .el .ds Aq ' 32 | .\" 33 | .\" If the F register is >0, we'll generate index entries on stderr for 34 | .\" titles (.TH), headers (.SH), subsections (.SS), items (.Ip), and index 35 | .\" entries marked with X<> in POD. Of course, you'll have to process the 36 | .\" output yourself in some meaningful fashion. 37 | .\" 38 | .\" Avoid warning from groff about undefined register 'F'. 39 | .de IX 40 | .. 41 | .nr rF 0 42 | .if \n(.g .if rF .nr rF 1 43 | .if (\n(rF:(\n(.g==0)) \{\ 44 | . if \nF \{\ 45 | . de IX 46 | . tm Index:\\$1\t\\n%\t"\\$2" 47 | .. 48 | . if !\nF==2 \{\ 49 | . nr % 0 50 | . nr F 2 51 | . \} 52 | . \} 53 | .\} 54 | .rr rF 55 | .\" 56 | .\" Required to disable full justification in groff 1.23.0. 57 | .if n .ds AD l 58 | .\" ======================================================================== 59 | .\" 60 | .IX Title "Peek 3" 61 | .TH Peek 3 2025-01-06 "perl v5.40.1" "User Contributed Perl Documentation" 62 | .\" For nroff, turn off justification. Always turn off hyphenation; it makes 63 | .\" way too many mistakes in technical documents. 64 | .if n .ad l 65 | .nh 66 | .SH NAME 67 | Data::Peek \- A collection of low\-level debug facilities 68 | .SH SYNOPSIS 69 | .IX Header "SYNOPSIS" 70 | .Vb 1 71 | \& use Data::Peek; 72 | \& 73 | \& print DDumper \e%hash; # Same syntax as Data::Dumper 74 | \& DTidy { ref => $ref }; 75 | \& 76 | \& print DPeek \e$var; 77 | \& my ($pv, $iv, $nv, $rv, $magic) = DDual ($var [, 1]); 78 | \& print DPeek for DDual ($!, 1); 79 | \& print DDisplay ("ab\enc\ex{20ac}\erdef\en"); 80 | \& print DHexDump ("ab\enc\ex{20ac}\erdef\en"); 81 | \& 82 | \& my $dump = DDump $var; 83 | \& my %hash = DDump \e@list; 84 | \& DDump \e%hash; 85 | \& 86 | \& my %hash = DDump (\e%hash, 5); # dig 5 levels deep 87 | \& 88 | \& my $dump; 89 | \& open my $fh, ">", \e$dump; 90 | \& DDump_IO ($fh, \e%hash, 6); 91 | \& close $fh; 92 | \& print $dump; 93 | \& 94 | \& # Imports 95 | \& use Data::Peek qw( :tidy VNR DGrow triplevar ); 96 | \& my $x = ""; DGrow ($x, 10000); 97 | \& my $tv = triplevar ("\eN{GREEK SMALL LETTER PI}", 3, "3.1415"); 98 | \& DDsort ("R"); 99 | \& DDumper [ $x ]; # use of :tidy makes DDumper behave like DTidy 100 | .Ve 101 | .SH DESCRIPTION 102 | .IX Header "DESCRIPTION" 103 | Data::Peek started off as \f(CW\*(C`DDumper\*(C'\fR being a wrapper module over 104 | Data::Dumper, but grew out to be a set of low\-level data 105 | introspection utilities that no other module provided yet, using the 106 | lowest level of the perl internals API as possible. 107 | .SS "DDumper ($var, ...)" 108 | .IX Subsection "DDumper ($var, ...)" 109 | Not liking the default output of Data::Dumper, and always feeling the need 110 | to set \f(CW\*(C`$Data::Dumper::Sortkeys = 1;\*(C'\fR, and not liking any of the default 111 | layouts, this function is just a wrapper around Data::Dumper::Dumper with 112 | everything set as I like it. 113 | .PP 114 | .Vb 2 115 | \& $Data::Dumper::Sortkeys = 1; 116 | \& $Data::Dumper::Indent = 1; 117 | .Ve 118 | .PP 119 | If \f(CW\*(C`Data::Peek\*(C'\fR is \f(CW\*(C`use\*(C'\fRd with import argument \f(CW\*(C`:tidy\*(C'\fR, the result is 120 | formatted according to Perl::Tidy, see DTidy below, otherwise the 121 | result is further beautified to meet my needs: 122 | .PP 123 | .Vb 4 124 | \& * quotation of hash keys has been removed (with the disadvantage 125 | \& that the output might not be parseable again). 126 | \& * arrows for hashes are aligned at 16 (longer keys don\*(Aqt align) 127 | \& * closing braces and brackets are now correctly aligned 128 | .Ve 129 | .PP 130 | In void context, \f(CW\*(C`DDumper\*(C'\fR \f(CW\*(C`warn\*(C'\fR\*(Aqs. 131 | .PP 132 | Example 133 | .PP 134 | .Vb 2 135 | \& $ perl \-MDP \e 136 | \& \-e\*(AqDDumper { ape => 1, foo => "egg", bar => [ 2, "baz", undef ]};\*(Aq 137 | \& 138 | \& { ape => 1, 139 | \& bar => [ 140 | \& 2, 141 | \& \*(Aqbaz\*(Aq, 142 | \& undef 143 | \& ], 144 | \& foo => \*(Aqegg\*(Aq 145 | \& }; 146 | .Ve 147 | .SS "DTidy ($var, ...)" 148 | .IX Subsection "DTidy ($var, ...)" 149 | \&\f(CW\*(C`DTidy\*(C'\fR is an alternative to \f(CW\*(C`DDumper\*(C'\fR, where the output of \f(CW\*(C`DDumper\*(C'\fR 150 | is formatted using \f(CW\*(C`Perl::Tidy\*(C'\fR (if available) according to your 151 | \&\f(CW\*(C`.perltidyrc\*(C'\fR instead of the default behavior, maybe somewhat like (YMMV): 152 | .PP 153 | .Vb 6 154 | \& $ perl \-MDP=:tidy \e 155 | \& \-we\*(AqDDumper { ape => 1, foo => "egg", bar => [ 2, "baz", undef ]};\*(Aq 156 | \& { \*(Aqape\*(Aq => 1, 157 | \& \*(Aqbar\*(Aq => [2, \*(Aqbaz\*(Aq, undef], 158 | \& \*(Aqfoo\*(Aq => \*(Aqegg\*(Aq 159 | \& } 160 | .Ve 161 | .PP 162 | If \f(CW\*(C`Data::Peek\*(C'\fR is \f(CW\*(C`use\*(C'\fRd with import argument \f(CW\*(C`:tidy\*(C'\fR, this is the 163 | default output method for \f(CW\*(C`DDumper\*(C'\fR. 164 | .PP 165 | If Perl::Tidy is not available, \f(CW\*(C`DTidy\*(C'\fR will fallback to \f(CW\*(C`DDumper\*(C'\fR. 166 | .PP 167 | This idea was shamelessly copied from John McNamara\*(Aqs Data::Dumper::Perltidy. 168 | .SS "DDsort ( 0 | 1 | R | N | NR | V | VR | VN | VNR )" 169 | .IX Subsection "DDsort ( 0 | 1 | R | N | NR | V | VR | VN | VNR )" 170 | Set the hash sort algorithm for DDumper. The default is to sort by key value. 171 | .PP 172 | .Vb 9 173 | \& 0 \- Do not sort 174 | \& 1 \- Sort by key 175 | \& R \- Reverse sort by key 176 | \& N \- Sort by key numerical 177 | \& NR \- Sort by key numerical descending 178 | \& V \- Sort by value 179 | \& VR \- Reverse sort by value 180 | \& VN \- Sort by value numerical 181 | \& VNR \- Reverse sort by value numerical 182 | .Ve 183 | .PP 184 | These can also be passed to import: 185 | .PP 186 | .Vb 10 187 | \& $ perl \-MDP=VNR \e 188 | \& \-we\*(AqDDumper { foo => 1, bar => 2, zap => 3, gum => 13 }\*(Aq 189 | \& { gum => 13, 190 | \& zap => 3, 191 | \& bar => 2, 192 | \& foo => 1 193 | \& }; 194 | \& $ perl \-MDP=V \e 195 | \& \-we\*(AqDDumper { foo => 1, bar => 2, zap => 3, gum => 13 }\*(Aq 196 | \& { foo => 1, 197 | \& gum => 13, 198 | \& bar => 2, 199 | \& zap => 3 200 | \& }; 201 | .Ve 202 | .SS DPeek 203 | .IX Subsection "DPeek" 204 | .SS "DPeek ($var)" 205 | .IX Subsection "DPeek ($var)" 206 | Playing with \f(CW\*(C`sv_dump\*(C'\fR, I found \f(CW\*(C`Perl_sv_peek\*(C'\fR, and it might be very 207 | useful for simple checks. If \f(CW$var\fR is omitted, uses \f(CW$_\fR. 208 | .PP 209 | Example 210 | .PP 211 | .Vb 1 212 | \& print DPeek "abc\ex{0a}de\ex{20ac}fg"; 213 | \& 214 | \& PV("abc\ende\e342\e202\e254fg"\e0) [UTF8 "abc\ende\ex{20ac}fg"] 215 | .Ve 216 | .PP 217 | In void context, \f(CW\*(C`DPeek\*(C'\fR prints to \f(CW\*(C`STDERR\*(C'\fR plus a newline. 218 | .SS DDisplay 219 | .IX Subsection "DDisplay" 220 | .SS "DDisplay ($var)" 221 | .IX Subsection "DDisplay ($var)" 222 | Show the PV content of a scalar the way perl debugging would have done. 223 | UTF\-8 detection is on, so this is effectively the same as returning the 224 | first part the \f(CW\*(C`DPeek\*(C'\fR returns for non\-UTF8 PV\*(Aqs or the second part for 225 | UTF\-8 PV\*(Aqs. \f(CW\*(C`DDisplay\*(C'\fR returns the empty string for scalars that no 226 | have a valid PV. 227 | .PP 228 | Example 229 | .PP 230 | .Vb 1 231 | \& print DDisplay "abc\ex{0a}de\ex{20ac}fg"; 232 | \& 233 | \& "abc\ende\ex{20ac}fg" 234 | .Ve 235 | .PP 236 | In void context, \f(CW\*(C`DDisplay\*(C'\fR uses \f(CW\*(C`warn\*(C'\fR to display the result. 237 | .SS DHexDump 238 | .IX Subsection "DHexDump" 239 | .SS "DHexDump ($var)" 240 | .IX Subsection "DHexDump ($var)" 241 | .ie n .SS "DHexDump ($var, $length)" 242 | .el .SS "DHexDump ($var, \f(CW$length\fP)" 243 | .IX Subsection "DHexDump ($var, $length)" 244 | Show the (stringified) content of a scalar as a hex\-dump. If \f(CW$var\fR 245 | is omitted, \f(CW$_\fR is dumped. Returns \f(CW\*(C`undef\*(C'\fR or an empty list if 246 | \&\f(CW$var\fR (or \f(CW$_\fR) is undefined. If \f(CW$length\fR is given and is lower than 247 | the length of the stringified \f(CW$var\fR, only <$length> bytes are dumped. 248 | .PP 249 | In void context, the dump is done to STDERR. In scalar context, the 250 | complete dump is returned as a single string. In list context, the dump 251 | is returned as lines. 252 | .PP 253 | Example 254 | .PP 255 | .Vb 1 256 | \& print DHexDump "abc\ex{0a}de\ex{20ac}fg"; 257 | \& 258 | \& 0000 61 62 63 0a 64 65 e2 82 ac 66 67 abc.de...fg 259 | .Ve 260 | .ie n .SS "my ($pv, $iv, $nv, $rv, $hm) = DDual ($var [, $getmagic])" 261 | .el .SS "my ($pv, \f(CW$iv\fP, \f(CW$nv\fP, \f(CW$rv\fP, \f(CW$hm\fP) = DDual ($var [, \f(CW$getmagic\fP])" 262 | .IX Subsection "my ($pv, $iv, $nv, $rv, $hm) = DDual ($var [, $getmagic])" 263 | DDual will return the basic elements in a variable, guaranteeing that no 264 | conversion takes place. This is very useful for dual\-var variables, or 265 | when checking is a variable has defined entries for a certain type of 266 | scalar. For each String (PV), Integer (IV), Double (NV), and Reference (RV), 267 | the current value of \f(CW$var\fR is returned or undef if it is not set (yet). 268 | The 5th element is an indicator if \f(CW$var\fR has magic, which is \fBnot\fR invoked 269 | in the returned values, unless explicitly asked for with a true optional 270 | second argument. 271 | .PP 272 | Example 273 | .PP 274 | .Vb 1 275 | \& print DPeek for DDual ($!, 1); 276 | .Ve 277 | .PP 278 | In void context, DDual does the equivalent of 279 | .PP 280 | .Vb 8 281 | \& { my @d = DDual ($!, 1); 282 | \& print STDERR 283 | \& DPeek ($!), "\en", 284 | \& " PV: ", DPeek ($d[0]), "\en", 285 | \& " IV: ", DPeek ($d[1]), "\en", 286 | \& " NV: ", DPeek ($d[2]), "\en", 287 | \& " RV: ", DPeek ($d[3]), "\en"; 288 | \& } 289 | .Ve 290 | .ie n .SS "my $len = DGrow ($pv, $size)" 291 | .el .SS "my \f(CW$len\fP = DGrow ($pv, \f(CW$size\fP)" 292 | .IX Subsection "my $len = DGrow ($pv, $size)" 293 | Fastest way to preallocate space for a PV scalar. Returns the allocated 294 | length. If \f(CW$size\fR is smaller than the already allocated space, it will 295 | not shrink. 296 | .PP 297 | .Vb 5 298 | \& cmpthese (\-2, { 299 | \& pack => q{my $x = ""; $x = pack "x20000"; $x = "";}, 300 | \& op_x => q{my $x = ""; $x = "x" x 20000; $x = "";}, 301 | \& grow => q{my $x = ""; DGrow ($x, 20000); $x = "";}, 302 | \& }); 303 | \& 304 | \& Rate op_x pack grow 5.8.9 5.10.1 5.12.4 5.14.2 305 | \& op_x 62127/s \-\- \-59% \-96% 118606/s 119730/s 352255/s 362605/s 306 | \& pack 152046/s 145% \-\- \-91% 380075/s 355666/s 347247/s 387349/s 307 | \& grow 1622943/s 2512% 967% \-\- 2818380/s 2918783/s 2672340/s 2886787/s 308 | .Ve 309 | .ie n .SS "my $tp = triplevar ($pv, $iv, $nv)" 310 | .el .SS "my \f(CW$tp\fP = triplevar ($pv, \f(CW$iv\fP, \f(CW$nv\fP)" 311 | .IX Subsection "my $tp = triplevar ($pv, $iv, $nv)" 312 | When making \f(CW\*(C`DDual\*(C'\fR I wondered if it were possible to create triple\-val 313 | scalar variables. Scalar::Util already gives us \f(CW\*(C`dualvar\*(C'\fR, that creates 314 | you a scalar with different numeric and string values that return different 315 | values in different context. Not that \f(CW\*(C`triplevar\*(C'\fR would be very useful, 316 | compared to \f(CW\*(C`dualvar\*(C'\fR, but at least this shows that it is possible. 317 | .PP 318 | \&\f(CW\*(C`triplevar\*(C'\fR is not exported by default. 319 | .PP 320 | Example: 321 | .PP 322 | .Vb 1 323 | \& DDual Data::Peek::triplevar ("\eN{GREEK SMALL LETTER PI}", 3, 3.1415); 324 | \& 325 | \& PVNV("\e317\e200"\e0) [UTF8 "\ex{3c0}"] 326 | \& PV: PV("\e317\e200"\e0) [UTF8 "\ex{3c0}"] 327 | \& IV: IV(3) 328 | \& NV: NV(3.1415) 329 | \& RV: SV_UNDEF 330 | .Ve 331 | .ie n .SS "DDump ([$var [, $dig_level]])" 332 | .el .SS "DDump ([$var [, \f(CW$dig_level\fP]])" 333 | .IX Subsection "DDump ([$var [, $dig_level]])" 334 | A very useful module when debugging is \f(CW\*(C`Devel::Peek\*(C'\fR, but is has one big 335 | disadvantage: it only prints to STDERR, which is not very handy when your 336 | code wants to inspect variables at a low level. 337 | .PP 338 | Perl itself has \f(CW\*(C`sv_dump\*(C'\fR, which does something similar, but still prints 339 | to STDERR, and only one level deep. 340 | .PP 341 | \&\f(CW\*(C`DDump\*(C'\fR is an attempt to make the innards available to the script level 342 | with a reasonable level of compatibility. \f(CW\*(C`DDump\*(C'\fR is context sensitive. 343 | .PP 344 | In void context, it behaves exactly like \f(CW\*(C`Perl_sv_dump\*(C'\fR. 345 | .PP 346 | In scalar context, it returns what \f(CW\*(C`Perl_sv_dump\*(C'\fR would have printed. 347 | .PP 348 | The default for the first argument is \f(CW$_\fR. 349 | .PP 350 | In list context, it returns a hash of the variable\*(Aqs properties. In this mode 351 | you can pass an optional second argument that determines the depth of digging. 352 | .PP 353 | Example 354 | .PP 355 | .Vb 1 356 | \& print scalar DDump "abc\ex{0a}de\ex{20ac}fg" 357 | \& 358 | \& SV = PV(0x723250) at 0x8432b0 359 | \& REFCNT = 1 360 | \& FLAGS = (PADBUSY,PADMY,POK,pPOK,UTF8) 361 | \& PV = 0x731ac0 "abc\ende\e342\e202\e254fg"\e0 [UTF8 "abc\ende\ex{20ac}fg"] 362 | \& CUR = 11 363 | \& LEN = 16 364 | \& 365 | \& my %h = DDump "abc\ex{0a}de\ex{20ac}fg"; 366 | \& print DDumper \e%h; 367 | \& 368 | \& { CUR => \*(Aq11\*(Aq, 369 | \& FLAGS => { 370 | \& PADBUSY => 1, 371 | \& PADMY => 1, 372 | \& POK => 1, 373 | \& UTF8 => 1, 374 | \& pPOK => 1 375 | \& }, 376 | \& LEN => \*(Aq16\*(Aq, 377 | \& PV => \*(Aq0x731ac0 "abc\e\ende\e\e342\e\e202\e\e254fg"\e\e0 [UTF8 "abc\e\ende\e\ex{20ac}fg"]\*(Aq, 378 | \& REFCNT => \*(Aq1\*(Aq, 379 | \& sv => \*(AqPV(0x723250) at 0x8432c0\*(Aq 380 | \& }; 381 | \& 382 | \& my %h = DDump { 383 | \& ape => 1, 384 | \& foo => "egg", 385 | \& bar => [ 2, "baz", undef ], 386 | \& }, 1; 387 | \& print DDumper \e%h; 388 | \& 389 | \& { FLAGS => { 390 | \& PADBUSY => 1, 391 | \& PADMY => 1, 392 | \& ROK => 1 393 | \& }, 394 | \& REFCNT => \*(Aq1\*(Aq, 395 | \& RV => { 396 | \& PVIV("ape") => { 397 | \& FLAGS => { 398 | \& IOK => 1, 399 | \& PADBUSY => 1, 400 | \& PADMY => 1, 401 | \& pIOK => 1 402 | \& }, 403 | \& IV => \*(Aq1\*(Aq, 404 | \& REFCNT => \*(Aq1\*(Aq, 405 | \& sv => \*(AqIV(0x747020) at 0x843a10\*(Aq 406 | \& }, 407 | \& PVIV("bar") => { 408 | \& CUR => \*(Aq0\*(Aq, 409 | \& FLAGS => { 410 | \& PADBUSY => 1, 411 | \& PADMY => 1, 412 | \& ROK => 1 413 | \& }, 414 | \& IV => \*(Aq1\*(Aq, 415 | \& LEN => \*(Aq0\*(Aq, 416 | \& PV => \*(Aq0x720210 ""\*(Aq, 417 | \& REFCNT => \*(Aq1\*(Aq, 418 | \& RV => \*(Aq0x720210\*(Aq, 419 | \& sv => \*(AqPVIV(0x7223e0) at 0x843a10\*(Aq 420 | \& }, 421 | \& PVIV("foo") => { 422 | \& CUR => \*(Aq3\*(Aq, 423 | \& FLAGS => { 424 | \& PADBUSY => 1, 425 | \& PADMY => 1, 426 | \& POK => 1, 427 | \& pPOK => 1 428 | \& }, 429 | \& IV => \*(Aq1\*(Aq, 430 | \& LEN => \*(Aq8\*(Aq, 431 | \& PV => \*(Aq0x7496c0 "egg"\e\e0\*(Aq, 432 | \& REFCNT => \*(Aq1\*(Aq, 433 | \& sv => \*(AqPVIV(0x7223e0) at 0x843a10\*(Aq 434 | \& } 435 | \& }, 436 | \& sv => \*(AqRV(0x79d058) at 0x843310\*(Aq 437 | \& }; 438 | .Ve 439 | .ie n .SS "DDump_IO ($io, $var [, $dig_level])" 440 | .el .SS "DDump_IO ($io, \f(CW$var\fP [, \f(CW$dig_level\fP])" 441 | .IX Subsection "DDump_IO ($io, $var [, $dig_level])" 442 | A wrapper function around perl\*(Aqs internal \f(CW\*(C`Perl_do_sv_dump\*(C'\fR, which 443 | makes \f(CW\*(C`Devel::Peek\*(C'\fR completely superfluous. 444 | .PP 445 | Example 446 | .PP 447 | .Vb 5 448 | \& my $dump; 449 | \& open my $eh, ">", \e$dump; 450 | \& DDump_IO ($eh, { 3 => 4, ape => [5..8]}, 6); 451 | \& close $eh; 452 | \& print $dump; 453 | \& 454 | \& SV = RV(0x79d9e0) at 0x843f00 455 | \& REFCNT = 1 456 | \& FLAGS = (TEMP,ROK) 457 | \& RV = 0x741090 458 | \& SV = PVHV(0x79c948) at 0x741090 459 | \& REFCNT = 1 460 | \& FLAGS = (SHAREKEYS) 461 | \& IV = 2 462 | \& NV = 0 463 | \& ARRAY = 0x748ff0 (0:7, 2:1) 464 | \& hash quality = 62.5% 465 | \& KEYS = 2 466 | \& FILL = 1 467 | \& MAX = 7 468 | \& RITER = \-1 469 | \& EITER = 0x0 470 | \& Elt "ape" HASH = 0x97623e03 471 | \& SV = RV(0x79d9d8) at 0x8440e0 472 | \& REFCNT = 1 473 | \& FLAGS = (ROK) 474 | \& RV = 0x741470 475 | \& SV = PVAV(0x7264b0) at 0x741470 476 | \& REFCNT = 2 477 | \& FLAGS = () 478 | \& IV = 0 479 | \& NV = 0 480 | \& ARRAY = 0x822f70 481 | \& FILL = 3 482 | \& MAX = 3 483 | \& ARYLEN = 0x0 484 | \& FLAGS = (REAL) 485 | \& Elt No. 0 486 | \& SV = IV(0x7467c8) at 0x7c1aa0 487 | \& REFCNT = 1 488 | \& FLAGS = (IOK,pIOK) 489 | \& IV = 5 490 | \& Elt No. 1 491 | \& SV = IV(0x7467b0) at 0x8440f0 492 | \& REFCNT = 1 493 | \& FLAGS = (IOK,pIOK) 494 | \& IV = 6 495 | \& Elt No. 2 496 | \& SV = IV(0x746810) at 0x75be00 497 | \& REFCNT = 1 498 | \& FLAGS = (IOK,pIOK) 499 | \& IV = 7 500 | \& Elt No. 3 501 | \& SV = IV(0x746d38) at 0x7799d0 502 | \& REFCNT = 1 503 | \& FLAGS = (IOK,pIOK) 504 | \& IV = 8 505 | \& Elt "3" HASH = 0xa400c7f3 506 | \& SV = IV(0x746fd0) at 0x7200e0 507 | \& REFCNT = 1 508 | \& FLAGS = (IOK,pIOK) 509 | \& IV = 4 510 | .Ve 511 | .SH INTERNALS 512 | .IX Header "INTERNALS" 513 | \&\f(CW\*(C`DDump\*(C'\fR uses an XS wrapper around \f(CW\*(C`Perl_sv_dump\*(C'\fR where the STDERR is 514 | temporarily caught to a pipe. The internal XS helper functions are not 515 | meant for user space 516 | .SS "DDump_XS (SV *sv)" 517 | .IX Subsection "DDump_XS (SV *sv)" 518 | Base interface to internals for \f(CW\*(C`DDump\*(C'\fR. 519 | .SH BUGS 520 | .IX Header "BUGS" 521 | Windows and AIX might be using a build where not all symbols that were 522 | supposed to be exported in the public API are not. \f(CW\*(C`Perl_pv_peek\*(C'\fR is 523 | one of them. 524 | .PP 525 | Not all types of references are supported. 526 | .PP 527 | No idea how far back this goes in perl support, but Devel::PPPort has 528 | proven to be a big help. 529 | .SH "SEE ALSO" 530 | .IX Header "SEE ALSO" 531 | Devel::Peek, Data::Dumper, Data::Dump, Devel::Dumpvar, 532 | Data::Dump::Streamer, Data::Dumper::Perltidy, Perl::Tidy. 533 | .SH AUTHOR 534 | .IX Header "AUTHOR" 535 | H.Merijn Brand 536 | .SH "COPYRIGHT AND LICENSE" 537 | .IX Header "COPYRIGHT AND LICENSE" 538 | Copyright (C) 2008\-2025 H.Merijn Brand 539 | .PP 540 | This library is free software; you can redistribute it and/or modify 541 | it under the same terms as Perl itself. 542 | -------------------------------------------------------------------------------- /sandbox/genMETA.pm: -------------------------------------------------------------------------------- 1 | #!/pro/bin/perl 2 | 3 | package genMETA; 4 | 5 | our $VERSION = "1.18-20250113"; 6 | 7 | use 5.014001; 8 | use warnings; 9 | use Carp; 10 | 11 | use CPAN::Meta::Converter; 12 | use CPAN::Meta::Validator; 13 | use Data::Peek; 14 | use Date::Calc qw( Delta_Days ); 15 | use Encode qw( encode decode ); 16 | use File::Find; 17 | use JSON::PP; 18 | use List::Util qw( first ); 19 | use Parse::CPAN::Meta; 20 | use Software::Security::Policy::Individual; 21 | use Term::ANSIColor qw(:constants); 22 | use Test::CPAN::Meta::YAML::Version; 23 | use Test::More (); 24 | use Text::Diff; 25 | use YAML::Syck; 26 | 27 | sub new { 28 | my $package = shift; 29 | return bless { @_ }, $package; 30 | } # new 31 | 32 | sub extract_version { 33 | my $fh = shift; 34 | my @vsn; 35 | while (<$fh>) { 36 | m/\$VERSION\b/ and push @vsn => $_; 37 | m{^(?:our\s+)? # declaration 38 | \$VERSION \s*=\s* # variable 39 | ["']? ([0-9._]+) # version 40 | (?:\s* - \s* [0-9]{4}-?[0-9]{2}-?[0-9]{2} \s*)? # date "0.01 - 20230412" 41 | ['"]? 42 | \s*;\s* 43 | (?:\x23 \s* [0-9]{4}-?[0-9]{2}-?[0-9]{2} \s*)? # date "0.01"; # 20230502 44 | $}x or next; 45 | return $1; 46 | } 47 | # No match on first scan, try without date 48 | for (@vsn) { 49 | m{^(?:our\s+)? # declaration 50 | \$VERSION \s*=\s* # variable 51 | ([""'']) ([0-9._]+) \1 # version 52 | \s*; 53 | }x or next; 54 | return $2; 55 | } 56 | } # extract_version 57 | 58 | sub version_from { 59 | my ($self, $src) = @_; 60 | 61 | $self->{mfpr} = {}; 62 | if (open my $mh, "<", "Makefile.PL") { 63 | my $mf = do { local $/; <$mh> }; 64 | 65 | if ($mf =~ m{\b NAME \s*=>\s* ["'] (\S+) ['"]}x) { 66 | $self->{name} = $1; 67 | $self->{name} =~ m/-/ and 68 | warn RED, "NAME in Makefile.PL contains a -", RESET, "\n"; 69 | $self->{name} =~ s/::/-/g; 70 | } 71 | if ($mf =~ m{\b DISTNAME \s*=>\s* ["'] (\S+) ['"]}x) { 72 | $self->{name} = $1; 73 | } 74 | 75 | if ($mf =~ m{\b VERSION_FROM \s*=>\s* ["'] (\S+) ['"]}x) { 76 | my $from = $1; 77 | -f $from or 78 | croak RED, "Makefile wants version from nonexisten $from", RESET, "\n"; 79 | $self->{from} //= $from; 80 | $from eq $self->{from} or 81 | croak RED, "VERSION_FROM mismatch Makefile.PL ($from) / YAML ($self->{from})", RESET, "\n"; 82 | } 83 | 84 | if ($mf =~ m[\b PREREQ_PM \s*=>\s* \{ ( [^}]+ ) \}]x) { 85 | my @pr = split m/\n/ => $1; 86 | $self->{mfpr} = { map { (m{ \b ["']? (\S+?) ['"]? \s*=>\s* ["']? ([-0-9._]+) ['"]? }x) } grep !m/^\s*#/ => @pr }; 87 | } 88 | 89 | $mf =~ m{--format=ustar} or 90 | warn RED, "TARFLAGS macro is missing", RESET, "\n"; 91 | } 92 | 93 | $src //= $self->{from} or croak "No file to extract version from"; 94 | 95 | open my $pm, "<", $src or croak "Cannot read $src"; 96 | my $version = extract_version ($pm) or croak "Cannot extract VERSION from $src\n"; 97 | close $pm; 98 | $self->{version} = $version; 99 | return $version 100 | } # version_from 101 | 102 | sub from_data { 103 | my ($self, @data) = @_; 104 | $self->{version} or $self->version_from (); 105 | s/VERSION/$self->{version}/g for @data; 106 | my ($dsct, $dmod); 107 | for (@data) { 108 | s/[ \t]+$//; 109 | m/^\s*(\w+):$/ and $dsct = $1; 110 | m/^\s*(\w(?:[\w:]+\w)?):\s+\d/ and $dmod = $1; 111 | s/\s+#\s*ignore\b\s*[:=]?\s*(\S+)$//i or next; 112 | $self->{cve_ignore}{$dsct}{$dmod} = $1; 113 | } 114 | $self->{yml} = \@data; 115 | $self->check_yaml (); 116 | $self->check_provides (); 117 | #DDumper $self->{cve_ignore}; 118 | return @data; 119 | } # from_data 120 | 121 | sub check_encoding { 122 | my $self = shift; 123 | my @tf = grep m{^(?: change | readme | .*\.pod )}ix => glob "*"; 124 | (my $tf = join ", " => @tf) =~ s/.*\K, / and /; 125 | 126 | print "Check if $tf are still valid UTF8 ...\n"; 127 | foreach my $tf (@tf) { 128 | open my $fh, "<", $tf or croak "$tf: $!\n"; 129 | my @c = <$fh>; 130 | my $c = join "" => @c; 131 | my @e; 132 | my $s = decode ("utf-8", $c, sub { push @e, shift; }); 133 | if (@e) { 134 | my @l; 135 | my $n = 0; 136 | for (@c) { 137 | $n++; 138 | eval { decode ("utf-8", $_, 1) }; 139 | $@ or next; 140 | $@ =~ s{ at /\S+ line \d+.*}{}; 141 | print BLUE, "$tf:$n\t$_\t$@", RESET; 142 | } 143 | croak "$tf is not valid UTF-8\n"; 144 | } 145 | my $u = encode ("utf-8", $s); 146 | $c eq $u and next; 147 | 148 | my $n; 149 | $n = 1; $c =~ s/^/$n++ . "\t"/gem; 150 | $n = 1; $u =~ s/^/$n++ . "\t"/gem; 151 | croak "$tf: recode makes content differ\n". diff \$c, \$u; 152 | } 153 | } # check_encoding 154 | 155 | sub check_required { 156 | my $self = shift; 157 | 158 | my $yml = $self->{h} or croak "No YAML to check"; 159 | 160 | warn "Check required and recommended module versions ...\n"; 161 | BEGIN { $V::NO_EXIT = $V::NO_EXIT = 1 } require V; 162 | my %req = map { %{$yml->{$_}} } grep m/requires/ => keys %{$yml}; 163 | my %rec = map { %{$yml->{$_}} } grep m/recommends/ => keys %{$yml}; 164 | my %sug = map { %{$yml->{$_}} } grep m/suggests/ => keys %{$yml}; 165 | if (my $of = $yml->{optional_features}) { 166 | foreach my $f (values %{$of}) { 167 | my %q = map { %{$f->{$_}} } grep m/requires/ => keys %{$f}; 168 | my %c = map { %{$f->{$_}} } grep m/recommends/ => keys %{$f}; 169 | my %s = map { %{$f->{$_}} } grep m/suggests/ => keys %{$f}; 170 | @req{keys %q} = values %q; 171 | @rec{keys %c} = values %c; 172 | @sug{keys %s} = values %s; 173 | } 174 | } 175 | if (my $of = $yml->{prereqs}) { 176 | foreach my $f (values %{$of}) { 177 | my %q = map { %{$f->{$_}} } grep m/requires/ => keys %{$f}; 178 | my %c = map { %{$f->{$_}} } grep m/recommends/ => keys %{$f}; 179 | my %s = map { %{$f->{$_}} } grep m/suggests/ => keys %{$f}; 180 | @req{keys %q} = values %q; 181 | @rec{keys %c} = values %c; 182 | @sug{keys %s} = values %s; 183 | } 184 | } 185 | my %vsn = ( %req, %rec, %sug ); 186 | delete @vsn{qw( perl version )}; 187 | for (sort keys %vsn) { 188 | if (my $mfv = delete $self->{mfpr}{$_}) { 189 | $req{$_} eq $mfv or 190 | croak RED, "PREREQ mismatch for $_ Makefile.PL ($mfv) / YAML ($req{$_})", RESET, "\n"; 191 | } 192 | $vsn{$_} eq "0" and next; 193 | my $v = V::get_version ($_); 194 | $v eq $vsn{$_} and next; 195 | printf STDERR "%s%-35s %-6s => %s%s%s\n", BLUE, $_, $vsn{$_}, GREEN, $v, RESET; 196 | } 197 | if (my @mfpr = grep { $_ ne "version" } sort keys %{$self->{mfpr}}) { 198 | croak RED, "Makefile.PL requires @mfpr, YAML does not", RESET, "\n"; 199 | } 200 | 201 | find (sub { 202 | $File::Find::dir =~ m{^blib\b} and return; 203 | $File::Find::name =~ m{(?:^|/)Bundle/.*\.pm} or return; 204 | if (open my $bh, "<", $_) { 205 | warn "Check bundle module versions $File::Find::name ...\n"; 206 | while (<$bh>) { 207 | my ($m, $dv) = m/^([A-Za-z_:]+)\s+([0-9.]+)\s*$/ or next; 208 | my $v = $m eq $self->{name} ? $self->{version} : V::get_version ($m); 209 | $v eq $dv and next; 210 | printf STDERR "%s%-35s %-6s => %s%s%s\n", BLUE, $m, $dv, GREEN, $v, RESET; 211 | } 212 | } 213 | }, glob "*"); 214 | } # check_required 215 | 216 | sub check_yaml { 217 | my $self = shift; 218 | 219 | my @yml = @{$self->{yml}} or croak "No YAML to check"; 220 | 221 | warn "Checking generated YAML ...\n" unless $self->{quiet}; 222 | my $h; 223 | my $yml = join "", @yml; 224 | eval { $h = Load ($yml) }; 225 | $@ and croak "$@\n"; 226 | $self->{name} //= $h->{name}; 227 | $self->{name} eq $h->{name} or 228 | croak RED, "NAME mismatch Makefile.PL / YAML", RESET, "\n"; 229 | $self->{name} =~ s/-/::/g; 230 | warn "Checking for $self->{name}-$self->{version}\n" unless $self->{quiet}; 231 | 232 | $self->{verbose} and print Dump $h; 233 | 234 | my $t = Test::CPAN::Meta::YAML::Version->new (data => $h); 235 | $t->parse () and 236 | croak join "\n", "Test::CPAN::Meta::YAML reported failure:", $t->errors, ""; 237 | 238 | eval { Parse::CPAN::Meta::Load ($yml) }; 239 | $@ and croak "$@\n"; 240 | 241 | $self->{h} = $h; 242 | $self->{yaml} = $yml; 243 | } # check_yaml 244 | 245 | sub check_minimum { 246 | my $self = shift; 247 | my $reqv = $self->{h}{requires}{perl} || $self->{h}{prereqs}{runtime}{requires}{perl}; 248 | my $locs; 249 | 250 | for (@_) { 251 | if (ref $_ eq "ARRAY") { 252 | $locs = { paths => $_ }; 253 | } 254 | elsif (ref $_ eq "HASH") { 255 | $locs = $_; 256 | } 257 | else { 258 | $reqv = $_; 259 | } 260 | } 261 | my $paths = (join ", " => @{($locs // {})->{paths} // []}) || "default paths"; 262 | 263 | $reqv or croak "No minimal required version for perl"; 264 | my $tmv = 0; 265 | $reqv > 5.009 and eval "use Test::MinimumVersion::Fast; \$tmv = 1"; 266 | $tmv or eval "use Test::MinimumVersion;"; 267 | print "Checking if $reqv is still OK as minimal version for $paths\n"; 268 | # All other minimum version checks done in xt 269 | Test::More::subtest "Minimum perl version $reqv" => sub { 270 | all_minimum_version_ok ($reqv, $locs); 271 | } or warn RED, "\n### Use 'perlver --blame' on the failing file(s)\n\n", RESET; 272 | } # check_minimum 273 | 274 | sub check_provides { 275 | my $self = shift; 276 | my $prov = $self->{h}{provides}; 277 | 278 | print "Check distribution module versions ...\n"; 279 | 280 | $prov or croak RED, "META does not contain a provides section", RESET, "\n"; 281 | 282 | ref $prov eq "HASH" or 283 | croak RED, "The provides section in META is not a HASH", RESET, "\n"; 284 | 285 | my $fail = 0; 286 | foreach my $m (sort keys %{$prov}) { 287 | my ($file, $pvsn) = @{$prov->{$m}}{qw( file version )}; 288 | unless ($file) { 289 | $fail++; 290 | say RED, " provided $m does not refer to a file", RESET; 291 | next; 292 | } 293 | unless ($pvsn) { 294 | $fail++; 295 | say RED, " provided $m does not declare a version", RESET; 296 | next; 297 | } 298 | 299 | printf " Expect %5s for %-32s ", $pvsn, $m; 300 | open my $fh, "<", $file; 301 | unless ($fh) { 302 | $fail++; 303 | say RED, "$file: $!\n", RESET; 304 | next; 305 | } 306 | 307 | my $version = extract_version ($fh); 308 | close $fh; 309 | unless ($version) { 310 | $fail++; 311 | say RED, "$file does not contain a VERSION", RESET; 312 | next; 313 | } 314 | 315 | if ($version ne $pvsn) { 316 | $fail++; 317 | say RED, "mismatch: $version", RESET; 318 | next; 319 | } 320 | say "ok"; 321 | } 322 | 323 | $fail and exit 1; 324 | } # check_provides 325 | 326 | sub check_changelog { 327 | # Check if the first date has been updated ... 328 | my @td = grep m/^Change(?:s|Log)$/i => glob "[Cc]*"; 329 | unless (@td) { 330 | warn "No ChangeLog to check\n"; 331 | return; 332 | } 333 | my %mnt = qw( jan 1 feb 2 mar 3 apr 4 may 5 jun 6 jul 7 aug 8 sep 9 oct 10 nov 11 dec 12 ); 334 | open my $fh, "<", $td[0] or croak "$td[0]: $!\n"; 335 | while (<$fh>) { 336 | s/\b([0-9]{4}) (?:[- ]) 337 | ([0-9]{1,2}) (?:[- ]) 338 | ([0-9]{1,2})\b/$3-$2-$1/x; # 2015-01-15 => 15-01-2015 339 | m/\b([0-9]{1,2}) (?:[- ]) 340 | ([0-9]{1,2}|[ADFJMNOSadfjmnos][acekopu][abcgilnprtvy]) (?:[- ]) 341 | ([0-9]{4})\b/x or next; 342 | my ($d, $m, $y) = ($1 + 0, ($mnt{lc $2} || $2) + 0, $3 + 0); 343 | printf STDERR "Most recent ChangeLog entry is dated %02d-%02d-%04d\n", $d, $m, $y; 344 | unless ($ENV{SKIP_CHANGELOG_DATE}) { 345 | my @t = localtime; 346 | my $D = Delta_Days ($y, $m , $d, $t[5] + 1900, $t[4] + 1, $t[3]); 347 | $D < 0 and croak RED, "Last entry in $td[0] is in the future!", RESET, "\n"; 348 | $D > 2 and croak RED, "Last entry in $td[0] is not up to date ($D days ago)", RESET, "\n"; 349 | $D > 0 and warn YELLOW, "Last entry in $td[0] is not today", RESET, "\n"; 350 | } 351 | last; 352 | } 353 | close $fh; 354 | } # check_changelog 355 | 356 | sub done_testing { 357 | check_changelog (); 358 | Test::More::done_testing (); 359 | } # done_testing 360 | 361 | sub quiet { 362 | my $self = shift; 363 | @_ and $self->{quiet} = defined $_[0]; 364 | $self->{quiet}; 365 | } # quiet 366 | 367 | sub print_json { 368 | my $self = shift; 369 | my $jsn = $self->{jsn} || $self->add_json (); 370 | print JSON::PP->new->utf8 (1)->pretty (1)->encode ($jsn); 371 | } # print_json 372 | 373 | sub print_yaml { 374 | my $self = shift; 375 | print @{$self->{yml}}; 376 | } # print_yaml 377 | 378 | sub write_yaml { 379 | my ($self, $out) = @_; 380 | $out ||= "META.yml"; 381 | $out =~ s/\.jso?n$/.yml/; 382 | open my $fh, ">", $out or croak "$out: $!\n"; 383 | print $fh @{$self->{yml}}; 384 | close $fh; 385 | $self->fix_meta ($out); 386 | } # print_yaml 387 | 388 | sub add_json { 389 | my $self = shift; 390 | # Convert to meta-spec version 2 391 | # licenses are lists now 392 | my $jsn = $self->{h}; 393 | $jsn->{"meta-spec"} = { 394 | version => "2", 395 | url => "https://metacpan.org/module/CPAN::Meta::Spec?#meta-spec", 396 | }; 397 | exists $jsn->{resources}{license} and 398 | $jsn->{resources}{license} = [ $jsn->{resources}{license} ]; 399 | delete $jsn->{distribution_type}; 400 | if (exists $jsn->{license}) { 401 | if (ref $jsn->{license} eq "ARRAY") { 402 | $jsn->{license}[0] =~ s/^perl$/perl_5/i; 403 | } 404 | else { 405 | $jsn->{license} =~ s/^perl$/perl_5/i; 406 | $jsn->{license} = [ $jsn->{license} ]; 407 | } 408 | } 409 | if (exists $jsn->{resources}{bugtracker}) { 410 | my $url = $jsn->{resources}{bugtracker}; 411 | $jsn->{resources}{bugtracker} = { 412 | web => $url, 413 | }; 414 | } 415 | if (exists $jsn->{resources}{repository}) { 416 | my $url = $jsn->{resources}{repository}; 417 | my $web = $url; 418 | $url =~ s{repo.or.cz/w/}{repo.or.cz/r/}; 419 | $web =~ s{repo.or.cz/r/}{repo.or.cz/w/}; 420 | $jsn->{resources}{repository} = { 421 | type => "git", 422 | web => $web, 423 | url => $url, 424 | }; 425 | } 426 | foreach my $sct ("", "configure_", "build_", "test_") { 427 | (my $x = $sct || "runtime") =~ s/_$//; 428 | for (qw( requires recommends suggests )) { 429 | exists $jsn->{"$sct$_"} and 430 | $jsn->{prereqs}{$x}{$_} = delete $jsn->{"$sct$_"}; 431 | } 432 | } 433 | 434 | # optional features do not yet know about requires and/or recommends diirectly 435 | if (my $of = $jsn->{optional_features}) { 436 | foreach my $f (keys %$of) { 437 | if (my $r = delete $of->{$f}{requires}) { 438 | #$jsn->{prereqs}{runtime}{recommends}{$_} //= $r->{$_} for keys %$r; 439 | $of->{$f}{prereqs}{runtime}{requires} = $r; 440 | } 441 | if (my $r = delete $of->{$f}{recommends}) { 442 | #$jsn->{prereqs}{runtime}{recommends}{$_} //= $r->{$_} for keys %$r; 443 | $of->{$f}{prereqs}{runtime}{recommends} = $r; 444 | } 445 | if (my $r = delete $of->{$f}{suggests}) { 446 | #$jsn->{prereqs}{runtime}{suggests}{$_} //= $r->{$_} for keys %$r; 447 | $of->{$f}{prereqs}{runtime}{suggests} = $r; 448 | } 449 | } 450 | } 451 | 452 | $jsn = CPAN::Meta::Converter->new ($jsn)->convert (version => "2"); 453 | $jsn->{generated_by} = "Author"; 454 | $self->{jsn} = $jsn; 455 | } # add_json 456 | 457 | sub fix_meta { 458 | my ($self, $yf) = @_; 459 | 460 | my $jsn = $self->add_json (); 461 | 462 | my $cmv = CPAN::Meta::Validator->new ($jsn); 463 | $cmv->is_valid or 464 | croak join "\n" => RED, "META Validator found fail:\n", $cmv->errors, RESET, ""; 465 | 466 | unless ($yf) { 467 | my @my = grep { -s } glob ("*/META.yml"), "META.yml" or croak "No META files"; 468 | $yf = $my[0]; 469 | } 470 | my $jf = $yf =~ s/yml$/json/r; 471 | open my $jh, ">", $jf or croak "Cannot update $jf: $!\n"; 472 | print $jh JSON::PP->new->utf8 (1)->pretty (1)->encode ($jsn); 473 | close $jh; 474 | 475 | # Now that 2.0 JSON is corrrect, create a 1.4 YAML back from the modified stuff 476 | my $yml = $jsn; 477 | # 1.4 does not know about test_*, move them to * 478 | if (my $tp = delete $yml->{prereqs}{test}) { 479 | foreach my $phase (keys %{$tp}) { 480 | my $p = $tp->{$phase}; 481 | #DDumper { $phase => $p }; 482 | $yml->{prereqs}{runtime}{$phase}{$_} //= $p->{$_} for keys %{$p}; 483 | } 484 | } 485 | 486 | # Optional features in 1.4 knows requires, but not recommends. 487 | # The Lancaster Consensus moves 2.0 optional recommends promote to 488 | # requires in 1.4 489 | if (my $of = $yml->{optional_features}) { 490 | foreach my $f (keys %$of) { 491 | if (my $r = delete $of->{$f}{prereqs}{runtime}{recommends}) { 492 | $of->{$f}{requires} = $r; 493 | } 494 | if (my $r = delete $of->{$f}{prereqs}{runtime}{suggests}) { 495 | $of->{$f}{suggests} = $r; 496 | } 497 | } 498 | } 499 | # runtime and test_requires are unknown as top-level in 1.4 500 | foreach my $phase (qw( xuntime test_requires )) { 501 | if (my $p = delete $yml->{$phase}) { 502 | foreach my $f (keys %$p) { 503 | $yml->{$f}{$_} ||= $p->{$f}{$_} for keys %{$p->{$f}}; 504 | } 505 | } 506 | } 507 | 508 | #DDumper $yml; 509 | # This does NOT create a correct YAML id the source does not comply! 510 | $yml = CPAN::Meta::Converter->new ($yml)->convert (version => "1.4"); 511 | $yml->{requires}{perl} //= $jsn->{prereqs}{runtime}{requires}{perl} 512 | // $self->{h}{requires}{perl} 513 | // ""; 514 | $yml->{build_requires} && !keys %{$yml->{build_requires}} and 515 | delete $yml->{build_requires}; 516 | #DDumper $yml; 517 | #exit; 518 | 519 | open my $my, ">", $yf or croak "Cannot update $yf: $!\n"; 520 | print $my Dump $yml; # @{$self->{yml}}; 521 | close $my; 522 | 523 | chmod 0644, glob "*/META.*"; 524 | unlink glob "MYMETA*"; 525 | } # fix_meta 526 | 527 | sub _cpfd { 528 | my ($self, $jsn, $sct, $f) = @_; 529 | 530 | open my $sh, ">", \my $b; 531 | my $sep = ""; 532 | for (qw( requires recommends suggests )) { 533 | my $x = "$sct$_"; 534 | my $s = $jsn->{$x} or next; 535 | print $sh $sep; 536 | foreach my $m (sort keys %$s) { 537 | $m eq "perl" and next; 538 | my $v = $s->{$m}; 539 | printf $sh qq{%-10s "%s"}, $_, $m; 540 | my $aw = (24 - length $m); $aw < 0 and $aw = 0; 541 | printf $sh qq{%s => "%s"}, " " x $aw, $v if $v; 542 | print $sh ";"; 543 | if (my $i = $self->{cve_ignore}{$x}{$m}) { 544 | print $sh " # ignore : $i"; 545 | } 546 | say $sh ""; 547 | } 548 | $sep = "\n"; 549 | } 550 | close $sh; 551 | $sct || $f and $b and $b .= "};"; 552 | return $b; 553 | } # _cpfd 554 | 555 | sub gen_cpanfile { 556 | my $self = shift; 557 | 558 | warn "Generating cpanfile ...\n"; 559 | open my $fh, ">", "cpanfile"; 560 | 561 | my $jsn = $self->{h}; 562 | foreach my $sct_ ("", "configure_", "build_", "test_", "runtime_") { 563 | 564 | my $sct = $sct_ =~ s/_$//r; 565 | 566 | my $b = _cpfd ($self, $jsn, $sct_, 0) or next; 567 | 568 | if ($sct) { 569 | say $fh qq/\non "$sct" => sub {/; 570 | say $fh $b =~ s/^(?=\S)/ /gmr; 571 | } 572 | else { 573 | print $fh $b; 574 | } 575 | } 576 | 577 | if (my $of = $jsn->{optional_features}) { 578 | foreach my $f (sort keys %$of) { 579 | my $fs = $of->{$f}; 580 | say $fh qq/\nfeature "$f", "$fs->{description}" => sub {/;#} 581 | say $fh _cpfd ($self, $fs, "", 1) =~ s/^(?=\S)/ /gmr; 582 | } 583 | } 584 | 585 | close $fh; 586 | 587 | warn "Check CVE's ...\n"; 588 | if (system "cpan-cve.pl", "-d", ".") { 589 | warn "### CVE WARNING\n"; 590 | warn "#\n"; 591 | warn "# The current release would have recommended versions\n"; 592 | warn "# with known CVE's that are not (yet) ignored\n"; 593 | sleep (5); 594 | } 595 | } # gen_cpanfile 596 | 597 | sub security_md { 598 | my ($self, $update) = @_; 599 | 600 | my $sfn = "SECURITY.md"; 601 | my $policy = Software::Security::Policy::Individual->new ({ 602 | maintainer => $self->{h}{author}[0], 603 | program => $self->{name}, 604 | timeframe => "10 days", 605 | url => $self->{h}{resources}{repository}, 606 | perl_support_years => 5, 607 | }); 608 | 609 | my $smd = $policy->fulltext; 610 | 611 | unless (-s $sfn) { 612 | open my $fh, ">:encoding(utf-8)", $sfn or die "$sfn: $! \n"; 613 | print $fh $smd; 614 | close $fh; 615 | 616 | if (open $fh, "<", "MANIFEST") { 617 | my @m = <$fh>; 618 | close $fh; 619 | unless (grep m/^$sfn(?:\s|$)/ => @m) { 620 | open $fh, ">>", "MANIFEST" or die "MANIFEST: $!\n"; 621 | say $fh "$sfn\t\tGuide for reporting security issues"; 622 | close $fh; 623 | } 624 | } 625 | say "$sfn added"; 626 | } 627 | 628 | open my $fh, "<:encoding(utf-8)", $sfn or die "$sfn: $!\n"; 629 | my $old = do { local $/; <$fh> }; 630 | close $fh; 631 | 632 | $old eq $smd and return; 633 | 634 | if ($update) { 635 | open my $fh, ">:encoding(utf-8)", $sfn or die "$sfn: $!\n"; 636 | print $fh $smd; 637 | close $fh; 638 | say "$sfn updated"; 639 | } 640 | else { 641 | say "$sfn required updates:"; 642 | say diff \$old, \$smd; 643 | say "to apply, use $0 --check --update"; 644 | } 645 | } # gen_security 646 | 647 | 1; 648 | -------------------------------------------------------------------------------- /Peek.pm: -------------------------------------------------------------------------------- 1 | package Data::Peek; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use XSLoader; 7 | 8 | use vars qw( $VERSION @ISA @EXPORT @EXPORT_OK ); 9 | $VERSION = "0.54"; 10 | @ISA = qw( Exporter ); 11 | @EXPORT = qw( DDumper DTidy DDsort DPeek DDisplay DDump DHexDump 12 | DDual DGrow ); 13 | @EXPORT_OK = qw( triplevar :tidy ); 14 | push @EXPORT, "DDump_IO"; 15 | 16 | XSLoader::load ("Data::Peek", $VERSION); 17 | 18 | our $has_perlio; 19 | our $has_perltidy; 20 | 21 | BEGIN { 22 | use Config; 23 | $has_perlio = ($Config{'useperlio'} || "undef") eq "define"; 24 | $has_perltidy = eval { require Perl::Tidy; $Perl::Tidy::VERSION }; 25 | } 26 | 27 | ### ############# DDumper () ################################################## 28 | 29 | use Data::Dumper; 30 | 31 | my %sk = ( 32 | undef => 0, 33 | "" => 0, 34 | 0 => 0, 35 | 1 => 1, 36 | 37 | 'R' => sub { # Sort reverse 38 | my $r = shift; 39 | [ reverse sort keys %{$r} ]; 40 | }, 41 | 'N' => sub { # Sort by key numerical 42 | my $r = shift; 43 | [ sort { $a <=> $b } keys %{$r} ]; 44 | }, 45 | 'NR' => sub { # Sort by key numerical reverse 46 | my $r = shift; 47 | [ sort { $b <=> $a } keys %{$r} ]; 48 | }, 49 | 'V' => sub { # Sort by value 50 | my $r = shift; 51 | [ sort { $r->{$a} cmp $r->{$b} } keys %{$r} ]; 52 | }, 53 | 'VN' => sub { # Sort by value numeric 54 | my $r = shift; 55 | [ sort { $r->{$a} <=> $r->{$b} } keys %{$r} ]; 56 | }, 57 | 'VNR' => sub { # Sort by value numeric reverse 58 | my $r = shift; 59 | [ sort { $r->{$b} <=> $r->{$a} } keys %{$r} ]; 60 | }, 61 | 'VR' => sub { # Sort by value reverse 62 | my $r = shift; 63 | [ sort { $r->{$b} cmp $r->{$a} } keys %{$r} ]; 64 | }, 65 | ); 66 | my $_sortkeys = 1; 67 | our $_perltidy = 0; 68 | 69 | my %pmap = map {( $_ => $_ )} map {( split //, $_ )} 70 | q{ !""#$%&'()*+,-./0123456789:;<=>}, 71 | q{@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^}, 72 | q{`abcdefghijklmnopqrstuvwxyz|~}, "{}"; 73 | $pmap{$_} = "." for grep { !exists $pmap{$_} } map { chr } 0 .. 255; 74 | 75 | sub DDsort { 76 | @_ or return; 77 | 78 | $_sortkeys = exists $sk{$_[0]} ? $sk{$_[0]} : $_[0]; 79 | } # DDsort 80 | 81 | sub import { 82 | my @exp = @_; 83 | my @etl; 84 | foreach my $p (@exp) { 85 | exists $sk{$p} and DDsort ($p), next; 86 | 87 | if ($p eq ":tidy") { 88 | $_perltidy = $has_perltidy; 89 | next; 90 | } 91 | 92 | push @etl, $p; 93 | } 94 | __PACKAGE__->export_to_level (1, @etl); 95 | } # import 96 | 97 | sub DDumper { 98 | $_perltidy and goto \&DTidy; 99 | 100 | local $Data::Dumper::Sortkeys = $_sortkeys; 101 | local $Data::Dumper::Indent = 1; 102 | local $Data::Dumper::Quotekeys = 0; 103 | local $Data::Dumper::Deparse = 1; 104 | local $Data::Dumper::Terse = 1; 105 | local $Data::Dumper::Purity = 1; 106 | local $Data::Dumper::Useqq = 0; # I want unicode visible 107 | 108 | my $s = Data::Dumper::Dumper (@_); 109 | $s =~ s/^(\s*)(.*?)\s*=>/sprintf "%s%-16s =>", $1, $2/gme; # Align => 110 | $s =~ s/\bbless\s*\(\s*/bless (/gm and $s =~ s/\s+\)([;,])$/)$1/gm; 111 | $s =~ s/^(?=\s*[]}](?:[;,]|$))/ /gm; 112 | $s =~ s/^(\s*[{[]) *\n *(?=\S)(?![{[])/$1 /gm; 113 | $s =~ s/^(\s+)/$1$1/gm; 114 | 115 | defined wantarray or warn $s; 116 | return $s; 117 | } # DDumper 118 | 119 | sub DTidy { 120 | $has_perltidy or goto \&DDumper; 121 | 122 | local $Data::Dumper::Sortkeys = $_sortkeys; 123 | local $Data::Dumper::Indent = 1; 124 | local $Data::Dumper::Quotekeys = 1; 125 | local $Data::Dumper::Deparse = 1; 126 | local $Data::Dumper::Terse = 1; 127 | local $Data::Dumper::Purity = 1; 128 | local $Data::Dumper::Useqq = 0; 129 | 130 | my $s = Data::Dumper::Dumper (@_); 131 | my $t; 132 | my @opts = ( 133 | # Disable stupid options in ~/.perltidyrc 134 | # people do so, even for root 135 | "--no-backup-and-modify-in-place", 136 | "--no-check-syntax", 137 | "--no-standard-output", 138 | "--no-warning-output", 139 | ); 140 | # RT#99514 - Perl::Tidy memoizes .perltidyrc incorrectly 141 | $has_perltidy > 20120714 and push @opts => "--no-memoize"; 142 | 143 | Perl::Tidy::perltidy ('source' => \$s, 'destination' => \$t, 'argv' => \@opts); 144 | $s = $t; 145 | 146 | defined wantarray or warn $s; 147 | return $s; 148 | } # DTidy 149 | 150 | ### ############# DDump () #################################################### 151 | 152 | sub _DDump_ref { 153 | my (undef, $down) = (@_, 0); 154 | 155 | my $ref = ref $_[0]; 156 | if ($ref eq "SCALAR" || $ref eq "REF") { 157 | my %hash = DDump (${$_[0]}, $down); 158 | return { %hash }; 159 | } 160 | if ($ref eq "ARRAY") { 161 | my @list; 162 | foreach my $list (@{$_[0]}) { 163 | my %hash = DDump ($list, $down); 164 | push @list, { %hash }; 165 | } 166 | return [ @list ]; 167 | } 168 | if ($ref eq "HASH") { 169 | my %hash; 170 | foreach my $key (sort keys %{$_[0]}) { 171 | $hash{DPeek ($key)} = { DDump ($_[0]->{$key}, $down) }; 172 | } 173 | return { %hash }; 174 | } 175 | undef; 176 | } # _DDump_ref 177 | 178 | sub _DDump { 179 | my (undef, $down, $dump, $fh) = (@_, ""); 180 | 181 | if ($has_perlio and open $fh, ">", \$dump) { 182 | #print STDERR "Using DDump_IO\n"; 183 | DDump_IO ($fh, $_[0], $down); 184 | close $fh; 185 | } 186 | else { 187 | #print STDERR "Using DDump_XS\n"; 188 | $dump = DDump_XS ($_[0]); 189 | } 190 | 191 | return $dump; 192 | } # _DDump 193 | 194 | sub DDump { 195 | my $down = @_ > 1 ? $_[1] : 0; 196 | my @dump = split m/[\r\n]+/, _DDump (@_ ? $_[0] : $_, wantarray || $down) or return; 197 | 198 | if (wantarray) { 199 | my %hash; 200 | ($hash{'sv'} = $dump[0]) =~ s/^SV\s*=\s*//; 201 | m/^\s+(\w+)\s*=\s*(.*)/ and $hash{$1} = $2 for @dump; 202 | 203 | if (exists $hash{'FLAGS'}) { 204 | $hash{'FLAGS'} =~ tr/()//d; 205 | $hash{'FLAGS'} = { map {( $_ => 1 )} split m/,/ => $hash{'FLAGS'} }; 206 | } 207 | 208 | $down && ref $_[0] and 209 | $hash{'RV'} = _DDump_ref ($_[0], $down - 1) || $_[0]; 210 | return %hash; 211 | } 212 | 213 | my $dump = join "\n", @dump, ""; 214 | 215 | defined wantarray and return $dump; 216 | 217 | warn $dump; 218 | } # DDump 219 | 220 | sub DHexDump { 221 | use bytes; 222 | my $off = 0; 223 | my @out; 224 | my $var = @_ ? $_[0] : $_; 225 | defined $var or return; 226 | my $fmt = @_ > 1 && $_[1] < length ($var) ? "A$_[1]" : "A*"; 227 | my $str = pack $fmt, $var; # force stringification 228 | for (unpack "(A32)*", unpack "H*", $str) { 229 | my @b = unpack "(A2)*", $_; 230 | my $out = sprintf "%04x ", $off; 231 | $out .= " ".($b[$_]||" ") for 0 .. 7; 232 | $out .= " "; 233 | $out .= " ".($b[$_]||" ") for 8 .. 15; 234 | $out .= " "; 235 | $out .= $pmap{$_} for map { chr hex $_ } @b; 236 | push @out, $out."\n"; 237 | $off += 16; 238 | } 239 | 240 | wantarray and return @out; 241 | 242 | defined wantarray and return join "", @out; 243 | 244 | warn join "", @out; 245 | } # DHexDump 246 | 247 | "Indent"; 248 | 249 | __END__ 250 | 251 | =head1 NAME 252 | 253 | Data::Peek - A collection of low-level debug facilities 254 | 255 | =head1 SYNOPSIS 256 | 257 | use Data::Peek; 258 | 259 | print DDumper \%hash; # Same syntax as Data::Dumper 260 | DTidy { ref => $ref }; 261 | 262 | print DPeek \$var; 263 | my ($pv, $iv, $nv, $rv, $magic) = DDual ($var [, 1]); 264 | print DPeek for DDual ($!, 1); 265 | print DDisplay ("ab\nc\x{20ac}\rdef\n"); 266 | print DHexDump ("ab\nc\x{20ac}\rdef\n"); 267 | 268 | my $dump = DDump $var; 269 | my %hash = DDump \@list; 270 | DDump \%hash; 271 | 272 | my %hash = DDump (\%hash, 5); # dig 5 levels deep 273 | 274 | my $dump; 275 | open my $fh, ">", \$dump; 276 | DDump_IO ($fh, \%hash, 6); 277 | close $fh; 278 | print $dump; 279 | 280 | # Imports 281 | use Data::Peek qw( :tidy VNR DGrow triplevar ); 282 | my $x = ""; DGrow ($x, 10000); 283 | my $tv = triplevar ("\N{GREEK SMALL LETTER PI}", 3, "3.1415"); 284 | DDsort ("R"); 285 | DDumper [ $x ]; # use of :tidy makes DDumper behave like DTidy 286 | 287 | =head1 DESCRIPTION 288 | 289 | Data::Peek started off as C being a wrapper module over 290 | L, but grew out to be a set of low-level data 291 | introspection utilities that no other module provided yet, using the 292 | lowest level of the perl internals API as possible. 293 | 294 | =head2 DDumper ($var, ...) 295 | 296 | Not liking the default output of Data::Dumper, and always feeling the need 297 | to set C<$Data::Dumper::Sortkeys = 1;>, and not liking any of the default 298 | layouts, this function is just a wrapper around Data::Dumper::Dumper with 299 | everything set as I like it. 300 | 301 | $Data::Dumper::Sortkeys = 1; 302 | $Data::Dumper::Indent = 1; 303 | 304 | If C is Cd with import argument C<:tidy>, the result is 305 | formatted according to L, see L below, otherwise the 306 | result is further beautified to meet my needs: 307 | 308 | * quotation of hash keys has been removed (with the disadvantage 309 | that the output might not be parseable again). 310 | * arrows for hashes are aligned at 16 (longer keys don't align) 311 | * closing braces and brackets are now correctly aligned 312 | 313 | In void context, C C's. 314 | 315 | Example 316 | 317 | $ perl -MDP \ 318 | -e'DDumper { ape => 1, foo => "egg", bar => [ 2, "baz", undef ]};' 319 | 320 | { ape => 1, 321 | bar => [ 322 | 2, 323 | 'baz', 324 | undef 325 | ], 326 | foo => 'egg' 327 | }; 328 | 329 | =head2 DTidy ($var, ...) 330 | 331 | C is an alternative to C, where the output of C 332 | is formatted using C (if available) according to your 333 | C<.perltidyrc> instead of the default behavior, maybe somewhat like (YMMV): 334 | 335 | $ perl -MDP=:tidy \ 336 | -we'DDumper { ape => 1, foo => "egg", bar => [ 2, "baz", undef ]};' 337 | { 'ape' => 1, 338 | 'bar' => [2, 'baz', undef], 339 | 'foo' => 'egg' 340 | } 341 | 342 | If C is Cd with import argument C<:tidy>, this is the 343 | default output method for C. 344 | 345 | If L is not available, C will fallback to C. 346 | 347 | This idea was shamelessly copied from John McNamara's L. 348 | 349 | =head2 DDsort ( 0 | 1 | R | N | NR | V | VR | VN | VNR ) 350 | 351 | Set the hash sort algorithm for DDumper. The default is to sort by key value. 352 | 353 | 0 - Do not sort 354 | 1 - Sort by key 355 | R - Reverse sort by key 356 | N - Sort by key numerical 357 | NR - Sort by key numerical descending 358 | V - Sort by value 359 | VR - Reverse sort by value 360 | VN - Sort by value numerical 361 | VNR - Reverse sort by value numerical 362 | 363 | These can also be passed to import: 364 | 365 | $ perl -MDP=VNR \ 366 | -we'DDumper { foo => 1, bar => 2, zap => 3, gum => 13 }' 367 | { gum => 13, 368 | zap => 3, 369 | bar => 2, 370 | foo => 1 371 | }; 372 | $ perl -MDP=V \ 373 | -we'DDumper { foo => 1, bar => 2, zap => 3, gum => 13 }' 374 | { foo => 1, 375 | gum => 13, 376 | bar => 2, 377 | zap => 3 378 | }; 379 | 380 | =head2 DPeek 381 | 382 | =head2 DPeek ($var) 383 | 384 | Playing with C, I found C, and it might be very 385 | useful for simple checks. If C<$var> is omitted, uses $_. 386 | 387 | Example 388 | 389 | print DPeek "abc\x{0a}de\x{20ac}fg"; 390 | 391 | PV("abc\nde\342\202\254fg"\0) [UTF8 "abc\nde\x{20ac}fg"] 392 | 393 | In void context, C prints to C plus a newline. 394 | 395 | =head2 DDisplay 396 | 397 | =head2 DDisplay ($var) 398 | 399 | Show the PV content of a scalar the way perl debugging would have done. 400 | UTF-8 detection is on, so this is effectively the same as returning the 401 | first part the C returns for non-UTF8 PV's or the second part for 402 | UTF-8 PV's. C returns the empty string for scalars that no 403 | have a valid PV. 404 | 405 | Example 406 | 407 | print DDisplay "abc\x{0a}de\x{20ac}fg"; 408 | 409 | "abc\nde\x{20ac}fg" 410 | 411 | In void context, C uses C to display the result. 412 | 413 | =head2 DHexDump 414 | 415 | =head2 DHexDump ($var) 416 | 417 | =head2 DHexDump ($var, $length) 418 | 419 | Show the (stringified) content of a scalar as a hex-dump. If C<$var> 420 | is omitted, C<$_> is dumped. Returns C or an empty list if 421 | C<$var> (or C<$_>) is undefined. If C<$length> is given and is lower than 422 | the length of the stringified C<$var>, only <$length> bytes are dumped. 423 | 424 | In void context, the dump is done to STDERR. In scalar context, the 425 | complete dump is returned as a single string. In list context, the dump 426 | is returned as lines. 427 | 428 | Example 429 | 430 | print DHexDump "abc\x{0a}de\x{20ac}fg"; 431 | 432 | 0000 61 62 63 0a 64 65 e2 82 ac 66 67 abc.de...fg 433 | 434 | =head2 my ($pv, $iv, $nv, $rv, $hm) = DDual ($var [, $getmagic]) 435 | 436 | DDual will return the basic elements in a variable, guaranteeing that no 437 | conversion takes place. This is very useful for dual-var variables, or 438 | when checking is a variable has defined entries for a certain type of 439 | scalar. For each String (PV), Integer (IV), Double (NV), and Reference (RV), 440 | the current value of C<$var> is returned or undef if it is not set (yet). 441 | The 5th element is an indicator if C<$var> has magic, which is B invoked 442 | in the returned values, unless explicitly asked for with a true optional 443 | second argument. 444 | 445 | Example 446 | 447 | print DPeek for DDual ($!, 1); 448 | 449 | In void context, DDual does the equivalent of 450 | 451 | { my @d = DDual ($!, 1); 452 | print STDERR 453 | DPeek ($!), "\n", 454 | " PV: ", DPeek ($d[0]), "\n", 455 | " IV: ", DPeek ($d[1]), "\n", 456 | " NV: ", DPeek ($d[2]), "\n", 457 | " RV: ", DPeek ($d[3]), "\n"; 458 | } 459 | 460 | =head2 my $len = DGrow ($pv, $size) 461 | 462 | Fastest way to preallocate space for a PV scalar. Returns the allocated 463 | length. If $size is smaller than the already allocated space, it will 464 | not shrink. 465 | 466 | cmpthese (-2, { 467 | pack => q{my $x = ""; $x = pack "x20000"; $x = "";}, 468 | op_x => q{my $x = ""; $x = "x" x 20000; $x = "";}, 469 | grow => q{my $x = ""; DGrow ($x, 20000); $x = "";}, 470 | }); 471 | 472 | Rate op_x pack grow 5.8.9 5.10.1 5.12.4 5.14.2 473 | op_x 62127/s -- -59% -96% 118606/s 119730/s 352255/s 362605/s 474 | pack 152046/s 145% -- -91% 380075/s 355666/s 347247/s 387349/s 475 | grow 1622943/s 2512% 967% -- 2818380/s 2918783/s 2672340/s 2886787/s 476 | 477 | =head2 my $tp = triplevar ($pv, $iv, $nv) 478 | 479 | When making C I wondered if it were possible to create triple-val 480 | scalar variables. L already gives us C, that creates 481 | you a scalar with different numeric and string values that return different 482 | values in different context. Not that C would be very useful, 483 | compared to C, but at least this shows that it is possible. 484 | 485 | C is not exported by default. 486 | 487 | Example: 488 | 489 | DDual Data::Peek::triplevar ("\N{GREEK SMALL LETTER PI}", 3, 3.1415); 490 | 491 | PVNV("\317\200"\0) [UTF8 "\x{3c0}"] 492 | PV: PV("\317\200"\0) [UTF8 "\x{3c0}"] 493 | IV: IV(3) 494 | NV: NV(3.1415) 495 | RV: SV_UNDEF 496 | 497 | =head2 DDump ([$var [, $dig_level]]) 498 | 499 | A very useful module when debugging is C, but is has one big 500 | disadvantage: it only prints to STDERR, which is not very handy when your 501 | code wants to inspect variables at a low level. 502 | 503 | Perl itself has C, which does something similar, but still prints 504 | to STDERR, and only one level deep. 505 | 506 | C is an attempt to make the innards available to the script level 507 | with a reasonable level of compatibility. C is context sensitive. 508 | 509 | In void context, it behaves exactly like C. 510 | 511 | In scalar context, it returns what C would have printed. 512 | 513 | The default for the first argument is C<$_>. 514 | 515 | In list context, it returns a hash of the variable's properties. In this mode 516 | you can pass an optional second argument that determines the depth of digging. 517 | 518 | Example 519 | 520 | print scalar DDump "abc\x{0a}de\x{20ac}fg" 521 | 522 | SV = PV(0x723250) at 0x8432b0 523 | REFCNT = 1 524 | FLAGS = (PADBUSY,PADMY,POK,pPOK,UTF8) 525 | PV = 0x731ac0 "abc\nde\342\202\254fg"\0 [UTF8 "abc\nde\x{20ac}fg"] 526 | CUR = 11 527 | LEN = 16 528 | 529 | my %h = DDump "abc\x{0a}de\x{20ac}fg"; 530 | print DDumper \%h; 531 | 532 | { CUR => '11', 533 | FLAGS => { 534 | PADBUSY => 1, 535 | PADMY => 1, 536 | POK => 1, 537 | UTF8 => 1, 538 | pPOK => 1 539 | }, 540 | LEN => '16', 541 | PV => '0x731ac0 "abc\\nde\\342\\202\\254fg"\\0 [UTF8 "abc\\nde\\x{20ac}fg"]', 542 | REFCNT => '1', 543 | sv => 'PV(0x723250) at 0x8432c0' 544 | }; 545 | 546 | my %h = DDump { 547 | ape => 1, 548 | foo => "egg", 549 | bar => [ 2, "baz", undef ], 550 | }, 1; 551 | print DDumper \%h; 552 | 553 | { FLAGS => { 554 | PADBUSY => 1, 555 | PADMY => 1, 556 | ROK => 1 557 | }, 558 | REFCNT => '1', 559 | RV => { 560 | PVIV("ape") => { 561 | FLAGS => { 562 | IOK => 1, 563 | PADBUSY => 1, 564 | PADMY => 1, 565 | pIOK => 1 566 | }, 567 | IV => '1', 568 | REFCNT => '1', 569 | sv => 'IV(0x747020) at 0x843a10' 570 | }, 571 | PVIV("bar") => { 572 | CUR => '0', 573 | FLAGS => { 574 | PADBUSY => 1, 575 | PADMY => 1, 576 | ROK => 1 577 | }, 578 | IV => '1', 579 | LEN => '0', 580 | PV => '0x720210 ""', 581 | REFCNT => '1', 582 | RV => '0x720210', 583 | sv => 'PVIV(0x7223e0) at 0x843a10' 584 | }, 585 | PVIV("foo") => { 586 | CUR => '3', 587 | FLAGS => { 588 | PADBUSY => 1, 589 | PADMY => 1, 590 | POK => 1, 591 | pPOK => 1 592 | }, 593 | IV => '1', 594 | LEN => '8', 595 | PV => '0x7496c0 "egg"\\0', 596 | REFCNT => '1', 597 | sv => 'PVIV(0x7223e0) at 0x843a10' 598 | } 599 | }, 600 | sv => 'RV(0x79d058) at 0x843310' 601 | }; 602 | 603 | =head2 DDump_IO ($io, $var [, $dig_level]) 604 | 605 | A wrapper function around perl's internal C, which 606 | makes C completely superfluous. 607 | 608 | Example 609 | 610 | my $dump; 611 | open my $eh, ">", \$dump; 612 | DDump_IO ($eh, { 3 => 4, ape => [5..8]}, 6); 613 | close $eh; 614 | print $dump; 615 | 616 | SV = RV(0x79d9e0) at 0x843f00 617 | REFCNT = 1 618 | FLAGS = (TEMP,ROK) 619 | RV = 0x741090 620 | SV = PVHV(0x79c948) at 0x741090 621 | REFCNT = 1 622 | FLAGS = (SHAREKEYS) 623 | IV = 2 624 | NV = 0 625 | ARRAY = 0x748ff0 (0:7, 2:1) 626 | hash quality = 62.5% 627 | KEYS = 2 628 | FILL = 1 629 | MAX = 7 630 | RITER = -1 631 | EITER = 0x0 632 | Elt "ape" HASH = 0x97623e03 633 | SV = RV(0x79d9d8) at 0x8440e0 634 | REFCNT = 1 635 | FLAGS = (ROK) 636 | RV = 0x741470 637 | SV = PVAV(0x7264b0) at 0x741470 638 | REFCNT = 2 639 | FLAGS = () 640 | IV = 0 641 | NV = 0 642 | ARRAY = 0x822f70 643 | FILL = 3 644 | MAX = 3 645 | ARYLEN = 0x0 646 | FLAGS = (REAL) 647 | Elt No. 0 648 | SV = IV(0x7467c8) at 0x7c1aa0 649 | REFCNT = 1 650 | FLAGS = (IOK,pIOK) 651 | IV = 5 652 | Elt No. 1 653 | SV = IV(0x7467b0) at 0x8440f0 654 | REFCNT = 1 655 | FLAGS = (IOK,pIOK) 656 | IV = 6 657 | Elt No. 2 658 | SV = IV(0x746810) at 0x75be00 659 | REFCNT = 1 660 | FLAGS = (IOK,pIOK) 661 | IV = 7 662 | Elt No. 3 663 | SV = IV(0x746d38) at 0x7799d0 664 | REFCNT = 1 665 | FLAGS = (IOK,pIOK) 666 | IV = 8 667 | Elt "3" HASH = 0xa400c7f3 668 | SV = IV(0x746fd0) at 0x7200e0 669 | REFCNT = 1 670 | FLAGS = (IOK,pIOK) 671 | IV = 4 672 | 673 | =head1 INTERNALS 674 | 675 | C uses an XS wrapper around C where the STDERR is 676 | temporarily caught to a pipe. The internal XS helper functions are not 677 | meant for user space 678 | 679 | =head2 DDump_XS (SV *sv) 680 | 681 | Base interface to internals for C. 682 | 683 | =head1 BUGS 684 | 685 | Windows and AIX might be using a build where not all symbols that were 686 | supposed to be exported in the public API are not. C is 687 | one of them. 688 | 689 | Not all types of references are supported. 690 | 691 | No idea how far back this goes in perl support, but Devel::PPPort has 692 | proven to be a big help. 693 | 694 | =head1 SEE ALSO 695 | 696 | L, L, L, L, 697 | L, L, L. 698 | 699 | =head1 AUTHOR 700 | 701 | H.Merijn Brand 702 | 703 | =head1 COPYRIGHT AND LICENSE 704 | 705 | Copyright (C) 2008-2025 H.Merijn Brand 706 | 707 | This library is free software; you can redistribute it and/or modify 708 | it under the same terms as Perl itself. 709 | 710 | =cut 711 | --------------------------------------------------------------------------------