Data-Dump-1.22/000755 000765 000024 00000000000 12143146506 013462 5ustar00gislestaff000000 000000 Data-Dump-1.22/Changes000644 000765 000024 00000011466 12143146460 014764 0ustar00gislestaff000000 000000 2013-05-10 Gisle Aas Release 1.22 Deal with class names containing '=' [RT#72415] Filters now get access to $ctx->expr; the textual expression denoting the current object. 2011-10-15 Gisle Aas Release 1.21 Make dump($1) work when $1 was integer [RT#63883] Dump floats without quoting 2011-10-02 Gisle Aas Release 1.20 Add depth() method to FilterContext Make dump($1) work [RT#63883] Limit our temp listen socket to localhost [RT#63534] 2010-10-19 Gisle Aas Release 1.19 Add skips to tests to make perl-5.8 happy 2010-10-18 Gisle Aas Release 1.18 Don't downgrade is_utf8-strings with MIME::Base64 [RT#60103] Deal with the perl-5.13 (?^:...) regex construct [RT#61552] croak on bad add_dump_filter argument 2010-06-12 Gisle Aas Release 1.17 Fix dump of "1\n" (the newline was lost) [RT#56595] Start using the range operator to shorten list dumps. For instance dump(1,2,3,4,5) now returns '(1 .. 5)'. CODE references now dumped as 'sub { ... }'. Potetential compatibility issue as perl-5.12 or better is needed to eval such strings. Fix how multiline hash values are indented. Make indentation configurable Improved documentation 2010-06-09 Gisle Aas Release 1.16 Add support for filter callbacks - filters can modify how selected objects are dumped Various enhancements to how/when hash keys are quoted - don't quote keywords - don't quote words prefixed with "-" - don't quote long identifier keys - quote all hash keys if one needs quoting for better alignment Use case-insensitive sorting for hash keys 2009-07-26 Gisle Aas Release 1.15 Fixed regexp that determines if hash keys are numeric [RT#48003] 2009-01-12 Gisle Aas Release 1.14 Data::Dump::Trace enhancements: - trace() function - prototypes 2009-01-02 Gisle Aas Release 1.13 Added the Data::Dump::Trace module 2008-10-21 Gisle Aas Release 1.12 Documentation tweaks. 2008-08-23 Gisle Aas Release 1.11 Documentation tweaks. 2008-08-21 Gisle Aas Release 1.10 Add the functions quote(), dd() and ddx(). Fix segfault when duming large repeated strings [RT#33520] Incorporated documentation improvements from Mark Stosberg Apply Data-Dump-1.08-ANDK-01.patch from CPAN. Might do some good on older perls I guess. 2006-11-29 Gisle Aas Release 1.08 By popular demand; don't put underscore into dumped integers to group thousands. 2006-11-24 Gisle Aas Release 1.07 Remove unused code. Add some more tests. 2004-11-12 Gisle Aas Release 1.06 Compatibility fix for bleadperl by David Dyck . 2004-11-11 Gisle Aas Release 1.05 Improved track scalar references; dump() ended up recursing forever on some cyclic structures. More tests. 2004-11-05 Gisle Aas Release 1.04 Try to not be confused when dumping tied hashes or arrays. . 2004-04-13 Gisle Aas Release 1.03 Dump strings with chars with ord > 255 using \x{...} escapes. 2003-12-18 Gisle Aas Release 1.02 Documentation fixes by Paul Croome . 2003-10-10 Gisle Aas Release 1.01 Improved formatting of Regexp objects. Put top level modifiers in the normal place and smart selection of separators. Perl 5.6 or better required. 2003-10-06 Gisle Aas Release 1.00 Support dumping of Regexp objects. If all the keys of a hash looks numeric sort them accordingly. Don't quote plain normalized integer keys. 2000-09-11 Gisle Aas Release 0.04 Think harder about when to align hash values. Compensate for the way references to references are stringified in perl-5.7.0. 1999-08-05 Gisle Aas Release 0.03 Fixed the generation of references to nested scalars. Separate thousands with _ in large integers. More tests. 1999-05-27 Gisle Aas Release 0.02 Don't die on data that we can't handle, like LVALUES. We now produce a warning and return it as a '#LVALUE#' string. Added parenthesis around bless argument. 1998-11-21 Gisle Aas First revision; 0.01 Data-Dump-1.22/lib/000755 000765 000024 00000000000 12143146506 014230 5ustar00gislestaff000000 000000 Data-Dump-1.22/Makefile.PL000644 000765 000024 00000002147 12131612121 015424 0ustar00gislestaff000000 000000 require 5.006; use ExtUtils::MakeMaker; WriteMakefile( NAME => "Data::Dump", VERSION_FROM => "lib/Data/Dump.pm", ABSTRACT_FROM => "lib/Data/Dump.pm", AUTHOR => 'Gisle Aas ', LICENSE => "perl", MIN_PERL_VERSION => 5.006, PREREQ_PM => { Symbol => 0, }, META_MERGE => { resources => { repository => 'http://github.com/gisle/data-dump', }, recommends => { 'MIME::Base64' => 0, }, }, BUILD_REQUIRES => { Test => 0, }, ); BEGIN { # compatibility with older versions of MakeMaker my $developer = -d "eg"; my %mm_req = ( LICENCE => 6.31, META_MERGE => 6.45, META_ADD => 6.45, MIN_PERL_VERSION => 6.48, BUILD_REQUIRES => 6.56, ); undef(*WriteMakefile); *WriteMakefile = sub { my %arg = @_; for (keys %mm_req) { unless (eval { ExtUtils::MakeMaker->VERSION($mm_req{$_}) }) { warn "$_ $@" if $developer; delete $arg{$_}; } } ExtUtils::MakeMaker::WriteMakefile(%arg); }; } Data-Dump-1.22/MANIFEST000644 000765 000024 00000000722 12143146506 014614 0ustar00gislestaff000000 000000 Changes lib/Data/Dump.pm lib/Data/Dump/Trace.pm lib/Data/Dump/Filtered.pm lib/Data/Dump/FilterContext.pm Makefile.PL MANIFEST README t/dd.t t/dollar-one.t t/dump.t t/eval.t t/filtered.t t/glob.t t/hash.t t/quote-unicode.t t/quote.t t/ref.t t/regexp.t t/scalar-obj.t t/scalar.t t/tied.t t/vstring.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Data-Dump-1.22/META.json000644 000765 000024 00000002057 12143146506 015107 0ustar00gislestaff000000 000000 { "abstract" : "Pretty printing of data structures", "author" : [ "Gisle Aas " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.120921", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Data-Dump", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "Test" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "recommends" : { "MIME::Base64" : "0" }, "requires" : { "Symbol" : "0", "perl" : "5.006" } } }, "release_status" : "stable", "resources" : { "repository" : { "url" : "http://github.com/gisle/data-dump" } }, "version" : "1.22" } Data-Dump-1.22/META.yml000644 000765 000024 00000001100 12143146506 014723 0ustar00gislestaff000000 000000 --- abstract: 'Pretty printing of data structures' author: - 'Gisle Aas ' build_requires: Test: 0 configure_requires: ExtUtils::MakeMaker: 0 dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.120921' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Data-Dump no_index: directory: - t - inc recommends: MIME::Base64: 0 requires: Symbol: 0 perl: 5.006 resources: repository: http://github.com/gisle/data-dump version: 1.22 Data-Dump-1.22/README000644 000765 000024 00000002276 12131612121 014335 0ustar00gislestaff000000 000000 NAME Data::Dump - Pretty printing of data structures SYNOPSIS use Data::Dump qw(dump ddx); $str = dump(@list); @copy_of_list = eval $str; # or use it for easy debug printout ddx localtime; DESCRIPTION This module provide functions that takes a list of values as their argument and produces a string as its result. The string contains Perl code that, when "eval"ed, produces a deep copy of the original arguments. The main feature of the module is that it strives to produce output that is easy to read. Example: @a = (1, [2, 3], {4 => 5}); dump(@a); Produces: (1, [2, 3], { 4 => 5 }) If you dump just a little data, it is output on a single line. If you dump data that is more complex or there is a lot of it, line breaks are automatically added to keep it easy to read. AUTHORS The "Data::Dump" module is written by Gisle Aas , based on "Data::Dumper" by Gurusamy Sarathy . Copyright 1998-2010 Gisle Aas. Copyright 1996-1998 Gurusamy Sarathy. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Data-Dump-1.22/t/000755 000765 000024 00000000000 12143146506 013725 5ustar00gislestaff000000 000000 Data-Dump-1.22/t/dd.t000644 000765 000024 00000000206 12131612121 014463 0ustar00gislestaff000000 000000 #!perl -w use strict; use Test; plan tests => 1; use Data::Dump; print "# "; dd getlogin; ddx localtime; ddx \%Exporter::; ok(1); Data-Dump-1.22/t/dollar-one.t000644 000765 000024 00000000453 12131612121 016134 0ustar00gislestaff000000 000000 use strict; use warnings; use Test::More tests => 6; use Data::Dump qw/dump/; if ("abc" =~ /(.+)/) { is(dump($1), '"abc"'); is(dump(\$1), '\"abc"'); is(dump([$1]), '["abc"]'); } if ("123" =~ /(.+)/) { is(dump($1), "123"); is(dump(\$1), '\123'); is(dump([$1]), '[123]'); } Data-Dump-1.22/t/dump.t000644 000765 000024 00000004136 12131612121 015047 0ustar00gislestaff000000 000000 #!perl -w use strict; use Test qw(plan ok); plan tests => 34; use Data::Dump qw(dump); ok(dump(), "()"); ok(dump("abc"), qq("abc")); ok(dump("1\n"), qq("1\\n")); ok(dump(undef), "undef"); ok(dump(0), "0"); ok(dump(1234), "1234"); ok(dump(12345), "12345"); ok(dump(12345678), "12345678"); ok(dump(123456789012345), "123456789012345"); ok(dump(0.333), "0.333"); ok(dump(1/3), qr/^0\.3+\z/); ok(dump(-33), "-33"); ok(dump(-1.5), "-1.5"); ok(dump("0123"), qq("0123")); ok(dump(1..2), "(1, 2)"); ok(dump(1..3), "(1, 2, 3)"); ok(dump(1..4), "(1 .. 4)"); ok(dump(1..5,6,8,9), "(1 .. 6, 8, 9)"); ok(dump(1..5,4..8), "(1 .. 5, 4 .. 8)"); ok(dump([-2..2]), "[-2 .. 2]"); ok(dump(["a0" .. "z9"]), qq(["a0" .. "z9"])); ok(dump(["x", 0, 1, 2, 3, "a", "b", "c", "d"]), qq(["x", 0 .. 3, "a" .. "d"])); ok(dump({ a => 1, b => 2 }), "{ a => 1, b => 2 }"); ok(dump({ 1 => 1, 2 => 1, 10 => 1 }), "{ 1 => 1, 2 => 1, 10 => 1 }"); ok(dump({ 0.14 => 1, 1.8 => 1, -0.5 => 1 }), qq({ "-0.5" => 1, "0.14" => 1, "1.8" => 1 })); ok(dump({ "1,1" => 1, "1,2" => 1 }), qq({ "1,1" => 1, "1,2" => 1 })); ok(dump({ a => 1, aa => 2, aaa => join("", "a" .. "z", "a" .. "z")}) . "\n", < 1, aa => 2, aaa => "abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz", } EOT ok(dump({ a => 1, aa => 2, aaaaaaaaaaaaaa => join("", "a" .. "z", "a" .. "z")}) . "\n", < 1, aa => 2, aaaaaaaaaaaaaa => "abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz", } EOT ok(dump(bless {}, "foo"), "bless({}, \"foo\")"); ok(dump(bless [], "foo"), "bless([], \"foo\")"); my $sv = []; ok(dump(bless \$sv, "foo"), "bless(do{\\(my \$o = [])}, \"foo\")"); ok(dump(bless { a => 1, aa => "abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz", aaa => \$sv}, "foo") . "\n", <<'EOT'); bless({ a => 1, aa => "abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz", aaa => bless(do{\(my $o = [])}, "foo"), }, "foo") EOT # stranger stuff ok(dump({ a => \&Data::Dump::dump, aa => do {require Symbol; Symbol::gensym()}}), "do {\n require Symbol;\n { a => sub { ... }, aa => Symbol::gensym() };\n}"); ok(dump(bless{}, "foo=bar"), 'bless({}, "foo=bar")'); Data-Dump-1.22/t/eval.t000644 000765 000024 00000000520 12131612121 015022 0ustar00gislestaff000000 000000 print "1..1\n"; use Data::Dump qw(dump); # Create some structure; $h = {af=>15, bf=>bless [1,2], "Foo"}; $h->{cf} = \$h->{af}; #$h->{bf}[2] = \$h; @s = eval($dump_h = dump($h, $h, \$h, \$h->{af})); $dump_s = dump(@s); print "not " unless $dump_h eq $dump_s; print "ok 1\n"; print "\n\$h = $dump_h;\n"; print "\n\$s = $dump_s;\n"; Data-Dump-1.22/t/filtered.t000644 000765 000024 00000003300 12143145317 015703 0ustar00gislestaff000000 000000 #!perl -w use strict; use Test qw(plan ok); plan tests => 41; use Data::Dump qw(dumpf); ok(dumpf("foo", sub { return { dump => "x" }}), 'x'); ok(dumpf("foo", sub { return { object => "x" }}), '"x"'); ok(dumpf("foo", sub { return { comment => "x" }}), "# x\n\"foo\""); ok(dumpf({}, sub { return { bless => "x"}}), "bless({}, \"x\")"); ok(dumpf({a => 1, b => 2}, sub { return { hide_keys => ["b"] }}), "{ a => 1 }"); ok(dumpf("foo", sub { return }), '"foo"'); my $cb_count = 0; ok(dumpf("foo", sub { my($ctx, $obj) = @_; $cb_count++; ok($$obj, "foo"); ok($ctx->object_ref, $obj); ok($ctx->class, ""); ok(!$ctx->object_isa("SCALAR")); ok($ctx->container_class, ""); ok(!$ctx->container_isa("SCALAR")); ok($ctx->container_self, ""); ok(!$ctx->is_ref); ok(!$ctx->is_blessed); ok(!$ctx->is_array); ok(!$ctx->is_hash); ok( $ctx->is_scalar); ok(!$ctx->is_code); ok($ctx->depth, 0); return; }), '"foo"'); ok($cb_count, 1); $cb_count = 0; ok(dumpf(bless({ a => 1, b => bless {}, "Bar"}, "Foo"), sub { my($ctx, $obj) = @_; $cb_count++; return unless $ctx->object_isa("Bar"); ok(ref($obj), "Bar"); ok($ctx->object_ref, $obj); ok($ctx->class, "Bar"); ok($ctx->object_isa("Bar")); ok(!$ctx->object_isa("Foo")); ok($ctx->container_class, "Foo"); ok($ctx->container_isa("Foo")); ok($ctx->container_self, '$self->{b}'); ok($ctx->is_ref); ok($ctx->is_blessed); ok(!$ctx->is_array); ok($ctx->is_hash); ok(!$ctx->is_scalar); ok(!$ctx->is_code); ok($ctx->depth, 1); ok($ctx->expr, '$var->{b}'); ok($ctx->expr("ref"), '$ref->{b}'); return; }) =~ /^bless\(.*, "Foo"\)\z/); ok($cb_count, 3); Data-Dump-1.22/t/glob.t000644 000765 000024 00000001304 12131612121 015017 0ustar00gislestaff000000 000000 #!perl -w use strict; use Test qw(plan ok); plan tests => 6; use Data::Dump qw(dump); use Symbol qw(gensym); ok(dump(*STDIN), "*main::STDIN"); ok(dump(\*STDIN), "\\*main::STDIN"); ok(dump(gensym()), "do {\n require Symbol;\n Symbol::gensym();\n}"); $a = []; ${*foo}[1] = $a; ${*foo}{bar} = 2; ok(dump(\*foo, $a) . "\n", <<'EOT'); do { my $a = \*main::foo; *{$a} = [undef, []]; *{$a} = { bar => 2 }; ($a, *{$a}{ARRAY}[1]); } EOT use IO::Socket::INET; my $s = IO::Socket::INET->new( Listen => 1, Timeout => 5, LocalAddr => '127.0.0.1', ); $s = dump($s); print "$s\n"; ok($s =~ /my \$a = bless\(Symbol::gensym\(\), "IO::Socket::INET"\);/); ok($s =~ /^\s+io_socket_timeout\s+=> 5,/m); Data-Dump-1.22/t/hash.t000644 000765 000024 00000001503 12131612121 015020 0ustar00gislestaff000000 000000 #!perl -w use strict; use Test; plan tests => 9; use Data::Dump qw(dump); my $DOTS = "." x 20; ok(dump({}), "{}"); ok(dump({ a => 1}), "{ a => 1 }"); ok(dump({ 1 => 1}), "{ 1 => 1 }"); ok(dump({strict => 1, shift => 2, abc => 3, -f => 4 }), "{ -f => 4, abc => 3, shift => 2, strict => 1 }"); ok(dump({supercalifragilisticexpialidocious => 1, a => 2}), "{ a => 2, supercalifragilisticexpialidocious => 1 }"); ok(dump({supercalifragilisticexpialidocious => 1, a => 2, b => $DOTS})."\n", < 2, b => "$DOTS", supercalifragilisticexpialidocious => 1, } EOT ok(dump({aa => 1, B => 2}), "{ aa => 1, B => 2 }"); ok(dump({a => 1, bar => $DOTS, baz => $DOTS, foo => 2 })."\n", < 1, bar => "$DOTS", baz => "$DOTS", foo => 2, } EOT ok(dump({a => 1, "b-z" => 2}), qq({ "a" => 1, "b-z" => 2 })); Data-Dump-1.22/t/quote-unicode.t000644 000765 000024 00000003021 12131612121 016653 0ustar00gislestaff000000 000000 #!perl -w BEGIN { if ($] < 5.008) { print "1..0 # Skipped: perl-5.8 required\n"; exit; } } use strict; use Test qw(plan ok skip); plan tests => 8; use Data::Dump qw(dump); ok(dump("\x{FF}"), qq("\\xFF")); ok(dump("\xFF\x{FFF}"), qq("\\xFF\\x{FFF}")); ok(dump(join("", map chr($_), 400 .. 500)), qq("\\x{190}\\x{191}\\x{192}\\x{193}\\x{194}\\x{195}\\x{196}\\x{197}\\x{198}\\x{199}\\x{19A}\\x{19B}\\x{19C}\\x{19D}\\x{19E}\\x{19F}\\x{1A0}\\x{1A1}\\x{1A2}\\x{1A3}\\x{1A4}\\x{1A5}\\x{1A6}\\x{1A7}\\x{1A8}\\x{1A9}\\x{1AA}\\x{1AB}\\x{1AC}\\x{1AD}\\x{1AE}\\x{1AF}\\x{1B0}\\x{1B1}\\x{1B2}\\x{1B3}\\x{1B4}\\x{1B5}\\x{1B6}\\x{1B7}\\x{1B8}\\x{1B9}\\x{1BA}\\x{1BB}\\x{1BC}\\x{1BD}\\x{1BE}\\x{1BF}\\x{1C0}\\x{1C1}\\x{1C2}\\x{1C3}\\x{1C4}\\x{1C5}\\x{1C6}\\x{1C7}\\x{1C8}\\x{1C9}\\x{1CA}\\x{1CB}\\x{1CC}\\x{1CD}\\x{1CE}\\x{1CF}\\x{1D0}\\x{1D1}\\x{1D2}\\x{1D3}\\x{1D4}\\x{1D5}\\x{1D6}\\x{1D7}\\x{1D8}\\x{1D9}\\x{1DA}\\x{1DB}\\x{1DC}\\x{1DD}\\x{1DE}\\x{1DF}\\x{1E0}\\x{1E1}\\x{1E2}\\x{1E3}\\x{1E4}\\x{1E5}\\x{1E6}\\x{1E7}\\x{1E8}\\x{1E9}\\x{1EA}\\x{1EB}\\x{1EC}\\x{1ED}\\x{1EE}\\x{1EF}\\x{1F0}\\x{1F1}\\x{1F2}\\x{1F3}\\x{1F4}")); ok(dump("\x{1_00FF}"), qq("\\x{100FF}")); ok(dump("\x{FFF}\x{1_00FF}" x 30), qq(("\\x{FFF}\\x{100FF}" x 30))); # Ensure that displaying long upgraded string does not downgrade $a = ""; $a .= chr($_) for 128 .. 255; $a .= "\x{FFF}"; chop($a); # upgrade ok(utf8::is_utf8($a)); skip($] < 5.010 ? "perl-5.10 required" : "", dump($a), 'pack("H*","' . join('', map sprintf("%02x", $_), 128..255). '")'); ok(utf8::is_utf8($a)); Data-Dump-1.22/t/quote.t000644 000765 000024 00000004054 12131612121 015236 0ustar00gislestaff000000 000000 #!perl -w use strict; use Test qw(plan ok skip); plan tests => 17; use Data::Dump qw(dump quote); $Data::Dump::TRY_BASE64 = 0; ok(dump(""), qq("")); ok(dump("\n"), qq("\\n")); ok(dump("\0\1\x1F\0" . 3), qq("\\0\\1\\37\\x003")); ok(dump("xx" x 30), qq(("x" x 60))); ok(dump("xy" x 30), qq(("xy" x 30))); ok(dump("\0" x 1024), qq(("\\0" x 1024))); ok(dump("\$" x 1024), qq(("\\\$" x 1024))); ok(dump("\n" x (1024 * 1024)), qq(("\\n" x 1048576))); ok(dump("\x7F\x80\xFF"), qq("\\x7F\\x80\\xFF")); ok(dump(join("", map chr($_), 0..127)), qq("\\0\\1\\2\\3\\4\\5\\6\\a\\b\\t\\n\\13\\f\\r\\16\\17\\20\\21\\22\\23\\24\\25\\26\\27\\30\\31\\32\\e\\34\\35\\36\\37 !\\"#\\\$%&'()*+,-./0123456789:;<=>?\\\@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\\\]^_`abcdefghijklmnopqrstuvwxyz{|}~\\x7F")); ok(dump(join("", map chr($_), 0..255)), qq(pack("H*","000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f202122232425262728292a2b2c2d2e2f303132333435363738393a3b3c3d3e3f404142434445464748494a4b4c4d4e4f505152535455565758595a5b5c5d5e5f606162636465666768696a6b6c6d6e6f707172737475767778797a7b7c7d7e7f808182838485868788898a8b8c8d8e8f909192939495969798999a9b9c9d9e9fa0a1a2a3a4a5a6a7a8a9aaabacadaeafb0b1b2b3b4b5b6b7b8b9babbbcbdbebfc0c1c2c3c4c5c6c7c8c9cacbcccdcecfd0d1d2d3d4d5d6d7d8d9dadbdcdddedfe0e1e2e3e4e5e6e7e8e9eaebecedeeeff0f1f2f3f4f5f6f7f8f9fafbfcfdfeff"))); if (eval { require MIME::Base64 }) { local $Data::Dump::TRY_BASE64 = 1; ok(dump(join("", map chr($_), 0..255)), "do {\n require MIME::Base64;\n MIME::Base64::decode(\"AAECAwQFBgcICQoLDA0ODxAREhMUFRYXGBkaGxwdHh8gISIjJCUmJygpKissLS4vMDEyMzQ1Njc4OTo7PD0+P0BBQkNERUZHSElKS0xNTk9QUVJTVFVWV1hZWltcXV5fYGFiY2RlZmdoaWprbG1ub3BxcnN0dXZ3eHl6e3x9fn+AgYKDhIWGh4iJiouMjY6PkJGSk5SVlpeYmZqbnJ2en6ChoqOkpaanqKmqq6ytrq+wsbKztLW2t7i5uru8vb6/wMHCw8TFxsfIycrLzM3Oz9DR0tPU1dbX2Nna29zd3t/g4eLj5OXm5+jp6uvs7e7v8PHy8/T19vf4+fr7/P3+/w==\");\n}"); } else { skip("MIME::Base64 missing", 1); } ok(quote(""), qq("")); ok(quote(42), qq("42")); ok(quote([]) =~ /^"ARRAY\(/); ok(quote('"'), qq("\\"")); ok(quote("\0" x 1024), join("", '"', ("\\0") x 1024, '"')); Data-Dump-1.22/t/ref.t000644 000765 000024 00000000547 12131612121 014660 0ustar00gislestaff000000 000000 #!perl -w use strict; use Test qw(plan ok); plan tests => 2; use Data::Dump qw(dump); my $s = \\1; ok(nl(dump($s)), <<'EOT'); \\1 EOT my %s; $s{C1} = \$s{C2}; $s{C2} = \$s{C1}; ok(nl(dump(\%s)), <<'EOT'); do { my $a = { C1 => \\do{my $fix}, C2 => 'fix' }; ${${$a->{C1}}} = $a->{C1}; $a->{C2} = ${$a->{C1}}; $a; } EOT sub nl { shift(@_) . "\n" } Data-Dump-1.22/t/regexp.t000644 000765 000024 00000001040 12143144612 015373 0ustar00gislestaff000000 000000 #!perl -w use Test; plan tests => 1; use Data::Dump; $a = { a => qr/Foo/, b => qr,abc/,is, c => qr/ foo /x, d => qr/foo/msix, e => qr//, f => qr/ # hi there how do this look /x, g => qr,///////,, h => qr*/|,:*, i => qr*/|,:#*, }; ok(Data::Dump::dump($a) . "\n", <<'EOT'); { a => qr/Foo/, b => qr|abc/|si, c => qr/ foo /x, d => qr/foo/msix, e => qr//, f => qr/ # hi there how do this look /x, g => qr|///////|, h => qr#/|,:#, i => qr/\/|,:#/, } EOT Data-Dump-1.22/t/scalar-obj.t000644 000765 000024 00000000645 12131612121 016120 0ustar00gislestaff000000 000000 print "1..3\n"; use Data::Dump qw(dump); $a = 42; bless \$a, "Foo"; my $d = dump($a); print "$d\n"; print "not " unless $d eq q(do { my $a = 42; bless \$a, "Foo"; $a; }); print "ok 1\n"; $d = dump(\$a); print "$d\n"; print "not " unless $d eq q(bless(do{\\(my $o = 42)}, "Foo")); print "ok 2\n"; $d = dump(\\$a); print "$d\n"; print "not " unless $d eq q(\\bless(do{\\(my $o = 42)}, "Foo")); print "ok 3\n"; Data-Dump-1.22/t/scalar.t000644 000765 000024 00000001045 12131612121 015343 0ustar00gislestaff000000 000000 print "1..3\n"; use Data::Dump qw(dump); $a = 42; @a = (\$a); $d = dump($a, $a, \$a, \\$a, "$a", $a+0, \@a); print "$d;\n"; print "not " unless $d eq q(do { my $a = 42; ($a, $a, \\$a, \\\\$a, 42, 42, [\\$a]); }); print "ok 1\n"; $d = dump(\\$a, \$a, $a, \@a); print "$d;\n"; print "not " unless $d eq q(do { my $a = \\\\42; ($a, $$a, $$$a, [$$a]); }); print "ok 2\n"; # not really a scalar test, but anyway $a = []; $d = dump(\$a, $a); print "$d;\n"; print "not " unless $d eq q(do { my $a = \[]; ($a, $$a); }); print "ok 3\n"; Data-Dump-1.22/t/tied.t000644 000765 000024 00000001703 12131612121 015024 0ustar00gislestaff000000 000000 #!perl -w use strict; use Test qw(plan ok); use Data::Dump qw(dump); plan tests => 4; { package MyTie; sub TIE { my $class = shift; bless {}, $class; } use vars qw(*TIEHASH *TIEARRAY *TIESCALAR); *TIEHASH = \&TIE; *TIEARRAY = \&TIE; *TIESCALAR = \&TIE; sub FIRSTKEY { return "a"; } sub NEXTKEY { my($self, $lastkey) = @_; return if $lastkey eq "d"; return ++$lastkey; } sub FETCHSIZE { return 4; } sub FETCH { my($self, $key) = @_; return "v$key" if defined $key; return "v"; } } my(%hash, @array, $scalar); tie %hash, "MyTie"; tie @array, "MyTie"; tie $scalar, "MyTie"; ok(nl(dump(\%hash)), < "va", b => "vb", c => "vc", d => "vd", } EOT ok(nl(dump(\@array)), < 9; use Data::Dump 'dump'; ok(dump(v10), q{v10}); ok(dump(v5.10.1), q{v5.10.1}); ok(dump(5.10.1), q{v5.10.1}); ok(dump(500.400.300.200.100), q{v500.400.300.200.100}); ok(dump(\5.10.1), q{\v5.10.1}); ok(dump(\v10), q{\v10}); ok(dump(\\v10), q{\\\\v10}); ok(dump([v10, v20, v30]), q{[v10, v20, v30]}); ok(dump({ version => v6.0.0 }), q({ version => v6.0.0 })); Data-Dump-1.22/lib/Data/000755 000765 000024 00000000000 12143146506 015101 5ustar00gislestaff000000 000000 Data-Dump-1.22/lib/Data/Dump/000755 000765 000024 00000000000 12143146506 016006 5ustar00gislestaff000000 000000 Data-Dump-1.22/lib/Data/Dump.pm000644 000765 000024 00000043576 12143146267 016367 0ustar00gislestaff000000 000000 package Data::Dump; use strict; use vars qw(@EXPORT @EXPORT_OK $VERSION $DEBUG); use subs qq(dump); require Exporter; *import = \&Exporter::import; @EXPORT = qw(dd ddx); @EXPORT_OK = qw(dump pp dumpf quote); $VERSION = "1.22"; $DEBUG = 0; use overload (); use vars qw(%seen %refcnt @dump @fixup %require $TRY_BASE64 @FILTERS $INDENT); $TRY_BASE64 = 50 unless defined $TRY_BASE64; $INDENT = " " unless defined $INDENT; sub dump { local %seen; local %refcnt; local %require; local @fixup; require Data::Dump::FilterContext if @FILTERS; my $name = "a"; my @dump; for my $v (@_) { my $val = _dump($v, $name, [], tied($v)); push(@dump, [$name, $val]); } continue { $name++; } my $out = ""; if (%require) { for (sort keys %require) { $out .= "require $_;\n"; } } if (%refcnt) { # output all those with refcounts first for (@dump) { my $name = $_->[0]; if ($refcnt{$name}) { $out .= "my \$$name = $_->[1];\n"; undef $_->[1]; } } for (@fixup) { $out .= "$_;\n"; } } my $paren = (@dump != 1); $out .= "(" if $paren; $out .= format_list($paren, undef, map {defined($_->[1]) ? $_->[1] : "\$".$_->[0]} @dump ); $out .= ")" if $paren; if (%refcnt || %require) { $out .= ";\n"; $out =~ s/^/$INDENT/gm; $out = "do {\n$out}"; } print STDERR "$out\n" unless defined wantarray; $out; } *pp = \&dump; sub dd { print dump(@_), "\n"; } sub ddx { my(undef, $file, $line) = caller; $file =~ s,.*[\\/],,; my $out = "$file:$line: " . dump(@_) . "\n"; $out =~ s/^/# /gm; print $out; } sub dumpf { require Data::Dump::Filtered; goto &Data::Dump::Filtered::dump_filtered; } sub _dump { my $ref = ref $_[0]; my $rval = $ref ? $_[0] : \$_[0]; shift; my($name, $idx, $dont_remember, $pclass, $pidx) = @_; my($class, $type, $id); my $strval = overload::StrVal($rval); # Parse $strval without using regexps, in order not to clobber $1, $2,... if ((my $i = rindex($strval, "=")) >= 0) { $class = substr($strval, 0, $i); $strval = substr($strval, $i+1); } if ((my $i = index($strval, "(0x")) >= 0) { $type = substr($strval, 0, $i); $id = substr($strval, $i + 2, -1); } else { die "Can't parse " . overload::StrVal($rval); } if ($] < 5.008 && $type eq "SCALAR") { $type = "REF" if $ref eq "REF"; } warn "\$$name(@$idx) $class $type $id ($ref)" if $DEBUG; my $out; my $comment; my $hide_keys; if (@FILTERS) { my $pself = ""; $pself = fullname("self", [@$idx[$pidx..(@$idx - 1)]]) if $pclass; my $ctx = Data::Dump::FilterContext->new($rval, $class, $type, $ref, $pclass, $pidx, $idx); my @bless; for my $filter (@FILTERS) { if (my $f = $filter->($ctx, $rval)) { if (my $v = $f->{object}) { local @FILTERS; $out = _dump($v, $name, $idx, 1); $dont_remember++; } if (defined(my $c = $f->{bless})) { push(@bless, $c); } if (my $c = $f->{comment}) { $comment = $c; } if (defined(my $c = $f->{dump})) { $out = $c; $dont_remember++; } if (my $h = $f->{hide_keys}) { if (ref($h) eq "ARRAY") { $hide_keys = sub { for my $k (@$h) { return 1 if $k eq $_[0]; } return 0; }; } } } } push(@bless, "") if defined($out) && !@bless; if (@bless) { $class = shift(@bless); warn "More than one filter callback tried to bless object" if @bless; } } unless ($dont_remember) { if (my $s = $seen{$id}) { my($sname, $sidx) = @$s; $refcnt{$sname}++; my $sref = fullname($sname, $sidx, ($ref && $type eq "SCALAR")); warn "SEEN: [\$$name(@$idx)] => [\$$sname(@$sidx)] ($ref,$sref)" if $DEBUG; return $sref unless $sname eq $name; $refcnt{$name}++; push(@fixup, fullname($name,$idx)." = $sref"); return "do{my \$fix}" if @$idx && $idx->[-1] eq '$'; return "'fix'"; } $seen{$id} = [$name, $idx]; } if ($class) { $pclass = $class; $pidx = @$idx; } if (defined $out) { # keep it } elsif ($type eq "SCALAR" || $type eq "REF" || $type eq "REGEXP") { if ($ref) { if ($class && $class eq "Regexp") { my $v = "$rval"; my $mod = ""; if ($v =~ /^\(\?\^?([msix-]*):([\x00-\xFF]*)\)\z/) { $mod = $1; $v = $2; $mod =~ s/-.*//; } my $sep = '/'; my $sep_count = ($v =~ tr/\///); if ($sep_count) { # see if we can find a better one for ('|', ',', ':', '#') { my $c = eval "\$v =~ tr/\Q$_\E//"; #print "SEP $_ $c $sep_count\n"; if ($c < $sep_count) { $sep = $_; $sep_count = $c; last if $sep_count == 0; } } } $v =~ s/\Q$sep\E/\\$sep/g; $out = "qr$sep$v$sep$mod"; undef($class); } else { delete $seen{$id} if $type eq "SCALAR"; # will be seen again shortly my $val = _dump($$rval, $name, [@$idx, "\$"], 0, $pclass, $pidx); $out = $class ? "do{\\(my \$o = $val)}" : "\\$val"; } } else { if (!defined $$rval) { $out = "undef"; } elsif (do {no warnings 'numeric'; $$rval + 0 eq $$rval}) { $out = $$rval; } else { $out = str($$rval); } if ($class && !@$idx) { # Top is an object, not a reference to one as perl needs $refcnt{$name}++; my $obj = fullname($name, $idx); my $cl = quote($class); push(@fixup, "bless \\$obj, $cl"); } } } elsif ($type eq "GLOB") { if ($ref) { delete $seen{$id}; my $val = _dump($$rval, $name, [@$idx, "*"], 0, $pclass, $pidx); $out = "\\$val"; if ($out =~ /^\\\*Symbol::/) { $require{Symbol}++; $out = "Symbol::gensym()"; } } else { my $val = "$$rval"; $out = "$$rval"; for my $k (qw(SCALAR ARRAY HASH)) { my $gval = *$$rval{$k}; next unless defined $gval; next if $k eq "SCALAR" && ! defined $$gval; # always there my $f = scalar @fixup; push(@fixup, "RESERVED"); # overwritten after _dump() below $gval = _dump($gval, $name, [@$idx, "*{$k}"], 0, $pclass, $pidx); $refcnt{$name}++; my $gname = fullname($name, $idx); $fixup[$f] = "$gname = $gval"; #XXX indent $gval } } } elsif ($type eq "ARRAY") { my @vals; my $tied = tied_str(tied(@$rval)); my $i = 0; for my $v (@$rval) { push(@vals, _dump($v, $name, [@$idx, "[$i]"], $tied, $pclass, $pidx)); $i++; } $out = "[" . format_list(1, $tied, @vals) . "]"; } elsif ($type eq "HASH") { my(@keys, @vals); my $tied = tied_str(tied(%$rval)); # statistics to determine variation in key lengths my $kstat_max = 0; my $kstat_sum = 0; my $kstat_sum2 = 0; my @orig_keys = keys %$rval; if ($hide_keys) { @orig_keys = grep !$hide_keys->($_), @orig_keys; } my $text_keys = 0; for (@orig_keys) { $text_keys++, last unless /^[-+]?(?:0|[1-9]\d*)(?:\.\d+)?\z/; } if ($text_keys) { @orig_keys = sort { lc($a) cmp lc($b) } @orig_keys; } else { @orig_keys = sort { $a <=> $b } @orig_keys; } my $quote; for my $key (@orig_keys) { next if $key =~ /^-?[a-zA-Z_]\w*\z/; next if $key =~ /^-?[1-9]\d{0,8}\z/; $quote++; last; } for my $key (@orig_keys) { my $val = \$rval->{$key}; # capture value before we modify $key $key = quote($key) if $quote; $kstat_max = length($key) if length($key) > $kstat_max; $kstat_sum += length($key); $kstat_sum2 += length($key)*length($key); push(@keys, $key); push(@vals, _dump($$val, $name, [@$idx, "{$key}"], $tied, $pclass, $pidx)); } my $nl = ""; my $klen_pad = 0; my $tmp = "@keys @vals"; if (length($tmp) > 60 || $tmp =~ /\n/ || $tied) { $nl = "\n"; # Determine what padding to add if ($kstat_max < 4) { $klen_pad = $kstat_max; } elsif (@keys >= 2) { my $n = @keys; my $avg = $kstat_sum/$n; my $stddev = sqrt(($kstat_sum2 - $n * $avg * $avg) / ($n - 1)); # I am not actually very happy with this heuristics if ($stddev / $kstat_max < 0.25) { $klen_pad = $kstat_max; } if ($DEBUG) { push(@keys, "__S"); push(@vals, sprintf("%.2f (%d/%.1f/%.1f)", $stddev / $kstat_max, $kstat_max, $avg, $stddev)); } } } $out = "{$nl"; $out .= "$INDENT# $tied$nl" if $tied; while (@keys) { my $key = shift @keys; my $val = shift @vals; my $vpad = $INDENT . (" " x ($klen_pad ? $klen_pad + 4 : 0)); $val =~ s/\n/\n$vpad/gm; my $kpad = $nl ? $INDENT : " "; $key .= " " x ($klen_pad - length($key)) if $nl; $out .= "$kpad$key => $val,$nl"; } $out =~ s/,$/ / unless $nl; $out .= "}"; } elsif ($type eq "CODE") { $out = 'sub { ... }'; } elsif ($type eq "VSTRING") { $out = sprintf +($ref ? '\v%vd' : 'v%vd'), $$rval; } else { warn "Can't handle $type data"; $out = "'#$type#'"; } if ($class && $ref) { $out = "bless($out, " . quote($class) . ")"; } if ($comment) { $comment =~ s/^/# /gm; $comment .= "\n" unless $comment =~ /\n\z/; $comment =~ s/^#[ \t]+\n/\n/; $out = "$comment$out"; } return $out; } sub tied_str { my $tied = shift; if ($tied) { if (my $tied_ref = ref($tied)) { $tied = "tied $tied_ref"; } else { $tied = "tied"; } } return $tied; } sub fullname { my($name, $idx, $ref) = @_; substr($name, 0, 0) = "\$"; my @i = @$idx; # need copy in order to not modify @$idx if ($ref && @i && $i[0] eq "\$") { shift(@i); # remove one deref $ref = 0; } while (@i && $i[0] eq "\$") { shift @i; $name = "\$$name"; } my $last_was_index; for my $i (@i) { if ($i eq "*" || $i eq "\$") { $last_was_index = 0; $name = "$i\{$name}"; } elsif ($i =~ s/^\*//) { $name .= $i; $last_was_index++; } else { $name .= "->" unless $last_was_index++; $name .= $i; } } $name = "\\$name" if $ref; $name; } sub format_list { my $paren = shift; my $comment = shift; my $indent_lim = $paren ? 0 : 1; if (@_ > 3) { # can we use range operator to shorten the list? my $i = 0; while ($i < @_) { my $j = $i + 1; my $v = $_[$i]; while ($j < @_) { # XXX allow string increment too? if ($v eq "0" || $v =~ /^-?[1-9]\d{0,9}\z/) { $v++; } elsif ($v =~ /^"([A-Za-z]{1,3}\d*)"\z/) { $v = $1; $v++; $v = qq("$v"); } else { last; } last if $_[$j] ne $v; $j++; } if ($j - $i > 3) { splice(@_, $i, $j - $i, "$_[$i] .. $_[$j-1]"); } $i++; } } my $tmp = "@_"; if ($comment || (@_ > $indent_lim && (length($tmp) > 60 || $tmp =~ /\n/))) { my @elem = @_; for (@elem) { s/^/$INDENT/gm; } return "\n" . ($comment ? "$INDENT# $comment\n" : "") . join(",\n", @elem, ""); } else { return join(", ", @_); } } sub str { if (length($_[0]) > 20) { for ($_[0]) { # Check for repeated string if (/^(.)\1\1\1/s) { # seems to be a repating sequence, let's check if it really is # without backtracking unless (/[^\Q$1\E]/) { my $base = quote($1); my $repeat = length; return "($base x $repeat)" } } # Length protection because the RE engine will blow the stack [RT#33520] if (length($_) < 16 * 1024 && /^(.{2,5}?)\1*\z/s) { my $base = quote($1); my $repeat = length($_)/length($1); return "($base x $repeat)"; } } } local $_ = "e; if (length($_) > 40 && !/\\x\{/ && length($_) > (length($_[0]) * 2)) { # too much binary data, better to represent as a hex/base64 string # Base64 is more compact than hex when string is longer than # 17 bytes (not counting any require statement needed). # But on the other hand, hex is much more readable. if ($TRY_BASE64 && length($_[0]) > $TRY_BASE64 && (defined &utf8::is_utf8 && !utf8::is_utf8($_[0])) && eval { require MIME::Base64 }) { $require{"MIME::Base64"}++; return "MIME::Base64::decode(\"" . MIME::Base64::encode($_[0],"") . "\")"; } return "pack(\"H*\",\"" . unpack("H*", $_[0]) . "\")"; } return $_; } my %esc = ( "\a" => "\\a", "\b" => "\\b", "\t" => "\\t", "\n" => "\\n", "\f" => "\\f", "\r" => "\\r", "\e" => "\\e", ); # put a string value in double quotes sub quote { local($_) = $_[0]; # If there are many '"' we might want to use qq() instead s/([\\\"\@\$])/\\$1/g; return qq("$_") unless /[^\040-\176]/; # fast exit s/([\a\b\t\n\f\r\e])/$esc{$1}/g; # no need for 3 digits in escape for these s/([\0-\037])(?!\d)/sprintf('\\%o',ord($1))/eg; s/([\0-\037\177-\377])/sprintf('\\x%02X',ord($1))/eg; s/([^\040-\176])/sprintf('\\x{%X}',ord($1))/eg; return qq("$_"); } 1; __END__ =head1 NAME Data::Dump - Pretty printing of data structures =head1 SYNOPSIS use Data::Dump qw(dump); $str = dump(@list); @copy_of_list = eval $str; # or use it for easy debug printout use Data::Dump; dd localtime; =head1 DESCRIPTION This module provide a few functions that traverse their argument and produces a string as its result. The string contains Perl code that, when Ced, produces a deep copy of the original arguments. The main feature of the module is that it strives to produce output that is easy to read. Example: @a = (1, [2, 3], {4 => 5}); dump(@a); Produces: "(1, [2, 3], { 4 => 5 })" If you dump just a little data, it is output on a single line. If you dump data that is more complex or there is a lot of it, line breaks are automatically added to keep it easy to read. The following functions are provided (only the dd* functions are exported by default): =over =item dump( ... ) =item pp( ... ) Returns a string containing a Perl expression. If you pass this string to Perl's built-in eval() function it should return a copy of the arguments you passed to dump(). If you call the function with multiple arguments then the output will be wrapped in parenthesis "( ..., ... )". If you call the function with a single argument the output will not have the wrapping. If you call the function with a single scalar (non-reference) argument it will just return the scalar quoted if needed, but never break it into multiple lines. If you pass multiple arguments or references to arrays of hashes then the return value might contain line breaks to format it for easier reading. The returned string will never be "\n" terminated, even if contains multiple lines. This allows code like this to place the semicolon in the expected place: print '$obj = ', dump($obj), ";\n"; If dump() is called in void context, then the dump is printed on STDERR and then "\n" terminated. You might find this useful for quick debug printouts, but the dd*() functions might be better alternatives for this. There is no difference between dump() and pp(), except that dump() shares its name with a not-so-useful perl builtin. Because of this some might want to avoid using that name. =item quote( $string ) Returns a quoted version of the provided string. It differs from C in that it will quote even numbers and not try to come up with clever expressions that might shorten the output. If a non-scalar argument is provided then it's just stringified instead of traversed. =item dd( ... ) =item ddx( ... ) These functions will call dump() on their argument and print the result to STDOUT (actually, it's the currently selected output handle, but STDOUT is the default for that). The difference between them is only that ddx() will prefix the lines it prints with "# " and mark the first line with the file and line number where it was called. This is meant to be useful for debug printouts of state within programs. =item dumpf( ..., \&filter ) Short hand for calling the dump_filtered() function of L. This works like dump(), but the last argument should be a filter callback function. As objects are visited the filter callback is invoked and it can modify how the objects are dumped. =back =head1 CONFIGURATION There are a few global variables that can be set to modify the output generated by the dump functions. It's wise to localize the setting of these. =over =item $Data::Dump::INDENT This holds the string that's used for indenting multiline data structures. It's default value is " " (two spaces). Set it to "" to suppress indentation. Setting it to "| " makes for nice visuals even if the dump output then fails to be valid Perl. =item $Data::Dump::TRY_BASE64 How long must a binary string be before we try to use the base64 encoding for the dump output. The default is 50. Set it to 0 to disable base64 dumps. =back =head1 LIMITATIONS Code references will be dumped as C<< sub { ... } >>. Thus, Cing them will not reproduce the original routine. The C<...>-operator used will also require perl-5.12 or better to be evaled. If you forget to explicitly import the C function, your code will core dump. That's because you just called the builtin C function by accident, which intentionally dumps core. Because of this you can also import the same function as C, mnemonic for "pretty-print". =head1 HISTORY The C module grew out of frustration with Sarathy's in-most-cases-excellent C. Basic ideas and some code are shared with Sarathy's module. The C module provides a much simpler interface than C. No OO interface is available and there are fewer configuration options to worry about. The other benefit is that the dump produced does not try to set any variables. It only returns what is needed to produce a copy of the arguments. This means that C simply returns C<'"foo"'>, and C simply returns C<'(1, 2, 3)'>. =head1 SEE ALSO L, L, L, L, L =head1 AUTHORS The C module is written by Gisle Aas , based on C by Gurusamy Sarathy . Copyright 1998-2010 Gisle Aas. Copyright 1996-1998 Gurusamy Sarathy. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Data-Dump-1.22/lib/Data/Dump/FilterContext.pm000644 000765 000024 00000003217 12143144702 021135 0ustar00gislestaff000000 000000 package Data::Dump::FilterContext; sub new { my($class, $obj, $oclass, $type, $ref, $pclass, $pidx, $idx) = @_; return bless { object => $obj, class => $ref && $oclass, reftype => $type, is_ref => $ref, pclass => $pclass, pidx => $pidx, idx => $idx, }, $class; } sub object_ref { my $self = shift; return $self->{object}; } sub class { my $self = shift; return $self->{class} || ""; } *is_blessed = \&class; sub reftype { my $self = shift; return $self->{reftype}; } sub is_scalar { my $self = shift; return $self->{reftype} eq "SCALAR"; } sub is_array { my $self = shift; return $self->{reftype} eq "ARRAY"; } sub is_hash { my $self = shift; return $self->{reftype} eq "HASH"; } sub is_code { my $self = shift; return $self->{reftype} eq "CODE"; } sub is_ref { my $self = shift; return $self->{is_ref}; } sub container_class { my $self = shift; return $self->{pclass} || ""; } sub container_self { my $self = shift; return "" unless $self->{pclass}; my $idx = $self->{idx}; my $pidx = $self->{pidx}; return Data::Dump::fullname("self", [@$idx[$pidx..(@$idx - 1)]]); } sub expr { my $self = shift; my $top = shift || "var"; $top =~ s/^\$//; # it's always added by fullname() my $idx = $self->{idx}; return Data::Dump::fullname($top, $idx); } sub object_isa { my($self, $class) = @_; return $self->{class} && $self->{class}->isa($class); } sub container_isa { my($self, $class) = @_; return $self->{pclass} && $self->{pclass}->isa($class); } sub depth { my $self = shift; return scalar @{$self->{idx}}; } 1; Data-Dump-1.22/lib/Data/Dump/Filtered.pm000644 000765 000024 00000012321 12143145016 020074 0ustar00gislestaff000000 000000 package Data::Dump::Filtered; use Data::Dump (); use Carp (); use base 'Exporter'; our @EXPORT_OK = qw(add_dump_filter remove_dump_filter dump_filtered); sub add_dump_filter { my $filter = shift; unless (ref($filter) eq "CODE") { Carp::croak("add_dump_filter argument must be a code reference"); } push(@Data::Dump::FILTERS, $filter); return $filter; } sub remove_dump_filter { my $filter = shift; @Data::Dump::FILTERS = grep $_ ne $filter, @Data::Dump::FILTERS; } sub dump_filtered { my $filter = pop; if (defined($filter) && ref($filter) ne "CODE") { Carp::croak("Last argument to dump_filtered must be undef or a code reference"); } local @Data::Dump::FILTERS = ($filter ? $filter : ()); return &Data::Dump::dump; } 1; =head1 NAME Data::Dump::Filtered - Pretty printing with filtering =head1 DESCRIPTION The following functions are provided: =over =item add_dump_filter( \&filter ) This registers a filter function to be used by the regular Data::Dump::dump() function. By default no filters are active. Since registering filters has a global effect is might be more appropriate to use the dump_filtered() function instead. =item remove_dump_filter( \&filter ) Unregister the given callback function as filter callback. This undoes the effect of L. =item dump_filtered(..., \&filter ) Works like Data::Dump::dump(), but the last argument should be a filter callback function. As objects are visited the filter callback is invoked at it might influence how objects are dumped. Any filters registered with L are ignored when this interface is invoked. Actually, passing C as \&filter is allowed and C<< dump_filtered(..., undef) >> is the official way to force unfiltered dumps. =back =head2 Filter callback A filter callback is a function that will be invoked with 2 arguments; a context object and reference to the object currently visited. The return value should either be a hash reference or C. sub filter_callback { my($ctx, $object_ref) = @_; ... return { ... } } If the filter callback returns C (or nothing) then normal processing and formatting of the visited object happens. If the filter callback returns a hash it might replace or annotate the representation of the current object. =head2 Filter context The context object provide methods that can be used to determine what kind of object is currently visited and where it's located. The context object has the following interface: =over =item $ctx->object_ref Alternative way to obtain a reference to the current object =item $ctx->class If the object is blessed this return the class. Returns "" for objects not blessed. =item $ctx->reftype Returns what kind of object this is. It's a string like "SCALAR", "ARRAY", "HASH", "CODE",... =item $ctx->is_ref Returns true if a reference was provided. =item $ctx->is_blessed Returns true if the object is blessed. Actually, this is just an alias for C<< $ctx->class >>. =item $ctx->is_array Returns true if the object is an array =item $ctx->is_hash Returns true if the object is a hash =item $ctx->is_scalar Returns true if the object is a scalar (a string or a number) =item $ctx->is_code Returns true if the object is a function (aka subroutine) =item $ctx->container_class Returns the class of the innermost container that contains this object. Returns "" if there is no blessed container. =item $ctx->container_self Returns an textual expression relative to the container object that names this object. The variable C<$self> in this expression is the container itself. =item $ctx->object_isa( $class ) Returns TRUE if the current object is of the given class or is of a subclass. =item $ctx->container_isa( $class ) Returns TRUE if the innermost container is of the given class or is of a subclass. =item $ctx->depth Returns how many levels deep have we recursed into the structure (from the original dump_filtered() arguments). =item $ctx->expr =item $ctx->expr( $top_level_name ) Returns an textual expression that denotes the current object. In the expression C<$var> is used as the name of the top level object dumped. This can be overridden by providing a different name as argument. =back =head2 Filter return hash The following elements has significance in the returned hash: =over =item dump => $string incorporate the given string as the representation for the current value =item object => $value dump the given value instead of the one visited and passed in as $object. Basically the same as specifying C<< dump => Data::Dump::dump($value) >>. =item comment => $comment prefix the value with the given comment string =item bless => $class make it look as if the current object is of the given $class instead of the class it really has (if any). The internals of the object is dumped in the regular way. The $class can be the empty string to make Data::Dump pretend the object wasn't blessed at all. =item hide_keys => ['key1', 'key2',...] =item hide_keys => \&code If the $object is a hash dump is as normal but pretend that the listed keys did not exist. If the argument is a function then the function is called to determine if the given key should be hidden. =back =head1 SEE ALSO L Data-Dump-1.22/lib/Data/Dump/Trace.pm000644 000765 000024 00000023052 12131612121 017370 0ustar00gislestaff000000 000000 package Data::Dump::Trace; $VERSION = "0.02"; # Todo: # - prototypes # in/out parameters key/value style # - exception # - wrap class # - configurable colors # - show call depth using indentation # - show nested calls sensibly # - time calls use strict; use base 'Exporter'; our @EXPORT_OK = qw(call mcall wrap autowrap trace); use Carp qw(croak); use overload (); my %obj_name; my %autowrap_class; my %name_count; sub autowrap { while (@_) { my $class = shift; my $info = shift; $info = { prefix => $info } unless ref($info); for ($info->{prefix}) { unless ($_) { $_ = lc($class); s/.*:://; } $_ = '$' . $_ unless /^\$/; } $autowrap_class{$class} = $info; } } sub wrap { my %arg = @_; my $name = $arg{name} || "func"; my $func = $arg{func}; my $proto = $arg{proto}; return sub { call($name, $func, $proto, @_); } if $func; if (my $obj = $arg{obj}) { $name = '$' . $name unless $name =~ /^\$/; $obj_name{overload::StrVal($obj)} = $name; return bless { name => $name, obj => $obj, proto => $arg{proto}, }, "Data::Dump::Trace::Wrapper"; } croak("Either the 'func' or 'obj' option must be given"); } sub trace { my($symbol, $prototype) = @_; no strict 'refs'; no warnings 'redefine'; *{$symbol} = wrap(name => $symbol, func => \&{$symbol}, proto => $prototype); } sub call { my $name = shift; my $func = shift; my $proto = shift; my $fmt = Data::Dump::Trace::Call->new($name, $proto, \@_); if (!defined wantarray) { $func->(@_); return $fmt->return_void(\@_); } elsif (wantarray) { return $fmt->return_list(\@_, $func->(@_)); } else { return $fmt->return_scalar(\@_, scalar $func->(@_)); } } sub mcall { my $o = shift; my $method = shift; my $proto = shift; return if $method eq "DESTROY" && !$o->can("DESTROY"); my $oname = ref($o) ? $obj_name{overload::StrVal($o)} || "\$o" : $o; my $fmt = Data::Dump::Trace::Call->new("$oname->$method", $proto, \@_); if (!defined wantarray) { $o->$method(@_); return $fmt->return_void(\@_); } elsif (wantarray) { return $fmt->return_list(\@_, $o->$method(@_)); } else { return $fmt->return_scalar(\@_, scalar $o->$method(@_)); } } package Data::Dump::Trace::Wrapper; sub AUTOLOAD { my $self = shift; our $AUTOLOAD; my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2); Data::Dump::Trace::mcall($self->{obj}, $method, $self->{proto}{$method}, @_); } package Data::Dump::Trace::Call; use Term::ANSIColor (); use Data::Dump (); *_dump = \&Data::Dump::dump; our %COLOR = ( name => "yellow", output => "cyan", error => "red", debug => "red", ); %COLOR = () unless -t STDOUT; sub _dumpav { return "(" . _dump(@_) . ")" if @_ == 1; return _dump(@_); } sub _dumpkv { return _dumpav(@_) if @_ % 2; my %h = @_; my $str = _dump(\%h); $str =~ s/^\{/(/ && $str =~ s/\}\z/)/; return $str; } sub new { my($class, $name, $proto, $input_args) = @_; my $self = bless { name => $name, proto => $proto, }, $class; my $proto_arg = $self->proto_arg; if ($proto_arg =~ /o/) { for (@$input_args) { push(@{$self->{input_av}}, _dump($_)); } } else { $self->{input} = $proto_arg eq "%" ? _dumpkv(@$input_args) : _dumpav(@$input_args); } return $self; } sub proto_arg { my $self = shift; my($arg, $ret) = split(/\s*=\s*/, $self->{proto} || ""); $arg ||= '@'; return $arg; } sub proto_ret { my $self = shift; my($arg, $ret) = split(/\s*=\s*/, $self->{proto} || ""); $ret ||= '@'; return $ret; } sub color { my($self, $category, $text) = @_; return $text unless $COLOR{$category}; return Term::ANSIColor::colored($text, $COLOR{$category}); } sub print_call { my $self = shift; my $outarg = shift; print $self->color("name", "$self->{name}"); if (my $input = $self->{input}) { $input = "" if $input eq "()" && $self->{name} =~ /->/; print $self->color("input", $input); } else { my $proto_arg = $self->proto_arg; print "("; my $i = 0; for (@{$self->{input_av}}) { print ", " if $i; my $proto = substr($proto_arg, 0, 1, ""); if ($proto ne "o") { print $self->color("input", $_); } if ($proto eq "o" || $proto eq "O") { print " = " if $proto eq "O"; print $self->color("output", _dump($outarg->[$i])); } } continue { $i++; } print ")"; } } sub return_void { my $self = shift; my $arg = shift; $self->print_call($arg); print "\n"; return; } sub return_scalar { my $self = shift; my $arg = shift; $self->print_call($arg); my $s = shift; my $name; my $proto_ret = $self->proto_ret; my $wrap = $autowrap_class{ref($s)}; if ($proto_ret =~ /^\$\w+\z/ && ref($s) && ref($s) !~ /^(?:ARRAY|HASH|CODE|GLOB)\z/) { $name = $proto_ret; } else { $name = $wrap->{prefix} if $wrap; } if ($name) { $name .= $name_count{$name} if $name_count{$name}++; print " = ", $self->color("output", $name), "\n"; $s = Data::Dump::Trace::wrap(name => $name, obj => $s, proto => $wrap->{proto}); } else { print " = ", $self->color("output", _dump($s)); if (!$s && $proto_ret =~ /!/ && $!) { print " ", $self->color("error", errno($!)); } print "\n"; } return $s; } sub return_list { my $self = shift; my $arg = shift; $self->print_call($arg); print " = ", $self->color("output", $self->proto_ret eq "%" ? _dumpkv(@_) : _dumpav(@_)), "\n"; return @_; } sub errno { my $t = ""; for (keys %!) { if ($!{$_}) { $t = $_; last; } } my $n = int($!); return "$t($n) $!"; } 1; __END__ =head1 NAME Data::Dump::Trace - Helpers to trace function and method calls =head1 SYNOPSIS use Data::Dump::Trace qw(autowrap mcall); autowrap("LWP::UserAgent" => "ua", "HTTP::Response" => "res"); use LWP::UserAgent; $ua = mcall(LWP::UserAgent => "new"); # instead of LWP::UserAgent->new; $ua->get("http://www.example.com")->dump; =head1 DESCRIPTION The following functions are provided: =over =item autowrap( $class ) =item autowrap( $class => $prefix ) =item autowrap( $class1 => $prefix1, $class2 => $prefix2, ... ) =item autowrap( $class1 => \%info1, $class2 => \%info2, ... ) Register classes whose objects are are automatically wrapped when returned by one of the call functions below. If $prefix is provided it will be used as to name the objects. Alternative is to pass an %info hash for each class. The recognized keys are: =over =item prefix => $string The prefix string used to name objects of this type. =item proto => \%hash A hash of prototypes to use for the methods when an object is wrapped. =back =item wrap( name => $str, func => \&func, proto => $proto ) =item wrap( name => $str, obj => $obj, proto => \%hash ) Returns a wrapped function or object. When a wrapped function is invoked then a trace is printed after the underlying function has returned. When a method on a wrapped object is invoked then a trace is printed after the methods on the underlying objects has returned. See L for description of the C argument. =item call( $name, \&func, $proto, @ARGS ) Calls the given function with the given arguments. The trace will use $name as the name of the function. See L for description of the $proto argument. =item mcall( $class, $method, $proto, @ARGS ) =item mcall( $object, $method, $proto, @ARGS ) Calls the given method with the given arguments. See L for description of the $proto argument. =item trace( $symbol, $prototype ) Replaces the function given by $symbol with a wrapped function. =back =head2 Prototypes B. The $proto argument to call() and mcall() can optionally provide a prototype for the function call. This give the tracer hints about how to best format the argument lists and if there are I or I arguments. The general form for the prototype string is: = The default prototype is "@ = @"; list of values as input and list of values as output. The value '%' can be used for both arguments and return value to say that key/value pair style lists are used. Alternatively, individual positional arguments can be listed each represented by a letter: =over =item C input argument =item C output argument =item C both input and output argument =back If the return value prototype has C appended, then it signals that this function sets errno ($!) when it returns a false value. The trace will display the current value of errno in that case. If the return value prototype looks like a variable name (with C<$> prefix), and the function returns a blessed object, then the variable name will be used as prefix and the returned object automatically traced. =head1 SEE ALSO L =head1 AUTHOR Copyright 2009 Gisle Aas. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut