Data-Printer-1.002001/0000755000000000000000000000000014552072607012735 5ustar rootrootData-Printer-1.002001/META.json0000644000000000000000000000261114552072607014356 0ustar rootroot{ "abstract" : "colored & full-featured pretty print of Perl data structures and objects", "author" : [ "Breno G. de Oliveira " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.70, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Data-Printer", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Fcntl" : "0", "File::Spec" : "0", "File::Temp" : "0", "Scalar::Util" : "0", "Test::More" : "0", "version" : "0.77" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/garu/Data-Printer/issues/" }, "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "url" : "https://github.com/garu/Data-Printer" } }, "version" : "1.002001", "x_serialization_backend" : "JSON::PP version 4.07" } Data-Printer-1.002001/examples/0000755000000000000000000000000014552072607014553 5ustar rootrootData-Printer-1.002001/examples/try_me.pl0000644000000000000000000000246614552041133016405 0ustar rootroot#!/usr/bin/env perl use strict; use warnings; use Scalar::Util qw(weaken); # This sample code is available to you so you # can see Data::Printer working out of the box. # It can be used as a quick way to test your # color palette scheme! package My::BaseClass; sub whatever {} package My::SampleClass; use base 'My::BaseClass'; sub new { bless {}, shift } sub public_method { 42 } sub _private_method { 'sample' } package main; my $obj = My::SampleClass->new; my $sample = { number => 123.456, string => 'a string', array => [ "foo\0has\tescapes", 6, undef ], hash => { foo => 'bar', baz => 789, }, readonly => \2, boolean => [1 == 1, 1 == 2], regexp => qr/foo.*bar/i, glob => \*STDOUT, code => sub { return 42 }, class => $obj, }; $sample->{weakref} = $sample; weaken $sample->{weakref}; BEGIN { $ENV{DATAPRINTERRC} = '' }; # <-- skip user's .dataprinter use DDP show_memsize => 1, show_refcount => 1, class => { format_inheritance => 'lines', inherited => 'public', linear_isa => 1 }; p $sample, theme => 'Material' , as => 'Material theme:'; p $sample, theme => 'Solarized', as => 'Solarized theme:'; p $sample, theme => 'Monokai', as => 'Monokai theme:'; p $sample, theme => 'Classic', as => 'Classic pre-1.0 theme:'; Data-Printer-1.002001/t/0000755000000000000000000000000014552072607013200 5ustar rootrootData-Printer-1.002001/t/011.3-object_pad.t0000644000000000000000000000163014552015171016110 0ustar rootrootuse strict; use warnings; use Test::More tests => 1; use Data::Printer::Common; use Data::Printer::Object; test_object_pad(); exit; sub test_object_pad { SKIP: { my $error = Data::Printer::Common::_tryme( 'use Object::Pad 0.60; class TestClass { has $x :param = 42; method one($dX) { } method two { } }' ); skip 'Object::Pad 0.60+ not found', 1 if $error; my $ddp = Data::Printer::Object->new( colored => 0, class => { show_reftype => 1 } ); my $obj = TestClass->new( x => 666 ); my $parsed = $ddp->parse($obj); is( $parsed, 'TestClass (ARRAY) { parents: Object::Pad::UNIVERSAL public methods (6): DOES, META, new, one, two Object::Pad::UNIVERSAL: BUILDARGS private methods (0) internals: [ [0] 666 ] }', 'parsed Object::Pad class' ); }; } Data-Printer-1.002001/t/024-tied.t0000644000000000000000000001005714552015171014611 0ustar rootrootuse strict; use warnings; package Tie::Fighter::Scalar; sub TIESCALAR { my $class = shift; my $foo = 1; return bless \$foo, $class; } sub FETCH { my $self = shift; return $$self; } sub STORE { } package Tie::Fighter::Array; sub TIEARRAY { my $class = shift; my @foo = (2, 3); return bless \@foo, $class; } sub FETCH { my ($self, $index) = @_; return $self->[$index]; } sub STORE { } sub FETCHSIZE { scalar @{$_[0]} } sub STORESIZE { } package Tie::Fighter::Hash; sub TIEHASH { my $class = shift; my %foo = ( test => 42 ); return bless \%foo, $class; } sub FETCH { my ($self, $key) = @_; return $self->{$key}; } sub STORE { } sub EXISTS { my ($self, $key) = @_; return exists $self->{$key}; } sub DELETE { } sub CLEAR { } sub FIRSTKEY { my $self = shift; my $a = keys %$self; # reset each() iterator return each %$self; } sub NEXTKEY { my $self = shift; return each %$self; } package Tie::Fighter::Handle; sub TIEHANDLE { my $i; return bless \$i, shift; } sub PRINT { } sub READ { return 'foo' } sub READLINE { return 'foo' } package Tie::Me::Up; sub TIEHASH { my ($class, $generator) = @_; return bless { generator => $generator, hash => {}, }, $class; } sub FETCH { my ($self, $key) = @_; return $self->{hash}{$key}; } sub STORE { my ($self, $key, $value) = @_; $self->{hash}{$key} = $self->{generator}->($value); } sub FIRSTKEY { my ($self) = @_; keys %{ $self->{hash} }; # reset each() iterator each %{ $self->{hash} }; } # lastkey is here for documentation, but we don't use it sub NEXTKEY { my ($self, $lastkey) = @_; return each %{ $self->{hash} }; } package main; use Test::More tests => 18; use Data::Printer::Object; my $ddp = Data::Printer::Object->new( colored => 0, seen_override => 1 ); my $var = 42; is $ddp->parse(\$var), '42', 'untied scalar shows only the scalar'; tie $var, 'Tie::Fighter::Scalar'; is $ddp->parse(\$var), '1 (tied to Tie::Fighter::Scalar)', 'tied scalar contains tied message'; $ddp->show_tied(0); is $ddp->parse(\$var), '1', '(still) tied scalar not shown on show_tied => 0'; $ddp->show_tied(1); untie $var; is $ddp->parse(\$var), '1', 'cleared (untied) scalar again shows no tie information'; my @var = (1); is $ddp->parse(\@var), '[ [0] 1 ]', 'untied array shows only the array'; tie @var, 'Tie::Fighter::Array'; is $ddp->parse(\@var), '[ [0] 2, [1] 3 ] (tied to Tie::Fighter::Array)', 'tied array contains tied message'; $ddp->show_tied(0); is $ddp->parse(\@var), '[ [0] 2, [1] 3 ]', '(still) tied array not shown on show_tied => 0'; $ddp->show_tied(1); untie @var; is $ddp->parse(\@var), '[ [0] 1 ]', 'cleared (untied) array again shows no tie information'; my %var = ( foo => 'bar' ); is $ddp->parse(\%var), '{ foo "bar" }', 'untied hash shows only the hash'; tie %var, 'Tie::Fighter::Hash'; is $ddp->parse(\%var), '{ test 42 } (tied to Tie::Fighter::Hash)', 'tied hash contains tied message'; $ddp->show_tied(0); is $ddp->parse(\%var), '{ test 42 }', '(still) tied hash not shown on show_tied => 0'; $ddp->show_tied(1); untie %var; is $ddp->parse(\%var), '{ foo "bar" }', 'cleared (untied) hash again shows no tie information'; $var = *DATA; like $ddp->parse(\$var), qr/\*main::DATA/, 'untied handle properly referenced'; unlike $ddp->parse(\$var), qr/tied to/, 'untied handle shows only the handle itself'; tie *$var, 'Tie::Fighter::Handle'; like $ddp->parse(\$var), qr/tied to Tie::Fighter::Handle/, 'tied handle contains tied message'; $ddp->show_tied(0); unlike $ddp->parse(\$var), qr/tied to/, 'tied handle not exposed on show_tied => 0'; $ddp->show_tied(1); untie *$var; unlike $ddp->parse(\$var), qr/tied to/, 'cleared (untied) handle again shows no tie information'; tie my %hash, 'Tie::Me::Up', sub { return scalar reverse $_[0] }; $hash{first} = '1234'; $hash{second} = 'ABCD'; $hash{third} = 'wtf?'; my $output = $ddp->parse(\%hash); unlike $output, qr/var\{\w+\}/, 'No false deduplication'; __DATA__ test file! Data-Printer-1.002001/t/004-vstring.t0000644000000000000000000000066614552015171015363 0ustar rootrootuse strict; use warnings; use Test::More; use Data::Printer::Object; if ($] < 5.010) { plan skip_all => 'Older perls do not have VSTRING support'; } else { plan tests => 1; } my $version = v1.2.3; my $ddp = Data::Printer::Object->new( colored => 0 ); my $res = $ddp->parse(\$version); if ($res eq 'VSTRING object (unable to parse)' || $res eq 'v1.2.3') { pass 'VSTRING'; } else { fail "expected v1.2.3, got '$res'!"; } Data-Printer-1.002001/t/011.2-roles.t0000644000000000000000000000541314552015171015144 0ustar rootrootuse strict; use warnings; use Test::More; use Data::Printer::Common; use Data::Printer::Object; plan tests => 8; test_role_tiny(); test_moo(); test_moose(); exit; sub test_role_tiny { SKIP: { my $role_tiny_error = Data::Printer::Common::_tryme( 'package TestRole; use Role::Tiny; sub role_a {} sub role_b {} 1; package TestClass; use Role::Tiny::With; with q(TestRole); sub new { bless {}, shift } 1;' ); skip 'Role::Tiny not found: ' . $role_tiny_error, 2 if $role_tiny_error; my $ddp = Data::Printer::Object->new( colored => 0 ); my $obj = TestClass->new; my $parsed = $ddp->parse($obj); like( $parsed, qr/^\s*roles \(1\): TestRole$/m, 'Role::Tiny role is listed' ); like( $parsed, qr/TestRole:\s+role_a, role_b/m, 'Role::Tiny object parsed properly' ); }; } sub test_moo { SKIP: { my $moo_error = Data::Printer::Common::_tryme( 'package MooTestRole; use Moo::Role; has attr_from_role => (is => "ro", required => 0);sub role_x {} sub role_y {} 1; package MooTestClass; use Moo; with q(MooTestRole); no Moo; 1;' ); skip 'Moo not found: ' . $moo_error, 3 if $moo_error; my $ddp = Data::Printer::Object->new( colored => 0 ); my $obj = MooTestClass->new; my $parsed = $ddp->parse($obj); like( $parsed, qr/^\s*roles \(1\): MooTestRole$/m, 'Moo role is listed' ); like( $parsed, qr/^\s*attributes \(1\): attr_from_role$/m, 'role attribute is found in Moo object' ); like( $parsed, qr/^\s*MooTestRole:\s+role_x, role_y/m, 'Moo object parsed properly' ); }; } sub test_moose { SKIP: { my $moose_error = Data::Printer::Common::_tryme( 'package MooseTestRole; use Moose::Role; has my_attr => (is => "ro", required => 0);sub role_p {} sub role_q {} 1; package MooseTestClass; use Moose; with q(MooseTestRole); no Moose; __PACKAGE__->meta->make_immutable; 1;' ); skip 'Moose not found: ' . $moose_error, 3 if $moose_error; my $ddp = Data::Printer::Object->new( colored => 0 ); my $obj = MooseTestClass->new; my $parsed = $ddp->parse($obj); like( $parsed, qr/^\s*roles \(1\): MooseTestRole$/m, 'Moose role is listed' ); like( $parsed, qr/^\s*attributes \(1\): my_attr$/m, 'role attribute is found in Moose object' ); like( $parsed, qr/MooseTestRole:\s+role_p, role_q/m, 'Moose object parsed properly' ); }; } Data-Printer-1.002001/t/000.1-home.t0000644000000000000000000000116314552015171014743 0ustar rootrootuse strict; use warnings; use Test::More tests => 4; use Data::Printer::Config; { local %ENV = %ENV; $ENV{HOME} = '/ddp-home'; is Data::Printer::Config::_my_home(), '/ddp-home', 'found HOME in env'; delete $ENV{HOME}; diag('$^O is ' . $^O); ok Data::Printer::Config::_my_home(), 'found home without env'; ok Data::Printer::Config::_project_home(), 'found project home'; { local $0; eval { $0 = '-e'; }; SKIP: { skip 'unable to change $0', 1 unless $0 eq '-e'; ok Data::Printer::Config::_project_home(), 'found project home'; }; } } Data-Printer-1.002001/t/000-load.t0000644000000000000000000000052314552015171014572 0ustar rootrootuse strict; use warnings; use Test::More tests => 3; BEGIN { use Data::Printer::Config; no warnings 'redefine'; *Data::Printer::Config::load_rc_file = sub { {} }; }; use Data::Printer; pass 'Data::Printer loaded successfully'; ok exists &p , 'p() was imported successfully'; ok exists &np, 'np() was imported successfully'; Data-Printer-1.002001/t/027-nativeperlclass.t0000644000000000000000000000231014552015171017057 0ustar rootrootuse strict; use warnings; use Test::More; use Data::Printer::Object; use Data::Printer::Common; if ($] < 5.038) { plan skip_all => 'perl native classes only available after 5.38'; exit; } my $error = Data::Printer::Common::_tryme(<<'EOCODE' use 5.38.0; use warnings; use feature 'class'; no warnings 'experimental::class'; class MyBaseClass { field $one :param; field $two; field $three :param //= 0; method base_foo { } } class MyClass :isa(MyBaseClass) { field $four; field $five :param = 42; field $six :param; field $seven :param(four); ADJUST { $four = $five } method foo ($x) { return $x * 2; } sub not_a_method { } }; 1; EOCODE ); if ($error) { plan skip_all => "error creating class: $error"; exit; } plan tests => 1; my $obj = MyClass->new( one => 'um', six => 'seis', four => 'quatro' ); my $ddp = Data::Printer::Object->new( colored => 0 ); my $res = $ddp->parse($obj); is $res, 'MyClass { parents: MyBaseClass public methods (4): foo, new, not_a_method MyBaseClass: base_foo private methods (0) internals: (opaque object) }', 'parsed perl 5.38 native object type'; Data-Printer-1.002001/t/002-scalar.t0000644000000000000000000002575314552046564015150 0ustar rootroot#!perl -T # ^^ taint mode must be on for taint checking. use strict; use warnings; use Test::More tests => 72; use Data::Printer::Object; use Scalar::Util; test_basic_values(); test_boolean_values(); test_tainted_values(); test_unicode_string(); test_escape_chars(); test_print_escapes(); test_max_string(); test_weak_ref(); test_readonly(); test_dualvar_lax(); test_dualvar_strict(); test_dualvar_off(); sub test_weak_ref { my $num = 3.14; my $ref = \$num; Scalar::Util::weaken($ref); my $ddp = Data::Printer::Object->new( colored => 0 ); is $ddp->parse($ref), '3.14 (weak)', 'parse() after weaken'; } sub test_basic_values { my $object = Data::Printer::Object->new( colored => 0 ); # hardcoded values: is $object->parse(\undef) , 'undef (read-only)' , 'hardcoded undef value'; is $object->parse(\123) , '123 (read-only)' , 'hardcoded integer value'; is $object->parse(\0) , '0 (read-only)' , 'hardcoded integer value'; is $object->parse(\123.456), '123.456 (read-only)', 'hardcoded floating point value'; is $object->parse(\'meep!'), '"meep!" (read-only)', 'hardcoded string value'; # variable values: my $var; is $object->parse(\$var), 'undef', 'undefined variable'; $var = undef; $object = Data::Printer::Object->new( colored => 0 ); is $object->parse(\$var), 'undef', 'explicitly undefined variable'; $object = Data::Printer::Object->new( colored => 0 ); $var = 0; is $object->parse(\$var), '0', 'integer 0 in variable'; $object = Data::Printer::Object->new( colored => 0 ); $var = -1; is $object->parse(\$var), '-1', 'integer -1 in variable'; $object = Data::Printer::Object->new( colored => 0 ); $var = 123; is $object->parse(\$var), '123', 'integer 123 in variable'; } sub test_boolean_values { SKIP: { skip 'booleans only exist after 5.36', 5 unless $] ge '5.036000'; my $object = Data::Printer::Object->new( colored => 0 ); my $var = 1 == 1; is $object->parse(\$var), 'true', 'boolean true is "true"'; $var = 1 == 2; is $object->parse(\$var), 'false', 'boolean false is "false"'; $var = 1; is $object->parse(\$var), '1', '1 is 1, not "true"'; $var = ''; is $object->parse(\$var), '""', 'empty string is "", not "false"'; $var = 0; is $object->parse(\$var), '0', '0 is 0, not "false"'; }; } sub test_tainted_values { SKIP: { # only use 1 char substring to avoid leaking # user information on test results: my $tainted = substr $ENV{'PATH'}, 0, 1; skip 'Skipping taint test: sample not found.', 2 => unless Scalar::Util::tainted($tainted); my $object = Data::Printer::Object->new( colored => 0 ); is $object->parse(\$tainted), qq("$tainted" (TAINTED)), 'show tainted scalar'; $object = Data::Printer::Object->new( colored => 0, show_tainted => 0 ); is $object->parse(\$tainted), qq("$tainted"), 'no tainted flag without show_tainted'; } } sub test_unicode_string { my $object = Data::Printer::Object->new( colored => 0 ); my $unicode_str = "\x{2603}"; my $ascii_str = "\x{ff}"; is $object->parse(\$unicode_str), qq("$unicode_str"), 'no suffix on unicode by default'; is $object->parse(\$ascii_str), qq("$ascii_str"), 'ascii scalar never has suffix (1)'; $object = Data::Printer::Object->new( colored => 0, show_unicode => 1 ); is $object->parse(\$unicode_str), qq("$unicode_str" (U)), 'unicode scalar gets suffix'; is $object->parse(\$ascii_str), qq("$ascii_str"), 'ascii scalar never has suffix (2)'; } sub test_escape_chars { my $string = "L\x{e9}on likes to build a m\x{f8}\x{f8}se \x{2603} with \x{2744}\x{2746}"; my $object = Data::Printer::Object->new( colored => 0 ); is $object->parse(\$string), qq("$string"), 'escape_chars => "none"'; $object = Data::Printer::Object->new( colored => 0, escape_chars => 'nonascii' ); is( $object->parse(\$string), qq("L\\x{e9}on likes to build a m\\x{f8}\\x{f8}se \\x{2603} with \\x{2744}\\x{2746}"), 'escaping nonascii' ); $object = Data::Printer::Object->new( colored => 0, escape_chars => 'nonascii', unicode_charnames => 1 ); is( $object->parse(\$string), qq("L\\N{LATIN SMALL LETTER E WITH ACUTE}on likes to build a m\\N{LATIN SMALL LETTER O WITH STROKE}\\N{LATIN SMALL LETTER O WITH STROKE}se \\N{SNOWMAN} with \\N{SNOWFLAKE}\\N{HEAVY CHEVRON SNOWFLAKE}"), 'escaping nonascii (with unicode_charnames)' ); $object = Data::Printer::Object->new( colored => 0, escape_chars => 'nonlatin1' ); is( $object->parse(\$string), qq("L\x{e9}on likes to build a m\x{f8}\x{f8}se \\x{2603} with \\x{2744}\\x{2746}"), 'escaping nonlatin1' ); $object = Data::Printer::Object->new( colored => 0, escape_chars => 'nonlatin1', unicode_charnames => 1 ); is( $object->parse(\$string), qq("L\x{e9}on likes to build a m\x{f8}\x{f8}se \\N{SNOWMAN} with \\N{SNOWFLAKE}\\N{HEAVY CHEVRON SNOWFLAKE}"), 'escaping nonlatin1 (with unicode_charnames)' ); $object = Data::Printer::Object->new( colored => 0, escape_chars => 'all' ); is( $object->parse(\$string), '"' . join('', map {(sprintf '\x{%02x}', ord($_)) } split //, $string) . '"', 'escaping all' ); $object = Data::Printer::Object->new( colored => 0, escape_chars => 'all', unicode_charnames => 1 ); $string = "L\x{e9}on"; is( $object->parse(\$string), '"\N{LATIN CAPITAL LETTER L}\N{LATIN SMALL LETTER E WITH ACUTE}\N{LATIN SMALL LETTER O}\N{LATIN SMALL LETTER N}"', 'escaping all (with unicode_charnames)' ); } sub test_print_escapes { my $object = Data::Printer::Object->new( colored => 0 ); my $string = "\n\r\t\0\f\b\a\e"; is $object->parse(\$string), qq("\n\r\t\\0\f\b\a\e"), 'only \0 is always escaped'; $object = Data::Printer::Object->new( colored => 0, print_escapes => 1 ); is $object->parse(\$string), q("\n\r\t\0\f\b\a\e"), 'print_escapes works'; } sub test_max_string { my $ddp = Data::Printer::Object->new( colored => 0, string_max => 10, string_preserve => 'begin', string_overflow => '[...__SKIPPED__...]', ); my $string = "I'll tell you, I think\nparsing strings is N-E-A-T"; is $ddp->parse(\$string), q("I'll tell [...39...]"), 'string_max begin'; $ddp = Data::Printer::Object->new( colored => 0, string_max => 10, string_preserve => 'end', string_overflow => '[...__SKIPPED__...]', ); is $ddp->parse(\$string), q("[...39...]is N-E-A-T"), 'string_max end'; $ddp = Data::Printer::Object->new( colored => 0, string_max => 10, string_preserve => 'extremes', string_overflow => '[...__SKIPPED__...]', ); is $ddp->parse(\$string), q("I'll [...39...]E-A-T"), 'string_max extremes'; $ddp = Data::Printer::Object->new( colored => 0, string_max => 10, string_preserve => 'middle', string_overflow => '[...__SKIPPED__...]', ); is $ddp->parse(\$string), qq("[...19...]ink\nparsin[...20...]"), 'string_max middle'; $ddp = Data::Printer::Object->new( colored => 0, string_max => 10, string_preserve => 'none', string_overflow => '[...__SKIPPED__...]', ); is $ddp->parse(\$string), q("[...49...]"), 'string_max none'; } sub test_readonly { my $ddp = Data::Printer::Object->new( colored => 0, show_readonly => 1 ); my $foo = 42; &Internals::SvREADONLY( \$foo, 1 ); is $ddp->parse(\$foo), '42 (read-only)', 'readonly variables'; } sub test_dualvar_lax { # if you are adding tests here, please repeat them in test_dualvar_strict for my $t ( [ 0, 'number' ], [ 0.0, 'number' ], [ '0.0', 'number' ], [ '3', 'number' ], [ '1.0', 'number'], [ '1.10', 'number'], [ 1.100, 'number'], [ 1.000, 'number'], [ '123 ', 'number', 123], [ '123.040 ', 'number', '123.040'], [ ' 123', 'number', 123], [ ' 123.040', 'number', '123.040'], [ Scalar::Util::dualvar( 42, "The Answer" ), 'dualvar', '"The Answer" (dualvar: 42)' ], [ "Nil", 'string', '"Nil"' ], [ 0123, 'number' ], [ "0199", 'dualvar', '"0199" (dualvar: 199)' ], ) { my ( $var, $type, $expected ) = @$t; my $ddp = Data::Printer::Object->new( colored => 0 ); is( $ddp->parse( \$var ), defined $expected ? $expected : "$var", "$var in lax mode is a $type" ); } # one very specific Perl dualvar TODO: { local $TODO; if ($^O eq 'MSWin32') { $TODO = q(Windows sometimes doesn't respect $! as a dualvar [lax]); } local $! = 2; like( Data::Printer::Object->new( colored => 0 )->parse( \$! ), qr/".+" \(dualvar: 2\)/, '$! is a dualvar' ); }; } sub test_dualvar_strict { # if you are adding tests here, please repeat them in test_dualvar_lax for my $t ( [ 0, 'number' ], [ 0.0, 'number' ], [ '0.0', 'number' ], [ '3', 'number' ], [ '1.0', 'dualvar', '"1.0" (dualvar: 1)'], [ '1.10', 'dualvar', '"1.10" (dualvar: 1.1)'], [ 1.10, 'number'], [ 1.000, 'number'], [ '123 ', 'dualvar', '"123 " (dualvar: 123)' ], [ '123.040 ', 'dualvar', '"123.040 " (dualvar: 123.04)' ], [ ' 123', 'dualvar', '" 123" (dualvar: 123)' ], [ ' 123.040', 'dualvar', '" 123.040" (dualvar: 123.04)' ], [ Scalar::Util::dualvar( 42, "The Answer" ), 'dualvar', '"The Answer" (dualvar: 42)' ], [ "Nil", 'string', '"Nil"' ], [ 0123, 'number' ], [ "0199", 'dualvar', '"0199" (dualvar: 199)' ], ) { my ( $var, $type, $expected ) = @$t; my $ddp = Data::Printer::Object->new( colored => 0, show_dualvar => 'strict' ); is( $ddp->parse( \$var ), defined $expected ? $expected : "$var", "$var in strict mode is a $type" ); } # one very specific Perl dualvar TODO: { local $TODO; if ($^O eq 'MSWin32') { $TODO = q(Windows sometimes doesn't respect $! as a dualvar [strict]); } local $! = 2; like( Data::Printer::Object->new( colored => 0, show_dualvar => 'strict' )->parse( \$! ), qr/".+" \(dualvar: 2\)/, '$! is a dualvar' ); }; } sub test_dualvar_off { # one very specific Perl dualvar $! = 2; is( index( Data::Printer::Object->new( colored => 0, show_dualvar => 'off' )->parse( \$! ), 'dualvar' ), -1, 'dualvar $! shown only as string when show_dualvar is off' ); } Data-Printer-1.002001/t/013-refcount.t0000644000000000000000000000541014552015171015504 0ustar rootrootuse strict; use warnings; use Test::More tests => 17; use Data::Printer::Object; use Scalar::Util qw(weaken isweak); use B; test_scalar_refcount(); test_hash_refcount(); test_array_refcount(); exit; sub test_array_refcount { my $var = [42]; my $count; eval { $count = B::svref_2object($var)->REFCNT }; push @$var, $var; my $count2; eval { $count2 = B::svref_2object($var)->REFCNT }; ok $count2 > $count, "array: $count2 > $count"; my $ddp = Data::Printer::Object->new( colored => 0, show_refcount => 1 ); is $ddp->parse($var), '[ [0] 42, [1] var ] (refcount: 2)', 'circular array ref'; weaken($var->[-1]); my $count3; eval { $count3 = B::svref_2object($var)->REFCNT }; ok $count3 == $count, "array: $count3 == $count"; is_deeply($ddp->{_seen}, {}, 'ensure proper internal structure (array)'); is $ddp->parse($var), '[ [0] 42, [1] var (weak) ]', 'circular array ref (weakened)'; my $data2 = [[10]]; push @{$data2}, $data2->[0]; my $out = $ddp->parse( \$data2 ); my @times_matched = $out =~ /refcount:/g; is(@times_matched, 1, 'found (refcount: 2) only once') or diag $out; } sub test_hash_refcount { my $var = { foo => 42 }; my $count; eval { $count = B::svref_2object($var)->REFCNT }; $var->{self} = $var; my $count2; eval { $count2 = B::svref_2object($var)->REFCNT }; ok $count2 > $count, "hash: $count2 > $count"; my $ddp = Data::Printer::Object->new( colored => 0, show_refcount => 1 ); is ($ddp->parse($var), '{ foo 42, self var } (refcount: 2)', 'circular hash ref'); weaken($var->{self}); my $count3; eval { $count3 = B::svref_2object($var)->REFCNT }; ok $count3 == $count, "hash: $count3 == $count"; is_deeply($ddp->{_seen}, {}, 'ensure proper internal structure (hash)'); is ($ddp->parse($var), '{ foo 42, self var (weak) }', 'circular hash ref (weakened)'); } sub test_scalar_refcount { my $ddp = Data::Printer::Object->new( colored => 0, show_refcount => 1 ); my $var; my $count; eval { $count = B::svref_2object(\$var)->REFCNT }; $var = \$var; my $count2; eval { $count2 = B::svref_2object(\$var)->REFCNT }; ok $count2 > $count, "scalar: $count2 > $count"; is $ddp->parse($var), '\\ var (refcount: 2)', 'circular scalar ref'; is $ddp->parse($var), '\\ var (refcount: 2)', 'circular scalar ref (retest)'; weaken($var); my $count3; eval { $count3 = B::svref_2object(\$var)->REFCNT }; ok $count3 == $count, "scalar: $count3 == $count"; is $ddp->parse($var), '\\ var (weak)', 'circular scalar ref (weakened)'; my $ref = \$var; $ddp = Data::Printer::Object->new( colored => 0, show_refcount => 1 ); is $ddp->parse($ref), '\\ var (weak) (refcount: 2)', 'circular scalar ref (weakened)'; } Data-Printer-1.002001/t/009-array.t0000644000000000000000000001016614552015171015006 0ustar rootrootuse strict; use warnings; use Test::More tests => 18; use Data::Printer::Object; use Scalar::Util (); my $ddp = Data::Printer::Object->new( colored => 0 ); my @array; my $res = $ddp->parse(\@array); is $res, '[]', 'empty array'; push @array, 3.14, 'test', undef; $ddp = Data::Printer::Object->new( colored => 0 ); $res = $ddp->parse(\@array); is $res, '[ [0] 3.14, [1] "test", [2] undef ]', 'array with elements'; push @array, \@array; $ddp = Data::Printer::Object->new( colored => 0 ); $res = $ddp->parse(\@array); is $res, '[ [0] 3.14, [1] "test", [2] undef, [3] var ]', 'array with elements and circular ref'; $ddp = Data::Printer::Object->new( colored => 0 ); Scalar::Util::weaken($array[3]); $res = $ddp->parse(\@array); is $res, '[ [0] 3.14, [1] "test", [2] undef, [3] var (weak) ]', 'array with elements and WEAK circular ref'; pop @array; $ddp = Data::Printer::Object->new( colored => 0, indent => 3 ); $res = $ddp->parse(\@array); is $res, '[ [0] 3.14, [1] "test", [2] undef ]', 'array with indent => 3'; $ddp = Data::Printer::Object->new( colored => 0, end_separator => 1 ); $res = $ddp->parse(\@array); is $res, '[ [0] 3.14, [1] "test", [2] undef, ]', 'array with end separator'; $ddp = Data::Printer::Object->new( colored => 0, separator => '!!' ); $res = $ddp->parse(\@array); is $res, '[ [0] 3.14!! [1] "test"!! [2] undef ]', 'array with !! as separator'; $ddp = Data::Printer::Object->new( colored => 0, separator => '!!', end_separator => 1 ); $res = $ddp->parse(\@array); is $res, '[ [0] 3.14!! [1] "test"!! [2] undef!! ]', 'array with !! as separator and end separator'; $ddp = Data::Printer::Object->new( colored => 0, index => 0 ); $res = $ddp->parse(\@array); is $res, '[ 3.14, "test", undef ]', 'array with no index'; $ddp = Data::Printer::Object->new( colored => 0, index => 0, indent => 2 ); $res = $ddp->parse(\@array); is $res, '[ 3.14, "test", undef ]', 'array with no index and indent => 2'; push @array, [7,8,9]; $ddp = Data::Printer::Object->new( colored => 0 ); $res = $ddp->parse(\@array); is $res, '[ [0] 3.14, [1] "test", [2] undef, [3] [ [0] 7, [1] 8, [2] 9 ] ]', 'array with nested array'; $ddp = Data::Printer::Object->new( colored => 0, max_depth => 1 ); $res = $ddp->parse(\@array); is $res, '[ [0] 3.14, [1] "test", [2] undef, [3] [...] ]', 'array with nested array over max_depth'; @array = (300 .. 350); $ddp = Data::Printer::Object->new( colored => 0, array_max => 7 ); is( $ddp->parse(\@array), '[ [0] 300, [1] 301, [2] 302, [3] 303, [4] 304, [5] 305, [6] 306, (...skipping 44 items...) ]', 'max_array'); $ddp = Data::Printer::Object->new( colored => 0, array_max => 7, array_preserve => 'begin', array_overflow => 'AND A LOT MORE!' ); is( $ddp->parse(\@array), '[ [0] 300, [1] 301, [2] 302, [3] 303, [4] 304, [5] 305, [6] 306, AND A LOT MORE! ]', 'max_array (begin is default + overflow message)'); $ddp = Data::Printer::Object->new( colored => 0, array_max => 7, array_preserve => 'end' ); is( $ddp->parse(\@array), '[ (...skipping 44 items...) [44] 344, [45] 345, [46] 346, [47] 347, [48] 348, [49] 349, [50] 350 ]', 'max_array preserving end'); $ddp = Data::Printer::Object->new( colored => 0, array_max => 7, array_preserve => 'extremes' ); is( $ddp->parse(\@array), '[ [0] 300, [1] 301, [2] 302, (...skipping 44 items...) [47] 347, [48] 348, [49] 349, [50] 350 ]', 'max_array preserving extremes'); $ddp = Data::Printer::Object->new( colored => 0, array_max => 7, array_preserve => 'middle' ); is( $ddp->parse(\@array), '[ (...skipping 22 items...) [22] 322, [23] 323, [24] 324, [25] 325, [26] 326, [27] 327, [28] 328, (...skipping 22 items...) ]', 'max_array preserving middle'); $ddp = Data::Printer::Object->new( colored => 0, array_max => 7, array_preserve => 'none' ); is( $ddp->parse(\@array), '[ (...skipping 51 items...) ]', 'max_array preserving none'); Data-Printer-1.002001/t/005-lvalue.t0000644000000000000000000000062014552015171015146 0ustar rootrootuse strict; use warnings; use Test::More tests => 2; use Data::Printer::Object; my $scalar_lvalue = \substr( "abc", 2); my $ddp = Data::Printer::Object->new( colored => 0 ); is $ddp->parse(\$scalar_lvalue), q("c" (LVALUE)), 'LVALUE ref with show_lvalue'; $ddp = Data::Printer::Object->new( colored => 0, show_lvalue => 0 ); is $ddp->parse(\$scalar_lvalue), q("c"), 'LVALUE ref without show_lvalue'; Data-Printer-1.002001/t/001-object.t0000644000000000000000000002152514552015171015127 0ustar rootroot#### this script tests basic object instantiation (arguments validation) use strict; use warnings; use Test::More tests => 124; use Data::Printer::Object; pass 'Data::Printer::Object loaded successfully'; test_defaults(); test_customization(); test_aliases(); test_colorization(); exit; sub test_defaults { ok my $ddp = Data::Printer::Object->new, 'Data::Printer::Object created'; is $ddp->name, 'var', 'default variable name is "var"'; is $ddp->show_tainted, 1, 'show_tainted default ON'; is $ddp->show_unicode, 0, 'show_unicode default OFF'; is $ddp->show_readonly, 1, 'show_readonly default OFF'; is $ddp->show_lvalue, 1, 'show_lvalue default ON'; is $ddp->show_refcount, 0, 'show_refcount default OFF'; is $ddp->show_memsize, 0, 'show_memsize default OFF'; is $ddp->memsize_unit, 'auto', 'memsize_unit default "auto"'; is $ddp->print_escapes, 0, 'print_escapes default OFF'; is $ddp->scalar_quotes, '"', 'scalar_quotes defaults to ["]'; is $ddp->escape_chars, 'none', 'escape_chars defaults to "none"'; is $ddp->caller_info, 0, 'caller_info default OFF'; is $ddp->caller_message, 'Printing in line __LINE__ of __FILENAME__:', 'default message'; is $ddp->string_max, 4096, 'string_max defaults to 4096'; is $ddp->string_preserve, 'begin', 'string_preserve defaults to "begin"'; is( $ddp->string_overflow, '(...skipping __SKIPPED__ chars...)', 'string_overflow' ); is $ddp->array_max, 100, 'array_max default to 100'; is $ddp->array_preserve, 'begin', 'array_preserve defaults to "begin"'; is $ddp->array_overflow, '(...skipping __SKIPPED__ items...)', 'array_overflow'; is $ddp->hash_max, 100, 'hash_max default 100'; is $ddp->hash_preserve, 'begin', 'hash_preserve defaults to "begin"'; is $ddp->hash_overflow, '(...skipping __SKIPPED__ keys...)', 'hash_overflow'; is $ddp->unicode_charnames, 0, 'unicode_charnames defaults OFF'; is $ddp->colored, 'auto', 'colored defaults to "auto"'; my $theme = $ddp->theme; is $theme->name, 'Material', 'default theme'; is $ddp->show_weak, 1, 'show_weak default ON'; is $ddp->max_depth, 0, 'max_depth defaults to infinite depth'; is $ddp->index, 1, 'index default ON'; is $ddp->separator, ',', 'separator is ","'; is $ddp->end_separator, 0, 'end_separator default OFF'; is $ddp->class_method, '_data_printer', 'class_method'; my $class_opts = $ddp->class; isa_ok $class_opts, 'Data::Printer::Object::ClassOptions'; is $ddp->hash_separator, ' ', 'hash_separator is 3 spaces'; is $ddp->align_hash, 1, 'align_hash default ON'; is $ddp->sort_keys, 1, 'sort_keys default ON'; is $ddp->quote_keys, 'auto', 'quote_keys defaults to "auto"'; is $ddp->deparse, 0, 'deparse default OFF'; is $ddp->show_dualvar, 'lax', 'dualvar default LAX'; } sub test_customization { my %custom = ( name => 'something', show_tainted => 0, show_unicode => 1, show_readonly => 0, show_lvalue => 0, show_refcount => 1, show_dualvar => 'strict', show_memsize => 1, memsize_unit => 'k', print_escapes => 1, scalar_quotes => q('), escape_chars => 'all', caller_info => 1, caller_message => 'meep!', string_max => 3, string_preserve => 'end', string_overflow => 'oh, noes! __SKIPPED__', array_max => 5, array_preserve => 'middle', array_overflow => 'hey!', hash_max => 7, hash_preserve => 'extremes', hash_overflow => 'YAY!', unicode_charnames => 1, colored => 0, theme => 'Monokai', show_weak => 0, max_depth => 4, index => 0, separator => '::', end_separator => 1, class_method => '_foo', class => { }, hash_separator => 'oo', align_hash => 0, sort_keys => 0, quote_keys => 0, deparse => 1, ); run_customization_tests(1, %custom); # as hash run_customization_tests(2, \%custom); # as hashref } sub run_customization_tests { my $pass = shift; ok my $ddp = Data::Printer::Object->new(@_); is $ddp->name, 'something', "custom variable name (pass: $pass)"; is $ddp->show_tainted, 0, "custom show_tainted (pass: $pass)"; is $ddp->show_unicode, 1, "custom show_unicode (pass: $pass)"; is $ddp->show_readonly, 0, "custom show_readonly (pass: $pass)"; is $ddp->show_lvalue, 0, "custom show_lvalue (pass: $pass)"; is $ddp->show_refcount, 1, "custom show_refcount (pass: $pass)"; is $ddp->show_dualvar, 'strict', "custom show_dualvar (pass: $pass)"; is $ddp->show_memsize, 1, "custom show_memsize (pass: $pass)"; is $ddp->memsize_unit, 'k', "custom memsize_unit (pass: $pass)"; is $ddp->print_escapes, 1, "custom print_escapes (pass: $pass)"; is $ddp->scalar_quotes, q('), "custom scalar_quotes (pass: $pass)"; is $ddp->escape_chars, 'all', "custom escape_chars (pass: $pass)"; is $ddp->caller_info, 1, "custom caller_info (pass: $pass)"; is $ddp->caller_message, 'meep!', "custom message (pass: $pass)"; is $ddp->string_max, 3, "custom string_max (pass: $pass)"; is $ddp->string_preserve, 'end', "custom string_preserve (pass: $pass)"; is( $ddp->string_overflow, 'oh, noes! __SKIPPED__', "custom string_overflow"); is $ddp->array_max, 5, "custom array_max (pass: $pass)"; is $ddp->array_preserve, 'middle', "custom array_preserve (pass: $pass)"; is $ddp->array_overflow, 'hey!', "custom array_overflow (pass: $pass)"; is $ddp->hash_max, 7, "custom hash_max (pass: $pass)"; is $ddp->hash_preserve, 'extremes', "custom hash_preserve (pass: $pass)"; is $ddp->hash_overflow, 'YAY!', "custom hash_overflow (pass: $pass)"; is $ddp->unicode_charnames, 1, "custom unicode_charnames (pass: $pass)"; is $ddp->colored, 0, "custom colored (pass: $pass)"; my $theme = $ddp->theme; is $theme->name, 'Monokai', "custom theme (pass: $pass)"; is $ddp->show_weak, 0, "custom show_weak (pass: $pass)"; is $ddp->max_depth, 4, "custom max_depth (pass: $pass)"; is $ddp->index, 0, "custom index (pass: $pass)"; is $ddp->separator, '::', "custom separator (pass: $pass)"; is $ddp->end_separator, 1, "custom end_separator (pass: $pass)"; is $ddp->class_method, '_foo', "custom class_method (pass: $pass)"; my $class_opts = $ddp->class; isa_ok $class_opts, 'Data::Printer::Object::ClassOptions'; is $ddp->hash_separator, 'oo', "custom hash_separator (pass: $pass)"; is $ddp->align_hash, 0, "custom align_hash (pass: $pass)"; is $ddp->sort_keys, 0, "custom sort_keys (pass: $pass)"; is $ddp->quote_keys, 0, "custom quote_keys (pass: $pass)"; is $ddp->deparse, 1, "custom deparse (pass: $pass)"; } sub test_aliases { my $ddp = Data::Printer::Object->new( as => 'this is a test' ); is $ddp->caller_info, 1, '"as" will set caller_info'; is $ddp->caller_message, 'this is a test', '"as" will set caller_message'; } sub test_colorization { my $ddp = Data::Printer::Object->new( colored => 1 ); is $ddp->maybe_colorize('x'), 'x', 'no color unless tag is provided'; is $ddp->maybe_colorize('x', 'invalid tag'), 'x', 'no color unless valid tag'; my $colored = $ddp->maybe_colorize('x', 'invalid tag', "\e[0;38;2m"); if ($colored eq "\e[0;38;2mx\e[m") { pass 'fallback to default color'; } else { $colored =~ s{\e}{\\e}gsm; my $sgr = $ddp->theme->sgr_color_for('invalid tag'); my $parsed = $ddp->theme->_parse_color("\e[0;38;2m"); $parsed =~ s{\e}{\\e}gsm if defined $parsed; fail 'fallback to default color:' . ' got "' . $colored . '" expected "\e[0;38;2mx\e[m"' . ' theme name: ' . $ddp->theme->name . ' color level: ' . $ddp->{_output_color_level} . ' sgr_color_for "invalid tag": ' . (defined $sgr ? $sgr : 'undef') . ' parsed default: ' . (defined $parsed ? $parsed : 'undef') ; ; } $ddp = Data::Printer::Object->new( colored => 1, colors => { 'invalid tag' => '' } ); $colored = $ddp->maybe_colorize('x', 'invalid tag', "\e[0;38;2m"); if ($colored eq 'x') { pass 'color has fallback but user declined'; } else { $colored =~ s{\e}{\\e}gsm; my $sgr = $ddp->theme->sgr_color_for('invalid tag'); my $parsed = $ddp->theme->_parse_color("\e[0;38;2m"); $parsed =~ s{\e}{\\e}gsm if defined $parsed; fail 'fallback to default color:' . ' got "' . $colored . '" expected "\e[0;38;2mx\e[m"' . ' theme name: ' . $ddp->theme->name . ' color level: ' . $ddp->{_output_color_level} . ' sgr_color_for "invalid tag": ' . (defined $sgr ? $sgr : 'undef') . ' parsed default: ' . (defined $parsed ? $parsed : 'undef') ; ; } } Data-Printer-1.002001/t/010-hashes.t0000644000000000000000000001005114552015171015124 0ustar rootrootuse strict; use warnings; use Test::More tests => 16; use Data::Printer::Object; my $ddp = Data::Printer::Object->new( colored => 0 ); my %hash = (); is($ddp->parse(\%hash), '{}', 'empty hash'); undef %hash; $ddp = Data::Printer::Object->new( colored => 0 ); is($ddp->parse(\%hash), '{}', 'undefined hash'); # the "%hash = 1" code below is wrong and issues # an "odd number of elements in hash assignment" # warning message. But since it's just a warning # (meaning the code will still run even under strictness) # we make sure to test everything will be alright. { no warnings 'misc'; %hash = 1; } $ddp = Data::Printer::Object->new( colored => 0 ); is( $ddp->parse(\%hash), '{ 1 undef }', 'evil hash of doom'); %hash = ( foo => 33, bar => 99 ); $ddp = Data::Printer::Object->new( colored => 0 ); is( $ddp->parse(\%hash), '{ bar 99, foo 33 }', 'simple hash'); $ddp = Data::Printer::Object->new( colored => 0, hash_separator => ': ' ); is( $ddp->parse(\%hash), '{ bar: 99, foo: 33 }', 'simple hash with custom separator'); $ddp = Data::Printer::Object->new( colored => 0 ); my $scalar = 4.2; $hash{$scalar} = \$scalar; $hash{hash} = { 1 => 2, 3 => { 4 => 5 }, 10 => 11 }; $hash{something} = [ 3 .. 5 ]; $hash{zelda} = 'moo'; is( $ddp->parse(\%hash), '{ 4.2 \\ 4.2, bar 99, foo 33, hash { 1 2, 3 { 4 5 }, 10 11 }, something [ [0] 3, [1] 4, [2] 5 ], zelda "moo" }', 'nested hash'); $ddp = Data::Printer::Object->new( colored => 0, align_hash => 0 ); is( $ddp->parse(\%hash), '{ 4.2 \\ 4.2, bar 99, foo 33, hash { 1 2, 3 { 4 5 }, 10 11 }, something [ [0] 3, [1] 4, [2] 5 ], zelda "moo" }', 'nested hash, unaligned'); $ddp = Data::Printer::Object->new( colored => 0 ); my $hash_ref = { c => 3 }; %hash = ( a => 1, b => \$hash_ref, d => 4 ); is( $ddp->parse(\%hash), '{ a 1, b \\ { c 3 }, d 4 }', 'reference of a hash reference'); $ddp = Data::Printer::Object->new( colored => 0 ); is( $ddp->parse(\\$hash_ref), '\\ { c 3 }', 'simple ref to hash ref' ); %hash = ( 'undef' => undef, foo => { 'meep' => undef }, zed => 26 ); $ddp = Data::Printer::Object->new( colored => 0 ); is( $ddp->parse(\%hash), '{ foo { meep undef }, undef undef, zed 26 }', 'hash with undefs' ); $ddp = Data::Printer::Object->new( colored => 0, hash_max => 6 ); my $i = 10; %hash = map { $_ => $i++ } split //, 'abcdefghijklmnopqrstuvwxyz'; is($ddp->parse(\%hash), '{ a 10, b 11, c 12, d 13, e 14, f 15, (...skipping 20 keys...) }', 'hash_max reached'); $ddp = Data::Printer::Object->new( colored => 0, hash_max => 6, hash_preserve => 'begin' ); is($ddp->parse(\%hash), '{ a 10, b 11, c 12, d 13, e 14, f 15, (...skipping 20 keys...) }', 'hash_max reached, preserve begin is the default'); $ddp = Data::Printer::Object->new( colored => 0, hash_max => 6, hash_preserve => 'end' ); is($ddp->parse(\%hash), '{ (...skipping 20 keys...) u 30, v 31, w 32, x 33, y 34, z 35 }', 'hash_max reached, preserving end'); $ddp = Data::Printer::Object->new( colored => 0, hash_max => 6, hash_preserve => 'middle' ); is($ddp->parse(\%hash), '{ (...skipping 9 keys...) j 19, k 20, l 21, m 22, n 23, o 24, (...skipping 11 keys...) }', 'hash_max reached, preserving middle'); $ddp = Data::Printer::Object->new( colored => 0, hash_max => 6, hash_preserve => 'extremes' ); is($ddp->parse(\%hash), '{ a 10, b 11, c 12, (...skipping 20 keys...) x 33, y 34, z 35 }', 'hash_max reached, preserving extremes'); $ddp = Data::Printer::Object->new( colored => 0, hash_max => 6, hash_preserve => 'none' ); is($ddp->parse(\%hash), '{ (...skipping 26 keys...) }', 'hash_max reached, preserving none'); Data-Printer-1.002001/t/016-merge_options.t0000644000000000000000000000475114552015171016543 0ustar rootrootuse strict; use warnings; use Test::More tests => 12; use Data::Printer::Config; is_deeply( Data::Printer::Config::_merge_options(undef, { foo => 42, bar => 27 }), { foo => 42, bar => 27 }, 'merge undef and hash' ); is_deeply( Data::Printer::Config::_merge_options(undef,[ foo => 42, bar => 27 ]), [ 'foo', 42, 'bar',27 ], 'merge undef and array' ); is_deeply( Data::Printer::Config::_merge_options({}, { foo => 42, bar => 27 }), { foo => 42, bar => 27 }, 'merge hash and hash' ); is_deeply( Data::Printer::Config::_merge_options([],[ foo => 42, bar => 27 ]), [ 'foo', 42, 'bar',27 ], 'merge array and array' ); is_deeply( Data::Printer::Config::_merge_options([], { foo => 42, bar => 27 }), { foo => 42, bar => 27 }, 'merge array and hash' ); is_deeply( Data::Printer::Config::_merge_options({},[ foo => 42, bar => 27 ]), [ 'foo', 42, 'bar',27 ], 'merge hash and array' ); is_deeply( Data::Printer::Config::_merge_options( { foo => 42, bar => 27 }, { foo => 666 }, ), { foo => 666, bar => 27 }, 'merge two hashes' ); is_deeply( Data::Printer::Config::_merge_options( { foo => { bar => 42, baz => 27 } }, { foo => { bar => 666 } }, ), { foo => { bar => 666, baz => 27 } }, 'merge two hashes with recursion' ); my $old = { x => [1], foo => { bar => 42, baz => { a => 1, b => 2 } } }; my $new = { x => [9,8], bar => 10, foo => { meep => 1, baz => { b => 4, c => q(a) } } }; my $merged = Data::Printer::Config::_merge_options($old, $new); is_deeply( $merged, { x => [9,8], bar => 10, foo => { bar => 42, meep => 1, baz => { a => 1, b => 4, c => q(a) } } }, 'merge two deep hash variables' ); $merged->{foo}{baz} = undef; # <-- are we really a new value or a ref? let's check! is_deeply( $old, { x => [1], foo => { bar => 42, baz => { a => 1, b => 2 } } }, 'old variable was not changed' ); is_deeply( $new, { x => [9,8], bar => 10, foo => { meep => 1, baz => { b => 4, c => q(a) } } }, 'new variable was not changed' ); is_deeply( Data::Printer::Config::_merge_options( { foo => 1, bar => 2, baz => { meep => 666, moop => [444], bla => [3,2,1] } }, { foo => 42, baz => { otherkey => 42, moop => [44,3] } } ), { foo => 42, bar => 2, baz => { meep => 666, moop => [44,3], otherkey => 42, bla => [3,2,1] } }, 'merged complex data structures' ); Data-Printer-1.002001/t/020-return_value.t0000644000000000000000000001240314552015171016370 0ustar rootrootuse strict; use warnings; use Test::More; BEGIN { use Data::Printer::Config; no warnings 'redefine'; *Data::Printer::Config::load_rc_file = sub { {} }; }; use Data::Printer colored => 0; if (!eval { require Capture::Tiny; 1; }) { plan skip_all => 'Capture::Tiny not found'; } else { plan tests => 32; } test_return_value_dump_on_scalar(); test_return_value_void_on_scalar(); test_return_value_pass_on_hashes(); test_return_value_pass_on_arrays(); test_return_value_pass_on_scalar(); test_method_chaining(); exit; sub test_return_value_dump_on_scalar { my $string = 'All your base are belong to us.'; my $return = 1; my ($stdout, $stderr) = Capture::Tiny::capture( sub { $return = p $string, return_value => 'dump'; 1; }); is $stdout, '', 'on dump STDOUT should be empty after p() (scalar, scalar)'; is $stderr, '', 'on dump STDERR also empty (scalar, scalar)'; is $return, qq("$string") , 'on dump returned variable (scalar scalar)'; ($stdout, $stderr) = Capture::Tiny::capture( sub { p $string, return_value => 'dump'; 1; }); is $stdout, '', 'on dump (no return) STDOUT should be empty after p() (scalar, scalar)'; is $stderr, qq("$string"\n), 'on dump (no return) STDERR (scalar, scalar)'; } sub test_return_value_void_on_scalar { my $string = 'All your base are belong to us.'; my $return = 1; my ($stdout, $stderr) = Capture::Tiny::capture( sub { $return = p $string, return_value => 'void'; }); is $stdout, '', 'STDOUT should be empty after p() (scalar, scalar)'; is $stderr, qq("$string"\n), 'pass-through STDERR (scalar, scalar)'; is $return, undef, 'pass-through return (scalar scalar)'; } sub test_return_value_pass_on_hashes { my %foo = ( answer => 42, question => 24 ); my $expected = <<'EOT'; { answer 42, question 24 } EOT my (%return_list, $return_scalar); my ($stdout, $stderr) = Capture::Tiny::capture( sub { %return_list = p %foo; }); is $stdout, '', 'STDOUT should be empty after p() (hash, list)'; is $stderr, $expected, 'pass-through STDERR (hash, list)'; is_deeply \%return_list, \%foo, 'pass-through return (hash list)'; ($stdout, $stderr) = Capture::Tiny::capture( sub { $return_scalar = p %foo; }); is $stdout, '', 'STDOUT should be empty after p() (hash, scalar)'; is $stderr, $expected, 'pass-through STDERR (hash, scalar)'; is $return_scalar, scalar %foo, 'pass-through return (hash scalar)'; } sub test_return_value_pass_on_arrays { my @return_list; my $return_scalar; my @foo = qw(foo bar); my $expected = <<'EOT'; [ [0] "foo", [1] "bar" ] EOT my ($stdout, $stderr) = Capture::Tiny::capture( sub { @return_list = p @foo; }); is $stdout, '', 'STDOUT should be empty after p() (array, list)'; is $stderr, $expected, 'pass-through STDERR (array, list)'; is_deeply \@return_list, \@foo, 'pass-through return (array list)'; ($stdout, $stderr) = Capture::Tiny::capture( sub { $return_scalar = p @foo; }); is $stdout, '', 'STDOUT should be empty after p() (array, scalar)'; is $stderr, $expected, 'pass-through STDERR (array, scalar)'; is $return_scalar, 2, 'pass-through return (array scalar)'; } sub test_return_value_pass_on_scalar { my $foo = 'how much wood would a woodchuck chuck if a woodchuck could chuck wood?'; my $expected = qq{"$foo"$/}; my $return_scalar; my @return_list; my ($stdout, $stderr) = Capture::Tiny::capture( sub { @return_list = p $foo; }); is $stdout, '', 'STDOUT should be empty after p() (scalar, list)'; is $stderr, $expected, 'pass-through STDERR (scalar, list)'; is_deeply \@return_list, [ $foo ], 'pass-through return (scalar list)'; ($stdout, $stderr) = Capture::Tiny::capture( sub { $return_scalar = p $foo; }); is $stdout, '', 'STDOUT should be empty after p() (scalar, scalar)'; is $stderr, $expected, 'pass-through STDERR (scalar, scalar)'; is $return_scalar, $foo, 'pass-through return (scalar scalar)'; } sub test_method_chaining { package Foo; sub new { bless {}, shift } sub bar { $_[0]->{meep}++; $_[0] } sub baz { $_[0]->{meep}++; $_[0] } sub biff { $_[0]->{meep}++; $_[0] } package main; my $expected =<<'EOT'; Foo { public methods (4): bar, baz, biff, new private methods (0) internals: { meep 2 } } EOT my $foo = Foo->new; my ($stdout, $stderr) = Capture::Tiny::capture( sub { (Data::Printer::p $foo->bar->baz)->biff; }); is $stdout, '', 'STDOUT should be empty after p() (object, direct)'; # remove warning line before test: $stderr =~ s/\A\[Data::Printer\] MRO::Compat not found.+\n//m; is $stderr, $expected, 'pass-through STDERR (object, direct)'; is $foo->{meep}, 3, 'pass-through return (object, direct)'; # once again, but this time in indirect object notation $foo = Foo->new; ($stdout, $stderr) = Capture::Tiny::capture( sub { $foo->bar->baz->Data::Printer::p->biff; }); is $stdout, '', 'STDOUT should be empty after p() (object, indirect)'; is $stderr, $expected, 'pass-through STDERR (object, indirect)'; is $foo->{meep}, 3, 'pass-through return (object, indirect)'; } Data-Printer-1.002001/t/000.2-warn.t0000644000000000000000000000061214552015171014761 0ustar rootrootuse strict; use warnings; use Test::More tests => 1; use Data::Printer::Common; sub warnings(&) { my $code = shift; my $got; local $SIG{__WARN__} = sub { $got = shift; }; $code->(); return $got } my $got = warnings { Data::Printer::Common::_warn(undef, "HA!") }; is( $got, "[Data::Printer] HA! at t/000.2-warn.t line 16.\n", 'warn with proper caller/line' ); Data-Printer-1.002001/t/100-filter_datetime.t0000644000000000000000000002201214552015171017012 0ustar rootrootuse strict; use warnings; use Test::More tests => 21; use Data::Printer::Object; my $has_timepiece; BEGIN { # Time::Piece is only able to overload # localtime() if it's loaded during compile-time $has_timepiece = !! eval 'use Time::Piece; 1'; }; test_time_piece(); test_datetime(); test_datetime_timezone(); test_datetime_incomplete(); test_datetime_tiny(); test_date_tiny(); test_date_calc_object(); test_date_handler(); test_date_simple(); test_mojo_date(); test_date_manip(); test_class_date(); test_time_seconds(); test_time_moment(); sub test_time_piece { SKIP: { my $how_many = 3; skip 'Time::Piece not available', $how_many unless $has_timepiece; my $t = localtime 1234567890; skip 'localtime not returning an object', $how_many unless ref $t and ref $t eq 'Time::Piece'; # we can't use a literal in our tests because of # timezone and epoch issues my $time_str = $t->cdate; my $ddp = Data::Printer::Object->new( colored => 0, filters => ['DateTime'], ); is ( $ddp->parse($t), $time_str, 'Time::Piece' ); $ddp = Data::Printer::Object->new( colored => 0, filters => ['DateTime'], filter_datetime => { show_class_name => 1 } ); is ( $ddp->parse($t), "$time_str (Time::Piece)", 'Time::Piece with class name' ); $ddp = Data::Printer::Object->new( colored => 0, filters => ['DateTime', { HASH => sub { 'a hash!' } }], ); is ( $ddp->parse([$t, {}]), "[ [0] $time_str, [1] a hash! ]", 'inline and class filters together (Time::Piece)' ); }; } sub test_datetime { SKIP: { skip 'DateTime not available', 3 unless eval 'use DateTime; 1'; my $d1 = DateTime->new( year => 1981, month => 9, day => 29, time_zone => 'floating', ); my $d2 = DateTime->new( year => 1984, month => 11, day => 15, time_zone => 'floating', ); my $ddp = Data::Printer::Object->new( colored => 0, filters => ['DateTime'] ); is( $ddp->parse($d1), '1981-09-29T00:00:00 [floating]', 'DateTime' ); $ddp = Data::Printer::Object->new( colored => 0, filters => ['DateTime'], filter_datetime => { show_timezone => 0 }, ); is( $ddp->parse($d1), '1981-09-29T00:00:00', 'DateTime without TZ data' ); my $diff; skip 'DateTime::Duration not available', 1 unless eval { $diff = $d2 - $d1; $diff && $diff->isa('DateTime::Duration') }; $ddp = Data::Printer::Object->new( colored => 0, filters => ['DateTime'], ); is( $ddp->parse($diff), '3y 1m 16d 0h 0m 0s', 'DateTime::Duration' ); }; } sub test_datetime_timezone { SKIP: { my $d; skip 'DateTime::TimeZone not found', 1 unless eval 'use DateTime::Duration; use DateTime::TimeZone; 1'; eval { $d = DateTime::TimeZone->new( name => 'America/Sao_Paulo' ) }; skip 'Error creating DateTime::TimeZone object', 1 unless $d; my $ddp = Data::Printer::Object->new( colored => 0, filters => ['DateTime'], ); is( $ddp->parse($d), 'America/Sao_Paulo', 'DateTime::TimeZone' ); }; } sub test_datetime_incomplete { SKIP: { skip 'DateTime::Incomplete not found', 1, unless eval 'use DateTime::Incomplete; 1'; my $d = DateTime::Incomplete->new( year => 2018 ); my $ddp = Data::Printer::Object->new( colored => 0, filters => ['DateTime'], ); is( $ddp->parse($d), '2018-xx-xxTxx:xx:xx', 'DateTime::Incomplete' ); }; } sub test_datetime_tiny { SKIP: { skip 'DateTime::Tiny not found', 1, unless eval 'use DateTime::Tiny; 1'; my $d = DateTime::Tiny->new( year => 2003, month => 3, day => 11 ); my $ddp = Data::Printer::Object->new( colored => 0, filters => ['DateTime'], ); is( $ddp->parse($d), '2003-03-11T00:00:00', 'DateTime::Tiny' ); }; } sub test_date_tiny { SKIP: { skip 'Date::Tiny not found', 1, unless eval 'use Date::Tiny; 1'; my $d = Date::Tiny->new( year => 2003, month => 3, day => 11 ); my $ddp = Data::Printer::Object->new( colored => 0, filters => ['DateTime'], ); is( $ddp->parse($d), '2003-03-11', 'Date::Tiny' ); }; } sub test_date_calc_object { SKIP: { skip 'Date::Calc::Object not found', 1, unless eval 'use Date::Calc::Object; 1'; my $d = Date::Calc::Object->localtime( 1234567890 ); my $ddp = Data::Printer::Object->new( colored => 0, filters => ['DateTime'], ); my $string = $d->string(2); # not sure when the epoch is :X is( $ddp->parse($d), $string, 'Date::Calc::Object' ); }; } sub test_date_handler { SKIP: { skip 'Date::Handler not found', 2, unless eval 'use Date::Handler; 1'; my $d = Date::Handler->new( date => 1234567890 ); my $string = "$d"; # not sure when the epoch is :X my $ddp = Data::Printer::Object->new( colored => 0, filters => ['DateTime'], ); is( $ddp->parse($d), $string, 'Date::Handler' ); my $diff; skip 'Date::Handler::Delta not found', 1 unless eval { require Date::Handler::Delta; $diff = Date::Handler->new( date => 1234567893 ) - $d; $diff && $diff->isa('Date::Handler::Delta') }; $string = $diff->AsScalar; is( $ddp->parse($diff), $string, 'Date::Handler::Delta' ); }; } sub test_date_simple { SKIP: { skip 'Date::Simple not found', 1, unless eval 'use Date::Simple; 1'; my $d = Date::Simple->new('2018-05-19'); my $ddp = Data::Printer::Object->new( colored => 0, filters => ['DateTime'], ); is( $ddp->parse($d), '2018-05-19', 'Date::Simple' ); }; } sub test_mojo_date { SKIP: { skip 'Mojo::Date not found', 1 unless eval 'use Mojo::Date; 1'; my $d = Mojo::Date->new('Sun, 06 Nov 1994 08:49:37 GMT'); skip 'Mojo::Date is too old', 1 unless $d->can('to_datetime'); my $ddp = Data::Printer::Object->new( colored => 0, filters => ['DateTime'], ); is( $ddp->parse($d), '1994-11-06T08:49:37Z', 'Mojo::Date' ); }; } sub test_date_manip { SKIP: { skip 'Date::Manip::Date not found', 1, unless eval 'use Date::Manip::Date; 1'; my $ddp = Data::Printer::Object->new( colored => 0, filters => ['DateTime'], ); my $d; skip 'Date::Manip too old, skipping test', 1 unless eval { $d = Date::Manip::Date->new('2000-01-21-12:00:00') }; is( $ddp->parse(\$d), '2000012112:00:00', 'Date::Manip::Obj' ); }; } sub test_class_date { SKIP: { skip 'Class::Date not found', 2, unless eval 'use Class::Date; 1'; my $d = Class::Date::date({ year => 2003, month => 3, day => 11 }, 'GMT'); my $ddp = Data::Printer::Object->new( colored => 0, filters => ['DateTime'], ); my $parsed = $ddp->parse($d); ok( $parsed eq '2003-03-11 00:00:00 [GMT]' || $parsed eq '2003-03-11 00:00:00 [UTC]' # some BSDs name GTM as UTC , "Class::Date is '$parsed'" ); skip 'Class::Date::Rel not found', 1 unless eval 'use Class::Date::Rel; 1'; my $reldate = Class::Date::Rel->new( "3Y 1M 3D 6h 2m 4s" ); is( $ddp->parse($reldate), '3Y 1M 3D 6h 2m 4s', 'Class::Date::Rel' ); }; } sub test_time_seconds { SKIP: { skip 'Time:Seconds not found', 2, unless eval 'use Time::Seconds; 1'; my $ddp = Data::Printer::Object->new( colored => 0, filters => ['DateTime'], ); my $d = Time::Seconds->new(); is($ddp->parse($d), '0 seconds', "Time::Seconds"); { no warnings 'redefine'; *Time::Seconds::can = sub { 0 } } my $has_original_can = Time::Seconds::can('new'); skip 'unable to override "can"', 1 if $has_original_can; is($ddp->parse($d), '0 seconds', "Time::Seconds (legacy)"); }; } sub test_time_moment { SKIP: { skip 'Time:Moment not found', 1, unless eval 'use Time::Moment; 1'; my $d = Time::Moment->new( year => 2012, month => 12, day => 24, hour => 15, minute => 30, second => 45, offset => 0, ); my $ddp = Data::Printer::Object->new( colored => 0, filters => ['DateTime'], ); is($ddp->parse($d), '2012-12-24T15:30:45Z', "Time::Moment"); }; } Data-Printer-1.002001/t/019-output.t0000644000000000000000000000461114552015171015227 0ustar rootrootuse strict; use warnings; use Test::More; BEGIN { use Data::Printer::Config; no warnings 'redefine'; *Data::Printer::Config::load_rc_file = sub { {} }; }; use Data::Printer colored => 0, return_value => 'void'; use Fcntl; use File::Temp qw( :seekable tempfile ); if (!eval { require Capture::Tiny; 1; }) { plan skip_all => 'Capture::Tiny not found'; } else { plan tests => 13; } #===================== # testing OUTPUT #===================== my $item = 42; my ($stdout, $stderr) = Capture::Tiny::capture( sub { p $item, output => *STDOUT; }); is $stdout, $item . $/, 'redirected output to STDOUT'; is $stderr, '', 'redirecting to STDOUT leaves STDERR empty'; #===================== # testing OUTPUT ref #===================== $item++; # just to make sure there won't be any sort of cache ($stdout, $stderr) = Capture::Tiny::capture( sub { p $item, output => \*STDOUT; }); is $stdout, $item . $/, 'redirected output to a STDOUT ref'; is $stderr, '', 'redirecting to STDOUT ref leaves STDERR empty'; #===================== # testing scalar ref #===================== $item++; my $destination; ($stdout, $stderr) = Capture::Tiny::capture( sub { p $item, output => \$destination; }); is $destination, $item . $/, 'redirected output to a scalar ref'; is $stdout, '', 'redirecting to scalar ref leaver STDOUT empty'; is $stderr, '', 'redirecting to scalar ref leaves STDERR empty'; #===================== # testing file handle #===================== $item++; my $fh = tempfile; ($stdout, $stderr) = Capture::Tiny::capture( sub { p $item, output => $fh; }); seek( $fh, 0, SEEK_SET ); my $buffer = do { local $/; <$fh> }; is $buffer, $item . $/, 'redirected output to a file handle'; is $stdout, '', 'redirecting to file handle leaves STDOUT empty'; is $stderr, '', 'redirecting to file handle leaves STDERR empty'; #==================== # testing file name #==================== $item++; my $filename; ($fh, $filename) = tempfile; ($stdout, $stderr) = Capture::Tiny::capture( sub { p $item, output => $filename, multiline => 0; }); seek( $fh, 0, SEEK_SET ); $buffer = do { local $/; <$fh> }; like $buffer, qr{\A$item\s*\z}, 'redirected output to a filename'; is $stdout , '' , 'redirecting to filename leaves STDOUT empty'; is $stderr , '' , 'redirecting to filename leaves STDERR empty'; Data-Printer-1.002001/t/104-filter_web.t0000644000000000000000000003513214552015171016006 0ustar rootrootuse strict; use warnings; use Test::More tests => 21; use Data::Printer::Object; test_json(); test_cookies(); test_http_request(); test_http_response(); exit; sub test_http_request { SKIP: { my $error = !eval { require HTTP::Request; 1 }; skip 'HTTP::Request not available', 1 if $error; my $r = HTTP::Request->new( 'POST', 'http://www.example.com/ddp', [ 'Content-Type' => 'application/json; charset=UTF-8', 'Cache-Control' => 'no-cache, must-revalidate', ], '{"foo":"bar","baz":42}' ); skip 'HTTP::Headers is too old', 1 unless $r->headers->can('flatten'); my $ddp = Data::Printer::Object->new( colored => 0, filters => ['Web'], ); is( $ddp->parse($r), 'POST http://www.example.com/ddp { headers: { Cache-Control "no-cache, must-revalidate", Content-Type "application/json; charset=UTF-8" } content: {"foo":"bar","baz":42} }', 'HTTP::Request' ); }; } sub test_http_response { SKIP: { my $error = !eval { require HTTP::Response; 1 }; skip 'HTTP::Response not available', 1 if $error; my $r = HTTP::Response->new( '200', 'OK', [ 'Content-Type' => 'application/json; charset=UTF-8', 'Cache-Control' => 'no-cache, must-revalidate', ], '{"foo":"bar","baz":42}' ); skip 'HTTP::Headers is too old', 1 unless $r->headers->can('flatten'); $r->previous( HTTP::Response->new( '302', 'Moved Temporarily',[ 'Location' => 'https://example.com/original' ] ) ); my $ddp = Data::Printer::Object->new( colored => 0, filters => ['Web'], ); is( $ddp->parse($r), "\x{e2}\x{a4}\x{bf}" . ' 302 Moved Temporarily (https://example.com/original) 200 OK { headers: { Cache-Control "no-cache, must-revalidate", Content-Type "application/json; charset=UTF-8" } content: {"foo":"bar","baz":42} }', 'HTTP::Response' ); }; } sub test_cookies { test_mojo_cookie(); test_dancer_cookie(); test_dancer2_cookie(); } sub test_dancer_cookie { SKIP: { my $error = !eval { require Dancer::Cookie; 1 }; skip 'Dancer::Cookie not available', 1 if $error; my $c = Dancer::Cookie->new( name => 'ddp', value => 'test', expires => time, domain => 'localhost', path => '/test', secure => 1, http_only => 1, ); my $ddp = Data::Printer::Object->new( colored => 0, filters => ['Web'], ); like( $ddp->parse($c), qr{ddp=test; expires=(?:[^;]+); domain=localhost; path=/test; secure; http-only \(Dancer::Cookie\)}, 'Dancer::Cookie parsed correctly' ); }; } sub test_dancer2_cookie { SKIP: { my $error = !eval { require Dancer2::Core::Cookie; 1 }; skip 'Dancer2::Core::Cookie not available', 1 if $error; my $c = Dancer2::Core::Cookie->new( name => 'ddp', value => 'test', expires => time, domain => 'localhost', path => '/test', secure => 1, http_only => 1, ); my $ddp = Data::Printer::Object->new( colored => 0, filters => ['Web'], ); like( $ddp->parse($c), qr{ddp=test; expires=(?:[^;]+); domain=localhost; path=/test; secure; http-only \(Dancer2::Core::Cookie\)}, 'Dancer2::Core::Cookie parsed correctly' ); }; } sub test_mojo_cookie { SKIP: { my $error = !eval { require Mojo::Cookie::Response; 1 }; skip 'Mojo::Cookie::Response not available', 1 if $error; my $c = Mojo::Cookie::Response->new; $c->name('ddp'); $c->value('test'); $c->expires( time ); $c->httponly(1); $c->max_age(60); $c->path('/test'); $c->secure(1); $c->host_only(0) if $c->can('host_only'); $c->domain('localhost'); my $ddp = Data::Printer::Object->new( colored => 0, filters => ['Web'], ); like( $ddp->parse($c), qr{ddp=test; expires=.+?; domain=localhost; path=/test; secure; http-only; max-age=60 \(Mojo::Cookie\)}, 'Mojo::Cookie parsed correctly' ); }; } sub test_json { my $json = '{"alpha":true,"bravo":false,"charlie":true,"delta":false}'; my $expected = '{ alpha:true, bravo:false, charlie:true, delta:false }'; test_json_pp($json, $expected); test_json_xs($json, $expected); test_json_json($json, $expected); test_json_any($json, $expected); test_json_maybexs($json, $expected); test_json_dwiw($json, $expected); test_json_parser($json, $expected); test_json_sl($json, $expected); test_json_mojo($json, $expected); test_json_pegex($json, $expected); test_json_cpanel($json, $expected); test_json_tiny($json, $expected); test_json_typist(); } sub test_json_typist { SKIP: { my $error = !eval { require JSON::Typist; require JSON; 1 }; skip 'JSON::Typist (or JSON, or both) not available', 1 if $error; diag('filter for JSON::Typist ' . $JSON::Typist::VERSION); my $ddp = Data::Printer::Object->new( colored => 0, multiline => 0, show_readonly => 0, filters => ['Web'], ); my $json = '{ "trueVal": true, "falseVal": false, "strVal": "123", "numVal": 123 }'; my $obj = JSON->new; my $payload; if ($obj->can('convert_blessed') && $obj->can('canonical') && $obj->can('decode')) { $payload = $obj->convert_blessed->canonical->decode($json); } else { skip 'not sure how to load JSON object for JSON::Typist', 1; } my $typist = JSON::Typist->new->apply_types( $payload ); is( $ddp->parse($typist), '{ falseVal:false, numVal:123, strVal:"123", trueVal:true }', 'JSON::Typist properly parsed' ); }; } sub test_json_pp { my ($json, $expected) = @_; SKIP: { my $error = !eval { require JSON::PP; 1 }; skip 'JSON::PP not available', 1 if $error; diag('filter tests for ' . $JSON::PP::VERSION); my $ddp = Data::Printer::Object->new( colored => 0, multiline => 0, filters => ['Web'], ); my $data = JSON::PP::decode_json($json); is( $ddp->parse($data), $expected, 'JSON::PP booleans parsed' ); }; } sub test_json_xs { my ($json, $expected) = @_; SKIP: { my $error = !eval { require JSON::XS; 1 }; skip 'JSON::XS not available', 1 if $error; diag('filter tests for JSON::XS ' . $JSON::XS::VERSION); my $ddp = Data::Printer::Object->new( colored => 0, multiline => 0, show_readonly => 0, filters => ['Web'], ); my $data = JSON::XS::decode_json($json); is( $ddp->parse($data), $expected, 'JSON::XS booleans parsed' ); }; } sub test_json_json { my ($json, $expected) = @_; SKIP: { my $error = !eval { require JSON; 1 }; skip 'JSON not available', 1 if $error; diag('filter tests for JSON ' . $JSON::VERSION); my $ddp = Data::Printer::Object->new( colored => 0, multiline => 0, show_readonly => 0, filters => ['Web'], ); my $data; my $obj = JSON->new; if ($obj->can('decode')) { $data = $obj->decode($json); } elsif ($obj->can('jsonToObj')) { $data = $obj->jsonToObj($json); } else { skip 'not sure how to load JSON object', 1; } is( $ddp->parse($data), $expected, 'parsed whatever powered JSON' ); }; } sub test_json_any { my ($json, $expected) = @_; SKIP: { my $error = !eval { require JSON::Any; JSON::Any->import(); 1 }; skip 'JSON::Any not available', 1 if $error; {no strict 'refs'; diag('filter tests for JSON::Any ' . $JSON::Any::VERSION . ' with ' . JSON::Any->handlerType . ' ' . ${ JSON::Any->handlerType . '::VERSION' }); } my $ddp = Data::Printer::Object->new( colored => 0, multiline => 0, show_readonly => 0, filters => ['Web'], ); my $data = JSON::Any->new->decode($json); is( $ddp->parse($data), $expected, 'parsed whatever powered JSON::Any' ); }; } sub test_json_maybexs { my ($json, $expected) = @_; SKIP: { my $error = !eval { require JSON::MaybeXS; 1 }; skip 'JSON::MaybeXS not available', 1 if $error; {no strict 'refs'; diag('filter tests for JSON::MaybeXS ' . $JSON::MaybeXS::VERSION . ' with ' . JSON::MaybeXS::JSON() . ' ' . ${ JSON::MaybeXS::JSON() . '::VERSION' }); } my $ddp = Data::Printer::Object->new( colored => 0, multiline => 0, show_readonly => 0, filters => ['Web'], ); my $data = JSON::MaybeXS::decode_json($json); is( $ddp->parse($data), $expected, 'parsed whatever powered JSON::MaybeXS' ); }; } sub test_json_dwiw { my ($json, $expected) = @_; my $ddp = Data::Printer::Object->new( colored => 0, multiline => 0, filters => ['Web'], ); SKIP: { my $error = !eval { require JSON::DWIW; 1 }; skip 'JSON::DWIW not available', 1 if $error; diag('filter for JSON::DWIW ' . $JSON::DWIW::VERSION); my $data = JSON::DWIW::from_json($json, { convert_bool => 1 }); is( $ddp->parse($data), $expected, 'JSON::DWIW live booleans' ); }; my $emulated = { alpha => bless( do { \( my $v = 1 ) }, 'JSON::DWIW::Boolean' ), bravo => bless( do { \( my $v = 0 ) }, 'JSON::DWIW::Boolean' ), charlie => bless( do { \( my $v = 1 ) }, 'JSON::DWIW::Boolean' ), delta => bless( do { \( my $v = 0 ) }, 'JSON::DWIW::Boolean' ), }; is($ddp->parse($emulated), $expected, 'JSON::DWIW, emulated'); } sub test_json_parser { my ($json, $expected) = @_; my $ddp = Data::Printer::Object->new( colored => 0, multiline => 0, filters => ['Web'], ); SKIP: { my $error = !eval { require JSON::Parser; 1 }; skip 'JSON::Parser not available', 1 if $error; diag('filter for JSON::Parser ' . $JSON::Parser::VERSION); my $data = JSON::Parser->new->jsonToObj($json); is( $ddp->parse($data), $expected, 'JSON::Parser live booleans' ); }; my $emulated = { alpha => bless({value => 'true' }, 'JSON::NotString' ), bravo => bless({value => 'false'}, 'JSON::NotString' ), charlie => bless({value => 'true' }, 'JSON::NotString' ), delta => bless({value => 'false'}, 'JSON::NotString' ), }; is($ddp->parse($emulated), $expected, 'JSON::Parser, emulated'); } sub test_json_sl { my ($json, $expected) = @_; my $ddp = Data::Printer::Object->new( colored => 0, multiline => 0, filters => ['Web'], ); SKIP: { my $error = !eval { require JSON::SL; 1 }; skip 'JSON::SL not available', 1 if $error; diag('filter for JSON::SL ' . $JSON::SL::VERSION); my $data = JSON::SL::decode_json($json); is( $ddp->parse($data), $expected, 'JSON::SL live booleans' ); }; my $emulated = { alpha => bless(do { \(my $o = 1) }, 'JSON::SL::Boolean' ), bravo => bless(do { \(my $o = 0) }, 'JSON::SL::Boolean' ), charlie => bless(do { \(my $o = 1) }, 'JSON::SL::Boolean' ), delta => bless(do { \(my $o = 0) }, 'JSON::SL::Boolean' ), }; is($ddp->parse($emulated), $expected, 'JSON::SL, emulated'); } sub test_json_mojo { my ($json, $expected) = @_; my $ddp = Data::Printer::Object->new( colored => 0, show_readonly => 0, multiline => 0, filters => ['Web'], ); SKIP: { my $error = !eval { require Mojo::JSON; require Mojolicious; 1 }; skip 'Mojo::JSON not available', 1 if $error; diag('filter for Mojo::JSON ' . $Mojolicious::VERSION); my $data = Mojo::JSON->can('new') ? Mojo::JSON->new->decode($json) : Mojo::JSON::decode_json($json) ; is( $ddp->parse($data), $expected, 'Mojo::JSON live booleans' ); }; } sub test_json_pegex { my ($json, $expected) = @_; my $ddp = Data::Printer::Object->new( colored => 0, multiline => 0, filters => ['Web'], ); SKIP: { my $error = !eval { require Pegex::JSON; 1 }; skip 'Pegex::JSON not available', 1 if $error; diag('filter for Pegex::JSON ' . $Pegex::JSON::VERSION); my $data = Pegex::JSON->can('parse') ? Pegex::JSON->parse($json) : Pegex::JSON->new->load($json) ; is( $ddp->parse($data), $expected, 'Pegex::JSON live booleans' ); }; } sub test_json_cpanel { my ($json, $expected) = @_; my $ddp = Data::Printer::Object->new( colored => 0, multiline => 0, show_readonly => 0, filters => ['Web'], ); SKIP: { my $error = !eval { require Cpanel::JSON::XS; 1 }; skip 'Cpanel::JSON::XS not available', 1 if $error; diag('filter for Cpanel::JSON::XS ' . $Cpanel::JSON::XS::VERSION); my $data = Cpanel::JSON::XS::decode_json($json); is( $ddp->parse($data), $expected, 'Cpanel::JSON::XS live booleans' ); }; } sub test_json_tiny { my ($json, $expected) = @_; my $ddp = Data::Printer::Object->new( colored => 0, multiline => 0, filters => ['Web'], ); SKIP: { my $error = !eval { require JSON::Tiny; 1 }; skip 'JSON::Tiny not available', 1 if $error; diag('filter for JSON::Tiny ' . $JSON::Tiny::VERSION); my $data = JSON::Tiny::decode_json($json); is( $ddp->parse($data), $expected, 'JSON::Tiny live booleans' ); }; } Data-Printer-1.002001/t/012-code.t0000644000000000000000000000157714552015171014602 0ustar rootrootuse Test::More tests => 4; use Data::Printer::Object; # use strict; # <-- messes with B::Deparse # use warnings; # <-- messes with B::Deparse use 5.008; # <-- prevents PERL5OPT from kicking in and mangling B::Deparse my $sub = sub { 0 }; my $ddp = Data::Printer::Object->new( colored => 0 ); is( $ddp->parse(\$sub), 'sub { ... }', 'subref test' ); $sub = sub { print 42 }; $ddp = Data::Printer::Object->new( colored => 0, deparse => 1 ); is( $ddp->parse(\$sub), 'sub { print 42; }', 'subref with deparse'); $ddp = Data::Printer::Object->new( colored => 0 ); my $data = [ 6, sub { print 42 }, 10 ]; is( $ddp->parse(\$data), '[ [0] 6, [1] sub { ... }, [2] 10 ]', 'subref in array'); $ddp = Data::Printer::Object->new( colored => 0, deparse => 1 ); is( $ddp->parse(\$data), '[ [0] 6, [1] sub { print 42; }, [2] 10 ]', 'subref in array'); Data-Printer-1.002001/t/018-alias.t0000644000000000000000000000050514552015171014755 0ustar rootrootuse strict; use warnings; use Test::More tests => 1; BEGIN { use Data::Printer::Config; no warnings 'redefine'; *Data::Printer::Config::load_rc_file = sub { {} }; }; use Data::Printer alias => 'Dumper', return_value => 'dump', colored => 0; my $scalar = 'test'; is( Dumper($scalar), '"test"', 'aliasing p()' ); Data-Printer-1.002001/t/008-regex.t0000644000000000000000000000116014552015171014773 0ustar rootrootuse strict; use warnings; use Test::More tests => 3; use Data::Printer::Object; my $ddp = Data::Printer::Object->new( colored => 0 ); my $regex_with_modifiers = qr{(?:moo(\d|\s)*[a-z]+(.?))}i; is( $ddp->parse(\$regex_with_modifiers), '(?:moo(\d|\s)*[a-z]+(.?)) (modifiers: i)', 'regex with modifiers' ); my $plain_regex = qr{(?:moo(\d|\s)*[a-z]+(.?))}; is( $ddp->parse(\$plain_regex), '(?:moo(\d|\s)*[a-z]+(.?))', 'plain regex' ); my $creepy_regex = qr{ | ^ \s* go \s }x; is( $ddp->parse(\$creepy_regex), "\n |\n ^ \\s* go \\s\n (modifiers: x)", 'creepy regex' ); Data-Printer-1.002001/t/000.0-nsort.t0000644000000000000000000000122314552015171015154 0ustar rootrootuse strict; use warnings; use Data::Printer::Common; use Test::More tests => 1; my $chosen = Data::Printer::Common::_initialize_nsort(); diag("available sort module: $chosen"); my @unsorted = ( 'DOES (UNIVERSAL)', 'VERSION (UNIVERSAL)', 'bar (Bar)', 'baz', 'borg', 'can (UNIVERSAL)', 'foo', 'isa (UNIVERSAL)', 'new' ); is_deeply( [ Data::Printer::Common::_nsort_pp(@unsorted) ], [ 'bar (Bar)', 'baz', 'borg', 'can (UNIVERSAL)', 'DOES (UNIVERSAL)', 'foo', 'isa (UNIVERSAL)', 'new', 'VERSION (UNIVERSAL)' ], 'pure-perl sorting looks sane' ); Data-Printer-1.002001/t/007.format.t0000644000000000000000000000035714552015171015160 0ustar rootrootuse strict; use warnings; use Test::More tests => 1; use Data::Printer::Object; format TEST = . my $form = *TEST{FORMAT}; my $ddp = Data::Printer::Object->new( colored => 0 ); is( $ddp->parse(\$form), 'FORMAT', 'FORMAT reference' ); Data-Printer-1.002001/t/021-p_vs_object.t0000644000000000000000000000762514552015171016165 0ustar rootroot#!perl -T # ^^ taint mode must be on for taint checking. use strict; use warnings; use Test::More tests => 26; use Scalar::Util; BEGIN { use Data::Printer::Config; no warnings 'redefine'; *Data::Printer::Config::load_rc_file = sub { {} }; }; use Data::Printer colored => 0, return_value => 'dump', show_refcount => 1, show_weak => 1, show_tainted => 1, multiline => 0, class => { expand => 0 } ; my $has_devel_size = !Data::Printer::Common::_tryme(sub { require Devel::Size; 1; }); test_tainted(); test_weak_ref(); test_refcount(); sub test_tainted { SKIP: { # only use 1 char substring to avoid leaking # user information on test results: my $tainted = substr $ENV{'PATH'}, 0, 1; skip 'Skipping taint test: sample not found.', 2 => unless Scalar::Util::tainted($tainted); my $pretty = p $tainted; is $pretty, qq("$tainted" (TAINTED)), 'found taint flag with p()'; my $pretty_np = np $tainted; is $pretty_np, $pretty, 'found taint flag with np()'; }; } sub test_weak_ref { my $num = 3.14; my $ref = \$num; Scalar::Util::weaken($ref); my $pretty = p $ref; is $pretty, '\ 3.14 (weak)', 'found weak flag with p()'; my $pretty_np = np $ref; is $pretty_np, $pretty, 'found weak flag with np()'; } sub test_refcount { my $array = [42]; push @$array, $array; my $pretty = p $array; is $pretty, '[ 42, var ] (refcount: 2)', 'circular array'; my $pretty_np = np $array; is $pretty_np, $pretty, 'circular array (np)'; my @simple_array = (42); push @simple_array, \@simple_array; $pretty = p @simple_array; is $pretty, '[ 42, var ] (refcount: 2)', 'circular (simple) array'; $pretty_np = np @simple_array; is $pretty_np, $pretty, 'circular (simple) array (np)'; Scalar::Util::weaken($array->[-1]); $pretty = p $array; is $pretty, '[ 42, var (weak) ]', 'circular (weak) array'; $pretty_np = np $array; is $pretty_np, $pretty, 'circular (weak) array (np)'; my %hash = ( foo => 42 ); $hash{self} = \%hash; $pretty = p %hash; is $pretty, '{ foo:42, self:var } (refcount: 2)', 'circular (simple) hash'; $pretty_np = np %hash; is $pretty_np, $pretty, 'circular (simple) hash (np)'; my $hash = { foo => 42 }; $hash->{self} = $hash; $pretty = p $hash; is $pretty, '{ foo:42, self:var } (refcount: 2)', 'circular hash'; $pretty_np = np $hash; is $pretty_np, $pretty, 'circular hash (np)'; my $other_hash = $hash; $pretty = p $other_hash; is $pretty, '{ foo:42, self:var } (refcount: 3)', 'circular hash with extra ref'; $pretty_np = np $other_hash; is $pretty_np, $pretty, 'circular hash with extra ref (np)'; Scalar::Util::weaken($hash->{self}); undef $other_hash; $pretty = p $hash; is $pretty, '{ foo:42, self:var (weak) }', 'circular (weak) hash'; $pretty_np = np $hash; is $pretty_np, $pretty, 'circular (weak) hash (np)'; my $scalar; $scalar = \$scalar; $pretty = p $scalar; is $pretty, '\\ var (refcount: 2)', 'circular scalar ref'; $pretty_np = np $scalar; is $pretty_np, $pretty, 'circular scalar ref (np)'; my $blessed = bless {}, 'Something'; $pretty = p $blessed; is $pretty, 'Something', 'blessed ref'; $pretty_np = np $blessed; is $pretty_np, $pretty, 'blessed ref (np)'; my $blessed2 = $blessed; $pretty = p $blessed2; is $pretty, 'Something (refcount: 2)', 'blessed ref (high refcount)'; $pretty_np = np $blessed2; is $pretty_np, $pretty, 'blessed ref (high refcount) (np)'; Scalar::Util::weaken($blessed2); $pretty = p $blessed2; is $pretty, 'Something (weak)', 'blessed ref (weak)'; $pretty_np = np $blessed2; is $pretty_np, $pretty, 'blessed ref (weak) (np)'; } Data-Printer-1.002001/t/025-profiles.t0000644000000000000000000001275514552015171015517 0ustar rootrootuse strict; use warnings; use Test::More; use Data::Printer::Config; use Data::Printer::Object; use File::Spec; plan tests => $] >= 5.009 ? 34 : 33; my @warnings; { no warnings 'redefine'; *Data::Printer::Common::_warn = sub { push @warnings, $_[1] }; } my $profile = Data::Printer::Config::_expand_profile({ profile => 'Invalid;Name!' }); is ref $profile, 'HASH', 'profile expanded into hash'; is_deeply $profile, {}, 'bogus profile not loaded'; is @warnings, 1, 'invalid profile triggers warning'; like $warnings[0], qr/invalid profile name/, 'right message on invalid profile'; @warnings = (); $profile = Data::Printer::Config::_expand_profile({ colored => 1, profile => 'Invalid;Name!' }); is ref $profile, 'HASH', 'profile expanded into hash'; is_deeply $profile, { colored => 1 }, 'options preserved after bogus profile not loaded'; is @warnings, 1, 'invalid profile triggers warning (2)'; like $warnings[0], qr/invalid profile name/, 'right message on invalid profile (2)'; @warnings = (); $profile = Data::Printer::Config::_expand_profile({ colored => 1, profile => 'BogusProfile' }); is ref $profile, 'HASH', '(bad) profile expanded into hash'; is_deeply $profile, { colored => 1 }, 'options preserved after bogus profile not loaded (3)'; is @warnings, 1, 'invalid profile triggers warning (3)'; like $warnings[0], qr/unable to load profile/, 'right message on invalid profile (3)'; @warnings = (); $profile = Data::Printer::Config::_expand_profile({ profile => 'Dumper' }); is @warnings, 0, 'no warnings after proper profile loaded'; is $profile->{name}, '$VAR1', 'profile loaded ok'; is $profile->{colored}, 0, 'profile color set'; @warnings = (); $profile = Data::Printer::Config::_expand_profile({ colored => 1, profile => 'Dumper' }); is @warnings, 0, 'no warnings after proper profile loaded with extra options'; is $profile->{name}, '$VAR1', 'profile with extra options loaded ok'; is $profile->{colored}, 1, 'profile color properly overriden'; @warnings = (); $profile = Data::Printer::Config::_expand_profile({ profile => 'Dumper' }); is @warnings, 0, 'dumper profile loaded'; my $ddp = Data::Printer::Object->new($profile); my $lvalue = \substr("abc", 2); my $file = File::Spec->catfile( Data::Printer::Config::_my_home('testing'), 'test_file.dat' ); open my $glob, '>', $file or skip "error opening '$file': $!", 1; format TEST = . my $format = *TEST{FORMAT}; my $vstring = v1.2.3; my $scalar = 1; my $regex = qr/^2\s\\\d+$/i; my $target = { foo => [undef, $scalar, 'two', $regex, $glob, $lvalue, \321, $vstring, $format, sub {}, bless(\$scalar, 'TestClass')] }; push @{$target->{foo}}, \$target->{foo}[0]; # circular ref check #1 push @{$target->{foo}}, $target->{foo}[6]; # circular ref check #2 @warnings = (); my $output = $ddp->parse($target); if (@warnings == 3 && $warnings[2] =~ /Objects may display/) { pop @warnings; } is @warnings, 2, 'dumper profile is unable to parse 2 types of ref'; like $warnings[0], qr/cannot handle ref type 10/, 'dumper warning on lvalue'; like $warnings[1], qr/cannot handle ref type 14/, 'dumper warning on format'; my $vstring_parsed; if ($] < 5.009) { $vstring_parsed = qq('\x01\x02\x03'); } else { my $error = Data::Printer::Common::_tryme(sub { require version; $vstring_parsed = version->parse($vstring)->normal; }); $vstring_parsed = 'VSTRING object (unable to parse)' if $error; } my $expected = <<"EODUMPER"; \$VAR1 = { 'foo' => [ undef, 1, 'two', qr/^2\\s\\\\\\d+\$/i, \\*{'::\$glob'}, , \\321, $vstring_parsed, , sub { "DUMMY" }, bless( do{\\(my \$o = 1)}, 'TestClass' ), \\\$VAR1->{'foo'}[0], \\\$VAR1->{'foo'}[6] ] }; EODUMPER chop $expected; # remove last newline is $output, $expected, 'proper result in dumper profile'; @warnings = (); $profile = Data::Printer::Config::_expand_profile({ profile => 'JSON' }); is @warnings, 0, 'json profile loaded'; $ddp = Data::Printer::Object->new($profile); $output = $ddp->parse($target); my $total_warnings = 10; if ($] < 5.009) { $total_warnings = 9; $vstring_parsed = "\x01\x02\x03" if $vstring_parsed !~ /v/i; } my $i = 0; is @warnings, $total_warnings, 'json profile is unable to parse some types of ref'; like $warnings[$i++], qr/regular expression cast to string \(flags removed\)/, 'json warning on regexes'; like $warnings[$i++], qr/json cannot express globs/, 'json warnings on globs'; like $warnings[$i++], qr/json cannot express references to scalars. Cast to non-reference/, 'json warning on refs'; if ($] >= 5.009) { like $warnings[$i++], qr/json cannot express vstrings/, 'json warnings on vstring'; } like $warnings[$i++], qr/json cannot express subroutines. Cast to string/, 'json warning on functions'; like $warnings[$i++], qr/json cannot express blessed objects/, 'json warning on objects'; like $warnings[$i++], qr/json cannot express references to scalars. /, 'json warning on refs'; like $warnings[$i++], qr/json cannot express circular references./, 'json warning on circular refs'; $expected = <<"EOJSON"; { "foo": [ null, 1, "two", "/^2\\s\\\\\\d+\$/i", , "c", 321, "$vstring_parsed", "FORMAT", "sub { ... }", 1, "var{"foo"}[0]", "var{"foo"}[6]" ] } EOJSON chop $expected; # remove last newline is $output, $expected, 'proper result in json profile'; Data-Printer-1.002001/t/023-filters.t0000644000000000000000000000353414552015171015335 0ustar rootrootuse strict; use warnings; use Test::More tests => 11; package My::Module; sub new { bless {}, shift } sub test { return 'this is a test' } package Other::Module; sub new { bless {}, shift } package Inherited::Module; our @ISA = qw(My::Module); sub whatever {} package main; BEGIN { use Data::Printer::Config; no warnings 'redefine'; *Data::Printer::Config::load_rc_file = sub { {} }; }; use DDP colored => 0, return_value => 'dump', filters => [{ 'My::Module' => sub { shift->test }, -class => sub { '1, 2, 3' }, SCALAR => sub { 'scalar here!' }, }]; my $obj = My::Module->new; my $string = 'oi?'; is p($obj), 'this is a test', 'basic object filter'; is p($string), 'scalar here!', 'scalar filter'; is( p($obj, filters => [{ 'My::Module' => sub { return 'mo' } }]), 'mo', 'overriding My::Module filter' ); # NOTE: a custom 'filters' key *REPLACES ALL* global/local filters, # not add to the existing ones. See for yourself: is( p($string, filters => [{ 'My::Module' => sub { return 'mo' } }]), '"oi?"', 'custom filter list destroys previous one' ); is p($obj), 'this is a test', 'basic object filter restored'; is p($string), 'scalar here!', 'scalar filter restored'; is( p($string, filters => [{ 'SCALAR' => sub { return } }]), '"oi?"', 'move to next filter if current filter returns' ); is( p($string, filters => [ { 'SCALAR' => sub { return } }, { 'SCALAR' => sub { return 222 } } ]), '222', 'move to next (custom) filter if current filter returns' ); my $obj2 = Other::Module->new; is p($obj2), '1, 2, 3', '-class filter works'; my $inherited = Inherited::Module->new; is p($inherited), 'this is a test', 'inherited filter'; is p($inherited, class => { parent_filters => 0 }), '1, 2, 3', 'disabling parent filters'; Data-Printer-1.002001/t/011.1-attributes.t0000644000000000000000000000267114552015171016210 0ustar rootrootuse strict; use warnings; use Test::More; use Data::Printer::Common; use Data::Printer::Object; plan tests => 4; test_moo(); test_moose(); exit; sub test_moo { SKIP: { my $moo_error = Data::Printer::Common::_tryme( 'package TestMooClass; use Moo; has bar => (is => "ro", required => 0); no Moo; 1;' ); skip 'Moo not found', 2 if $moo_error; my $ddp = Data::Printer::Object->new( colored => 0 ); my $obj = TestMooClass->new; my $parsed = $ddp->parse($obj); like( $parsed, qr/attributes \(1\): bar$/m, 'Moo object parsed properly' ); unlike( $parsed, qr/roles/, 'No role output displayed since no roles were used.' ); }; } sub test_moose { SKIP: { my $moose_error = Data::Printer::Common::_tryme( 'package TestMooseClass; use Moose; has foo => (is => "rw", required => 0); no Moose; 1;' ); skip 'Moose not found', 2 if $moose_error; my $ddp = Data::Printer::Object->new( colored => 0 ); my $obj = TestMooseClass->new; my $parsed = $ddp->parse($obj); like( $parsed, qr/attributes \(1\): foo$/m, 'Moose object parsed properly' ); unlike( $parsed, qr/roles/, 'No role output displayed since no roles were used.' ); }; } Data-Printer-1.002001/t/103-filter_contenttype.t0000644000000000000000000001007514552015171017603 0ustar rootrootuse strict; use warnings; use Test::More tests => 32; use Data::Printer::Object; # we pad a bunch of 'dd' because of a minimum length check inside the filter: my %signatures = ( "\x89\x50\x4E\x47" => 'PNG Image', "\x47\x49\x46" => 'GIF Image', "\x4D\x4D\x00\x2A" => 'TIFF Image', "\x49\x49\x2A\x00" => 'TIFF Image', "\xff\xd8\xff" => 'JPEG Image', "\x00\x00\x01\x00" => 'ICO Image', "\x00\x00\x01\xb0\xbf" => 'MPEG Video', "\x00\x00\x01\xc3\xa8" => 'MPEG Video', "\x52\x49\x46\x46\x00\x00\x57\x41\x56\x45" => 'WAV Audio', "\x52\x49\x46\x46\x00\x00\x41\x56\x49" => 'AVI Video', "\x50\x4b\x30\x40" => 'Zip Archive', "\x50\x4b\x70\x60" => 'Zip Archive', "\x25\x50\x44\x46" => "PDF Document", "\x7F\x45\x4C\x46" => "Binary ELF data", "\x66\x4C\x61\x43" => "FLAC Audio", "\x4F\x67\x67\x53" => "OGG Audio", "\x1F\x8B\x80" => "Gzip Archive", "\x49\x44\x33" => "MP3 Audio", "\x42\x5A\x68" => "Bzip2 Archive", "\x4D\x5A" => "Binary Windows EXE data", "\x42\x4D" => "BMP Image", "\xFF\xFB" => "MP3 Audio", "\x3d\x73\x72\x6c\x01" => "Binary Sereal v1 data", "\x3d\x73\x72\x6c\x02" => "Binary Sereal v2 data", "\x3d\xf3\x72\x6c\x03" => "Binary Sereal v3 data", "\x3d\xf3\x72\x6c\x04" => "Binary Sereal v4 data", ); my $ddp = Data::Printer::Object->new( colored => 0, filters => ['ContentType'], ); foreach my $k (keys %signatures) { # increase content length deliberately: my $content = $k . ("\xdd" x 20); like( $ddp->parse(\$content, seen_override => 1), qr/\($signatures{$k}, \d\dB\)/, "found the right content type for " . $signatures{$k} ); } my $png = "\x89\x50\x4E\x47"; foreach my $i (1 .. 32) { $png .= hex($i); } $ddp = Data::Printer::Object->new( colored => 0, filters => ['ContentType'], filter_contenttype => { show_size => 0 }, ); is( $ddp->parse(\$png), "\x{f0}\x{9f}\x{96}\x{bc} (PNG Image)", 'content type without size' ); $ddp = Data::Printer::Object->new( colored => 0, filters => ['ContentType'], filter_contenttype => { size_unit => 'k', show_symbol => 0, }, ); is $ddp->parse(\$png), '(PNG Image, 0K)', 'content type with forced size unit'; $ddp = Data::Printer::Object->new( colored => 0, filters => ['ContentType'], filter_contenttype => { hexdump => 1, show_symbol => 0, }, ); is $ddp->parse(\$png), '(PNG Image, 59B) 0x00000000 (00000) 89504e47 31323334 35363738 39313631 .PNG123456789161 0x00000010 (00016) 37313831 39323032 31323232 33323432 7181920212223242 0x00000020 (00032) 35333233 33333433 35333633 37333833 5323334353637383 0x00000030 (00048) 39343034 31343834 393530 94041484950', 'content type with hexdump'; $ddp = Data::Printer::Object->new( colored => 0, filters => ['ContentType'], filter_contenttype => { hexdump => 1, hexdump_size => 19, show_symbol => 0, }, ); is $ddp->parse(\$png), '(PNG Image, 59B) 0x00000000 (00000) 89504e47 31323334 35363738 39313631 .PNG123456789161 0x00000010 (00016) 373138 718', 'content type with hexdump size 19'; $ddp = Data::Printer::Object->new( colored => 0, filters => ['ContentType'], filter_contenttype => { hexdump => 1, hexdump_size => 19, hexdump_indent => 1, show_symbol => 0, }, ); $ddp->indent; is $ddp->parse(\$png), '(PNG Image, 59B) 0x00000000 (00000) 89504e47 31323334 35363738 39313631 .PNG123456789161 0x00000010 (00016) 373138 718', 'content type with hexdump size 19 (indented)'; $ddp = Data::Printer::Object->new( colored => 0, filters => ['ContentType'], filter_contenttype => { hexdump => 1, hexdump_size => 5, hexdump_offset => 10, show_symbol => 0, }, ); is $ddp->parse(\$png), '(PNG Image, 59B) 0x0000000a (00010) 37383931 36 78916', 'content type with hexdump size 5 from offset 10'; Data-Printer-1.002001/t/014-memsize.t0000644000000000000000000000222414552015171015331 0ustar rootrootuse strict; use warnings; use Test::More tests => 6; use Data::Printer::Object; use Data::Printer::Common; my $error = Data::Printer::Common::_tryme(sub { require Devel::Size; 1; }); SKIP: { skip 'Devel::Size not found - cannot test show_memsize', 6 if $error; my $ddp = Data::Printer::Object->new( colored => 0, show_memsize => 1 ); my @x = (1, 'two'); my $res = $ddp->parse(\@x); my @count = $res =~ /B|K|M/g; is (scalar @count, 1, 'show_memsize == 1 only goes 1 level deep') or diag($res); like $res, qr/\] \(\d+(?:B|K|M)\)\z/, 'show_memsize looks ok when set to 1'; $ddp = Data::Printer::Object->new( colored => 0, show_memsize => 2 ); $res = $ddp->parse(\@x); @count = $res =~ /B|K|M/g; is (scalar @count, 3, 'show_memsize == 2 goes 2 levels deep.'); like $res, qr/ \(\d+(?:B|K|M)\)\z/, 'show_memsize looks ok when set to 2'; $ddp = Data::Printer::Object->new( colored => 0, show_memsize => 'all' ); $res = $ddp->parse(\@x); @count = $res =~ /B|K|M/g; is (scalar @count, 3, 'show_memsize == all show everything.'); like $res, qr/ \(\d+(?:B|K|M)\)\z/, 'show_memsize looks ok when set to "all"'; }; Data-Printer-1.002001/t/026-caller_message.t0000644000000000000000000000132514552015171016632 0ustar rootrootuse strict; use warnings; use Test::More tests => 2; BEGIN { use Data::Printer::Config; no warnings 'redefine'; *Data::Printer::Config::load_rc_file = sub { {} }; }; use Data::Printer colored => 0, caller_info => 1, return_value => 'dump', caller_message_newline => 0, caller_message_position => 'before'; my $x; my $got = p $x; is( $got, 'Printing in line 19 of t/026-caller_message.t: undef', 'caller_info shows the proper caller message (after)' ); $got = p $x, caller_message_position => 'after'; is( $got, 'undef Printing in line 26 of t/026-caller_message.t:', 'caller_info shows the proper caller message (before)' ); Data-Printer-1.002001/t/102-filter_digest.t0000644000000000000000000000275314552015171016511 0ustar rootrootuse strict; use warnings; use Test::More tests => 3 * 7; # tests * modules use Data::Printer::Object; my $data = 'I can has Digest?'; foreach my $module (qw( Digest::Adler32 Digest::MD2 Digest::MD4 Digest::MD5 Digest::SHA Digest::SHA1 Digest::Whirlpool )) { SKIP: { eval "use $module; 1"; skip "$module not available", 3 if $@; my $digest = $module->new; skip "$module is too old", 3 if $module eq 'Digest::MD5' and !$digest->isa('Digest::base'); $digest->add( $data ); my $ddp = Data::Printer::Object->new( colored => 0, show_readonly => 0, filters => ['Digest'], filter_digest => { show_class_name => 0 }, ); my $dump = $ddp->parse($digest); $ddp = Data::Printer::Object->new( colored => 0, show_readonly => 0, filters => ['Digest'], ); my $named_dump = $ddp->parse($digest); my $hex = $digest->hexdigest; is( $dump, $hex, "$module digest dump"); is( $named_dump, "$hex ($module)", "$module digest dump with class name" ); $ddp = Data::Printer::Object->new( colored => 0, show_readonly => 0, filters => ['Digest'], ); is( $ddp->parse($digest), $digest->hexdigest . " ($module) [reset]", "reset $module" ); }; } Data-Printer-1.002001/t/998-color.t0000644000000000000000000001051614552015171015026 0ustar rootrootuse strict; use warnings; use Test::More; use Data::Printer::Object; use Scalar::Util; package DDPTestObject; sub new { bless {}, shift } 1; package main; my $ddp = Data::Printer::Object->new( colored => 1, print_escapes => 1, escape_chars => 'nonascii', string_max => 30, class => { show_reftype => 1 }, show_refcount => 1, ); if ($ddp->{_output_color_level} == 3) { plan tests => 1; } else { plan skip_all => 'color level ' . $ddp->{_output_color_level} . ' < 3'; } sub testsub {} my $data = { arrayref => [[10], DDPTestObject->new], hashref => { string => "this is a string", special => "one\t\x{2603}two\0\n\e[0m\x{2603}" . ('B' x 100), number => 3.14, ref => \42, regex => qr{(?:\s+)$}ix, lvalue => \substr("abc", 2), undef => undef, sub => \&testsub, "we\e[0mird\0key\x{2603}!" => 1, }, }; push @{$data->{arrayref}}, $data->{arrayref}[0]; my $got = $ddp->parse(\$data); my $expected = qq|\e[0;38;2;102;217;239m{\e[m \e[0;38;2;121;134;203marrayref\e[m\e[0;38;2;102;217;239m \e[m\e[0;38;2;102;217;239m[\e[m \e[0;38;2;161;187;197m[0] \e[m\e[0;38;2;102;217;239m[\e[m \e[0;38;2;161;187;197m[0] \e[m\e[0;38;2;247;140;106m10\e[m \e[0;38;2;102;217;239m]\e[m (refcount: 2)\e[0;38;2;102;217;239m,\e[m \e[0;38;2;161;187;197m[1] \e[m\e[0;38;2;199;146;234mDDPTestObject\e[m \e[0;38;2;102;217;239m(\e[m\e[0;38;2;199;146;234mHASH\e[m\e[0;38;2;102;217;239m)\e[m \e[0;38;2;102;217;239m{\e[m public methods (1): \e[0;38;2;130;170;255mnew\e[m private methods (0) internals: \e[0;38;2;102;217;239m{}\e[m \e[0;38;2;102;217;239m}\e[m\e[0;38;2;102;217;239m,\e[m \e[0;38;2;161;187;197m[2] \e[m\e[0;38;2;240;113;120mvar{arrayref}[0]\e[m \e[0;38;2;102;217;239m]\e[m\e[0;38;2;102;217;239m,\e[m \e[0;38;2;121;134;203mhashref\e[m \e[0;38;2;102;217;239m \e[m\e[0;38;2;102;217;239m{\e[m \e[0;38;2;121;134;203mlvalue\e[m \e[0;38;2;102;217;239m \e[m\e[0;38;2;102;217;239m"\e[m\e[0;38;2;144;181;90mc\e[m\e[0;38;2;102;217;239m"\e[m\e[0;38;2;247;140;106m (LVALUE)\e[m| . (q{ (refcount: 2)}x!!($] < 5.014000)) . qq|\e[0;38;2;102;217;239m,\e[m \e[0;38;2;121;134;203mnumber\e[m \e[0;38;2;102;217;239m \e[m\e[0;38;2;247;140;106m3.14\e[m\e[0;38;2;102;217;239m,\e[m \e[0;38;2;121;134;203mref\e[m \e[0;38;2;102;217;239m \e[m\\ \e[0;38;2;247;140;106m42\e[m (read-only)\e[0;38;2;102;217;239m,\e[m \e[0;38;2;121;134;203mregex\e[m \e[0;38;2;102;217;239m \e[m\e[0;38;2;255;203;107m(?:\\s+)\$\e[m (modifiers: ix)| . (q{ (refcount: 2)}x!!($] =~ /5.01100[12]/)) . qq|\e[0;38;2;102;217;239m,\e[m \e[0;38;2;121;134;203mspecial\e[m \e[0;38;2;102;217;239m \e[m\e[0;38;2;102;217;239m"\e[m\e[0;38;2;144;181;90mone\e[0;38;2;0;150;136m\\t\e[0;38;2;144;181;90m\e[0;38;2;0;150;136m\\x{2603}\e[0;38;2;144;181;90mtwo\e[0;38;2;0;150;136m\\0\e[0;38;2;144;181;90m\e[0;38;2;0;150;136m\\n\e[0;38;2;144;181;90m\e[0;38;2;0;150;136m\\e\e[0;38;2;144;181;90m[0m\e[0;38;2;0;150;136m\\x{2603}\e[0;38;2;144;181;90mBBBBBBBBBBBBBBB\e[0;38;2;79;90;97m(...skipping 85 chars...)\e[0;38;2;144;181;90m\e[m\e[0;38;2;102;217;239m"\e[m\e[0;38;2;102;217;239m,\e[m \e[0;38;2;121;134;203mstring\e[m \e[0;38;2;102;217;239m \e[m\e[0;38;2;102;217;239m"\e[m\e[0;38;2;144;181;90mthis is a string\e[m\e[0;38;2;102;217;239m"\e[m\e[0;38;2;102;217;239m,\e[m \e[0;38;2;121;134;203msub\e[m \e[0;38;2;102;217;239m \e[m\e[0;38;2;79;90;97msub { ... }\e[m (refcount: 2)\e[0;38;2;102;217;239m,\e[m \e[0;38;2;121;134;203mundef\e[m \e[0;38;2;102;217;239m \e[m\e[0;38;2;255;83;112mundef\e[m\e[0;38;2;102;217;239m,\e[m \e[0;38;2;102;217;239m"\e[m\e[0;38;2;121;134;203mwe\e[0;38;2;0;150;136m\\e\e[0;38;2;121;134;203m[0mird\e[0;38;2;0;150;136m\\0\e[0;38;2;121;134;203mkey\e[0;38;2;0;150;136m\\x{2603}\e[0;38;2;121;134;203m!\e[m\e[0;38;2;102;217;239m"\e[m\e[0;38;2;102;217;239m \e[m\e[0;38;2;247;140;106m1\e[m \e[0;38;2;102;217;239m}\e[m \e[0;38;2;102;217;239m}\e[m|; is($got, $expected, 'colored output'); if ($got ne $expected) { $got =~ s{\e}{\\e}gsm; diag("escaped version for debug:\n$got"); } Data-Printer-1.002001/t/006-glob.t0000644000000000000000000000335014552015171014605 0ustar rootrootuse strict; use warnings; use Test::More; use Data::Printer::Object; use Data::Printer::Config; use File::Spec; use Fcntl; my $ddp = Data::Printer::Object->new( colored => 0 ); my $filename = File::Spec->catfile( Data::Printer::Config::_my_home('testing'), 'test_file.dat' ); if ( open my $var, '>', $filename ) { my $str = $ddp->parse(\$var); my @layers = (); my $error = Data::Printer::Common::_tryme(sub { @layers = PerlIO::get_layers $var }); close $var; if ($error) { plan tests => 4; diag("error getting handle layers from PerlIO: $error"); } else { plan tests => @layers + 4; foreach my $l (@layers) { like $str, qr/$l/, "layer $l present in info"; } } } else { diag("error writing to $filename: $!"); } SKIP: { skip "error opening $filename for (write) testing: $!", 4 unless open my $var, '>', $filename; my $flags; eval { $flags = fcntl($var, F_GETFL, 0) }; skip 'fcntl not fully supported', 4 if $@ or !$flags; $ddp = Data::Printer::Object->new( colored => 0 ); like $ddp->parse(\$var), qr{write-only}, 'write-only handle'; close $var; skip "error appending to $filename: $!", 3 unless open $var, '+>>', $filename; $ddp = Data::Printer::Object->new( colored => 0 ); like $ddp->parse(\$var), qr{read/write}, 'read/write handle'; $ddp = Data::Printer::Object->new( colored => 0 ); like $ddp->parse(\$var), qr/flags:[^,]+append/, 'append flag'; close $var; skip "error reading from $filename: $!", 1 unless open $var, '<', $filename; $ddp = Data::Printer::Object->new( colored => 0 ); like $ddp->parse(\$var), qr{read-only}, 'read-only handle'; close $var; }; Data-Printer-1.002001/t/003-ref.t0000644000000000000000000000202014552015171014424 0ustar rootrootuse strict; use warnings; use Test::More tests => 7; use Data::Printer::Object; my $ddp = Data::Printer::Object->new( colored => 0, show_readonly => 0 ); my $data = "test"; my $ref = \$data; my $ref2ref = \$ref; my $res = $ddp->parse(\$ref2ref); is $res, q(\\ \\ "test"), 'reference to reference to scalar'; my $doublecheck = $ddp->parse(\$ref2ref); is $doublecheck, $res, 'checking again gives the same result (previously seen addresses)'; $ddp = Data::Printer::Object->new( colored => 0, show_readonly => 0 ); $res = $ddp->parse(\\$ref2ref); is $res, q(\\ \\ \\ "test"), 'ref2ref2ref2scalar'; my $x = []; my $y = $x; Scalar::Util::weaken($y); is $ddp->parse($x), '[]', 'regular array ref'; is $ddp->parse($y), '[] (weak)', 'weak array ref'; $x->[0] = $x; Scalar::Util::weaken($x->[0]); is $ddp->parse($x), '[ [0] var (weak) ]', 'circular array'; my $array_of_refs = [\1, \2]; $res = $ddp->parse($array_of_refs); is $res, '[ [0] \ 1, [1] \ 2 ]', 'proper results when 2 references present on the same array (regression)'; Data-Printer-1.002001/t/011-class.t0000644000000000000000000003424214552015171014767 0ustar rootrootuse strict; use warnings; package Bar; sub bar { 'Bar' } sub borg { } sub _moo { } 1; package Foo; our @ISA = qw(Bar); sub new { bless { test => 42 }, shift } sub foo { } sub baz { } sub borg { $_[0]->{borg} = $_[1]; } sub _other { } 1; package Baz; sub bar { 'Baz' } 1; package Meep; our @ISA = qw(Foo Baz); 1; package ParentLess; sub new { bless {}, shift } 1; package FooArray; sub new { bless [], shift } sub foo { } 1; package FooScalar; sub new { my $val = 42; bless \$val, shift } sub foo { } 1; package FooCode; sub new { my $ref = sub {}; bless $ref, shift } sub foo { } 1; package ICanHazStringOverload; use overload '""' => sub { 'le string of le object' }; sub new { bless {}, shift }; 1; package ICanHazNumberOverload; use overload '0+' => sub { 42 }; sub new { bless {}, shift }; 1; package ChildOfOverload; our @ISA = ('ICanHazNumberOverload'); sub new { bless {}, shift }; 1; package UnrelatedOverload; use overload '<' => sub {}, '+' => sub {}; sub new { bless {}, shift }; 1; package ICanHazStringMethodOne; sub new { bless {}, shift }; sub as_string { 'number one!' } sub stringify { 'second!' }; 1; package ICanHazStringMethodTwo; sub new { bless {}, shift }; sub stringify { 'second!' }; 1; package main; use Test::More tests => 38; use Data::Printer::Object; use Data::Printer::Common; my $ddp = Data::Printer::Object->new( colored => 0 ); # first we try some very weird edge cases # https://github.com/garu/Data-Printer/issues/105 my $weird = bless {}, 'HASH'; is( $ddp->parse($weird), 'HASH { public methods (0) private methods (0) internals: {} }', 'empty "HASH" object' ); $weird = bless [], 'ARRAY'; is( $ddp->parse($weird), 'ARRAY { public methods (0) private methods (0) internals: [] }', 'empty "ARRAY" object' ); $weird = bless {}, "0"; is( $ddp->parse($weird), '0 { public methods (0) private methods (0) internals: {} }', 'empty "0" object' ); # okay, now back to testing "proper" objects :) my $object = Foo->new; is( $ddp->parse($object), 'Foo { parents: Bar public methods (5): baz, borg, foo, new Bar: bar private methods (1): _other internals: { test 42 } }', 'testing objects' ); $ddp = Data::Printer::Object->new( colored => 0, class => { linear_isa => 1 } ); is( $ddp->parse($object), 'Foo { parents: Bar linear @ISA: Foo, Bar public methods (5): baz, borg, foo, new Bar: bar private methods (1): _other internals: { test 42 } }', 'testing objects, forcing linear @ISA' ); $ddp = Data::Printer::Object->new( colored => 0, class => { parents => 0 } ); is( $ddp->parse($object), 'Foo { public methods (5): baz, borg, foo, new Bar: bar private methods (1): _other internals: { test 42 } }', 'testing objects (parents => 0)' ); $ddp = Data::Printer::Object->new( colored => 0, class => { show_methods => 'none' } ); is( $ddp->parse($object), 'Foo { parents: Bar internals: { test 42 } }', 'testing objects (no methods)' ); $ddp = Data::Printer::Object->new( colored => 0, class => { show_methods => 'public' } ); is( $ddp->parse($object), 'Foo { parents: Bar public methods (5): baz, borg, foo, new Bar: bar internals: { test 42 } }', 'testing objects (only public methods)' ); $ddp = Data::Printer::Object->new( colored => 0, class => { show_methods => 'private' } ); is( $ddp->parse($object), 'Foo { parents: Bar public methods (1): Bar: bar private methods (1): _other internals: { test 42 } }', 'testing objects (show_methods private, show_inherited public)' ); $ddp = Data::Printer::Object->new( colored => 0, class => { show_methods => 'private', inherited => 'private' } ); is( $ddp->parse($object), 'Foo { parents: Bar private methods (2): _other Bar: _moo internals: { test 42 } }', 'testing objects (only private methods)' ); $ddp = Data::Printer::Object->new( colored => 0, class => { show_methods => 'private', inherited => 'none' } ); is( $ddp->parse($object), 'Foo { parents: Bar private methods (1): _other internals: { test 42 } }', 'testing objects (only public private methods)' ); $ddp = Data::Printer::Object->new( colored => 0, class => { show_methods => 'all', inherited => 'all' } ); is( $ddp->parse($object), 'Foo { parents: Bar public methods (5): baz, borg, foo, new Bar: bar private methods (2): _other Bar: _moo internals: { test 42 } }', 'testing objects (explicitly asking for all methods)' ); $ddp = Data::Printer::Object->new( colored => 0, class => { internals => 0 } ); is( $ddp->parse($object), 'Foo { parents: Bar public methods (5): baz, borg, foo, new Bar: bar private methods (1): _other }', 'testing objects (no internals)' ); $ddp = Data::Printer::Object->new( colored => 0, class => { inherited => 'none' } ); is( $ddp->parse($object), 'Foo { parents: Bar public methods (4): baz, borg, foo, new private methods (1): _other internals: { test 42 } }', 'testing objects (inherited => "none")' ); my $sort_class = Data::Printer::Common::_initialize_nsort(); my $has_uc_sort = $sort_class eq 'Sort::Key::Natural'; my @methods = $has_uc_sort ? ( (defined &UNIVERSAL::DOES ? 'DOES (UNIVERSAL)' : ()), 'VERSION (UNIVERSAL)', 'bar (Bar)', 'baz', 'borg', 'can (UNIVERSAL)', 'foo', (defined &UNIVERSAL::import ? 'import (UNIVERSAL)' : ()), 'isa (UNIVERSAL)', 'new', (defined &UNIVERSAL::unimport ? 'unimport (UNIVERSAL)' : ()), ) : ( 'bar (Bar)', 'baz', 'borg', 'can (UNIVERSAL)', (defined &UNIVERSAL::DOES ? 'DOES (UNIVERSAL)' : ()), 'foo', (defined &UNIVERSAL::import ? 'import (UNIVERSAL)' : ()), 'isa (UNIVERSAL)', 'new', (defined &UNIVERSAL::unimport ? 'unimport (UNIVERSAL)' : ()), 'VERSION (UNIVERSAL)', ); my $n = @methods; my $public_method_list = join ', ', @methods; $ddp = Data::Printer::Object->new( colored => 0, class => { inherited => 'all', universal => 1, format_inheritance => 'string' } ); is( $ddp->parse($object), "Foo { parents: Bar public methods ($n): $public_method_list private methods (2): _moo (Bar), _other internals: { test 42 } }", 'testing objects (inherited => "all", universal => 1, format_inheritance => string)' ); $ddp = Data::Printer::Object->new( colored => 0, class => { inherited => 'all', universal => 1, format_inheritance => 'lines' } ); my $universal_methods = join ', ', $has_uc_sort ? ( (defined &UNIVERSAL::DOES ? 'DOES' : ()), 'VERSION', 'can', (defined &UNIVERSAL::import ? 'import' : ()), 'isa', (defined &UNIVERSAL::unimport ? 'unimport' : ()), ) : ( 'can', (defined &UNIVERSAL::DOES ? 'DOES' : ()), (defined &UNIVERSAL::import ? 'import' : ()), 'isa', (defined &UNIVERSAL::import ? 'unimport' : ()), 'VERSION', ); is( $ddp->parse($object), "Foo { parents: Bar public methods ($n): baz, borg, foo, new Bar: bar UNIVERSAL: $universal_methods private methods (2): _other Bar: _moo internals: { test 42 } }", 'testing objects (inherited => "all", universal => 1, format_inheritance => "lines")' ); $ddp = Data::Printer::Object->new( colored => 0, class => { expand => 0 } ); is( $ddp->parse($object), 'Foo', 'testing objects without expansion' ); $object->borg( Foo->new ); $ddp = Data::Printer::Object->new( colored => 0, class => { inherited => 'none' } ); is( $ddp->parse($object), 'Foo { parents: Bar public methods (4): baz, borg, foo, new private methods (1): _other internals: { borg Foo, test 42 } }', 'testing nested objects' ); $ddp = Data::Printer::Object->new( colored => 0, class => { expand => 'all', inherited => 'none' } ); is( $ddp->parse($object), 'Foo { parents: Bar public methods (4): baz, borg, foo, new private methods (1): _other internals: { borg Foo { parents: Bar public methods (4): baz, borg, foo, new private methods (1): _other internals: { test 42 } }, test 42 } }', 'testing nested objects with expansion' ); my $obj_with_isa = Meep->new; SKIP: { my $has_mro = Data::Printer::Common::_initialize_mro(); skip 'MRO::Compat not available, linear ISA not reliable', 3 unless $has_mro == 1; $ddp = Data::Printer::Object->new( colored => 0 ); is( $ddp->parse($obj_with_isa), 'Meep { parents: Foo, Baz linear @ISA: Meep, Foo, Bar, Baz public methods (5): Bar: bar Foo: baz, borg, foo, new private methods (0) internals: { test 42 } }', 'testing objects with @ISA' ); $ddp = Data::Printer::Object->new( colored => 0, class => { inherited => 'none' } ); is( $ddp->parse($obj_with_isa), 'Meep { parents: Foo, Baz linear @ISA: Meep, Foo, Bar, Baz public methods (0) private methods (0) internals: { test 42 } }', 'testing objects with @ISA and no inheritance' ); $ddp = Data::Printer::Object->new( colored => 0, class => { inherited => 'none', universal => 1 } ); is( $ddp->parse($obj_with_isa), 'Meep { parents: Foo, Baz linear @ISA: Meep, Foo, Bar, Baz, UNIVERSAL public methods (0) private methods (0) internals: { test 42 } }', 'testing objects with @ISA and no inheritance but with universal' ); }; $ddp = Data::Printer::Object->new( colored => 0, class => { linear_isa => 0, inherited => 'none' } ); is( $ddp->parse($obj_with_isa), 'Meep { parents: Foo, Baz public methods (0) private methods (0) internals: { test 42 } }', 'testing objects with @ISA, opting out the @ISA' ); $ddp = Data::Printer::Object->new( colored => 0 ); my $parentless = ParentLess->new; is( $ddp->parse($parentless), 'ParentLess { public methods (1): new private methods (0) internals: {} }', 'testing parentless object' ); $ddp = Data::Printer::Object->new( colored => 0 ); my $scalar_obj = FooScalar->new; is( $ddp->parse($scalar_obj), 'FooScalar { public methods (2): foo, new private methods (0) internals: 42 }', 'testing blessed scalar' ); $ddp = Data::Printer::Object->new( colored => 0, class => { show_reftype => 1 } ); is( $ddp->parse($scalar_obj), 'FooScalar (SCALAR) { public methods (2): foo, new private methods (0) internals: 42 }', 'testing blessed scalar with reftype' ); $ddp = Data::Printer::Object->new( colored => 0 ); my $array_obj = FooArray->new; is( $ddp->parse($array_obj), 'FooArray { public methods (2): foo, new private methods (0) internals: [] }', 'testing blessed array' ); $ddp = Data::Printer::Object->new( colored => 0 ); my $code_obj = FooCode->new; is( $ddp->parse($code_obj), 'FooCode { public methods (2): foo, new private methods (0) internals: sub { ... } }', 'testing blessed code' ); $ddp = Data::Printer::Object->new( colored => 0 ); my $str_overload = ICanHazStringOverload->new; is( $ddp->parse($str_overload), 'le string of le object (ICanHazStringOverload)', 'object with string overload' ); my $num_overload = ICanHazNumberOverload->new; is( $ddp->parse($num_overload), '42 (ICanHazNumberOverload)', 'object with number overload' ); my $child_overload = ChildOfOverload->new; is( $ddp->parse($child_overload), '42 (ChildOfOverload)', 'object with inherited overload' ); my $unrelated = UnrelatedOverload->new; is( $ddp->parse($unrelated), 'UnrelatedOverload { public methods (1): new private methods (0) overloads: +, < internals: {} }', 'object with different overload (should not stringify - lines inheritance)' ); $ddp = Data::Printer::Object->new( colored => 0, class => { format_inheritance => 'string' } ); is( $ddp->parse($unrelated), 'UnrelatedOverload { public methods (1): new private methods (0) overloads: +, < internals: {} }', 'object with different overload (should not stringify - string inheritance)' ); $ddp = Data::Printer::Object->new( colored => 0, class => { show_overloads => 0 } ); is( $ddp->parse($unrelated), 'UnrelatedOverload { public methods (1): new private methods (0) internals: {} }', 'object with different overload (not showing overloads)' ); $ddp = Data::Printer::Object->new( colored => 0 ); is( $ddp->parse( ICanHazStringMethodOne->new ), 'number one! (ICanHazStringMethodOne)', 'object with as_string and stringify (prefer as_string)' ); is( $ddp->parse( ICanHazStringMethodTwo->new ), 'second! (ICanHazStringMethodTwo)', 'object with stringify' ); $ddp = Data::Printer::Object->new( colored => 0, class => { stringify => 0 } ); is( $ddp->parse( ICanHazStringMethodTwo->new ), 'ICanHazStringMethodTwo { public methods (2): new, stringify private methods (0) internals: {} }', 'object with stringify => 0 expands normally' ); my $xs_code = <<'EOXS'; package MyDDPXSClass; use Class::XSAccessor constructor => 'new', accessors => { foo => 'foo', bar => 'bar', _private_from_parent => '_private_from_parent', }; sub meep { 42 } sub muup { 33 } 1; package MyDDPXSChild; use base 'MyDDPXSClass'; use Class::XSAccessor accessors => { meep => 'meep', moop => 'moop', _priv => '_priv' }; 1; 1; EOXS SKIP: { skip 'Class::XSAccessor not available to test XS inheritance', 1 unless eval "$xs_code"; package main; my $obj = MyDDPXSChild->new( meep => 12, bar => 'test' ); my $ddp = Data::Printer::Object->new( colored => 0, class => { inherited => 'all' } ); is( $ddp->parse($obj), 'MyDDPXSChild { parents: MyDDPXSClass public methods (6): meep, moop MyDDPXSClass: bar, foo, muup, new private methods (2): _priv MyDDPXSClass: _private_from_parent internals: { bar "test", meep 12 } }', 'proper introspection of XS object'); }; Data-Printer-1.002001/t/999-themes.t0000644000000000000000000001211714552015171015175 0ustar rootrootuse strict; use warnings; use Test::More tests => 41; use Data::Printer::Theme; test_basic_load(); test_invalid_load(); test_color_override(); test_invalid_colors(); test_color_level_downgrade(); exit; sub test_invalid_colors { my @invalids = ( {}, 'rgb(256,255,255)', 'rgb(255,256,255)', 'rgb(255,255,256)', 'rgb(-1,0,0)', 'rgb(0,-1,0)', 'rgb(0,0,-1)', '#AABBCCDD', '#eeffgg', 'green on_some_bizarre_color', 'another_weird_color', ); my $i = 0; require Data::Printer::Common; no warnings 'redefine'; *Data::Printer::Common::_warn = sub { my (undef, $message) = @_; like $message, qr/invalid color/, "invalid color '$invalids[$i]'"; }; while ($i < @invalids) { my $theme = Data::Printer::Theme->new( name => 'Material', color_overrides => { string => $invalids[$i] }, color_level => 3, ); $i++; } } sub test_color_override { ok my $theme = Data::Printer::Theme->new( name => 'Material', color_level => 3, color_overrides => { array => 'rgb(55,100,80)', hash => '#B2CCD6', string => "\e[0;38;2m", number => 'bright_green on_yellow', empty => '', } ), 'able to load theme with customization'; is $theme->name, 'Material', 'customized theme keeps its name'; is $theme->customized, 1, 'customized flag is set'; is $theme->color_for('array'), 'rgb(55,100,80)', 'custom color for array'; is $theme->color_for('hash'), '#B2CCD6', 'custom color for hash'; is $theme->color_for('string'), "\e[0;38;2m", 'custom color for string'; is $theme->color_for('number'), 'bright_green on_yellow', 'custom color for number'; is $theme->sgr_color_for('this is an invalid tag'), undef, 'invalid tag'; is $theme->sgr_color_for('empty'), '', 'empty tag'; my $sgr = $theme->sgr_color_for('array'); $sgr =~ s{\e}{\\e}; is $sgr, '\e[0;38;2;55;100;80m', 'custom SGR for array'; $sgr = $theme->sgr_color_for('hash'); $sgr =~ s{\e}{\\e}; is $sgr, '\e[0;38;2;178;204;214m', 'custom SGR for hash'; $sgr = $theme->sgr_color_for('string'); $sgr =~ s{\e}{\\e}; is $sgr, '\e[0;38;2m', 'custom SGR for string'; $sgr = $theme->sgr_color_for('number'); $sgr =~ s{\e}{\\e}; is $sgr, '\e[92;43m', 'custom SGR for number'; $sgr = $theme->sgr_color_for('class'); $sgr =~ s{\e}{\\e}; is $sgr, '\e[0;38;2;199;146;234m', 'original SGR for class color unchanged'; } sub test_basic_load { ok my $theme = Data::Printer::Theme->new( name => 'Material', color_level => 3, ), 'able to load default theme'; isa_ok $theme, 'Data::Printer::Theme'; can_ok $theme, qw(new name customized color_reset color_for sgr_color_for); is $theme->name, 'Material', 'got the right theme'; is $theme->customized, 0, 'customized flag not set'; is $theme->color_for('array'), '#A1BBC5', 'fetched original color'; my $sgr = $theme->sgr_color_for('array'); $sgr =~ s{\e}{\\e}; is $sgr, '\e[0;38;2;161;187;197m', 'fetched SGR variant for array color'; $sgr = $theme->sgr_color_for('class'); $sgr =~ s{\e}{\\e}; is $sgr, '\e[0;38;2;199;146;234m', 'fetched SGR variant for class color'; $theme = Data::Printer::Theme->new(name => 'Monokai', color_level => 3); is $theme->name, 'Monokai', 'able to load Monokai theme'; $theme = Data::Printer::Theme->new(name => 'Solarized', color_level => 3); is $theme->name, 'Solarized', 'able to load Solarized theme'; $theme = Data::Printer::Theme->new(name => 'Classic', color_level => 3); is $theme->name, 'Classic', 'able to load Classic theme'; } package Data::Printer::Theme::InvalidTheme; sub colors { return [] } package main; sub test_invalid_load { my $warning; require Data::Printer::Common; no warnings 'redefine'; *Data::Printer::Common::_warn = sub { (undef, $warning) = @_ }; my $theme = Data::Printer::Theme->new( name => 'InvalidTheme', color_level => 3, ); is_deeply( $theme, { colors => {}, sgr_colors => {}, color_level => 3 }, 'unknown theme loads no colors' ); like($warning, qr/error loading theme 'InvalidTheme'/, 'got right warning message (1)'); undef $warning; undef $theme; $INC{'Data/Printer/Theme/InvalidTheme.pm'} = 'mock loaded, make use/require pass'; $theme = Data::Printer::Theme->new( name => 'InvalidTheme', color_level => 3, ); is_deeply $theme, { color_level => 3, colors => {}, sgr_colors => {} }, 'invalid theme loads no colors'; like($warning, qr/error loading theme 'InvalidTheme'/, 'got right warning message (2)'); } sub test_color_level_downgrade { my $theme = Data::Printer::Theme->new( name => 'Material', color_level => 2, ); my $reduced = Data::Printer::Theme::_rgb2short(0x79,0x86,0xcb); is $reduced, 104, '(r,g,b) downgrade to 256 colors'; } Data-Printer-1.002001/t/015-multiline.t0000644000000000000000000000046114552015171015664 0ustar rootrootuse strict; use warnings; use Test::More tests => 1; use Data::Printer::Object; my $data = [ 1, 2, { foo => 3, bar => 4 } ]; push @$data, $data->[2]; my $ddp = Data::Printer::Object->new( colored => 0, multiline => 0 ); is( $ddp->parse($data), '[ 1, 2, { bar:4, foo:3 }, var[2] ]', 'single line dump'); Data-Printer-1.002001/t/017-rc_file.t0000644000000000000000000002361314552015171015273 0ustar rootrootuse strict; use warnings; use Test::More tests => 39; use Data::Printer::Config; use Data::Printer::Common; my $good_content = <<'EOTEXT'; # some comment # another comment whatever = Something Interesting answer = 42 class.data.may.be.deep = 0 but true class.data.may.not = 1 class.simple = bla ; and ; some more comments filters = Foo, Bar spaced1 = ' ' spaced2 = ' " ' spaced3 = " " spaced4 = " ' " [Some::Module] meep = moop filters = Meep [Other::Module] hard.times = come.easy filters = [Module::With::CustomFilter] option = val begin filter MockObj return ($ddp, $obj, 'ok!'); end filter EOTEXT my $expected = { _ => { answer => 42, spaced1 => q( ), spaced2 => q( " ), spaced3 => q( ), spaced4 => q( ' ), whatever => 'Something Interesting', class => { simple => 'bla', data => { may => { not => 1, be => { deep => '0 but true', } } } }, filters => ['Foo', 'Bar'], }, 'Some::Module' => { meep => 'moop', filters => ['Meep'] }, 'Other::Module' => { hard => { times => 'come.easy' }, filters => [] }, 'Module::With::CustomFilter' => { option => 'val', filters => [{ MockObj => sub {}}] } }; my $warn_count = 0; { no warnings 'redefine'; *Data::Printer::Common::_warn = sub { my (undef, $message) = @_; $warn_count++; like $message, qr/ignored filter 'MockObj' from rc file/, 'skip filters on permissive rc files'; } } my $data = Data::Printer::Config::_str2data('data.rc', $good_content); is $warn_count, 1, 'warning caught due to bad filters'; is_deeply($data, { _ => { answer => 42, spaced1 => q( ), spaced2 => q( " ), spaced3 => q( ), spaced4 => q( ' ), whatever => 'Something Interesting', class => { simple => 'bla', data => { may => { not => 1, be => { deep => '0 but true', } } } }, filters => ['Foo', 'Bar'], }, 'Some::Module' => { meep => 'moop', filters => ['Meep'] }, 'Other::Module' => { hard => { times => 'come.easy' }, filters => [] }, 'Module::With::CustomFilter' => { option => 'val' } }, 'filter was properly ignored'); { no warnings 'redefine'; *Data::Printer::Config::_file_mode_is_restricted = sub { 1 }; } $warn_count = 0; $data = Data::Printer::Config::_str2data('data.rc', $good_content); is $warn_count, 0, 'no new warnings caught'; ok exists $data->{'Module::With::CustomFilter'}{filters}[0]{MockObj}, 'parsed MockObj'; is ref $data->{'Module::With::CustomFilter'}{filters}[0]{MockObj}, 'CODE', 'subref was set.'; ok my @filter_ret = $data->{'Module::With::CustomFilter'}{filters}[0]{MockObj}->(123, 456), 'able to call filter function'; is_deeply(\@filter_ret, [456, 123, 'ok!'], 'variables and code properly set!'); $expected->{'Module::With::CustomFilter'}{filters}[0]{MockObj} = $data->{'Module::With::CustomFilter'}{filters}[0]{MockObj}; is_deeply($data, $expected, 'parsed rc file'); { no warnings 'redefine'; *Data::Printer::Common::_warn = sub { my (undef, $message) = @_; $warn_count++; if ($warn_count == 1) { like $message, qr/error reading rc file/, 'message about parse error found'; } else { like $message, qr/RC file format changed in/, 'helper message found'; } }; } my $bad_content = <<'EOLEGACY'; { foo => 123 } EOLEGACY my $data2 = Data::Printer::Config::_str2data('data.rc', $bad_content); is_deeply($data2, {}, 'parse error returns valid structure'); is $warn_count, 2, 'parse error issues warnings'; $warn_count = 0; $bad_content = <<'EODOUBLEBEGIN'; begin filter lala begin filter lele end filter lele end filter lala EODOUBLEBEGIN my $double_begin = Data::Printer::Config::_str2data('data.rc', $bad_content); is_deeply($double_begin, {}, 'double begin returns valid structure'); is $warn_count, 1, 'double begin issues warnings'; $warn_count = 0; SKIP: { my $dir = Data::Printer::Config::_my_home('testing'); skip "unable to create temp dir", 22 unless $dir && -d $dir; require File::Spec; my $filename = File::Spec->catfile($dir, '.dataprinter'); my $error = Data::Printer::Common::_tryme(sub { open my $fh, '>', $filename or die "error creating test rc file $filename: $!"; print $fh $good_content or die "error writing to test rc file $filename: $!"; return 1; }); skip $error, 22 if $error; my $data_from_rc = Data::Printer::Config::load_rc_file($filename); $expected->{'Module::With::CustomFilter'}{filters}[0]{MockObj} = $data_from_rc->{'Module::With::CustomFilter'}{filters}[0]{MockObj}; is_deeply($data_from_rc, $expected, 'loaded rc file'); is $warn_count, 0, 'no warnings after proper rc file'; { local %ENV = %ENV; $ENV{DATAPRINTERRC} = $filename; { no warnings 'redefine'; *Data::Printer::Config::_project_home = sub { fail '(project) should never be reached'; die }; *Data::Printer::Config::_my_home = sub { fail '(home) should never be reached'; die }; } my $data_from_env = Data::Printer::Config::load_rc_file(); is $warn_count, 0, 'no warnings after proper rc loaded from env'; ok exists $data_from_env->{'Module::With::CustomFilter'}{filters}[0]{MockObj}, 'parsed MockObj'; is ref $data_from_env->{'Module::With::CustomFilter'}{filters}[0]{MockObj}, 'CODE', 'subref was set.'; $expected->{'Module::With::CustomFilter'}{filters}[0]{MockObj} = $data_from_env->{'Module::With::CustomFilter'}{filters}[0]{MockObj}; is_deeply($data_from_env, $expected, 'loaded rc file from ENV'); delete $ENV{DATAPRINTERRC}; my $found_me = 0; { no warnings 'redefine'; *Data::Printer::Config::_project_home = sub { $found_me = 1; return File::Spec->catdir($dir, 'lala') }; } my $data_from_project = Data::Printer::Config::load_rc_file(); is $found_me, 1, 'overriden project dir was found'; is $warn_count, 0, 'no warnings after rc loaded from project home'; ok exists $data_from_project->{'Module::With::CustomFilter'}{filters}[0]{MockObj}, 'parsed MockObj'; is ref $data_from_project->{'Module::With::CustomFilter'}{filters}[0]{MockObj}, 'CODE', 'subref was set.'; $expected->{'Module::With::CustomFilter'}{filters}[0]{MockObj} = $data_from_project->{'Module::With::CustomFilter'}{filters}[0]{MockObj}; is_deeply($data_from_project, $expected, 'loaded rc file from (custom) project dir'); $found_me = 0; { no warnings 'redefine'; *Data::Printer::Config::_project_home = sub { return; }; *Data::Printer::Config::_my_home = sub { $found_me = 1; return $dir }; } my $data_from_home = Data::Printer::Config::load_rc_file(); is $found_me, 1, 'overriden homedir was found'; is $warn_count, 0, 'no warnings after rc loaded from project home'; ok exists $data_from_home->{'Module::With::CustomFilter'}{filters}[0]{MockObj}, 'parsed MockObj'; is ref $data_from_home->{'Module::With::CustomFilter'}{filters}[0]{MockObj}, 'CODE', 'subref was set.'; $expected->{'Module::With::CustomFilter'}{filters}[0]{MockObj} = $data_from_home->{'Module::With::CustomFilter'}{filters}[0]{MockObj}; is_deeply($data_from_home, $expected, 'loaded rc file from (custom) home'); } $error = Data::Printer::Common::_tryme(sub { Data::Printer::Config::convert(); }); like $error, qr/please provide a .dataprinter file path/, 'convert() with no file'; $error = Data::Printer::Common::_tryme(sub { Data::Printer::Config::convert($dir); }); like $error, qr/file '\Q$dir\E' not found/, 'convert() with dir, not file'; $error = Data::Printer::Common::_tryme(sub { open my $fh, '>', $filename or die "error creating test rc file $filename: $!"; print $fh '1' or die "error writing to test rc file $filename: $!"; return 1; }); skip $error, 4 if $error; $error = Data::Printer::Common::_tryme(sub { Data::Printer::Config::convert($filename); }); like $error, qr/config file must return a hash reference/, 'convert() with file not returning hash reference'; my $content_to_convert = <<'EOCONTENT'; { foo => 1, bar => 'bla', outer => { inner => { further => 'hello!' }, greeting => 'hej hej', other => sub { return 1 }, }, color => { number => 'cyan' }, filters => { -external => ['Something'], SCALAR => sub { 1 }, }, } EOCONTENT my @warn_messages; {no warnings 'redefine'; *Data::Printer::Common::_warn = sub { push @warn_messages, $_[1]; }; }; $error = Data::Printer::Common::_tryme(sub { open my $fh, '>', $filename or die "error creating test rc file $filename: $!"; print $fh $content_to_convert or die "error writing to test rc file $filename: $!"; return 1; }); #### skip $error, 4 if $error; my $converted; $error = Data::Printer::Common::_tryme(sub { $converted = Data::Printer::Config::convert($filename); }); is @warn_messages, 2, 'two warnings generated'; like $warn_messages[0], qr/path 'filters.SCALAR': expected scalar, found/, 'proper warning for filter subref'; like $warn_messages[1], qr/path 'outer.other': expected scalar, found/, 'proper warning for subref'; my $expected_conversion = <<'EOCONFIG'; bar = bla colors.number = cyan filters = Something foo = 1 outer.greeting = 'hej hej' outer.inner.further = hello! EOCONFIG is $converted, $expected_conversion, 'rc file converted successfully'; }; Data-Printer-1.002001/t/022-no_prototypes.t0000644000000000000000000000263614552015171016612 0ustar rootrootuse strict; use warnings; use Test::More tests => 7; use Scalar::Util; BEGIN { use Data::Printer::Config; no warnings 'redefine'; *Data::Printer::Config::load_rc_file = sub { {} }; }; use Data::Printer colored => 0, return_value => 'dump', use_prototypes => 0; is p(\"test"), '"test" (read-only)', 'scalar without prototype check'; my $undef; is p($undef), 'undef', 'undef scalar (no ref exception) without prototype check'; is p( { foo => 42 } ), '{ foo 42 }', 'hash without prototype check'; is p( [ 1, 2 ] ), '[ [0] 1, [1] 2 ]', 'array without prototype check'; DDPTestOther::test_no_prototypes_on_pass(); exit; package # hide from pause DDPTestOther; use Data::Printer colored => 0, return_value => 'pass'; use Test::More; sub test_no_prototypes_on_pass { SKIP: { my $has_capture_tiny = eval { require Capture::Tiny; 1; }; skip 'Capture::Tiny not found', 3 unless $has_capture_tiny; my $val = 123; my $ret; my ($stdout, $stderr) = Capture::Tiny::capture( sub { $ret = p($val, return_value => 'pass'); 1; }); is $ret, $val, 'pass works without prototypes'; is $stdout, '', 'pass STDOUT works without prototypes'; is $stderr, "123\n", 'pass STDERR works without prototypes'; }; } Data-Printer-1.002001/t/101-filter_db.t0000644000000000000000000003514614552015171015620 0ustar rootrootuse strict; use warnings; use Test::More tests => 24; use Data::Printer::Object; test_dbi(); test_dbic(); sub test_dbi { SKIP: { my $dbh; skip 'DBI not available', 8 unless eval 'use DBI; 1'; skip 'unable to test DBI', 8 unless eval { $dbh = DBI->connect('dbi:Mem(RaiseError=1):'); 1; }; diag('filter tests for DBI ' . $DBI::VERSION); my $ddp = Data::Printer::Object->new( colored => 0, filters => ['DB'], ); is( $ddp->parse($dbh), 'Mem Database Handle (connected) { Auto Commit: 1 Statement Handles: 0 Last Statement: - }', 'DBH output' ); my $sth = $dbh->prepare('CREATE TABLE foo ( bar TEXT, baz TEXT )'); is( $ddp->parse($dbh), 'Mem Database Handle (connected) { Auto Commit: 1 Statement Handles: 1 (0 active) Last Statement: CREATE TABLE foo ( bar TEXT, baz TEXT ) }', 'DBH output (after setting statement)' ); is( $ddp->parse($sth), 'CREATE TABLE foo ( bar TEXT, baz TEXT )', 'STH output (before execute)' ); skip 'error running query', 5 unless eval { $sth->execute; 1 }; is( $ddp->parse($sth), 'CREATE TABLE foo ( bar TEXT, baz TEXT )', 'STH output (after execute)' ); my $sth2 = $dbh->prepare('SELECT * FROM foo WHERE bar = ?'); is( $ddp->parse($dbh), 'Mem Database Handle (connected) { Auto Commit: 1 Statement Handles: 2 (0 active) Last Statement: SELECT * FROM foo WHERE bar = ? }', 'DBH output (after new statement)' ); $sth2->execute(42); is( $ddp->parse($sth2), 'SELECT * FROM foo WHERE bar = ? (bindings unavailable)', 'STH-2 output' ); is( $ddp->parse($dbh), 'Mem Database Handle (connected) { Auto Commit: 1 Statement Handles: 2 (1 active) Last Statement: SELECT * FROM foo WHERE bar = ? }', 'DBH output (after executing new statement)' ); undef $sth; $dbh->disconnect; is( $ddp->parse($dbh), 'Mem Database Handle (disconnected) { Auto Commit: 1 Statement Handles: 1 (1 active) Last Statement: SELECT * FROM foo WHERE bar = ? }', 'DBH output (after disconnecting and undefining sth)' ); }; } sub test_dbic { my $packages = <<'EOPACKAGES'; package MyDDPTest::Schema::Result::User; use strict; use warnings; use base 'DBIx::Class::Core'; __PACKAGE__->load_components('InflateColumn::DateTime'); __PACKAGE__->table('user'); __PACKAGE__->add_columns( user_id => { data_type => 'integer', is_nullable => 0, is_numeric => 1, is_auto_increment => 1, }, identity => { data_type => 'integer' }, email => { data_type => 'varchar', size => 50, default_value => 'a@b.com' }, city => { data_type => 'varchar', size => 10 }, state => { data_type => 'varchar', size => 3 }, code1 => { data_type => 'decimal', size => [8,2] }, created => { data_type => 'datetime', is_nullable => 1 }, ); __PACKAGE__->set_primary_key('user_id'); __PACKAGE__->add_unique_constraint(['email']); __PACKAGE__->has_many( pets => 'MyDDPTest::Schema::Result::Pet' ); sub do_something {} 1; package MyDDPTest::Schema::Result::BadSize; use strict; use warnings; use base 'DBIx::Class::Core'; __PACKAGE__->table('bad_size'); __PACKAGE__->add_columns( foo => { data_type => 'varchar(2)', size => 3 }, ); 1; package MyDDPTest::Schema::Result::Pet; use strict; use warnings; use base 'DBIx::Class::Core'; __PACKAGE__->table('pet'); __PACKAGE__->add_columns( name => { data_type => 'varchar(10)', is_nullable => 0 }, size => { data_type => 'integer', default_value => 10 }, user => { data_type => 'integer', is_nullable => 1 }, ); __PACKAGE__->set_primary_key('name', 'size'); __PACKAGE__->belongs_to( user => 'MyDDPTest::Schema::Result::User' ); sub sleep {} sub _nap {} 1; package MyDDPTest::Schema::Result::BigPet; use strict; use warnings; use base 'DBIx::Class::Core'; __PACKAGE__->table_class('DBIx::Class::ResultSource::View'); __PACKAGE__->table('bigpet'); __PACKAGE__->result_source_instance->is_virtual(1); __PACKAGE__->result_source_instance->view_definition( 'SELECT name,size from pet where size > 10' ); __PACKAGE__->add_columns(qw(name size)); sub my_virtual_sub {} 1; package MyDDPTest::Schema; use strict; use warnings; use base 'DBIx::Class::Schema'; 1; EOPACKAGES SKIP: { skip 'DBD::SQLite not available', 16 unless eval "use DBD::SQLite; 1"; skip 'DBIx::Class not available', 16 unless eval "$packages"; diag('filter tests for DBIC ' . $DBIx::Class::VERSION . ' and DBD::SQLite ' . $DBD::SQLite::VERSION); package main; my $schema; skip 'could not connect with DBIx::Class + SQLite: '. $@, 16, unless eval { MyDDPTest::Schema->load_classes({ 'MyDDPTest::Schema::Result' => [qw(Pet BigPet User)] }); $schema = MyDDPTest::Schema->connect( 'dbi:SQLite(RaiseError=1):dbname=:memory:' ); $schema->deploy({ add_drop_table => 0, add_fk_index => 0 }); $schema->load_classes({ 'MyDDPTest::Schema::Result' => ['BadSize'] }); 1; }; my $ddp = Data::Printer::Object->new( colored => 0, filters => ['DB'], ); my $dbh = $schema->storage->dbh; # <-- force connection; my $last_statement = $dbh->{Statement} || '-'; is( $ddp->parse($schema), 'MyDDPTest::Schema { connection: SQLite Database Handle (connected) loaded sources: BadSize, BigPet, Pet, User }', 'basic schema dump' ); $ddp = Data::Printer::Object->new( colored => 0, filters => ['DB'], filter_db => { schema => { show_handle => 1 } } ); is( $ddp->parse($schema), 'MyDDPTest::Schema { connection: SQLite Database Handle (connected) { dbname: :memory: Auto Commit: 1 Statement Handles: 0 Last Statement: ' . $last_statement . ' } loaded sources: BadSize, BigPet, Pet, User }', 'schema dump with show_handle' ); $ddp = Data::Printer::Object->new( colored => 0, filters => ['DB'], filter_db => { schema => { loaded_sources => 'none' } } ); is( $ddp->parse($schema), 'MyDDPTest::Schema { connection: SQLite Database Handle (connected) }', 'schema dump with loaded_sources => none' ); $ddp = Data::Printer::Object->new( colored => 0, filters => ['DB'], filter_db => { schema => { expand => 0 } } ); is( $ddp->parse($schema), 'MyDDPTest::Schema (SQLite - connected)', 'schema dump with expand => 0' ); $ddp = Data::Printer::Object->new( colored => 0, filters => ['DB'], filter_db => { schema => { show_handle => 0, loaded_sources => 'details' } } ); is( $ddp->parse($schema), q|MyDDPTest::Schema { connection: SQLite Database Handle (connected) loaded sources: BadSize ResultSource { table: "bad_size" columns: foo varchar(2) (meta size as 3) }, BigPet ResultSource (Virtual View) { table: "bigpet" columns: name (unknown data type), size (unknown data type) }, Pet ResultSource { table: "pet" columns: name varchar(10) not null (primary), size integer default 10 (primary), user integer null }, User ResultSource { table: "user" columns: user_id integer not null auto_increment (primary), city varchar(10), code1 decimal(8,2), created datetime null, email varchar(50) default "a@b.com", identity integer, state varchar(3) non-primary uniques: (email) as 'user_email' } }|, 'schema dump with loaded_sources => details' ); $ddp = Data::Printer::Object->new( colored => 0, filters => ['DB'], filter_db => { schema => { show_handle => 0, loaded_sources => 'details' }, column_info => 'names', } ); is( $ddp->parse($schema), q|MyDDPTest::Schema { connection: SQLite Database Handle (connected) loaded sources: BadSize ResultSource { table: "bad_size" columns: foo }, BigPet ResultSource (Virtual View) { table: "bigpet" columns: name, size }, Pet ResultSource { table: "pet" columns: name (primary), size (primary), user }, User ResultSource { table: "user" columns: user_id (primary), city, code1, created, email, identity, state non-primary uniques: (email) as 'user_email' } }|, 'schema dump with loaded_sources => details and column_info => names' ); my $user_source = $schema->source('User'); $ddp = Data::Printer::Object->new( colored => 0, filters => ['DB'], ); is ($ddp->parse($user_source), q|User ResultSource { table: "user" columns: user_id integer not null auto_increment (primary), city varchar(10), code1 decimal(8,2), created datetime null, email varchar(50) default "a@b.com", identity integer, state varchar(3) non-primary uniques: (email) as 'user_email' }|, 'single ResultSource dump' ); my $rs = $schema->resultset('User'); $ddp = Data::Printer::Object->new( colored => 0, filters => ['DB'], ); is ($ddp->parse($rs), 'User ResultSet { current search parameters: - as query: (SELECT me.user_id, me.identity, me.email, me.city, me.state, me.code1, me.created FROM user me) }', 'empty resultset'); my $db_user = $rs->new({ identity => 123, email => 'test@example.com', city => 'berlin', state => 'xx', code1 => 12.3, created => undef, }); $ddp = Data::Printer::Object->new( colored => 0, filters => ['DB'], ); is ($ddp->parse($rs), 'User ResultSet { current search parameters: - as query: (SELECT me.user_id, me.identity, me.email, me.city, me.state, me.code1, me.created FROM user me) }', 'still empty after creation'); is($ddp->parse($db_user), 'User Row (NOT in storage) { city: "berlin" code1: 12.3 created: undef email: "test@example.com" identity: 123 state: "xx" }', 'db user after new() NOT in storage and no user_id '); $db_user->insert; is ($ddp->parse($db_user), 'User Row (in storage) { city: "berlin" code1: 12.3 created: undef email: "test@example.com" identity: 123 state: "xx" user_id: 1 }', 'db user after insert'); $ddp = Data::Printer::Object->new( colored => 0, filters => ['DB'], ); $db_user->city('rio'); is ($ddp->parse($db_user), 'User Row (in storage) { city: "rio" (updated) code1: 12.3 created: undef email: "test@example.com" identity: 123 state: "xx" user_id: 1 }', 'dirty db user'); $db_user->update; is ($ddp->parse($db_user), 'User Row (in storage) { city: "rio" code1: 12.3 created: undef email: "test@example.com" identity: 123 state: "xx" user_id: 1 }', 'updated db user'); $rs = $rs->search( { 'email' => { like => 'foo%' }, 'state' => ['CA','NY'], 'pets.name' => { -in => [qw(Rex Mewmew)] }, }, { '+select' => ['pets.name'], '+as' => ['pet_name'], join => ['pets'], order_by => { -desc => ['city'] } } ); $ddp = Data::Printer::Object->new( colored => 0, filters => ['DB'], ); like ($ddp->parse($rs), qr|\A\QUser ResultSet { current search parameters: { email { like "foo%" }, pets.name { -in [ [0] "Rex", [1] "Mewmew" ] }, state [ [0] "CA", [1] "NY" ] } as query: (SELECT me.user_id, me.identity, me.email, me.city, me.state, me.code1, me.created, pets.name FROM user me LEFT JOIN pet pets ON pets.user = me.user_id WHERE ( ( email LIKE ? AND pets.name IN ( ?, ? ) AND ( state = ? OR state = ? ) ) )\E\s+\QORDER BY city DESC) foo% (varchar) Rex (varchar(10)) Mewmew (varchar(10)) CA (varchar) NY (varchar) }\E\z|, 'resultset with search'); my $from_db = $schema->resultset('User')->search( { user_id => 1 }, { '+select' => [ { LENGTH => 'identity', -as => 'meep' } ], '+as' => ['length_test'], } )->single; $ddp = Data::Printer::Object->new( colored => 0, filters => ['DB'], ); my $code1 = $from_db->code1; # OpenBSD sometimes says 12.3000000000000007 is ($ddp->parse($from_db), qq(User Row (in storage) { city: "rio" code1: $code1 created: undef email: "test\@example.com" identity: 123 length_test: 3 (extra) state: "xx" user_id: 1 }), 'db entry with extra col'); # TODO: test some ->all() with prefetch # my $arrayrefref = $schema->resultset('User')->search(\[ 'email REGEXP ?' => 'gmail']); is ($ddp->parse($arrayrefref), 'User ResultSet { current search parameters: [ [0] "email REGEXP ?", [1] "gmail" ] as query: (SELECT me.user_id, me.identity, me.email, me.city, me.state, me.code1, me.created FROM user me WHERE ( email REGEXP ? )) gmail }', 'literal sql with bind params'); }; } Data-Printer-1.002001/xt/0000755000000000000000000000000014552072607013370 5ustar rootrootData-Printer-1.002001/xt/whitespaces.t0000644000000000000000000000060414552015171016065 0ustar rootrootuse strict; use warnings; my $success = eval { require Test::Whitespaces; }; if ($success) { Test::Whitespaces->import({ dirs => [ qw( examples lib t ) ], }); 1; } else { require Test::More; Test::More->import; Test::More::plan(skip_all => 'Test::Whitespaces not found'); } Data-Printer-1.002001/xt/pod.t0000644000000000000000000000026614552015171014334 0ustar rootrootuse strict; use warnings; use Test::More; my $success = eval "use Test::Pod 1.41; 1"; if ($success) { all_pod_files_ok(); } else { plan skip_all => 'Test::Pod not found'; } Data-Printer-1.002001/xt/pod-coverage.t0000644000000000000000000000150214552015171016117 0ustar rootrootuse strict; use warnings; use Test::More; my $success = eval "use Test::Pod::Coverage 1.04; 1"; if ($success) { plan tests => 18; foreach my $m (grep $_ !~ /(?:SCALAR|LVALUE|ARRAY|CODE|VSTRING|REF|GLOB|HASH|FORMAT|OBJECT|GenericClass|Regexp|Common)\z/, all_modules()) { my $params = {}; if ($m =~ /\AData::Printer::Theme::/) { $params = { also_private => [qr/\Acolors\z/] }; } elsif ($m =~ /\AData::Printer::Profile::/) { $params = { also_private => [qr/\Aprofile\z/] }; } elsif ($m eq 'Data::Printer::Theme') { $params = { also_private => [qw(new name customized color_for sgr_color_for color_reset)] }; } pod_coverage_ok($m, $params, "$m is covered"); } } else { plan skip_all => 'Test::Pod::Coverage not found'; } Data-Printer-1.002001/xt/changes.t0000644000000000000000000000020314552015171015151 0ustar rootrootuse Test::More; eval 'use Test::CPAN::Changes'; plan skip_all => 'Test::CPAN::Changes required for this test' if $@; changes_ok(); Data-Printer-1.002001/README.md0000644000000000000000000000742514552056310014215 0ustar rootrootData::Printer ============= [![Coverage Status](https://coveralls.io/repos/garu/Data-Printer/badge.png)](https://coveralls.io/r/garu/Data-Printer) [![CPAN version](https://badge.fury.io/pl/Data-Printer.png)](http://badge.fury.io/pl/Data-Printer) Data::Printer is a Perl module to *pretty-print Perl data structures and objects* in full color, in a way that is *properly formatted to be inspected by a human*. Basic Usage: ------------ ```perl my $data = get_some_data_from_somewhere(); ... use DDP; p $data; # <-- pretty-prints $data's content to STDERR ``` ![See Data::Printer in action](https://raw.githubusercontent.com/garu/Data-Printer/master/examples/ddp.gif) Main features: -------------- * Variable dumps designed for _easy parsing by the human brain_, not a machine; * _Highly customizable_, from indentation size to depth level. You can even rename the exported p() function! * Beautiful (and customizable) colors to highlight variable dumps and make issues stand-out quickly on your console. Comes bundled with several themes for you to pick. * Filters for specific data structures and objects to make debugging much, much easier. Includes filters for several popular classes from CPAN like JSON::\*, URI, HTTP::\*, LWP, Digest::\*, DBI and DBIx::Class, printing what really matters to developers debugging code. It also lets you create your own custom filters easily. * Lets you inspect information that's otherwise difficult to find/debug in Perl 5, like circular references, reference counting (refcount), weak/read-only information, even estimated data size - all to help you spot issues with your data like leaks without having to know a lot about internal data structures or install heavy-weight tools like Devel::Gladiator. * keep your custom settings on a `.dataprinter` file that allows _different options per module_ being analyzed! You may also create a custom profile class with your preferences and filters and upload it to CPAN. * output to many different targets like files, variables or open handles (defaults to STDERR). You can send your dumps to the screen or anywhere else, and customize this setting on a per-project or even per-module basis, like print everything from Some::Module to a debug.log file with extra info, and everything else to STDERR. * *Easy to learn, easy to master*. Seriously, what you already know cover about 90% of all use cases. * Works on *Perl 5.8 and later* Because you can't control where you debug, we try our best to be compatible with all versions of Perl 5. * Best of all? *No non-core dependencies*, Zero. Nada. so don't worry about adding extra weight to your project, as Data::Printer can be easily added/removed. Please refer to [Data::Printer's complete documentation](https://metacpan.org/pod/Data::Printer) for details on how to customize the output to your needs. Or (after installation) type: perldoc Data::Printer To view the complete docs on your terminal. Installation ------------ To install this module via cpanm: > cpanm Data::Printer Or, at the cpan shell: cpan> install Data::Printer If you wish to install it manually, download and unpack the tarball and run the following commands: perl Makefile.PL make make test make install Of course, instead of downloading the tarball you may simply clone the git repository: $ git clone git://github.com/garu/Data-Printer.git Thank you for using Data::Printer! Please let me know of potential issues, bugs and wishlists :) LICENSE AND COPYRIGHT --------------------- Copyright (C) 2011-2024 Breno G. de Oliveira This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License. See http://dev.perl.org/licenses/ for more information. Data-Printer-1.002001/lib/0000755000000000000000000000000014552072607013503 5ustar rootrootData-Printer-1.002001/lib/DDP.pm0000644000000000000000000000104314552072424014443 0ustar rootrootpackage DDP; use strict; use warnings; use Data::Printer; BEGIN { push our @ISA, 'Data::Printer'; our $VERSION = '1.002001'; $VERSION = eval $VERSION; } 1; __END__ =head1 NAME DDP - Data::Printer shortcut for faster debugging =head1 SYNOPSIS use DDP; p $my_data; =head1 DESCRIPTION Tired of typing C every time? C lets you quickly call your favorite variable dumper! It behaves exactly like L - it is, indeed, just an alias to it :) Happy debugging! =head1 SEE ALSO L Data-Printer-1.002001/lib/Data/0000755000000000000000000000000014552072607014354 5ustar rootrootData-Printer-1.002001/lib/Data/Printer.pm0000644000000000000000000011642714552072424016345 0ustar rootrootpackage Data::Printer; use strict; use warnings; use Data::Printer::Object; use Data::Printer::Common; use Data::Printer::Config; our $VERSION = '1.002001'; $VERSION = eval $VERSION; my $rc_arguments; my %arguments_for; sub import { my $class = shift; _initialize(); my $args; if (@_ > 0) { $args = @_ == 1 ? shift : {@_}; Data::Printer::Common::_warn( undef, 'Data::Printer can receive either a hash or a hash reference' ) unless ref $args eq 'HASH'; $args = Data::Printer::Config::_expand_profile($args) if exists $args->{profile}; } # every time you load it, we override the version from *your* caller my $caller = caller; $arguments_for{$caller} = $args; my $use_prototypes = _find_option('use_prototypes', $args, $caller, 1); my $exported = ($use_prototypes ? \&p : \&_p_without_prototypes); my $imported = _find_option('alias', $args, $caller, 'p'); { no strict 'refs'; *{"$caller\::$imported"} = $exported; *{"$caller\::np"} = \&np; } } sub _initialize { # potential race but worst case is we read it twice :) { no warnings 'redefine'; *_initialize = sub {} } my $rc_filename = Data::Printer::Config::_get_first_rc_file_available(); $rc_arguments = Data::Printer::Config::load_rc_file($rc_filename); if ( exists $rc_arguments->{'_'}{live_update} && defined $rc_arguments->{'_'}{live_update} && $rc_arguments->{'_'}{live_update} =~ /\A\d+\z/ && $rc_arguments->{'_'}{live_update} > 0) { my $now = time; my $last_mod = (stat $rc_filename)[9]; { no warnings 'redefine'; *_initialize = sub { if (time - $now > $rc_arguments->{'_'}{live_update}) { my $new_last_mod = (stat $rc_filename)[9]; if (defined $new_last_mod && $new_last_mod > $last_mod) { $now = time; $last_mod = $new_last_mod; $rc_arguments = Data::Printer::Config::load_rc_file($rc_filename); if (!exists $rc_arguments->{'_'}{live_update} || !$rc_arguments->{'_'}{live_update}) { *_initialize = sub {}; } } } }; } } } sub np (\[@$%&];%) { my (undef, %properties) = @_; _initialize(); my $caller = caller; my $args_to_use = _fetch_args_with($caller, \%properties); return '' if $args_to_use->{quiet}; my $printer = Data::Printer::Object->new($args_to_use); # force color level 0 on 'auto' colors: if ($printer->colored eq 'auto') { $printer->{_output_color_level} = 0; } my $ref = ref $_[0]; if ($ref eq 'ARRAY' || $ref eq 'HASH' || ($ref eq 'REF' && ref ${$_[0]} eq 'REF')) { $printer->{_refcount_base}++; } my $output = $printer->parse($_[0]); if ($printer->caller_message_position eq 'after') { $output .= $printer->_write_label; } else { $output = $printer->_write_label . $output; } return $output; } sub p (\[@$%&];%) { my (undef, %properties) = @_; _initialize(); my $caller = caller; my $args_to_use = _fetch_args_with($caller, \%properties); my $want_value = defined wantarray; # return as quickly as possible under 'quiet'. if ($args_to_use->{quiet}) { # we avoid creating a Data::Printer::Object instance # to speed things up, since we don't do anything under 'quiet'. my $return_type = Data::Printer::Common::_fetch_anyof( $args_to_use, 'return_value', 'pass', [qw(pass dump void)] ); return _handle_output(undef, undef, $want_value, $_[0], $return_type, 1); } my $printer = Data::Printer::Object->new($args_to_use); if ($printer->colored eq 'auto' && $printer->return_value eq 'dump' && $want_value) { $printer->{_output_color_level} = 0; } my $ref = ref $_[0]; if ($ref eq 'ARRAY' || $ref eq 'HASH' || ($ref eq 'REF' && ref ${$_[0]} eq 'REF')) { $printer->{_refcount_base}++; } my $output = $printer->parse($_[0]); if ($printer->caller_message_position eq 'after') { $output .= $printer->_write_label; } else { $output = $printer->_write_label . $output; } return _handle_output($output, $printer->{output_handle}, $want_value, $_[0], $printer->return_value, undef); } # This is a p() clone without prototypes. Just like regular Data::Dumper, # this version expects a reference as its first argument. We make a single # exception for when we only get one argument, in which case we ref it # for the user and keep going. sub _p_without_prototypes { my (undef, %properties) = @_; my $item; if (!ref $_[0] && @_ == 1) { my $item_value = $_[0]; $item = \$item_value; } _initialize(); my $caller = caller; my $args_to_use = _fetch_args_with($caller, \%properties); my $want_value = defined wantarray; # return as quickly as possible under 'quiet'. if ($args_to_use->{quiet}) { # we avoid creating a Data::Printer::Object instance # to speed things up, since we don't do anything under 'quiet'. my $return_type = Data::Printer::Common::_fetch_anyof( $args_to_use, 'return_value', 'pass', [qw(pass dump void)] ); return _handle_output(undef, undef, $want_value, $_[0], $return_type, 1); } my $printer = Data::Printer::Object->new($args_to_use); if ($printer->colored eq 'auto' && $printer->return_value eq 'dump' && $want_value) { $printer->{_output_color_level} = 0; } my $ref = ref( defined $item ? $item : $_[0] ); if ($ref eq 'ARRAY' || $ref eq 'HASH' || ($ref eq 'REF' && ref(defined $item ? $item : ${$_[0]}) eq 'REF')) { $printer->{_refcount_base}++; } my $output = $printer->parse((defined $item ? $item : $_[0])); if ($printer->caller_message_position eq 'after') { $output .= $printer->_write_label; } else { $output = $printer->_write_label . $output; } return _handle_output($output, $printer->{output_handle}, $want_value, $_[0], $printer->return_value, undef); } sub _handle_output { my ($output, $out_handle, $wantarray, $data, $return_type, $quiet) = @_; if ($return_type eq 'pass') { print { $out_handle } $output . "\n" unless $quiet; require Scalar::Util; my $ref = Scalar::Util::blessed($data); return $data if defined $ref; $ref = Scalar::Util::reftype($data); if (!$ref) { return $data; } elsif ($ref eq 'ARRAY') { return @$data; } elsif ($ref eq 'HASH') { return %$data; } elsif ( grep { $ref eq $_ } qw(REF SCALAR VSTRING) ) { return $$data; } else { return $data; } } elsif ($return_type eq 'void' || !$wantarray) { print { $out_handle} $output . "\n" unless $quiet; return; } else { return $output; } } sub _fetch_args_with { my ($caller, $run_properties) = @_; my $args_to_use = {}; if (keys %$rc_arguments) { $args_to_use = Data::Printer::Config::_merge_options( $args_to_use, $rc_arguments->{'_'} ); if (exists $rc_arguments->{$caller}) { $args_to_use = Data::Printer::Config::_merge_options( $args_to_use, $rc_arguments->{$caller} ); } } if ($arguments_for{$caller}) { $args_to_use = Data::Printer::Config::_merge_options( $args_to_use, $arguments_for{$caller} ); } if (keys %$run_properties) { $run_properties = Data::Printer::Config::_expand_profile($run_properties) if exists $run_properties->{profile}; $args_to_use = Data::Printer::Config::_merge_options( $args_to_use, $run_properties ); } return $args_to_use; } sub _find_option { my ($key, $args, $caller, $default) = @_; my $value; if (exists $args->{$key}) { $value = $args->{$key}; } elsif ( exists $rc_arguments->{$caller} && exists $rc_arguments->{$caller}{$key} ) { $value = $rc_arguments->{$caller}{$key}; } elsif (exists $rc_arguments->{'_'}{$key}) { $value = $rc_arguments->{'_'}{$key}; } else { $value = $default; } return $value; } 'Marielle, presente.'; __END__ =encoding utf8 =head1 NAME Data::Printer - colored & full-featured pretty print of Perl data structures and objects =head1 SYNOPSIS Want to see what's inside a variable in a complete, colored and human-friendly way? use DDP; # same as 'use Data::Printer' p $some_var; p $some_var, as => "This label will be printed too!"; # no need to use '\' before arrays or hashes! p @array; p %hash; # printing anonymous array references: p [ $one, $two, $three ]->@*; # perl 5.24 or later! p @{[ $one, $two, $three ]}; # same, older perls &p( [ $one, $two, $three ] ); # same, older perls # printing anonymous hash references: p { foo => $foo, bar => $bar }->%*; # perl 5.24 or later! p %{{ foo => $foo, bar => $bar }}; # same, older perls &p( { foo => $foo, bar => $bar } ); # same, older perls The snippets above will print the contents of the chosen variables to STDERR on your terminal, with colors and a few extra features to help you debug your code. If you wish to grab the output and handle it yourself, call C: my $dump = np $var; die "this is what happened: " . np %data; The C function is the same as C but will return the string containing the dump. By default it has no colors, but you can change that easily too. That's pretty much it :) =for html samples of Data::Printer output for several kinds of data and objects Data::Printer is L, even on a per-module basis! Once you figure out your own preferences, create a L<< .dataprinter configuration file|/The .dataprinter configuration file >> for yourself (or one for each project) and Data::Printer will automatically use it! =head1 FEATURES Here's what Data::Printer offers Perl developers, out of the box: =over 4 =item * Variable dumps designed for B<< easy parsing by the human brain >>, not a machine. =back =over 4 =item * B<< Highly customizable >>, from indentation size to depth level. You can even rename the exported C function! =back =over 4 =item * B<< Beautiful (and customizable) colors >> to highlight variable dumps and make issues stand-out quickly on your console. Comes bundled with L for you to pick that work on light and dark terminal backgrounds, and you can create your own as well. =back =over 4 =item * B<< L for specific data structures and objects >> to make debugging much, much easier. Includes filters for many popular classes from CPAN like JSON::*, URI, HTTP::*, LWP, Digest::*, DBI and DBIx::Class. printing what really matters to developers debugging code. It also lets you create your own custom filters easily. =back =over 4 =item * Lets you B<< inspect information that's otherwise difficult to find/debug >> in Perl 5, like circular references, reference counting (refcount), weak/read-only information, overloaded operators, tainted data, ties, dual vars, even estimated data size - all to help you spot issues with your data like leaks without having to know a lot about internal data structures or install hardcore tools like Devel::Peek and Devel::Gladiator. =back =over 4 =item * B<< Full support for dumping perl 5.38 native classes >>. =back =over 4 =item * keep your custom settings on a L<< .dataprinter|/The .dataprinter configuration file >> file that allows B<< different options per module >> being analyzed! You can have B<< one C<.dataprinter> file per project >>, or default to one in your home directory. You may also create a custom L class with your preferences and filters and upload it to CPAN. =back =over 4 =item * B<< output to many different targets >> like files, variables or open handles (defaults to STDERR). You can send your dumps to the screen or anywhere else, and customize this setting on a per-project or even per-module basis, like print everything from Some::Module to a debug.log file with extra info, and everything else to STDERR. =back =over 4 =item * B<< Easy to learn, easy to master >>. Seriously, the synopsis above and the customization section below cover about 90% of all use cases. =back =over 4 =item * Works on B<< Perl 5.8 and later >>. Because you can't control where you debug, we try our best to be compatible with all versions of Perl 5, from the oldest available to the bleeding edge. =back =over 4 =item * Best of all? All that with B<< No non-core dependencies >>, Zero. Nada. So don't worry about adding extra weight to your project, as Data::Printer can be easily added/removed. =back =head1 DESCRIPTION The ever-popular Data::Dumper is a fantastic tool, meant to stringify data structures in a way they are suitable for being "eval"'ed back in. The thing is, a lot of people keep using it (and similar ones, like Data::Dump) to print data structures and objects on screen for inspection and debugging, and while you I use those modules for that, it doesn't mean you I. This is where Data::Printer comes in. It is meant to do one thing and one thing only: I<< format Perl variables and objects to be inspected by a human >> If you want to serialize/store/restore Perl data structures, this module will NOT help you. Try Storable, Data::Dumper, JSON, or whatever. CPAN is full of such solutions! Whenever you type C or C, we export two functions to your namespace: =head2 p() This function pretty-prints the contents of whatever variable to STDERR (by default), and will use colors by default if your terminal supports it. p @some_array; p %some_hash; p $scalar_or_ref; Note that anonymous structures will only work if you postderef them: p [$foo, $bar, $baz]->@*; you may also deref it manually: p %{{ foo => $foo }}; or prefix C with C<&>: &p( [$foo, $bar, $baz] ); # & (note mandatory parenthesis) You can pass custom options that will work only on that particular call: p @var, as => "some label", colored => 0; p %var, show_memsize => 1; By default, C prints to STDERR and returns the same variable being dumped. This lets you quickly wrap variables with C without worrying about changing return values. It means that if you change this: sub foo { my $x = shift + 13; $x } to this: sub foo { my $x = shift + 13; p($x) } The function will still return C<$x> after printing the contents. This form of handling data even allows method chaining, so if you want to inspect what's going on in the middle of this: $object->foo->bar->baz; You can just add C anywhere: $object->foo->DDP::p->bar->baz; # what happens to $object after ->foo? Check out the L section below for all available options, including changing the return type, output target and a lot more. =head2 np() The C function behaves exactly like C except it always returns the string containing the dump (thus ignoring any setting regarding dump mode or destination), and contains no colors by default. In fact, the only way to force a colored C is to pass C<< colored => 1 >> as an argument to each call. It is meant to provide an easy way to fetch the dump and send it to some unsupported target, or appended to some other text (like part of a log message). =head1 CUSTOMIZATION There are 3 possible ways to customize Data::Printer: 1. B<[RECOMMENDED]> Creating a C<.dataprinter> file either on your home directory or your project's base directory, or both, or wherever you set the C environment variable to. 2. Setting custom properties on module load. This will override any setting from your config file on the namespace (package/module) it was called: use DDP max_depth => 2, deparse => 1; 3. Setting custom properties on the actual call to C or C. This overrides all other settings: p $var, show_tainted => 1, indent => 2; =head2 The .dataprinter configuration file The most powerful way to customize Data::Printer is to have a C<.dataprinter> file in your home directory or your project's root directory. The format is super simple and can be understood in the example below: # global settings (note that only full line comments are accepted) max_depth = 1 theme = Monokai class.stringify = 0 # use quotes if you want spaces to be significant: hash_separator = " => " # You can set rules that apply only to a specific # caller module (in this case, MyApp::Some::Module): [MyApp::Some::Module] max_depth = 2 class.expand = 0 escape_chars = nonlatin1 [MyApp::Other::Module] multiline = 0 output = /var/log/myapp/debug.data # use 'quiet' to silence all output from p() and np() # called from the specified package. [MyApp::Yet::Another] quiet = 1 Note that if you set custom properties as arguments to C or C, you should group suboptions as a hashref. So while the C<.dataprinter> file has "C<< class.expand = 0 >>" and "C<< class.inherited = none >>", the equivalent code is "C<< class => { expand => 0, inherited => 'none' } >>". =head3 live updating your .dataprinter without restarts Data::Printer 1.1 introduces a new 'live_update' flag that can be set to a positive integer to enable live updates. When this mode is on, Data::Printer will check if the C<.dataprinter> file has been updated and, if so, it will reload it. This way you can toggle features on and off and control output verbosity directly from your C<.dataprinter> file without needing to change or restart running code. =head2 Properties Quick Reference Below are (almost) all available properties and their (hopefully sane) default values. See L for further information on each of them: # scalar options show_tainted = 1 show_unicode = 1 show_lvalue = 1 print_escapes = 0 scalar_quotes = " escape_chars = none string_max = 4096 string_preserve = begin string_overflow = '(...skipping __SKIPPED__ chars...)' unicode_charnames = 0 # array options array_max = 100 array_preserve = begin array_overflow = '(...skipping __SKIPPED__ items...)' index = 1 # hash options hash_max = 100 hash_preserve = begin hash_overflow = '(...skipping __SKIPPED__ keys...)' hash_separator = ' ' align_hash = 1 sort_keys = 1 quote_keys = auto # general options name = var return_value = pass output = stderr use_prototypes = 1 indent = 4 show_readonly = 1 show_tied = 1 show_dualvar = lax show_weak = 1 show_refcount = 0 show_memsize = 0 memsize_unit = auto separator = , end_separator = 0 caller_info = 0 caller_message = 'Printing in line __LINE__ of __FILENAME__' max_depth = 0 deparse = 0 alias = p warnings = 1 # colorization (see Colors & Themes below) colored = auto theme = Material # object output class_method = _data_printer class.parents = 1 class.linear_isa = auto class.universal = 1 class.expand = 1 class.stringify = 1 class.show_reftype = 0 class.show_overloads = 1 class.show_methods = all class.sort_methods = 1 class.inherited = none class.format_inheritance = string class.parent_filters = 1 class.internals = 1 =head3 Settings' shortcuts =over 4 =item * B - prints a string before the dump. So: p $some_var, as => 'here!'; is a shortcut to: p $some_var, caller_info => 1, caller_message => 'here!'; =item * B - lets you create shorter dumps. By setting it to 0, we use a single space as linebreak and disable the array index. Setting it to 1 (the default) goes back to using "\n" as linebreak and restore whatever array index you had originally. =item * B - when set to 1, disables all max string/hash/array values. Use this to generate complete (full) dumps of all your content, which is trimmed by default. =item * B - when set to 1, disables all data parsing and returns as quickly as possible. Use this to disable all output from C and C inside a particular package, either from the 'use' call or from .dataprinter. (introduced in version 1.1) =back =head2 Colors & Themes Data::Printer lets you set custom colors for pretty much every part of the content being printed. For example, if you want numbers to be shown in bright green, just put C<< colors.number = #00ff00 >> on your configuration file. See L for the full list of labels, ways to represent and customize colors, and even how to group them in your own custom theme. The colorization is set by the C property. It can be set to 0 (never colorize), 1 (always colorize) or 'auto' (the default), which will colorize C only when there is no C environment variable, the output is going to the terminal (STDOUT or STDERR) and your terminal actually supports colors. =head2 Profiles You may bundle your settings and filters into a profile module. It works like a configuration file but gives you the power and flexibility to use Perl code to find out what to print and how to print. It also lets you use CPAN to store your preferred settings and install them into your projects just like a regular dependency. use DDP profile => 'ProfileName'; See L for all the ways to load a profile, a list of available profiles and how to make one yourself. =head2 Filters Data::Printer works by passing your variable to a different set of filters, depending on whether it's a scalar, a hash, an array, an object, etc. It comes bundled with filters for all native data types (always enabled, but overwritable), including a generic object filter that pretty-prints regular and Moo(se) objects and is even aware of Role::Tiny. Data::Printer also comes with filter bundles that can be quickly activated to make it easier to debug L and many popular CPAN modules that handle L, L (yes, even DBIx::Class), L like MD5 and SHA1, and L content like HTTP requests and responses. So much so we recommend everyone to activate all bundled filters by putting the following line on your C<.dataprinter> file: filters = ContentType, DateTime, DB, Digest, Web Creating your custom filters is very easy, and you're encouraged to upload them to CPAN. There are many options available under the C<< Data::Printer::Filter::* >> namespace. Check L for more information! =head2 Making your classes DDP-aware (without adding any dependencies!) The default object filter will first check if the class implements a sub called 'C<_data_printer()>' (or whatever you set the "class_method" option to in your settings). If so, Data::Printer will use it to get the string to print instead of making a regular class dump. This means you could have the following in one of your classes: sub _data_printer { my ($self, $ddp) = @_; return 'Hey, no peeking! But foo contains ' . $self->foo; } Notice that B<< you can do this without adding Data::Printer as a dependency >> to your project! Just write your sub and it will be called with the object to be printed and a C<$ddp> object ready for you. See L<< Data::Printer::Object|Data::Printer::Object/"Methods and Accessors for Filter Writers" >> for how to use it to pretty-print your data. Finally, if your object implements string overload or provides a method called "to_string", "as_string" or "stringify", Data::Printer will use it. To disable this behaviour, set C<< class.stringify = 0 >> on your C<.dataprinter> file, or call p() with C<< class => { stringify => 0 } >>. Loading a filter for that particular class will of course override these settings. =head1 CAVEATS You can't pass more than one variable at a time. p $foo, $bar; # wrong p $foo; p $bar; # right You can't use it in variable declarations (it will most likely not do what you want): p my @array = qw(a b c d); # wrong my @array = qw(a b c d); p @array; # right If you pass a nonexistent key/index to DDP using prototypes, they will trigger autovivification: use DDP; my %foo; p $foo{bar}; # undef, but will create the 'bar' key (with undef) my @x; p $x[5]; # undef, but will initialize the array with 5 elements (all undef) Slices (both array and hash) must be coerced into actual arrays (or hashes) to properly shown. So if you want to print a slice, instead of doing something like this: p @somevar[1..10]; # WRONG! DON'T DO THIS! try one of those: my @x = @somevar[1..10]; p @x; # works! p [ @somevar[1..0] ]->@*; # also works! p @{[@somevar[1..0]]}; # this works too!! Finally, as mentioned before, you cannot pass anonymous references on the default mode of C<< use_prototypes = 1 >>: p { foo => 1 }; # wrong! p %{{ foo => 1 }}; # right p { foo => 1 }->%*; # right on perl 5.24+ &p( { foo => 1 } ); # right, but requires the parenthesis sub pp { p @_ }; # wrapping it also lets you use anonymous data. use DDP use_prototypes => 0; p { foo => 1 }; # works, but now p(@foo) will fail, you must always pass a ref, # e.g. p(\@foo) =head1 BACKWARDS INCOMPATIBLE CHANGES While we make a genuine effort not to break anything on new releases, sometimes we do. To make things easier for people migrating their code, we have aggregated here a list of all incompatible changes since ever: =over 4 =item * 1.00 - some defaults changed! Because we added a bunch of new features (including color themes), you may notice some difference on the default output of Data::Printer. Hopefully it's for the best. =item * 1.00 - new C<.dataprinter> file format. I<< This should only affect you if you have a C<.dataprinter> file. >> The change was required to avoid calling C on potentially tainted/unknown code. It also provided a much cleaner interface. =item * 1.00 - new way of creating external filters. I<< This only affects you if you write or use external filters. >> Previously, the sub in your C call would get the reference to be parsed and a properties hash. The properties hash has been replaced with a L instance, providing much more power and flexibility. Because of that, the filter call does not export C/C anymore, replaced by methods in Data::Printer::Object. =item * 1.00 - new way to call filters. I<< This affects you if you load your own inline filters >>. The fix is quick and Data::Printer will generate a warning explaining how to do it. Basically, C<< filters => { ... } >> became C<< filters => [{ ... }] >> and you must replace C<< -external => [1,2] >> with C<< filters => [1, 2] >>, or C<< filters => [1, 2, {...}] >> if you also have inline filters. This allowed us much more power and flexibility with filters, and hopefully also makes things clearer. =item * 0.36 - C's default return value changed from 'dump' to 'pass'. This was a very important change to ensure chained calls and to prevent weird side-effects when C is the last statement in a sub. L<< Read the full discussion|https://github.com/garu/Data-Printer/issues/16 >>. =back Any undocumented change was probably unintended. If you bump into one, please file an issue on Github! =head1 TIPS & TRICKS =head2 Using p() in some/all of your loaded modules I<< (contributed by Matt S. Trout (mst)) >> While debugging your software, you may want to use Data::Printer in some or all loaded modules and not bother having to load it in each and every one of them. To do this, in any module loaded by C, simply write: ::p @myvar; # note the '::' in front of p() Then call your program like: perl -MDDP myapp.pl This also has the advantage that if you leave one p() call in by accident, it will trigger a compile-time failure without the -M, making it easier to spot :) If you really want to have p() imported into your loaded modules, use the next tip instead. =head2 Adding p() to all your loaded modules I<< (contributed by Árpád Szász) >> If you wish to automatically add Data::Printer's C function to every loaded module in you app, you can do something like this to your main program: BEGIN { { no strict 'refs'; require Data::Printer; my $alias = 'p'; foreach my $package ( keys %main:: ) { if ( $package =~ m/::$/ ) { *{ $package . $alias } = \&Data::Printer::p; } } } } B This will override all locally defined subroutines/methods that are named C

, if they exist, in every loaded module. If you already have a subroutine named 'C', be sure to change C<$alias> to something custom. If you rather avoid namespace manipulation altogether, use the previous tip instead. =head2 Using Data::Printer from the Perl debugger I<< (contributed by Árpád Szász and Marcel Grünauer (hanekomu)) >> With L, you can easily set the perl debugger to use Data::Printer to print variable information, replacing the debugger's standard C function. All you have to do is add these lines to your C<.perldb> file: use DB::Pluggable; DB::Pluggable->run_with_config( \'[DataPrinter]' ); # note the '\' Then call the perl debugger as you normally would: perl -d myapp.pl Now Data::Printer's C command will be used instead of the debugger's! See L for more information on how to use the perl debugger, and L for extra functionality and other plugins. If you can't or don't want to use DB::Pluggable, or simply want to keep the debugger's C function and add an extended version using Data::Printer (let's call it C for instance), you can add these lines to your C<.perldb> file instead: $DB::alias{px} = 's/px/DB::px/'; sub px { my $expr = shift; require Data::Printer; print Data::Printer::p($expr); } Now, inside the Perl debugger, you can pass as reference to C expressions to be dumped using Data::Printer. =head2 Using Data::Printer in a perl shell (REPL) Some people really enjoy using a REPL shell to quickly try Perl code. One of the most popular ones out there are L and L. If you use them, now you can also see its output with Data::Printer! =over 4 =item * B =back Just install L and add a line with C<< [DataPrinter] >> to your C<.replyrc> file. That's it! Next time you run the 'reply' REPL, Data::Printer will be used to dump variables! =over 4 =item * B =back Just install L and add the following line to your re.pl configuration file (usually ".re.pl/repl.rc" in your home dir): load_plugin('DataPrinter'); The next time you run C, it should dump all your REPL using Data::Printer! =head2 Easily rendering Data::Printer's output as HTML To turn Data::Printer's output into HTML, you can do something like: use HTML::FromANSI; use Data::Printer; my $html_output = ansi2html( np($object, colored => 1) ); In the example above, the C<$html_output> variable contains the HTML escaped output of C, so you can print it for later inspection or render it (if it's a web app). =head2 Using Data::Printer with Template Toolkit I<< (contributed by Stephen Thirlwall (sdt)) >> If you use Template Toolkit and want to dump your variables using Data::Printer, install the L module and load it in your template: [% USE DataPrinter %] The provided methods match those of C: ansi-colored dump of the data structure in "myvar": [% DataPrinter.dump( myvar ) %] html-formatted, colored dump of the same data structure: [% DataPrinter.dump_html( myvar ) %] The module allows several customization options, even letting you load it as a complete drop-in replacement for Template::Plugin::Dumper so you don't even have to change your previous templates! =head2 Migrating from Data::Dumper to Data::Printer If you are porting your code to use Data::Printer instead of Data::Dumper, you could replace: use Data::Dumper; with something like: use Data::Printer; sub Dumper { np @_, colored => 1 } this sub will accept multiple variables just like Data::Dumper. =head2 Unified interface for Data::Printer and other debug formatters I<< (contributed by Kevin McGrath (catlgrep)) >> If you want a really unified approach to easily flip between debugging outputs, use L and its plugins, like L. =head2 Printing stack traces with arguments expanded using Data::Printer I<< (contributed by Sergey Aleynikov (randir)) >> There are times where viewing the current state of a variable is not enough, and you want/need to see a full stack trace of a function call. The L module uses Data::Printer to provide you just that. It exports a C function that pretty-prints detailed information on each function in your stack, making it easier to spot any issues! =head2 Troubleshooting apps in real time without changing a single line of your code I<< (contributed by Marcel Grünauer (hanekomu)) >> L is a dynamic instrumentation framework for troubleshooting Perl programs, similar to L. In a nutshell, C lets you create probes for certain conditions in your application that, once met, will perform a specific action. Since it uses Aspect-oriented programming, it's very lightweight and you only pay for what you use. C can be very useful since it allows you to debug your software without changing a single line of your original code. And Data::Printer comes bundled with it, so you can use the C function to view your data structures too! # Print a stack trace every time the name is changed, # except when reading from the database. dip -e 'before { print longmess(np $_->{args}[1], colored => 1) if $_->{args}[1] } call "MyObj::name" & !cflow("MyObj::read")' myapp.pl You can check L's own documentation for more information and options. =head2 Sample output for color fine-tuning I<< (contributed by Yanick Champoux (yanick)) >> The "examples/try_me.pl" file included in this distribution has a sample dump with a complex data structure to let you quickly test color schemes. =head1 VERSIONING AND UPDATES As of 1.0.0 this module complies with C versioning scheme (SemVer), meaning backwards incompatible changes will trigger a new major number, new features without any breaking changes trigger a new minor number, and simple patches trigger a revision number. =head1 CONTRIBUTORS Many thanks to everyone who helped design and develop this module with patches, bug reports, wishlists, comments and tests. They are (alphabetically): Adam Rosenstein, Alexandr Ciornii (chorny), Alexander Hartmaier (abraxxa), Allan Whiteford, Anatoly (Snelius30), Andre Klärner, Andreas König (andk), Andy Bach, Anthony DeRobertis, Árpád Szász, Athanasios Douitsis (aduitsis), Baldur Kristinsson, Benct Philip Jonsson (bpj), brian d foy, Chad Granum (exodist), Chris Prather (perigrin), Curtis Poe (Ovid), David D Lowe (Flimm), David E. Condon (hhg7), David Golden (xdg), David Precious (bigpresh), David Raab, David E. Wheeler (theory), Damien Krotkine (dams), Denis Howe, dirk, Dotan Dimet, Eden Cardim (edenc), Elliot Shank (elliotjs), Elvin Aslanov, Eugen Konkov (KES777), Fernando Corrêa (SmokeMachine), Fitz Elliott, Florian Schlichting (fschlich), Frew Schmidt (frew), GianniGi, Graham Knop (haarg), Graham Todd, Gregory J. Oschwald, grr, Håkon Hægland, Iaroslav O. Kosmina (darviarush), Ivan Bessarabov (bessarabv), J Mash, James E. Keenan (jkeenan), Jarrod Funnell (Timbus), Jay Allen (jayallen), Jay Hannah (jhannah), jcop, Jesse Luehrs (doy), Joel Berger (jberger), John S. Anderson (genehack), Karen Etheridge (ether), Kartik Thakore (kthakore), Kevin Dawson (bowtie), Kevin McGrath (catlgrep), Kip Hampton (ubu), Londran, Marcel Grünauer (hanekomu), Marco Masetti (grubert65), Mark Fowler (Trelane), Martin J. Evans, Matthias Muth, Matt S. Trout (mst), Maxim Vuets, Michael Conrad, Mike Doherty (doherty), Nicolas R (atoomic), Nigel Metheringham (nigelm), Nuba Princigalli (nuba), Olaf Alders (oalders), Paul Evans (LeoNerd), Pedro Melo (melo), Philippe Bruhat (BooK), Przemysław Wesołek (jest), Rebecca Turner (iarna), Renato Cron (renatoCRON), Ricardo Signes (rjbs), Rob Hoelz (hoelzro), Salve J. Nilsen (sjn), sawyer, Sebastian Willing (Sewi), Sébastien Feugère (smonff), Sergey Aleynikov (randir), Slaven Rezić, Stanislaw Pusep (syp), Stephen Thirlwall (sdt), sugyan, Tai Paul, Tatsuhiko Miyagawa (miyagawa), Thomas Sibley (tsibley), Tim Heaney (oylenshpeegul), Toby Inkster (tobyink), Torsten Raudssus (Getty), Tokuhiro Matsuno (tokuhirom), trapd00r, Tsai Chung-Kuan, Veesh Goldman (rabbiveesh), vividsnow, Wesley Dal`Col (blabos), y, Yanick Champoux (yanick). If I missed your name, please drop me a line! =head1 LICENSE AND COPYRIGHT Copyright (C) 2011-2024 Breno G. de Oliveira This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License. See L for more information. =head1 DISCLAIMER OF WARRANTY BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR, OR CORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. Data-Printer-1.002001/lib/Data/Printer/0000755000000000000000000000000014552072607015777 5ustar rootrootData-Printer-1.002001/lib/Data/Printer/Common.pm0000644000000000000000000003544314552015171017567 0ustar rootrootpackage Data::Printer::Common; # Private library of shared Data::Printer code. use strict; use warnings; use Scalar::Util; my $mro_initialized = 0; my $nsort_initialized; sub _filter_category_for { my ($name) = @_; my %core_types = map { $_ => 1 } qw(SCALAR LVALUE ARRAY HASH REF VSTRING GLOB FORMAT Regexp CODE OBJECT); return exists $core_types{$name} ? 'type_filters' : 'class_filters'; } # strings are tough to process: there are control characters like "\t", # unicode characters to name or escape (or do nothing), max_string to # worry about, and every single piece of that could have its own color. # That, and hash keys and strings share this. So we put it all in one place. sub _process_string { my ($ddp, $string, $src_color) = @_; # colorizing messes with reduce_string because we are effectively # adding new (invisible) characters to the string. So we need to # handle reduction first. But! Because we colorize string_max # *and* we should escape any colors already present, we need to # do both at the same time. $string = _reduce_string($ddp, $string, $src_color); # now we escape all other control characters except for "\e", which was # already escaped in _reduce_string(), and convert any chosen charset # to the \x{} format. These could go in any particular order: $string = _escape_chars($ddp, $string, $src_color); $string = _print_escapes($ddp, $string, $src_color); # finally, send our wrapped string: return $ddp->maybe_colorize($string, $src_color); } sub _colorstrip { my ($string) = @_; $string =~ s{ \e\[ [\d;]* m }{}xmsg; return $string; } sub _reduce_string { my ($ddp, $string, $src_color) = @_; my $max = $ddp->string_max; my $str_len = length($string); if ($max && $str_len && $str_len > $max) { my $preserve = $ddp->string_preserve; my $skipped_chars = $str_len - ($preserve eq 'none' ? 0 : $max); my $skip_message = $ddp->maybe_colorize( $ddp->string_overflow, 'caller_info', undef, $src_color ); $skip_message =~ s/__SKIPPED__/$skipped_chars/g; if ($preserve eq 'end') { substr $string, 0, $skipped_chars, ''; $string =~ s{\e}{$ddp->maybe_colorize('\\e', 'escaped', undef, $src_color)}ge if $ddp->print_escapes; $string = $skip_message . $string; } elsif ($preserve eq 'begin') { $string = substr($string, 0, $max); $string =~ s{\e}{$ddp->maybe_colorize('\\e', 'escaped', undef, $src_color)}ge if $ddp->print_escapes; $string = $string . $skip_message; } elsif ($preserve eq 'extremes') { my $leftside_chars = int($max / 2); my $rightside_chars = $max - $leftside_chars; my $leftside = substr($string, 0, $leftside_chars); my $rightside = substr($string, -$rightside_chars); if ($ddp->print_escapes) { $leftside =~ s{\e}{$ddp->maybe_colorize('\\e', 'escaped', undef, $src_color)}ge; $rightside =~ s{\e}{$ddp->maybe_colorize('\\e', 'escaped', undef, $src_color)}ge; } $string = $leftside . $skip_message . $rightside; } elsif ($preserve eq 'middle') { my $string_middle = int($str_len / 2); my $middle_substr = int($max / 2); my $substr_begin = $string_middle - $middle_substr; my $message_begin = $ddp->string_overflow; $message_begin =~ s/__SKIPPED__/$substr_begin/gs; my $chars_left = $str_len - ($substr_begin + $max); my $message_end = $ddp->string_overflow; $message_end =~ s/__SKIPPED__/$chars_left/gs; $string = substr($string, $substr_begin, $max); $string =~ s{\e}{$ddp->maybe_colorize('\\e', 'escaped', undef, $src_color)}ge if $ddp->print_escapes; $string = $ddp->maybe_colorize($message_begin, 'caller_info', undef, $src_color) . $string . $ddp->maybe_colorize($message_end, 'caller_info', undef, $src_color) ; } else { # preserving 'none' only shows the skipped message: $string = $skip_message; } } else { # nothing to do? ok, then escape any colors already present: $string =~ s{\e}{$ddp->maybe_colorize('\\e', 'escaped', undef, $src_color)}ge if $ddp->print_escapes; } return $string; } # _escape_chars() replaces characters with their "escaped" versions. # Because it may be called on scalars or (scalar) hash keys and they # have different colors, we need to be aware of that. sub _escape_chars { my ($ddp, $scalar, $src_color) = @_; my $escape_kind = $ddp->escape_chars; my %target_for = ( nonascii => '[^\x{00}-\x{7f}]+', nonlatin1 => '[^\x{00}-\x{ff}]+', ); if ($ddp->unicode_charnames) { require charnames; if ($escape_kind eq 'all') { $scalar = join('', map { sprintf '\N{%s}', charnames::viacode(ord $_) } split //, $scalar); $scalar = $ddp->maybe_colorize($scalar, 'escaped'); } else { $scalar =~ s{($target_for{$escape_kind})}{$ddp->maybe_colorize( (join '', map { sprintf '\N{%s}', charnames::viacode(ord $_) } split //, $1), 'escaped', undef, $src_color)}ge if exists $target_for{$escape_kind}; } } elsif ($escape_kind eq 'all') { $scalar = join('', map { sprintf '\x{%02x}', ord $_ } split //, $scalar); $scalar = $ddp->maybe_colorize($scalar, 'escaped'); } else { $scalar =~ s{($target_for{$escape_kind})}{$ddp->maybe_colorize((join '', map { sprintf '\x{%02x}', ord $_ } split //, $1), 'escaped', undef, $src_color)}ge if exists $target_for{$escape_kind}; } return $scalar; } # _print_escapes() prints invisible chars if they exist on a string. # Because it may be called on scalars or (scalar) hash keys and they # have different colors, we need to be aware of that. Also, \e is # deliberately omitted because it was escaped from the original # string earlier, and the \e's we have now are our own colorized # output. sub _print_escapes { my ($ddp, $string, $src_color) = @_; # always escape the null character $string =~ s/\0/$ddp->maybe_colorize('\\0', 'escaped', undef, $src_color)/ge; return $string unless $ddp->print_escapes; my %escaped = ( "\n" => '\n', # line feed "\r" => '\r', # carriage return "\t" => '\t', # horizontal tab "\f" => '\f', # formfeed "\b" => '\b', # backspace "\a" => '\a', # alert (bell) ); foreach my $k ( keys %escaped ) { $string =~ s/$k/$ddp->maybe_colorize($escaped{$k}, 'escaped', undef, $src_color)/ge; } return $string; } sub _initialize_nsort { return 'Sort::Key::Natural' if $INC{'Sort/Key/Natural.pm'}; return 'Sort::Naturally' if $INC{'Sort/Naturally.pm'}; return 'Sort::Key::Natural' if !_tryme('use Sort::Key::Natural; 1;'); return 'Sort::Naturally' if !_tryme('use Sort::Naturally; 1;'); return 'core'; } sub _nsort { if (!$nsort_initialized) { my $nsort_class = _initialize_nsort(); if ($nsort_class eq 'Sort::Key::Natural') { $nsort_initialized = \&{ $nsort_class . '::natsort' }; } elsif ($nsort_class ne 'core') { $nsort_initialized = \&{ $nsort_class . '::nsort' }; } else { $nsort_initialized = \&_nsort_pp } } return $nsort_initialized->(@_); } # this is a very simple 'natural-ish' sorter, heavily inspired in # http://www.perlmonks.org/?node_id=657130 by thundergnat and tye sub _nsort_pp { my $i; my @unsorted = map lc, @_; foreach my $data (@unsorted) { no warnings 'uninitialized'; $data =~ s/((\.0*)?)(\d+)/("\x0" x length $2) . (pack 'aNa*', 0, length $3, $3)/eg; $data .= ' ' . $i++; } return @_[ map { (split)[-1] } sort @unsorted ]; } sub _fetch_arrayref_of_scalars { my ($props, $name) = @_; return [] unless exists $props->{$name} && ref $props->{$name} eq 'ARRAY'; my @valid; foreach my $option (@{$props->{$name}}) { if (ref $option) { # FIXME: because there is no object at this point, we need to check # the 'warnings' option ourselves. _warn(undef, "'$name' option requires scalar values only. Ignoring $option.") if !exists $props->{warnings} || !$props->{warnings}; next; } push @valid, $option; } return \@valid; } sub _fetch_anyof { my ($props, $name, $default, $list) = @_; return $default unless exists $props->{$name}; foreach my $option (@$list) { return $option if $props->{$name} eq $option; } _die( "invalid value '$props->{$name}' for option '$name'" . "(must be one of: " . join(',', @$list) . ")" ); }; sub _fetch_scalar_or_default { my ($props, $name, $default) = @_; return $default unless exists $props->{$name}; if (my $ref = ref $props->{$name}) { _die("'$name' property must be a scalar, not a reference to $ref"); } return $props->{$name}; } sub _die { my ($message) = @_; my ($file, $line) = _get_proper_caller(); die '[Data::Printer] ' . $message . " at $file line $line.\n"; } sub _warn { my ($ddp, $message) = @_; return if $ddp && !$ddp->warnings; my ($file, $line) = _get_proper_caller(); warn '[Data::Printer] ' . $message . " at $file line $line.\n"; } sub _get_proper_caller { my $frame = 1; while (my @caller = caller($frame++)) { if ($caller[0] !~ /\AD(?:DP|ata::Printer)/) { return ($caller[1], $caller[2]); } } return ('n/d', 'n/d'); } # simple eval++ adapted from Try::Tiny. # returns a (true) error message if failed. sub _tryme { my ($subref_or_string) = @_; my $previous_error = $@; my ($failed, $error); if (ref $subref_or_string eq 'CODE') { $failed = not eval { local $SIG{'__DIE__'}; # make sure we don't trigger any exception hooks. $@ = $previous_error; $subref_or_string->(); return 1; }; $error = $@; } else { my $code = q(local $SIG{'__DIE__'};) . $subref_or_string; $failed = not eval $code; $error = $@; } $@ = $previous_error; # at this point $failed contains a true value if the eval died, # even if some destructor overwrote $@ as the eval was unwinding. return unless $failed; return ($error || '(unknown error)'); } # When printing array elements or hash keys, we may traverse all of it # or just a few chunks. This function returns those chunks' indexes, and # a scalar ref to a message whenever a chunk was skipped. sub _fetch_indexes_for { my ($array_ref, $prefix, $ddp) = @_; my $max_function = $prefix . '_max'; my $preserve_function = $prefix . '_preserve'; my $overflow_function = $prefix . '_overflow'; my $max = $ddp->$max_function; my $preserve = $ddp->$preserve_function; return (0 .. $#{$array_ref}) if !$max || @$array_ref <= $max; my $skip_message = $ddp->maybe_colorize($ddp->$overflow_function, 'overflow'); if ($preserve eq 'begin' || $preserve eq 'end') { my $n_elements = @$array_ref - $max; $skip_message =~ s/__SKIPPED__/$n_elements/g; return $preserve eq 'begin' ? ((0 .. ($max - 1)), \$skip_message) : (\$skip_message, ($n_elements .. $#{$array_ref})) ; } elsif ($preserve eq 'extremes') { my $half_max = int($max / 2); my $last_index_of_chunk_one = $half_max - 1; my $n_elements = @$array_ref - $max; my $first_index_of_chunk_two = @$array_ref - ($max - $half_max); $skip_message =~ s/__SKIPPED__/$n_elements/g; return ( (0 .. $last_index_of_chunk_one), \$skip_message, ($first_index_of_chunk_two .. $#{$array_ref}) ); } elsif ($preserve eq 'middle') { my $array_middle = int($#{$array_ref} / 2); my $first_index_to_show = $array_middle - int($max / 2); my $last_index_to_show = $first_index_to_show + $max - 1; my ($message_begin, $message_end) = ($skip_message, $skip_message); $message_begin =~ s/__SKIPPED__/$first_index_to_show/gse; my $items_left = $#{$array_ref} - $last_index_to_show; $message_end =~ s/__SKIPPED__/$items_left/gs; return ( \$message_begin, $first_index_to_show .. $last_index_to_show, \$message_end ); } else { # $preserve eq 'none' my $n_elements = scalar(@$array_ref); $skip_message =~ s/__SKIPPED__/$n_elements/g; return (\$skip_message); } } # helpers below strongly inspired by the excellent Package::Stash: sub _linear_ISA_for { my ($class, $ddp) = @_; _initialize_mro($ddp) unless $mro_initialized; my $isa; if ($mro_initialized > 0) { $isa = mro::get_linear_isa($class); } else { # minimal fallback in case Class::MRO isn't available # (should only matter for perl < 5.009_005): $isa = [ $class, _get_superclasses_for($class) ]; } return [@$isa, ($ddp->class->universal ? 'UNIVERSAL' : ())]; } sub _initialize_mro { my ($ddp) = @_; my $error = _tryme(sub { if ($] < 5.009_005) { require MRO::Compat } else { require mro } 1; }); if ($error && index($error, 'in @INC') != -1 && $mro_initialized == 0) { _warn( $ddp, ($] < 5.009_005 ? 'MRO::Compat' : 'mro') . ' not found in @INC.' . ' Objects may display inaccurate/incomplete ISA and method list' ); } $mro_initialized = $error ? -1 : 1; } sub _get_namespace { my ($class_name) = @_; my $namespace; { no strict 'refs'; $namespace = \%{ $class_name . '::' } } # before 5.10, stashes don't ever seem to drop to a refcount of zero, # so weakening them isn't helpful Scalar::Util::weaken($namespace) if $] >= 5.010; return $namespace; } sub _get_superclasses_for { my ($class_name) = @_; my $namespace = _get_namespace($class_name); my $res = _get_symbol($class_name, $namespace, 'ISA', 'ARRAY'); return @{ $res || [] }; } sub _get_symbol { my ($class_name, $namespace, $symbol_name, $symbol_kind) = @_; if (exists $namespace->{$symbol_name}) { my $entry_ref = \$namespace->{$symbol_name}; if (ref($entry_ref) eq 'GLOB') { return *{$entry_ref}{$symbol_kind}; } else { if ($symbol_kind eq 'CODE') { no strict 'refs'; return \&{ $class_name . '::' . $symbol_name }; } } } return; } 1; Data-Printer-1.002001/lib/Data/Printer/Theme/0000755000000000000000000000000014552072607017041 5ustar rootrootData-Printer-1.002001/lib/Data/Printer/Theme/Solarized.pm0000644000000000000000000000607314552042205021330 0ustar rootrootpackage Data::Printer::Theme::Solarized; # inspired by Ethan Schoonover's Solarized theme: # http://ethanschoonover.com/solarized use strict; use warnings; sub colors { my %code_for = ( base03 => '#1c1c1c', # '#002b36' base02 => '#262626', # '#073642' base01 => '#585858', # '#586e75' base00 => '#626262', # '#657b83' base0 => '#808080', # '#839496' base1 => '#8a8a8a', # '#93a1a1' base2 => '#e4e4e4', # '#eee8d5' base3 => '#ffffd7', # '#fdf6e3' yellow => '#af8700', # '#b58900' orange => '#d75f00', # '#cb4b16' red => '#d70000', # '#dc322f' magenta => '#af005f', # '#d33682' violet => '#5f5faf', # '#6c71c4' blue => '#0087ff', # '#268bd2' cyan => '#00afaf', # '#2aa198' green => '#5f8700', # '#859900' ); return { array => $code_for{violet}, # array index numbers number => $code_for{cyan}, # numbers string => $code_for{cyan}, # strings class => $code_for{yellow}, # class names method => $code_for{orange}, # method names undef => $code_for{red}, # the 'undef' value hash => $code_for{green}, # hash keys regex => $code_for{orange}, # regular expressions code => $code_for{base2}, # code references glob => $code_for{blue}, # globs (usually file handles) vstring => $code_for{base1}, # version strings (v5.16.0, etc) lvalue => $code_for{green}, # lvalue label format => $code_for{green}, # format type true => $code_for{blue}, # boolean type (true) false => $code_for{blue}, # boolean type (false) repeated => $code_for{red}, # references to seen values caller_info => $code_for{cyan}, # details on what's being printed weak => $code_for{violet}, # weak references flag tainted => $code_for{violet}, # tainted flag unicode => $code_for{magenta}, # utf8 flag escaped => $code_for{red}, # escaped characters (\t, \n, etc) brackets => $code_for{base0}, # (), {}, [] separator => $code_for{base0}, # the "," between hash pairs, array elements, etc quotes => $code_for{'base0'}, unknown => $code_for{red}, # any (potential) data type unknown to Data::Printer }; } 1; __END__ =head1 NAME Data::Printer::Theme::Solarized - Solarized theme for DDP =head1 SYNOPSIS In your C<.dataprinter> file: theme = Solarized Or during runtime: use DDP theme => 'Solarized'; =head1 DESCRIPTION This module implements the Solarized theme for Data::Printer, inspired by L =for html Solarized Theme =head1 SEE ALSO L L Data-Printer-1.002001/lib/Data/Printer/Theme/Monokai.pm0000644000000000000000000000512214552040347020770 0ustar rootrootpackage Data::Printer::Theme::Monokai; # inspired by Wimer Hazenberg's Monokai theme: monokai.nl use strict; use warnings; sub colors { my %code_for = ( grey => '#75715E', yellow => '#E6DB74', violet => '#AE81FF', pink => '#F92672', cyan => '#66D9EF', green => '#A6E22E', orange => '#FD971F', empty => '', ); return { array => $code_for{orange}, # array index numbers number => $code_for{violet}, # numbers string => $code_for{yellow}, # (or 'very_light_gray'?) # strings class => $code_for{green}, # class names method => $code_for{green}, # method names undef => $code_for{pink}, # the 'undef' value hash => $code_for{cyan}, # hash keys regex => $code_for{green}, # regular expressions code => $code_for{orange}, # code references glob => $code_for{violet}, # globs (usually file handles) vstring => $code_for{cyan}, # version strings (v5.16.0, etc) lvalue => $code_for{green}, # lvalue label format => $code_for{violet}, # format type true => $code_for{violet}, # boolean type (true) false => $code_for{violet}, # boolean type (false) repeated => $code_for{pink}, # references to seen values caller_info => $code_for{grey}, # details on what's being printed weak => $code_for{green}, # weak references flag tainted => $code_for{green}, # tainted flag unicode => $code_for{green}, # utf8 flag escaped => $code_for{pink}, # escaped characters (\t, \n, etc) brackets => $code_for{empty}, # (), {}, [] separator => $code_for{empty}, # the "," between hash pairs, array elements, etc quotes => $code_for{yellow}, unknown => $code_for{pink}, # any (potential) data type unknown to Data::Printer }; } 1; __END__ =head1 NAME Data::Printer::Theme::Monokai - Monokai theme for DDP =head1 SYNOPSIS In your C<.dataprinter> file: theme = Monokai Or during runtime: use DDP theme => 'Monokai'; =head1 DESCRIPTION This module implements the Monokai theme for Data::Printer, inspired by L. =for html Monokai Theme =head1 SEE ALSO L L Data-Printer-1.002001/lib/Data/Printer/Theme/Material.pm0000644000000000000000000000617114552042106021131 0ustar rootrootpackage Data::Printer::Theme::Material; # inspired by Mattia Astorino's Material theme: # https://github.com/material-theme/vsc-material-theme use strict; use warnings; sub colors { my %code_for = ( 'very_light_gray' => '#EEFFFF', 'light_gray' => '#A1BBC5', 'gray' => '#4f5a61', 'green' => '#90B55A', #'#C3E88D', 'teal' => '#009688', 'light_teal' => '#73d1c8', 'cyan' => '#66D9EF', 'blue' => '#82AAFF', 'indigo' => '#7986CB', 'purple' => '#C792EA', 'pink' => '#FF5370', 'red' => '#F07178', 'strong_orange' => '#F78C6A', 'orange' => '#FFCB6B', 'light_orange' => '#FFE082', ); return { array => $code_for{light_gray}, # array index numbers number => $code_for{strong_orange}, # numbers string => $code_for{green}, # (or 'very_light_gray'?) # strings class => $code_for{purple}, # class names method => $code_for{blue}, # method names undef => $code_for{pink}, # the 'undef' value hash => $code_for{indigo}, # hash keys regex => $code_for{orange}, # regular expressions code => $code_for{gray}, # code references glob => $code_for{strong_orange}, # globs (usually file handles) vstring => $code_for{strong_orange}, # version strings (v5.16.0, etc) lvalue => $code_for{strong_orange}, # lvalue label format => $code_for{strong_orange}, # format type true => $code_for{blue}, # boolean type (true) false => $code_for{blue}, # boolean type (false) repeated => $code_for{red}, # references to seen values caller_info => $code_for{gray}, # details on what's being printed weak => $code_for{green}, # weak references flag tainted => $code_for{light_orange}, # tainted flag unicode => $code_for{light_orange}, # utf8 flag escaped => $code_for{teal}, # escaped characters (\t, \n, etc) brackets => $code_for{cyan}, # (), {}, [] separator => $code_for{cyan}, # the "," between hash pairs, array elements, etc quotes => $code_for{cyan}, unknown => $code_for{red}, # any (potential) data type unknown to Data::Printer }; } 1; __END__ =head1 NAME Data::Printer::Theme::Material - Material theme for DDP =head1 SYNOPSIS In your C<.dataprinter> file: theme = Material Or during runtime: use DDP theme => 'Material'; =head1 DESCRIPTION This module implements the Material theme for Data::Printer, inspired by L. =for html Material Theme =head1 SEE ALSO L L Data-Printer-1.002001/lib/Data/Printer/Theme/Classic.pm0000644000000000000000000000440214552042330020746 0ustar rootrootpackage Data::Printer::Theme::Classic; # classic Data::Printer colors, for nostalgic users :D use strict; use warnings; sub colors { return { array => 'bright_white', # array index numbers number => 'bright_blue', # numbers string => 'bright_yellow', # strings class => 'bright_green', # class names method => 'bright_green', # method names undef => 'bright_red', # the 'undef' value hash => 'magenta', # hash keys regex => 'yellow', # regular expressions code => 'green', # code references glob => 'bright_cyan', # globs (usually file handles) vstring => 'bright_blue', # version strings (v5.16.0, etc) lvalue => '', # lvalue label format => '', # format type true => 'bright_cyan', # boolean type (true) false => 'bright_cyan', # boolean type (false) repeated => 'white on_red', # references to seen values caller_info => 'bright_cyan', # details on what's being printed weak => 'cyan', # weak references tainted => 'red', # tainted content unicode => '', # utf8 flag escaped => 'bright_red', # escaped characters (\t, \n, etc) brackets => '', # (), {}, [] separator => '', # the "," between hash pairs, array elements, etc quotes => '', unknown => 'bright_yellow on_blue', # any (potential) data type unknown to Data::Printer }; } 1; __END__ =head1 NAME Data::Printer::Theme::Classic - Classic DDP color theme for nostalgic users =head1 SYNOPSIS In your C<.dataprinter> file: theme = Classic Or during runtime: use DDP theme => 'Classic'; =head1 DESCRIPTION This module implements the Classic theme for Data::Printer, which was the default theme before Data::Printer 1.0. =for html Classic Theme =head1 SEE ALSO L L Data-Printer-1.002001/lib/Data/Printer/Theme.pm0000644000000000000000000002657414552036501017406 0ustar rootrootpackage Data::Printer::Theme; use strict; use warnings; use Data::Printer::Common; # the theme name sub name { my ($self) = @_; return $self->{name}; } # true if the theme has at least one color override sub customized { my ($self) = @_; return exists $self->{is_custom} ? 1 : 0; } # displays the color as-is sub color_for { my ($self, $color_type) = @_; return $self->{colors}{$color_type} || ''; } # prints the SGR (terminal) color modifier sub sgr_color_for { my ($self, $color_type) = @_; return unless exists $self->{sgr_colors}{$color_type}; return $self->{sgr_colors}{$color_type} || '' } # prints the SGR (terminal) color reset modifier sub color_reset { return "\e[m" } sub new { my ($class, %params) = @_; my $color_level = $params{color_level}; my $colors_to_override = $params{color_overrides}; my $theme_name = $params{name}; # before we put user info on string eval, make sure # it's just a module name: $theme_name =~ s/[^a-zA-Z0-9:]+//gsm; my $theme = bless { name => $theme_name, color_level => $color_level, colors => {}, sgr_colors => {}, }, $class; $theme->_load_theme($params{ddp}) or delete $theme->{name}; $theme->_maybe_override_theme_colors($colors_to_override, $params{ddp}); return $theme; } sub _maybe_override_theme_colors { my ($self, $colors_to_override, $ddp) = @_; return unless $colors_to_override && ref $colors_to_override eq 'HASH' && keys %$colors_to_override; my $error = Data::Printer::Common::_tryme(sub { foreach my $kind (keys %$colors_to_override ) { my $override = $colors_to_override->{$kind}; die "invalid color for '$kind': must be scalar not ref" if ref $override; my $parsed = $self->_parse_color($override, $ddp); if (defined $parsed) { $self->{colors}{$kind} = $override; $self->{sgr_colors}{$kind} = $parsed; $self->{is_custom}{$kind} = 1; } } }); if ($error) { Data::Printer::Common::_warn($ddp, "error overriding color: $error. Skipping!"); } return; } sub _load_theme { my ($self, $ddp) = @_; my $theme_name = $self->{name}; my $class = 'Data::Printer::Theme::' . $theme_name; my $error = Data::Printer::Common::_tryme("use $class; 1;"); if ($error) { Data::Printer::Common::_warn($ddp, "error loading theme '$theme_name': $error."); return; } my $loaded_colors = {}; my $loaded_colors_sgr = {}; $error = Data::Printer::Common::_tryme(sub { my $class_colors; { no strict 'refs'; $class_colors = &{ $class . '::colors'}(); } die "${class}::colors() did not return a hash reference" unless ref $class_colors eq 'HASH'; foreach my $kind (keys %$class_colors) { my $loaded_color = $class_colors->{$kind}; die "color for '$kind' must be a scalar in theme '$theme_name'" if ref $loaded_color; my $parsed_color = $self->_parse_color($loaded_color, $ddp); if (defined $parsed_color) { $loaded_colors->{$kind} = $loaded_color; $loaded_colors_sgr->{$kind} = $parsed_color; } } }); if ($error) { Data::Printer::Common::_warn($ddp, "error loading theme '$theme_name': $error. Output will have no colors"); return; } $self->{colors} = $loaded_colors; $self->{sgr_colors} = $loaded_colors_sgr; return 1; } sub _parse_color { my ($self, $color_label, $ddp) = @_; return unless defined $color_label; return '' unless $color_label; my $color_code; if ($color_label =~ /\Argb\((\d+),(\d+),(\d+)\)\z/) { my ($r, $g, $b) = ($1, $2, $3); if ($r < 256 && $g < 256 && $b < 256) { if ($self->{color_level} == 3) { $color_code = "\e[0;38;2;$r;$g;${b}m"; } else { my $reduced = _rgb2short($r,$g,$b); $color_code = "\e[0;38;5;${reduced}m"; } } else { Data::Printer::Common::_warn($ddp, "invalid color '$color_label': all colors must be between 0 and 255"); } } elsif ($color_label =~ /\A#([0-9a-f]{2})([0-9a-f]{2})([0-9a-f]{2})\z/i) { my ($r, $g, $b) = map hex($_), ($1, $2, $3); if ($self->{color_level} == 3) { $color_code = "\e[0;38;2;$r;$g;${b}m"; } else { my $reduced = _rgb2short($r,$g,$b); $color_code = "\e[0;38;5;${reduced}m"; } } elsif ($color_label =~ /\A\e\[\d+(:?;\d+)*m\z/) { $color_code = $color_label; } elsif ($color_label =~ /\A (?: \s* (?:on_)? (?:bright_)? (?:black|red|green|yellow|blue|magenta|cyan|white) )+ \s*\z/x ) { my %ansi_colors = ( 'black' => 30, 'on_black' => 40, 'red' => 31, 'on_red' => 41, 'green' => 32, 'on_green' => 42, 'yellow' => 33, 'on_yellow' => 43, 'blue' => 34, 'on_blue' => 44, 'magenta' => 35, 'on_magenta' => 45, 'cyan' => 36, 'on_cyan' => 46, 'white' => 37, 'on_white' => 47, 'bright_black' => 90, 'on_bright_black' => 100, 'bright_red' => 91, 'on_bright_red' => 101, 'bright_green' => 92, 'on_bright_green' => 102, 'bright_yellow' => 93, 'on_bright_yellow' => 103, 'bright_blue' => 94, 'on_bright_blue' => 104, 'bright_magenta' => 95, 'on_bright_magenta' => 105, 'bright_cyan' => 96, 'on_bright_cyan' => 106, 'bright_white' => 97, 'on_bright_white' => 107, ); $color_code = "\e[" . join(';' => map $ansi_colors{$_}, split(/\s+/, $color_label)) . 'm' ; } else { Data::Printer::Common::_warn($ddp, "invalid color '$color_label'"); } return $color_code; } sub _rgb2short { my ($r,$g,$b) = @_; my @snaps = (47, 115, 155, 195, 235); my @new; foreach my $color ($r,$g,$b) { my $big = 0; foreach my $s (@snaps) { $big++ if $s < $color; } push @new, $big } return $new[0]*36 + $new[1]*6 + $new[2] + 16 } 1; __END__ =head1 NAME Data::Printer::Theme - create your own color themes for DDP! =head1 SYNOPSIS package Data::Printer::Theme::MyCustomTheme; sub colors { return { array => '#aabbcc', # array index numbers number => '#aabbcc', # numbers string => '#aabbcc', # strings class => '#aabbcc', # class names method => '#aabbcc', # method names undef => '#aabbcc', # the 'undef' value hash => '#aabbcc', # hash keys regex => '#aabbcc', # regular expressions code => '#aabbcc', # code references glob => '#aabbcc', # globs (usually file handles) vstring => '#aabbcc', # version strings (v5.30.1, etc) lvalue => '#aabbcc', # lvalue label format => '#aabbcc', # format type true => '#aabbcc', # boolean type (true) false => '#aabbcc', # boolean type (false) repeated => '#aabbcc', # references to seen values caller_info => '#aabbcc', # details on what's being printed weak => '#aabbcc', # weak references flag tainted => '#aabbcc', # tainted flag unicode => '#aabbcc', # utf8 flag escaped => '#aabbcc', # escaped characters (\t, \n, etc) brackets => '#aabbcc', # (), {}, [] separator => '#aabbcc', # the "," between hash pairs, array elements, etc quotes => '#aabbcc', # q(") unknown => '#aabbcc', # any (potential) data type unknown to Data::Printer }; } 1; Then in your C<.dataprinter> file: theme = MyCustomTheme That's it! Alternatively, you can load it at runtime: use DDP theme => 'MyCustomTheme'; =head1 DESCRIPTION Data::Printer colorizes your output by default. Originally, the only way to customize colors was to override the default ones. Data::Printer 1.0 introduced themes, and now you can pick a theme or create your own. Data::Printer comes with several themes for you to choose from: =over 4 =item * L I<(the default)> =for html Material Theme =item * L =for html Monokai Theme =item * L =for html Solarized Theme =item * L I<(original pre-1.0 colors)> =for html Classic Theme =back Run C<< examples/try_me.pl >> to see them in action on your own terminal! =head1 CREATING YOUR THEMES A theme is a module in the C namespace. It doesn't have to inherit or load any module. All you have to do is implement a single function, C, that returns a hash reference where keys are the expected color labels, and values are the colors you want to use. Feel free to copy & paste the code from the SYNOPSIS and customize at will :) =head2 Customizing Colors Setting any color to C means I<< "Don't colorize this" >>. Otherwise, the color is a string which can be one of the following: =head3 Named colors, Term::ANSIColor style (discouraged) Only 8 named colors are supported: black, red, green, yellow, blue, magenta, cyan, white and their C, C and C variants. Those are provided only as backards compatibility with older versions of Data::Printer and, because of their limitation, we encourage you to try and use one of the other representations. =head3 SGR Escape code (Terminal style) You may provide any SGR escape sequence, and they will be honored as long as you use double quotes (e.g. C<"\e[38;5;196m">). You may use this to achieve extra control like blinking, etc. Note, however, that some terminals may not support them. =head3 An RGB value in one of those formats (Recommended) 'rgb(0,255,30)' '#00FF3B' B There may not be a real 1:1 conversion between RGB and terminal colors. In those cases we use approximation to achieve the closest option. =head1 SEE ALSO L Data-Printer-1.002001/lib/Data/Printer/Filter/0000755000000000000000000000000014552072607017224 5ustar rootrootData-Printer-1.002001/lib/Data/Printer/Filter/Digest.pm0000644000000000000000000000607114552015171020776 0ustar rootrootpackage Data::Printer::Filter::Digest; use strict; use warnings; use Data::Printer::Filter; filter 'Digest::base' => \&_print_digest; # these modules don't inherit from Digest::base but have the same interface: filter 'Digest::MD2' => \&_print_digest; filter 'Digest::MD4' => \&_print_digest; sub _print_digest { my ($obj, $ddp) = @_; my $digest = $obj->clone->hexdigest; my $str = $digest; my $ref = ref $obj; if ( !exists $ddp->extra_config->{filter_digest}{show_class_name} || $ddp->extra_config->{filter_digest}{show_class_name} ) { $str .= " ($ref)"; } if( !exists $ddp->extra_config->{filter_digest}{show_reset} || $ddp->extra_config->{filter_digest}{show_reset} ) { if ($digest eq $ref->new->hexdigest) { $str .= ' [reset]'; } } return $ddp->maybe_colorize($str, 'datetime', '#ffaaff'); } 1; __END__ =head1 NAME Data::Printer::Filter::Digest - pretty-printing MD5, SHA and many other digests =head1 SYNOPSIS In your C<.dataprinter> file: filters = Digest You may also setup the look and feel with the following options: filter_digest.show_class_name = 0 filter_digest.show_reset = 1 # you can even customize your themes: colors.digest = #27ac3c That's it! =head1 DESCRIPTION This is a filter plugin for L. It filters through several message digest objects and displays their current value in hexadecimal format as a string. =head2 Parsed Modules Any module that inherits from L. The following ones are actively supported: =over 4 =item * L =item * L =item * L =item * L =item * L =item * L =item * L =back If you have any suggestions for more modules or better output, please let us know. =head2 Extra Options Aside from the display color, there are a few other options to be customized via the C option key: =head3 show_class_name If set to true (the default) the class name will be displayed right next to the hexadecimal digest. =head3 show_reset If set to true (the default), the filter will add a C<[reset]> tag after dumping an empty digest object. See the rationale below. =head2 Note on dumping Digest::* objects The digest operation is effectively a destructive, read-once operation. Once it has been performed, most Digest::* objects are automatically reset and can be used to calculate another digest value. This behaviour - or, rather, forgetting about this behaviour - is a common source of issues when working with Digests. This Data::Printer filter will B destroy your object. Instead, we work on a I version to display the hexdigest, leaving your original object untouched. As another debugging convenience for developers, since the empty object will produce a digest even after being used, this filter adds by default a C<[reset]> tag to indicate that the object is empty, in a 'reset' state - i.e. its hexdigest is the same as the hexdigest of a new, empty object of that same class. =head1 SEE ALSO L Data-Printer-1.002001/lib/Data/Printer/Filter/CODE.pm0000644000000000000000000000266314552015171020274 0ustar rootrootpackage Data::Printer::Filter::CODE; use strict; use warnings; use Data::Printer::Filter; use Data::Printer::Common; use Scalar::Util (); use Fcntl; filter 'CODE' => \&parse; sub parse { my ($subref, $ddp) = @_; my $string; my $color = 'code'; if ($ddp->deparse) { $string = _deparse($subref, $ddp); if ($ddp->coderef_undefined && $string =~ /\A\s*sub\s*;\s*\z/) { $string = $ddp->coderef_undefined; $color = 'undef'; } } elsif ($ddp->coderef_undefined && !_subref_is_reachable($subref)) { $string = $ddp->coderef_undefined; $color = 'undef'; } else { $string = $ddp->coderef_stub; } return $ddp->maybe_colorize($string, $color); }; ####################################### ### Private auxiliary helpers below ### ####################################### sub _deparse { my ($subref, $ddp) = @_; require B::Deparse; # FIXME: line below breaks encapsulation on Data::Printer::Object my $i = $ddp->{indent} + $ddp->{_array_padding}; my $deparseopts = ["-sCi${i}v'Useless const omitted'"]; my $sub = 'sub ' . B::Deparse->new($deparseopts)->coderef2text($subref); my $pad = $ddp->newline; $sub =~ s/\n/$pad/gse; return $sub; } sub _subref_is_reachable { my ($subref) = @_; require B; my $cv = B::svref_2object($subref); return !(B::class($cv->ROOT) eq 'NULL' && !${ $cv->const_sv }); } 1; Data-Printer-1.002001/lib/Data/Printer/Filter/DateTime.pm0000644000000000000000000001421014552015171021245 0ustar rootrootpackage Data::Printer::Filter::DateTime; use strict; use warnings; use Data::Printer::Filter; use Scalar::Util; filter 'Time::Piece' => sub { _format($_[0]->cdate , @_) }; filter 'Time::Moment' => sub { _format($_[0]->to_string , @_) }; filter 'DateTime::TimeZone' => sub { _format($_[0]->name , @_) }; filter 'DateTime::Incomplete' => sub { _format($_[0]->iso8601 , @_) }; filter 'DateTime::Tiny' => sub { _format($_[0]->as_string , @_) }; filter 'Date' => sub { _format($_[0]->to_string , @_) }; filter 'Date::Tiny' => sub { _format($_[0]->as_string , @_) }; filter 'Date::Calc::Object' => sub { _format($_[0]->string(2) , @_) }; filter 'Date::Handler' => sub { _format("$_[0]" , @_) }; filter 'Date::Handler::Delta' => sub { _format($_[0]->AsScalar , @_) }; filter 'Date::Simple' => sub { _format("$_[0]" , @_) }; filter 'Date::Manip::Obj' => sub { _format(scalar $_[0]->value, @_) }; filter 'Mojo::Date' => sub { my $date = $_[0]->can('to_datetime') ? $_[0]->to_datetime : $_[0]->to_string ; return _format($date , @_); }; filter 'Class::Date::Rel' => sub { my ($obj, $ddp) = @_; my $string = ''; if (my $months = $obj->mon_part) { if (my $years = int($months / 12)) { $string .= $years . 'Y'; $months -= $years * 12; } if ($months) { $string .= (length($string) ? ' ' : '') . $months . 'M'; } } if (my $seconds = $obj->sec_part) { my $minutes = int($seconds / 60); my $hours = int($minutes / 60); my $days = int($hours / 24); my $delta = 0; if ($days) { $string .= (length($string) ? ' ' : '') . $days . 'D'; $delta = $days * 24; $hours -= $delta; } if ($hours) { $string .= (length($string) ? ' ' : '') . $hours . 'h'; $delta = $delta * 60 + $hours * 60; $minutes -= $delta; } if ($minutes) { $string .= (length($string) ? ' ' : '') . $minutes . 'm'; $delta = $delta * 60 + $minutes * 60; $seconds -= $delta; } if ($seconds) { $string .= (length($string) ? ' ' : '') . $seconds . 's'; } } return _format( $string, @_ ); }; filter 'DateTime', sub { my ($obj, $ddp) = @_; my $string = "$obj"; if (!exists $ddp->extra_config->{filter_datetime}{show_timezone} || $ddp->extra_config->{filter_datetime}{show_timezone} ) { $string .= ' ' . $ddp->maybe_colorize('[', 'brackets') . $obj->time_zone->name . $ddp->maybe_colorize(']', 'brackets'); } return _format( $string, @_ ); }; filter 'DateTime::Duration', sub { my ($obj, $ddp) = @_; my @dur = $obj->in_units(qw(years months days hours minutes seconds)); my $string = "$dur[0]y $dur[1]m $dur[2]d $dur[3]h $dur[4]m $dur[5]s"; return _format( $string, @_ ); }; filter 'Class::Date', sub { my ($obj, $ddp) = @_; my $string = $obj->strftime("%Y-%m-%d %H:%M:%S"); if (!exists $ddp->extra_config->{filter_datetime}{show_timezone} || $ddp->extra_config->{filter_datetime}{show_timezone} ) { $string .= ' ' . $ddp->maybe_colorize('[', 'brackets') . $obj->tzdst . $ddp->maybe_colorize(']', 'brackets'); } return _format( $string, @_ ); }; sub _time_seconds_formatter { my ($n, $counted) = @_; my $number = sprintf("%d", $n); # does a "floor" $counted .= 's' if 1 != $number; return ($number, $counted); } filter 'Time::Seconds', sub { my ($obj, $ddp) = @_; my $str = ''; if ($obj->can('pretty')) { $str = $obj->pretty; } else { # simple pretty() implementation: if ($obj < 0) { $obj = -$obj; $str = 'minus '; } if ($obj >= 60) { if ($obj >= 3600) { if ($obj >= 86400) { my ($days, $sd) = _time_seconds_formatter($obj->days, "day"); $str .= "$days $sd, "; $obj -= ($days * 86400); } my ($hours, $sh) = _time_seconds_formatter($obj->hours, "hour"); $str .= "$hours $sh, "; $obj -= ($hours * 3600); } my ($mins, $sm) = _time_seconds_formatter($obj->minutes, "minute"); $str .= "$mins $sm, "; $obj -= ($mins * 60); } $str .= join ' ', _time_seconds_formatter($obj->seconds, "second"); } return _format($str, $obj, $ddp); }; sub _format { my ($str, $obj, $ddp) = @_; if ($ddp->extra_config->{filter_datetime}{show_class_name}) { $str .= ' ' . $ddp->maybe_colorize('(', 'brackets') . Scalar::Util::blessed($obj) . $ddp->maybe_colorize(')', 'brackets'); } return $ddp->maybe_colorize($str, 'datetime', '#aaffaa'); } 1; __END__ =head1 NAME Data::Printer::Filter::DateTime - pretty-printing date and time objects (not just DateTime!) =head1 SYNOPSIS In your C<.dataprinter> file: filters = DateTime You may also customize the look and feel with the following options (defaults shown): filter_datetime.show_class_name = 1 filter_datetime.show_timezone = 0 # you can even customize your themes: colors.datetime = #cc7a23 That's it! =head1 DESCRIPTION This is a filter plugin for L. It filters through several date and time manipulation classes and displays the time (or time duration) as a string. =head2 Parsed Modules =over 4 =item * L, L =item * L =item * L, L, L, L =item * L =item * L =item * L =item * L =item * L, L =item * L =item * L =item * L, L =item * L =back If you have any suggestions for more modules or better output, please let us know. =head1 SEE ALSO L Data-Printer-1.002001/lib/Data/Printer/Filter/Regexp.pm0000644000000000000000000000170014552015171021003 0ustar rootrootpackage Data::Printer::Filter::Regexp; use strict; use warnings; use Data::Printer::Filter; use Data::Printer::Common; filter 'Regexp' => sub { my ($regexp, $ddp) = @_; my $val = "$regexp"; my $string; # a regex to parse a regex. Talk about full circle :) # note: we are not validating anything, just grabbing modifiers if ($val =~ m/\(\?\^?([uladxismnpogce]*)(?:\-[uladxismnpogce]+)?:(.*)\)/s) { my ($modifiers, $parsed_val) = ($1, $2); $string = $ddp->maybe_colorize($parsed_val, 'regex'); if ($modifiers) { $string .= " (modifiers: $modifiers)"; } } else { Data::Printer::Common::_warn($ddp, "Unrecognized regex $val. Please submit a bug report for Data::Printer."); $string = $ddp->maybe_colorize('Unknown Regexp', 'regex'); } if ($ddp->show_tied and my $tie = ref tied $regexp) { $string .= " (tied to $tie)"; } return $string; }; 1; Data-Printer-1.002001/lib/Data/Printer/Filter/DB.pm0000644000000000000000000004631614552015171020052 0ustar rootrootpackage Data::Printer::Filter::DB; use strict; use warnings; use Data::Printer::Filter; use Data::Printer::Common; filter 'DBI::db', sub { my ($dbh, $ddp) = @_; my $name = $dbh->{Driver}{Name}; my $string = "$name Database Handle " . $ddp->maybe_colorize('(', 'brackets') . _get_db_status($dbh->{Active}, $ddp) . $ddp->maybe_colorize(')', 'brackets') ; return $string if exists $ddp->extra_config->{filter_db}{connection_details} && !$ddp->extra_config->{filter_db}{connection_details}; $string .= ' ' . $ddp->maybe_colorize('{', 'brackets'); $ddp->indent; my %dsn = split( /[;=]/, $dbh->{Name} ); foreach my $k (keys %dsn) { $string .= $ddp->newline . $k . $ddp->maybe_colorize(':', 'separator') . ' ' . $dsn{$k}; } $string .= $ddp->newline . 'Auto Commit: ' . $dbh->{AutoCommit}; my $kids = $dbh->{Kids}; $string .= $ddp->newline . 'Statement Handles: ' . $kids; if ($kids > 0) { $string .= ' (' . $dbh->{ActiveKids} . ' active)'; } if ( defined $dbh->err ) { $string .= $ddp->newline . 'Error: ' . $dbh->errstr; } $string .= $ddp->newline . 'Last Statement: ' . $ddp->maybe_colorize(($dbh->{Statement} || '-'), 'string'); $ddp->outdent; $string .= $ddp->newline . $ddp->maybe_colorize('}', 'brackets'); return $string; }; filter 'DBI::st', sub { my ($sth, $ddp) = @_; my $str = $ddp->maybe_colorize(($sth->{Statement} || '-'), 'string'); if ($sth->{NUM_OF_PARAMS} > 0) { my $values = $sth->{ParamValues}; if ($values) { $str .= ' ' . $ddp->maybe_colorize('(', 'brackets') . join($ddp->maybe_colorize(',', 'separator') . ' ', map { my $v = $values->{$_}; $ddp->parse($v); } 1 .. $sth->{NUM_OF_PARAMS} ) . $ddp->maybe_colorize(')', 'brackets'); } else { $str .= ' ' . $ddp->maybe_colorize('(bindings unavailable)', 'undef'); } } return $str; }; # DBIx::Class filters filter 'DBIx::Class::Schema' => sub { my ($schema, $ddp) = @_; my $name = $ddp->maybe_colorize(ref($schema), 'class'); my $storage = $schema->storage; my $config = {}; $config = $ddp->extra_config->{filter_db}{schema} if exists $ddp->extra_config->{filter_db} && exists $ddp->extra_config->{filter_db}{schema}; my $expand = exists $config->{expand} ? $config->{expand} : $ddp->class->expand ; my $connected = _get_db_status($storage->connected, $ddp); if (!$expand) { return "$name " . $ddp->maybe_colorize('(', 'brackets') . $storage->sqlt_type . " - $connected" . $ddp->maybe_colorize(')', 'brackets') ; } $ddp->indent; my $output = $name . ' ' . $ddp->maybe_colorize('{', 'brackets') . $ddp->newline . 'connection: ' . ($config->{show_handle} ? $ddp->parse($storage->dbh) : $storage->sqlt_type . " Database Handle ($connected)" ); if ($storage->is_replicating) { $output .= $ddp->newline . 'replication lag: ' . $storage->lag_behind_master; } my $load_sources = 'names'; if (exists $config->{loaded_sources}) { my $type = $config->{loaded_sources}; if ($type && ($type eq 'names' || $type eq 'details' || $type eq 'none')) { $load_sources = $type; } else { Data::Printer::Common::_warn( $ddp, "filter_db.schema.loaded_sources must be names, details or none" ); } } if ($load_sources ne 'none') { my @sources = $schema->sources; @sources = Data::Printer::Common::_nsort(@sources) if $ddp->class->sort_methods && @sources; $output .= $ddp->newline . 'loaded sources:'; if ($load_sources eq 'names') { $output .= ' ' . (@sources ? join(', ', map($ddp->maybe_colorize($_, 'method'), @sources)) : '-' ); } else { $ddp->indent; foreach my $i (0 .. $#sources) { my $source = $schema->source($sources[$i]); $output .= $ddp->newline . $ddp->parse($source); $output .= $ddp->maybe_colorize(',', 'separator') if $i < $#sources; } $ddp->outdent; } } $ddp->outdent; $output .= $ddp->newline . $ddp->maybe_colorize('}', 'brackets'); return $output; }; filter 'DBIx::Class::Row' => sub { my ($row, $ddp) = @_; my $output = $row->result_source->source_name . ' Row ' . $ddp->maybe_colorize('(', 'brackets') . ($row->in_storage ? '' : 'NOT ') . 'in storage' . $ddp->maybe_colorize(') {', 'brackets'); $ddp->indent; my %orig_columns = map { $_ => 1 } $row->columns; my %data = $row->get_columns; my %dirty = $row->get_dirty_columns; # TODO: maybe also get_inflated_columns() ? my @ordered = Data::Printer::Common::_nsort(keys %data); my $longest = 0; foreach my $col (@ordered) { my $l = length $col; $longest = $l if $l > $longest; } my $show_updated_label = !exists $ddp->extra_config->{filter_db}{show_updated_label} || $ddp->extra_config->{filter_db}{show_updated_label}; my $show_extra_label = !exists $ddp->extra_config->{filter_db}{show_extra_label} || $ddp->extra_config->{filter_db}{show_extra_label}; foreach my $col (@ordered) { my $padding = $longest - length($col); my $content = $data{$col}; $output .= $ddp->newline . $col . $ddp->maybe_colorize(':', 'separator') . ' ' . (' ' x $padding) . $ddp->parse(\$content, seen_override => 1) ; if (exists $dirty{$col} && $show_updated_label) { $output .= ' (updated)'; } if (!exists $orig_columns{$col} && $show_extra_label) { $output .= ' (extra)'; } } # TODO: methods: foo, bar <-- follows class.*, but can be overriden by filter_db.class.* $ddp->outdent; $output .= $ddp->newline . $ddp->maybe_colorize('}', 'brackets'); return $output; }; filter 'DBIx::Class::ResultSet' => sub { my ($rs, $ddp) = @_; $ddp->indent; my $output = $rs->result_source->source_name . ' ResultSet ' . $ddp->maybe_colorize('{', 'brackets') . $ddp->newline; # NOTE: we're totally breaking DBIC's encapsulation here. But since DDP # is a tool to inspect the inner workings of objects, it's okay. Ish. $output .= 'current search parameters: '; my $attrs; if ($rs->can('_resolved_attrs') && eval { $attrs = { %{ $rs->_resolved_attrs } }; 1; } && ref $attrs eq 'HASH' ) { if (exists $attrs->{where}) { $output .= $ddp->parse($attrs->{where}) } else { $output .= '-'; } } else { $output .= $ddp->maybe_colorize('(unable to lookup - patches welcome!)', 'unknown'); } # TODO: show joins/prefetches/from # TODO: look at get_cache() for results if ($rs->can('as_query')) { my $query_data = $rs->as_query; my @query_data = @$$query_data; my $sql = shift @query_data; $output .= $ddp->newline . 'as query:'; $ddp->indent; $output .= $ddp->newline . $ddp->maybe_colorize( $sql, 'string' ) ; if (@query_data) { $output .= $ddp->newline . join( $ddp->newline, map { my $bound = $_->[1]; if ($_->[0]{sqlt_datatype}) { $bound .= ' ' . $ddp->maybe_colorize('(', 'brackets') . $_->[0]{sqlt_datatype} . $ddp->maybe_colorize(')', 'brackets'); } $bound } @query_data ); } $ddp->outdent; } if (my $cached = $rs->get_cache) { $output .= $ddp->newline . 'cached results:'; $ddp->indent; $output .= $ddp->newline . $ddp->parse($cached); $ddp->outdent; } $ddp->outdent; $output .= $ddp->newline . $ddp->maybe_colorize('}', 'brackets'); return $output; }; filter 'DBIx::Class::ResultSource' => sub { my ($source, $ddp) = @_; my $cols = $source->columns_info; my $output = $source->source_name . ' ResultSource'; if ($source->isa('DBIx::Class::ResultSource::View')) { $output .= ' ' . $ddp->maybe_colorize('(', 'brackets') . ($source->is_virtual ? 'Virtual ' : '') . 'View' . $ddp->maybe_colorize(')', 'brackets') ; } my $show_source_table = !exists $ddp->extra_config->{filter_db}{show_source_table} || $ddp->extra_config->{filter_db}{show_source_table}; my $column_info = 'details'; if (exists $ddp->extra_config->{filter_db}{column_info}) { my $new = $ddp->extra_config->{filter_db}{column_info}; if ($new && ($new eq 'names' || $new eq 'details' || $new eq 'none')) { $column_info = $new; } else { Data::Printer::Common::_warn( $ddp, "filter_db.column_info must be names, details or none" ); } } return $output if !$show_source_table && $column_info eq 'none'; $ddp->indent; $output .= ' ' . $ddp->maybe_colorize('{', 'brackets'); if ($show_source_table) { $output .= $ddp->newline . 'table: ' . $ddp->parse(\$source->name); } if ($column_info ne 'none') { my $columns = $source->columns_info; $output .= $ddp->newline . 'columns:'; $output .= ' - ' unless %$columns; my $separator = $ddp->maybe_colorize(',', 'separator') . ' '; if ($column_info eq 'names') { my %parsed_cols = map { $_ => 1 } keys %$columns; my @primary = Data::Printer::Common::_nsort($source->primary_columns); if (@primary) { delete $parsed_cols{$_} foreach @primary; $output .= ' ' . join($separator => map { $ddp->maybe_colorize($_, 'method') . ' (primary)' } @primary ); $output .= ',' if keys %parsed_cols; } if (keys %parsed_cols) { $output .= ' ' . join($separator => map { $ddp->maybe_colorize($_, 'method') } Data::Printer::Common::_nsort(keys %parsed_cols) ); } } else { # details! $output .= _show_column_details($source, $columns, $ddp); } my %uniques = $source->unique_constraints; delete $uniques{primary}; if (keys %uniques) { $output .= $ddp->newline . 'non-primary uniques:'; $ddp->indent; foreach my $key (Data::Printer::Common::_nsort(keys %uniques)) { $output .= $ddp->newline . $ddp->maybe_colorize('(', 'brackets') . join($separator, @{$uniques{$key}}) . $ddp->maybe_colorize(')', 'brackets') . " as '$key'" ; } $ddp->outdent; } # TODO: use $source->relationships and $source->relationship_info # to list relationships between sources. (filter_db.show_relationships # TODO: public methods implemented by the user # TODO; "current result count" (touching the db) # TODO: "first X eresults" (touching the db) } $ddp->outdent; return $output . $ddp->newline . $ddp->maybe_colorize('}', 'brackets'); }; sub _show_column_details { my ($source, $columns, $ddp) = @_; my $output = ''; my %parsed_columns; foreach my $colname (keys %$columns) { my $meta = $columns->{$colname}; my $parsed = ' '; if (exists $meta->{data_type} && defined $meta->{data_type}) { $parsed .= $meta->{data_type}; if (exists $meta->{size}) { my @size = ref $meta->{size} eq 'ARRAY' ? @{$meta->{size}} : ($meta->{size}) ; if ($meta->{data_type} =~ /\((.+?)\)/) { my @other_size = split ',' => $1; my $different_sizes = @size != @other_size; if (!$different_sizes) { foreach my $i (0 .. $#size) { if ($size[$i] != $other_size[$i]) { $different_sizes = 1; last; } } } if ($different_sizes) { $parsed .= ' (meta size as ' . join(',' => @size) . ')'; } } else { $parsed .= '(' . join(',' => @size) . ')'; } } } else { $parsed .= $ddp->maybe_colorize('(unknown data type)', 'unknown'); } if (exists $meta->{is_nullable}) { $parsed .= ((' not')x !$meta->{is_nullable}) . ' null'; } if (exists $meta->{default_value} && defined $meta->{default_value}) { my $default = $meta->{default_value}; if (ref $default) { $default = $$default; } elsif (defined $meta->{is_numeric}) { # <-- not undef! $default = $meta->{is_numeric} ? 0+$default : qq("$default"); } elsif ($source->storage->is_datatype_numeric($meta->{data_type})) { $default = 0+$default; } else { $default = qq("$default"); } $parsed .= " default $default"; } if (exists $meta->{is_auto_increment} && $meta->{is_auto_increment}) { $parsed .= ' auto_increment'; } $parsed_columns{$colname} = $parsed; } my @primary_keys = $source->primary_columns; if (keys %parsed_columns || @primary_keys) { my $separator = $ddp->maybe_colorize(',', 'separator'); $ddp->indent; foreach my $colname (@primary_keys) { my $value = exists $parsed_columns{$colname} ? delete $parsed_columns{$colname} : ''; $output .= $ddp->newline . $colname . (defined $value ? $value : '') . ' (primary)' . (keys %parsed_columns ? $separator : '') ; } if (keys %parsed_columns) { my @sorted_columns = Data::Printer::Common::_nsort(keys %parsed_columns); foreach my $i (0 .. $#sorted_columns) { my $colname = $sorted_columns[$i]; # TODO: v-align column names (like hash keys) $output .= $ddp->newline . $colname . $parsed_columns{$colname} . ($i == $#sorted_columns ? '' : $separator) ; } } $ddp->outdent; } return $output; } sub _get_db_status { my ($status, $ddp) = @_; return $status ? $ddp->maybe_colorize('connected', 'filter_db_connected', '#a0d332') : $ddp->maybe_colorize('disconnected', 'filter_db_disconnected', '#b3422d') ; } 1; __END__ =head1 NAME Data::Printer::Filter::DB - pretty-printing database objects (DBI, DBIx::Class, etc) =head1 SYNOPSIS In your C<.dataprinter> file: filters = DB You may also customize the look and feel with the following options (defaults shown): ### DBH settings: # expand database handle objects filter_db.connection_details = 1 ### DBIx::Class settings: # signal when a result column is dirty: filter_db.show_updated_label = 1 # signal when result rows contain extra columns: filter_db.show_extra_label = 1 # override class.expand for schema dump filter_db.schema.expand = 1 # expand DBH handle on schema dump (may touch DB) filter_db.schema.show_handle = 0 # show source details (connected tables) on schema dump # (may be set to 'names', 'details' or 'none') filter_db.schema.loaded_sources = names # show source table name ResultSource objects filter_db.show_source_table = 1 # show source columns ('names', 'details' or 'none'): filter_db.column_info = details # this plugin honors theme colors where applicable # and provides the following custom colors for you to use: colors.filter_db_connected = #a0d332 colors.filter_db_disconnected = #b3422d That's it! =head1 DESCRIPTION This is a filter plugin for L that displays (hopefully) more relevant information on database objects than a regular dump. =head2 Parsed Modules =head3 L If it's a database handle, for example, this filter may show you something like this: SQLite Database Handle (connected) { dbname: file.db Auto Commit: 1 Statement Handles: 2 (1 active) Last Statement: SELECT * FROM some_table } You can show less information by setting this option on your C<.dataprinter>: filter_db.connection_details = 0 If you have a statement handler like this (for example): my $sth = $dbh->prepare('SELECT * FROM foo WHERE bar = ?'); $sth->execute(42); use DDP; p $sth; This is what you'll get: SELECT * FROM foo WHERE bar = ? (42) Note that if your driver does not support holding of parameter values, you'll get a C message instead of the bound values. =head3 L This filter is able to pretty-print many common DBIx::Class objects for inspection. Unless otherwrise noted, none of those calls will touch the database. B objects are dumped by default like this: MyApp::Schema { connection: MySQL Database Handle (connected) replication lag: 4 loaded sources: ResultName1, ResultName2, ResultName3 } If your C<.dataprinter> settings have C set to C<0>, it will only show this: MyApp::Schema (MySQL - connected) You may override this with C (or 0). Other available options for the schema are (default values shown): # if set to 1, expands 'connection' into a complete DBH dump # NOTE: this may touch the database as it could try to reconnect # to fetch a healthy DBH: filter_db.schema.show_handle = 0 # set to 'details' to view source details, or 'none' to skip it: filter_db.schema.loaded_sources = names B objects will be expanded to show details of what that source represents on the database (as perceived by DBIx::Class), including column information and whether the table is virtual or not. User ResultSource { table: "user" columns: user_id integer not null auto_increment (primary), email varchar(100), bio text non-primary uniques: (email) as 'user_email' } =head4 Ever got bit by DBIx::Class? Let us know if we can help by creating an issue on Data::Printer's Github. Patches are welcome! =head1 SEE ALSO L Data-Printer-1.002001/lib/Data/Printer/Filter/REF.pm0000644000000000000000000000105414552015171020167 0ustar rootrootpackage Data::Printer::Filter::REF; use strict; use warnings; use Data::Printer::Filter; use Scalar::Util (); filter 'REF' => \&parse; sub parse { my ($ref, $ddp) = @_; my $string = ''; # we only add the '\' if it's not an object if (!Scalar::Util::blessed($$ref) && (ref $$ref eq 'REF' || ref $$ref eq 'SCALAR' || ref $$ref eq 'VSTRING')) { $string .= '\\ '; } $string .= $ddp->parse($$ref); if ($ddp->show_tied and my $tie = ref tied $ref) { $string .= " (tied to $tie)"; } return $string; }; 1; Data-Printer-1.002001/lib/Data/Printer/Filter/OBJECT.pm0000644000000000000000000000025314552015171020521 0ustar rootrootpackage Data::Printer::Filter::OBJECT; use strict; use warnings; use Data::Printer::Filter; filter 'OBJECT' => \&parse; sub parse { return '(opaque object)'; }; 1; Data-Printer-1.002001/lib/Data/Printer/Filter/SCALAR.pm0000644000000000000000000001014414552072052020521 0ustar rootrootpackage Data::Printer::Filter::SCALAR; use strict; use warnings; use Data::Printer::Filter; use Scalar::Util; use constant HAS_BOOLEAN => $] ge '5.036000'; filter 'SCALAR' => \&parse; filter 'LVALUE' => sub { my ($scalar_ref, $ddp) = @_; my $string = parse($scalar_ref, $ddp); if ($ddp->show_lvalue) { $string .= $ddp->maybe_colorize(' (LVALUE)', 'lvalue'); } return $string; }; sub parse { my ($scalar_ref, $ddp) = @_; my $ret; my $value = ref $scalar_ref ? $$scalar_ref : $scalar_ref; if (not defined $value) { $ret = $ddp->maybe_colorize('undef', 'undef'); } elsif (HAS_BOOLEAN && _is_bool($value)) { if ($value) { $ret = $ddp->maybe_colorize('true', 'true'); } else { $ret = $ddp->maybe_colorize('false', 'false'); } } elsif ( $ddp->show_dualvar ne 'off' ) { my $numified; $numified = do { no warnings 'numeric'; 0+ $value } if defined $value; if ( $numified ) { if ( "$numified" eq $value || ( # lax mode allows decimal zeroes $ddp->show_dualvar eq 'lax' && ((index("$numified",'.') != -1 && $value =~ /\A\s*${numified}[0]*\s*\z/) || (index("$numified",'.') == -1 && $value =~ /\A\s*$numified(?:\.[0]*)?\s*\z/)) ) ) { $value =~ s/\A\s+//; $value =~ s/\s+\z//; $ret = $ddp->maybe_colorize($value, 'number'); } else { $ret = Data::Printer::Common::_process_string( $ddp, "$value", 'string' ); $ret = _quoteme($ddp, $ret); $ret .= ' (dualvar: ' . $ddp->maybe_colorize( $numified, 'number' ) . ')'; } } elsif ( !$numified && _is_number($value) ) { $ret = $ddp->maybe_colorize($value, 'number'); } else { $ret = Data::Printer::Common::_process_string($ddp, $value, 'string'); $ret = _quoteme($ddp, $ret); } } elsif (_is_number($value)) { $ret = $ddp->maybe_colorize($value, 'number'); } else { $ret = Data::Printer::Common::_process_string($ddp, $value, 'string'); $ret = _quoteme($ddp, $ret); } $ret .= _check_tainted($ddp, $scalar_ref); $ret .= _check_unicode($ddp, $scalar_ref); if ($ddp->show_tied and my $tie = ref tied $$scalar_ref) { $ret .= " (tied to $tie)"; } return $ret; }; ####################################### ### Private auxiliary helpers below ### ####################################### sub _quoteme { my ($ddp, $text) = @_; my $scalar_quotes = $ddp->scalar_quotes; if (defined $scalar_quotes) { # foo'bar ==> 'foo\'bar' $text =~ s{$scalar_quotes}{\\$scalar_quotes}g if index($text, $scalar_quotes) >= 0; my $quote = $ddp->maybe_colorize( $scalar_quotes, 'quotes' ); $text = $quote . $text . $quote; } return $text; } sub _check_tainted { my ($self, $var) = @_; return ' (TAINTED)' if $self->show_tainted && Scalar::Util::tainted($$var); return ''; } sub _check_unicode { my ($self, $var) = @_; return ' (U)' if $self->show_unicode && utf8::is_utf8($$var); return ''; } sub _is_number { my ($maybe_a_number) = @_; # Scalar values that start with a zero are strings, NOT numbers. # You can write `my $foo = 0123`, but then `$foo` will be 83, # (numbers starting with zero are octal integers) return if $maybe_a_number =~ /^-?0[0-9]/; my $is_number = $maybe_a_number =~ m/ ^ -? # numbers may begin with a '-' sign, but can't with a '+'. # If they do they are not numbers, but strings. [0-9]+ # then there should be some numbers ( \. [0-9]+ )? # there can be decimal part, which is optional ( e [+-] [0-9]+ )? # and an also optional exponential notation part \z /x; return $is_number; } sub _is_bool { no if HAS_BOOLEAN, warnings => 'experimental::builtin'; return builtin::is_bool($_[0]); } 1; Data-Printer-1.002001/lib/Data/Printer/Filter/GenericClass.pm0000644000000000000000000003331214552015171022117 0ustar rootrootpackage Data::Printer::Filter::GenericClass; use strict; use warnings; use Data::Printer::Filter; use Data::Printer::Common; use Scalar::Util; filter '-class' => sub { my ($object, $ddp) = @_; # if the class implements its own Data::Printer method, we use it! if ($ddp->class_method and my $method = $object->can( $ddp->class_method )) { return $method->($object, $ddp) if ref $method eq 'CODE'; } my $class_name = ref $object; # there are many parts of the class filter that require the object's # linear ISA, so we declare it earlier and load it only once: my $linear_ISA = Data::Printer::Common::_linear_ISA_for($class_name, $ddp); # if the object overloads stringification, use it! # except for PDF::API2 which has a destructive stringify() if ($ddp->class->stringify && $class_name ne 'PDF::API2') { my $str = _get_stringification($ddp, $object, $class_name); return $ddp->maybe_colorize("$str ($class_name)", 'class') if defined $str; } # otherwise, do our generic object representation: my $show_reftype = $ddp->class->show_reftype; my $show_internals = $ddp->class->internals; my $reftype; if ($show_reftype || $show_internals) { $reftype = Scalar::Util::reftype($object); $reftype = 'Regexp' if $reftype eq 'REGEXP'; } $ddp->{_class_depth}++; my $string = $ddp->maybe_colorize( $class_name, 'class' ); if ($show_reftype) { $string .= ' ' . $ddp->maybe_colorize('(', 'brackets') . $ddp->maybe_colorize( $reftype, 'class' ) . $ddp->maybe_colorize(')', 'brackets'); } if ($ddp->class->expand eq 'all' || $ddp->class->expand >= $ddp->{_class_depth}) { $ddp->indent; $string .= ' ' . $ddp->maybe_colorize('{', 'brackets'); my @superclasses = Data::Printer::Common::_get_superclasses_for($class_name); if (@superclasses && $ddp->class->parents) { $string .= $ddp->newline . 'parents: ' . join(', ', map $ddp->maybe_colorize($_, 'class'), @superclasses) ; } my (%roles, %attributes); if ($INC{'Role/Tiny.pm'} && exists $Role::Tiny::APPLIED_TO{$class_name}) { %roles = %{ $Role::Tiny::APPLIED_TO{$class_name} }; } my $is_moose = 0; foreach my $parent (@$linear_ISA) { if ($parent eq 'Moo::Object') { Data::Printer::Common::_tryme(sub { my $moo_maker = 'Moo'->_constructor_maker_for($class_name); if (defined $moo_maker) { %attributes = %{ $moo_maker->all_attribute_specs }; } }); last; } elsif ($parent eq 'Moose::Object') { Data::Printer::Common::_tryme(sub { my $class_meta = $class_name->meta; $is_moose = 1; %attributes = map { $_->name => { index => $_->insertion_order, init_arg => $_->init_arg, is => (defined $_->writer ? 'rw' : 'ro'), reader => $_->reader, required => $_->is_required, } } $class_meta->get_all_attributes(); foreach my $role ($class_meta->calculate_all_roles()) { $roles{ $role->name } = 1; } }); last; } elsif ($parent eq 'Object::Pad::UNIVERSAL') { Data::Printer::Common::_tryme(sub { my $meta = Object::Pad::MOP::Class->for_class( $class_name ); %attributes = map { $_->name . $_->value($class_name) => { } } $meta->fields; %roles = map { $_->name => 1 } $meta->direct_roles; }); } } if ($ddp->class->show_methods ne 'none') { if (my @role_list = keys %roles) { @role_list = Data::Printer::Common::_nsort(@role_list) if @role_list && $ddp->class->sort_methods; $string .= $ddp->newline . 'roles (' . scalar(@role_list) . '): ' . join(', ' => map $ddp->maybe_colorize($_, 'class'), @role_list) ; } if (my @attr_list = keys %attributes) { @attr_list = Data::Printer::Common::_nsort(@attr_list) if @attr_list && $ddp->class->sort_methods; $string .= $ddp->newline . 'attributes (' . scalar(@attr_list) . '): ' . join(', ' => map $ddp->maybe_colorize($_, 'method'), @attr_list) ; } } my $show_linear_isa = $ddp->class->linear_isa && ( ($ddp->class->linear_isa eq 'auto' and @superclasses > 1) or ($ddp->class->linear_isa ne 'auto') ); if ($show_linear_isa && @$linear_ISA) { $string .= $ddp->newline . 'linear @ISA: ' . join(', ' => map $ddp->maybe_colorize($_, 'class'), @$linear_ISA) ; } if ($ddp->class->show_methods ne 'none') { $string .= _show_methods($class_name, $linear_ISA, \%attributes, $ddp); if ($is_moose && $ddp->class->show_wrapped) { my $modified = ''; my $modified_count = 0; $ddp->indent; for my $method ($class_name->meta->get_all_methods) { if (ref $method eq 'Class::MOP::Method::Wrapped') { foreach my $kind (qw(before around after)) { my $getter_method = $kind . '_modifiers'; if (my @modlist = $method->$getter_method) { $modified .= $ddp->newline . $kind . ' ' . $method->name . ': ' . (@modlist > 1 ? $ddp->parse(\@modlist) : $ddp->parse($modlist[0])); $modified_count++; } } } } $ddp->outdent; if ($modified_count) { $string .= $ddp->newline . 'method modifiers (' . $modified_count . '):' . $modified; } } } if ($ddp->class->show_overloads) { my @overloads = _get_overloads($object); if (@overloads) { $string .= $ddp->newline . 'overloads: ' . join(', ' => @overloads); } } if ($show_internals) { $string .= $ddp->newline . 'internals: ' . $ddp->parse_as($reftype, $object) ; } $ddp->outdent; $string .= $ddp->newline . $ddp->maybe_colorize('}', 'brackets'); } $ddp->{_class_depth}--; if ($ddp->show_tied and my $tie = ref tied $object) { $string .= " (tied to $tie)"; } return $string; }; ####################################### ### Private auxiliary helpers below ### ####################################### sub _get_stringification { my ($ddp, $object, $class_name) = @_; require overload; if (overload::Overloaded($object) && (overload::Method($object, q("")) || overload::Method($object, q(0+)) ) ) { my $string; my $error = Data::Printer::Common::_tryme(sub { $string = '' . $object }); if ($error) { Data::Printer::Common::_warn( $ddp, "string/number overload error for object $class_name: $error" ); } else { return $string; } } foreach my $method (qw(as_string stringify to_string)) { if ($object->can($method)) { my $string; my $error = Data::Printer::Common::_tryme(sub { $string = $object->$method }); if ($error) { Data::Printer::Common::_warn( $ddp, "error stringifying object $class_name with $method\(\): $error" ); } else { return $string; } } } return; } # returns array of all overloads in class; sub _get_overloads { my ($object) = @_; require overload; return () unless overload::Overloaded($object); return sort grep overload::Method($object, $_), map split(/\s+/), values %overload::ops; } sub _show_methods { my ($class_name, $linear_ISA, $attributes, $ddp) = @_; my %methods = ( public => {}, private => {} ); my @all_methods = map _methods_of( $_, Data::Printer::Common::_get_namespace($_) ), @$linear_ISA; my $show_methods = $ddp->class->show_methods; my $show_inherited = $ddp->class->inherited; my %seen_method_name; foreach my $method (@all_methods) { my ($package_string, $method_string) = @$method; next if exists $attributes->{$method_string}; next if $seen_method_name{$method_string}++; next if $method_string eq '__ANON__'; # anonymous subs don't matter here. my $type = substr($method_string, 0, 1) eq '_' ? 'private' : 'public'; if ($package_string eq $class_name) { next unless $show_methods eq 'all' || $show_methods eq $type; $methods{$type}{$method_string} = undef; } else { next unless $show_inherited eq 'all' || $show_inherited eq $type; $methods{$type}{$method_string} = $package_string; } } my $string = ''; foreach my $type (qw(public private)) { next unless $show_methods eq 'all' or $show_methods eq $type or $show_inherited eq 'all' or $show_inherited eq $type ; if ($ddp->class->format_inheritance eq 'string') { my @method_list = keys %{$methods{$type}}; @method_list = Data::Printer::Common::_nsort(@method_list) if @method_list && $ddp->class->sort_methods; $string .= $ddp->newline . "$type methods (" . scalar(@method_list) . ')'; if (@method_list) { $string .= ': ' . join(', ' => map { $ddp->maybe_colorize( $_ . (defined $methods{$type}{$_} ? " ($methods{$type}{$_})" : ''), 'method' ) } @method_list) ; } } else { # 'lines' # first we convert our hash to { pkg => [ @methods ] } my %lined_methods; my @base_methods; my $total_methods = 0; foreach my $method (keys %{$methods{$type}}) { my $pkg_name = $methods{$type}{$method}; if (defined $pkg_name) { push @{ $lined_methods{$pkg_name} }, $method; } else { push @base_methods, $method; } $total_methods++; } # then we print them, starting with our own methods: @base_methods = Data::Printer::Common::_nsort(@base_methods) if @base_methods && $ddp->class->sort_methods; $string .= $ddp->newline . "$type methods ($total_methods)" . ($total_methods ? ':' : '') ; if (@base_methods) { my $base_string = join(', ' => map { $ddp->maybe_colorize($_, 'method') } @base_methods); $ddp->indent; # newline only if we have parent methods to show: $string .= (keys %lined_methods ? $ddp->newline : ' ') . $base_string; $ddp->outdent; } foreach my $pkg (sort keys %lined_methods) { $ddp->indent; $string .= $ddp->newline . "$pkg:"; @{$lined_methods{$pkg}} = Data::Printer::Common::_nsort(@{$lined_methods{$pkg}}) if $ddp->class->sort_methods; $ddp->indent; $string .= $ddp->newline . join(', ' => map { $ddp->maybe_colorize($_, 'method') } @{$lined_methods{$pkg}} ); $ddp->outdent; $ddp->outdent; } } } return $string; } sub _methods_of { require B; my ($class_name, $namespace) = @_; my @methods; foreach my $subref (_get_all_subs_from($class_name, $namespace)) { next unless $subref; my $m = B::svref_2object($subref); next unless $m && $m->isa('B::CV'); my $gv = $m->GV; next unless $gv && !$gv->isa('B::Special') && $gv->NAME; push @methods, [ $gv->STASH->NAME, $gv->NAME ]; } return @methods; } sub _get_all_subs_from { my ($class_name, $namespace) = @_; my @subs; foreach my $key (keys %$namespace) { # perlsub says any sub starting with '(' is reserved for overload, # so we skip those: next if substr($key, 0, 1) eq '('; if ( # any non-typeglob in the symbol table is a constant or stub ref(\$namespace->{$key}) ne 'GLOB' # regular subs are stored in the CODE slot of the typeglob || defined(*{$namespace->{$key}}{CODE}) ) { push @subs, $key; } } my @symbols; foreach my $sub (@subs) { push @symbols, Data::Printer::Common::_get_symbol($class_name, $namespace, $sub, 'CODE'); } return @symbols; } 1; Data-Printer-1.002001/lib/Data/Printer/Filter/ARRAY.pm0000644000000000000000000000713414552015171020436 0ustar rootrootpackage Data::Printer::Filter::ARRAY; use strict; use warnings; use Data::Printer::Filter; use Data::Printer::Common; use Scalar::Util (); filter 'ARRAY' => \&parse; sub parse { my ($array_ref, $ddp) = @_; my $tied = ''; if ($ddp->show_tied and my $tie = ref tied @$array_ref) { $tied = " (tied to $tie)"; } return $ddp->maybe_colorize('[]', 'brackets') . $tied unless @$array_ref; return $ddp->maybe_colorize('[', 'brackets') . $ddp->maybe_colorize('...', 'array') . $ddp->maybe_colorize(']', 'brackets') . $tied if $ddp->max_depth && $ddp->current_depth >= $ddp->max_depth; #Scalar::Util::weaken($array_ref); my $string = $ddp->maybe_colorize('[', 'brackets'); my @i = Data::Printer::Common::_fetch_indexes_for($array_ref, 'array', $ddp); # when showing array index, we must add the padding for newlines: my $has_index = $ddp->index; my $local_padding = 0; if ($has_index) { my $last_index; # Get the last index shown to add the proper padding. # If the array has 5000 elements but we're showing 4, # the padding must be 3 + length(1), not 3 + length(5000): for (my $idx = $#i; $idx >= 0; $idx--) { next if ref $i[$idx]; $last_index = $i[$idx]; last; } if (defined $last_index) { $local_padding = 3 + length($last_index); $ddp->{_array_padding} += $local_padding; } } $ddp->indent; foreach my $idx (@i) { $string .= $ddp->newline; # $idx is a message to display, not a real index if (ref $idx) { $string .= $$idx; next; } my $original_varname = $ddp->current_name; # if name was "var" it must become "var[0]", "var[1]", etc $ddp->current_name( $original_varname . ($ddp->arrows eq 'all' || ($ddp->arrows eq 'first' && $ddp->current_depth == 1) ? '->' : '') . "[$idx]" ); if ($has_index) { substr($string, -$local_padding) = ''; # get rid of local padding $string .= $ddp->maybe_colorize( sprintf("%-*s", $local_padding, "[$idx]"), 'array' ); } # scalar references should be re-referenced to gain # a '\' in front of them. my $ref = ref $array_ref->[$idx]; if ($ref) { if ($ref eq 'SCALAR') { $string .= $ddp->parse(\$array_ref->[$idx], tied_parent => !!$tied); } elsif ($ref eq 'REF') { $string .= $ddp->parse(\$array_ref->[$idx], tied_parent => !!$tied); } else { $string .= $ddp->parse($array_ref->[$idx], tied_parent => !!$tied); } } else { # not a reference, so we don't need to worry about refcounts. # it helps to prevent cases where Perl reuses addresses: $string .= $ddp->parse(\$array_ref->[$idx], seen_override => 1); } $string .= $ddp->maybe_colorize($ddp->separator, 'separator') if $idx < $#{$array_ref} || $ddp->end_separator; # we're finished with "var[x]", turn it back to "var": $ddp->current_name( $original_varname ); } $ddp->outdent; $ddp->{_array_padding} -= $local_padding if $has_index; $string .= $ddp->newline; $string .= $ddp->maybe_colorize(']', 'brackets'); return $string . $tied; }; ####################################### ### Private auxiliary helpers below ### ####################################### 1; Data-Printer-1.002001/lib/Data/Printer/Filter/VSTRING.pm0000644000000000000000000000153314552015171020711 0ustar rootrootpackage Data::Printer::Filter::VSTRING; use strict; use warnings; use Data::Printer::Filter; use Data::Printer::Common; filter 'VSTRING' => \&parse; sub parse { my ($vstring, $ddp) = @_; my $string = ''; # The reason we don't simply do: # use version 0.77 (); # is because it was causing some issues with UNIVERSAL on Perl 5.8 and # some versions of version.pm. So now we do it on runtime on the filter. # ->parse() will raise an error unless version.pm >= 0.77. my $error = Data::Printer::Common::_tryme(sub { require version; $string = version->parse($$vstring)->normal; }); $string = 'VSTRING object (unable to parse)' if $error; if ($ddp->show_tied and my $tie = ref tied $$vstring) { $string .= " (tied to $tie)"; } return $ddp->maybe_colorize($string, 'vstring'); }; 1; Data-Printer-1.002001/lib/Data/Printer/Filter/Web.pm0000644000000000000000000002330314552015171020271 0ustar rootrootpackage Data::Printer::Filter::Web; use strict; use warnings; use Data::Printer::Filter; #################### ### JSON parsers ### Heavily inspired by nuba++'s excellent Data::Printer::Filter::JSON ############################################# sub _parse_json_boolean { my ($value, $ddp) = @_; my @colors = ($value eq 'true' ? ('filter_web_json_true', '#ccffcc') : ('filter_web_json_false', '#ffcccc') ); return $ddp->maybe_colorize($value, @colors); } # JSON::NotString is from JSON::Parser (JSON 1.x) filter 'JSON::NotString' => sub { _parse_json_boolean($_[0]->{value}, $_[1]) }; # JSON::Typist filter 'JSON::Typist::String' => sub { my ($obj, $ddp) = @_; require Data::Printer::Common; my $ret = Data::Printer::Common::_process_string($ddp, "$obj", 'string'); my $quote = $ddp->maybe_colorize($ddp->scalar_quotes, 'quotes'); return $quote . $ret . $quote; }; filter 'JSON::Typist::Number' => sub { return $_[1]->maybe_colorize($_[0], 'number'); }; # NOTE: boolean is used by Pegex::JSON foreach my $json (qw( JSON::DWIW::Boolean JSON::PP::Boolean JSON::SL::Boolean JSON::XS::Boolean boolean JSON::Tiny::_Bool Mojo::JSON::_Bool Cpanel::JSON::XS::Boolean )) { filter "$json" => sub { my ($obj, $ddp) = @_; # because JSON boolean objects are just repeated all over # the place, we must remove them from our "seen" table: $ddp->unsee($obj); return _parse_json_boolean(($$obj == 1 ? 'true' : 'false'), $ddp); }; } for my $json (qw( JSON::JOM::Value JSON::JOM::Array JSON::JOM::Object )) { filter "$json" => sub { my ($obj, $ddp) = @_; return $ddp->parse($obj->TO_JSON); }; } #################### ### Cookie parsers ############################################# filter 'Mojo::Cookie' => sub { my ($obj, $ddp) = @_; return _format_cookie({ expires => scalar $obj->expires, max_age => $obj->max_age, domain => $obj->domain, path => $obj->path, secure => $obj->secure, http_only => $obj->httponly, host_only => ($obj->can('host_only') ? $obj->host_only : 0), name => $obj->name, value => $obj->value, class => 'Mojo::Cookie', }, $ddp); }; filter 'Dancer::Cookie' => sub { my ($obj, $ddp) = @_; return _format_cookie({ expires => scalar $obj->expires, domain => $obj->domain, path => $obj->path, secure => $obj->secure, http_only => $obj->http_only, name => $obj->name, value => $obj->value, class => 'Dancer::Cookie', }, $ddp); }; filter 'Dancer2::Core::Cookie' => sub { my ($obj, $ddp) = @_; return _format_cookie({ expires => scalar $obj->expires, domain => $obj->domain, path => $obj->path, secure => $obj->secure, http_only => $obj->http_only, name => $obj->name, value => $obj->value, class => 'Dancer2::Core::Cookie', }, $ddp); }; sub _format_cookie { my ($data, $ddp) = @_; return $ddp->maybe_colorize( $data->{name} . '=' . Data::Printer::Common::_process_string($ddp, $data->{value}) . '; expires=' . $data->{expires} . '; domain=' . $data->{domain} . '; path=' . $data->{path} . ('; secure'x!!$data->{secure}) . ('; http-only'x!!$data->{http_only}) . ('; host-only'x!!$data->{host_only}) . (defined $data->{max_age} ? '; max-age=' . $data->{max_age} : '') , 'filter_web_cookie', '#0b3e21' ) . ' (' . $ddp->maybe_colorize($data->{class}, 'class') . ')'; } #################### ### HTTP parsers ############################################# filter 'HTTP::Request' => sub { my ($obj, $ddp) = @_; my $output = $ddp->maybe_colorize($obj->method, 'filter_web_method', '#fefe33') . ' ' . $ddp->maybe_colorize($obj->uri, 'filter_web_uri', '#fefe88') ; if ($ddp->extra_config->{filter_web}{show_class_name}) { $output .= ' (' . $ddp->maybe_colorize(ref $obj, 'class') . ')'; } my $expand_headers = !exists $ddp->extra_config->{filter_web}{expand_headers} || $ddp->extra_config->{filter_web}{expand_headers}; my $content = $obj->decoded_content; if ($expand_headers || $content) { $output .= ' {'; $ddp->indent; if ($expand_headers) { if ($obj->headers->can('flatten')) { my %headers = $obj->headers->flatten; $output .= $ddp->newline . 'headers: ' . $ddp->parse(\%headers); } } if ($content) { $output .= $ddp->newline . 'content: ' . Data::Printer::Common::_process_string($ddp, $content, 'string'); } $ddp->outdent; $output .= $ddp->newline . '}'; } return $output; }; filter 'HTTP::Response' => sub { my ($obj, $ddp) = @_; my $output = _maybe_show_request($obj, $ddp); if (!exists $ddp->extra_config->{filter_web}{show_redirect} || $ddp->extra_config->{filter_web}{show_redirect} ) { foreach my $redir ($obj->redirects) { $output .= "\x{e2}\x{a4}\x{bf} " . $redir->code . ' ' . $redir->message . ' (' . $redir->header('location') . ')' . $ddp->newline; } } my %colors = ( 1 => ['filter_web_response_info' , '#3333fe'], 2 => ['filter_web_response_success' , '#33fe33'], 3 => ['filter_web_response_redirect', '#fefe33'], 4 => ['filter_web_response_error' , '#fe3333'], 5 => ['filter_web_response_error' , '#fe3333'], ); my $status_key = substr($obj->code, 0, 1); $output .= $ddp->maybe_colorize( $obj->status_line, (exists $colors{$status_key} ? @{$colors{$status_key}} : @{$colors{1}}) ); if ($ddp->extra_config->{filter_web}{show_class_name}) { $output .= ' (' . $ddp->maybe_colorize(ref $obj, 'class') . ')'; } my $expand_headers = !exists $ddp->extra_config->{filter_web}{expand_headers} || $ddp->extra_config->{filter_web}{expand_headers}; my $content = $obj->decoded_content; if ($expand_headers || $content) { $output .= ' {'; $ddp->indent; if ($expand_headers) { if ($obj->headers->can('flatten')) { my %headers = $obj->headers->flatten; $output .= $ddp->newline . 'headers: ' . $ddp->parse(\%headers); } } if ($content) { $output .= $ddp->newline . 'content: ' . Data::Printer::Common::_process_string($ddp, $content, 'string'); } $ddp->outdent; $output .= $ddp->newline . '}'; } return $output; }; sub _maybe_show_request { my ($obj, $ddp) = @_; return '' unless $ddp->extra_config->{filter_web}{show_request_in_response}; my ($redir) = $obj->redirects; my $output = 'Request: '; my $request; if ($redir) { $request = $redir->request; } else { $request = $obj->request; } return $output . ($request ? $ddp->parse($request) : '-'); } 1; __END__ =head1 NAME Data::Printer::Filter::Web - pretty-printing of HTTP/JSON/LWP/Plack/Dancer/Catalyst/Mojo... =head1 SYNOPSIS In your C<.dataprinter> file: filters = Web You may also customize the look and feel with the following options (defaults shown): filter_web.show_class_name = 0 filter_web.expand_headers = 1 filter_web.show_redirect = 1 filter_web.show_request_in_response = 0 # you can even customize your themes: colors.filter_web_json_true = #ccffcc colors.filter_web_json_false = #ffcccc colors.filter_web_cookie = #0b3e21 colors.filter_web_method = #fefe33 colors.filter_web_uri = $fefe88 colors.filter_web_response_success = #fefe33 colors.filter_web_response_info = #fefe33 colors.filter_web_response_redirect = #fefe33 colors.filter_web_response_error = #fefe33 =head1 DESCRIPTION This is a filter plugin for L. It filters through several web-related objects and display their content in a (hopefully!) more useful way than a regular dump. =head1 PARSED MODULES =head2 JSON Because Perl has no C or C tokens, many JSON parsers implement boolean objects to represent those. With this filter, you'll get "true" and "false" (which is what probably you want to see) instead of an object dump on those booleans. This module filters through the following modules: C, C, C, C, C, C, C, C, C, C, C and C. Also, if you use C to parse your JSON strings, a Data::Printer dump using this filter will always properly print numbers as numbers and strings as strings. =head2 COOKIES This filter is able to handle cookies from C/C and C frameworks. Other frameworks like C rely on C and C, which simply store them in a hash, not an object. =head2 HTTP REQUEST/RESPONSE C and C objects are filtered to display headers and content. These are returned by L, L and many others. If the response comes from chained redirects (that the source HTTP::Response object knows about), this filter will show you the entire redirect chain above the actual object. You may disable this by changing the C option. =head1 SEE ALSO L Data-Printer-1.002001/lib/Data/Printer/Filter/ContentType.pm0000644000000000000000000002325014552015171022031 0ustar rootrootpackage Data::Printer::Filter::ContentType; use strict; use warnings; use Data::Printer::Filter; filter 'SCALAR' => sub { my ($data, $ddp) = @_; # don't bother looking on files that are just too small return unless defined $$data; my $len = length($$data); return if $len < 22; my $hex = unpack('H22', $$data); my $hex_8 = substr($hex,0,8); my $type; if ($hex_8 eq '89504e47') { $type = 'PNG Image'; } elsif ($hex_8 eq '4d4d002a' || $hex_8 eq '49492a00') { $type = 'TIFF Image'; } elsif ($hex_8 eq '00000100') { $type = 'ICO Image'; } elsif ($hex_8 eq '52494646') { my $rest = substr($hex,12,8); if ($rest eq '57415645') { $type = 'WAV Audio'; } elsif ($rest =~ /\A415649/) { $type = 'AVI Video'; } } elsif ($hex_8 =~ /\A504b(?:30|50|70)(?:40|60|80)/) { $type = 'Zip Archive'; } elsif ($hex_8 eq '25504446') { $type = 'PDF Document'; } elsif ($hex_8 eq '7f454c46') { $type = 'Binary ELF data'; } elsif ($hex_8 eq '664c6143') { $type = 'FLAC Audio'; } elsif ($hex_8 eq '4f676753') { $type = 'OGG Audio'; } else { my $hex_6 = substr($hex,0,6); if($hex_6 eq '474946') { $type = 'GIF Image'; } elsif ($hex_6 eq 'ffd8ff') { $type = 'JPEG Image'; } elsif ($hex_6 eq '000001') { if (hex(substr($hex,6,2)) >= 0xb0 && hex(substr($hex,8,2)) <= 0xbf ) { $type = 'MPEG Video'; } } elsif ($hex_6 eq '1f8b80') { $type = 'Gzip Archive'; } elsif ($hex_6 eq '494433') { $type = 'MP3 Audio'; } elsif ($hex_6 eq '425a68') { $type = 'Bzip2 Archive'; } else { my $hex_4 = substr($hex,0,4); if ($hex_4 eq 'fffb') { $type = 'MP3 Audio'; } elsif ($hex_4 eq '424d') { $type = 'BMP Image'; } elsif ($hex_4 eq '4d5a') { $type = 'Binary Windows EXE data' } elsif ($hex_8 eq '3d73726c') { my $v = substr($hex, 9, 1); if ($v == 1 || $v == 2) { $type = "Binary Sereal v$v data"; } } elsif ($hex_8 eq '3df3726c') { my $v = substr($hex, 9, 1); if ($v == 3 || $v == 4) { $type = "Binary Sereal v$v data"; } } else { # type not found! Let other filters have a go. return; } } } return unless $type; my $unit = 'AUTO'; if (exists $ddp->extra_config->{filter_contenttype}{size_unit}) { $unit = uc $ddp->extra_config->{filter_contenttype}{size_unit}; if (!$unit || ($unit ne 'AUTO' && $unit ne 'B' && $unit ne 'K' && $unit ne 'M')) { Data::Printer::Common::_warn($ddp, 'filter_contenttype.size_unit must be auto, b, k or m'); $unit = 'auto'; } } if ($unit eq 'M' || ($unit eq 'AUTO' && $len > 1024*1024)) { $len = $len / (1024*1024); $unit = 'M'; } elsif ($unit eq 'K' || ($unit eq 'AUTO' && $len > 1024)) { $len = $len / 1024; $unit = 'K'; } else { $unit = 'B'; } my $show_size = !exists $ddp->extra_config->{filter_contenttype}{show_size} || $ddp->extra_config->{filter_contenttype}{show_size}; my $symbol = ''; if (!exists $ddp->extra_config->{filter_contenttype}{show_symbol} || $ddp->extra_config->{filter_contenttype}{show_symbol} ) { if ($type =~ /Image/) { $symbol = "\x{f0}\x{9f}\x{96}\x{bc} "; # FRAME WITH PICTURE } elsif ($type =~ /Video/) { $symbol = "\x{f0}\x{9f}\x{8e}\x{ac} "; # CLAPPER BOARD } elsif ($type =~ /Audio/) { $symbol = "\x{f0}\x{9f}\x{8e}\x{b5} "; # MUSICAL NOTE } elsif ($type =~ /Archive/) { $symbol = "\x{f0}\x{9f}\x{97}\x{84} "; # FILE CABINET } elsif ($type =~ /Document/) { $symbol = "\x{f0}\x{9f}\x{93}\x{84} "; # PAGE FACING UP } elsif ($type =~ /Binary/) { $symbol = "\x{f0}\x{9f}\x{96}\x{a5} "; # DESKTOP COMPUTER } } my $output = $symbol . $ddp->maybe_colorize('(', 'brackets') . $ddp->maybe_colorize( $type . ((', ' . ($len < 0 ? sprintf("%.2f", $len) : int($len)) . $unit)x!!$show_size), 'filter_contenttype', '#ca88dd' ) . $ddp->maybe_colorize(')', 'brackets') ; return $output if !exists $ddp->extra_config->{filter_contenttype}{hexdump} || !$ddp->extra_config->{filter_contenttype}{hexdump}; my ($h_size, $h_offset, $h_indent) = (0, 0, 0); $h_size = $ddp->extra_config->{filter_contenttype}{hexdump_size} if exists $ddp->extra_config->{filter_contenttype}{hexdump_size}; $h_offset = $ddp->extra_config->{filter_contenttype}{hexdump_offset} if exists $ddp->extra_config->{filter_contenttype}{hexdump_offset}; $h_indent = $ddp->extra_config->{filter_contenttype}{hexdump_indent} if exists $ddp->extra_config->{filter_contenttype}{hexdump_indent}; $output .= hexdump($ddp, $$data, $h_size, $h_offset, $h_indent); return $output; }; # inspired by https://www.perlmonks.org/?node_id=1140391 sub hexdump { my ($ddp, $data, $size, $offset, $indent) = @_; my $output = ''; my $current_size = 0; my $is_last = 0; my $linebreak = $indent ? $ddp->newline : "\n"; if ($offset > 0) { return '' if $offset >= length($data); $data = substr($data, $offset); } elsif ($offset < 0) { $offset = length($data) + $offset; $offset = 0 if $offset < 0; $data = substr($data, $offset); } foreach my $chunk (unpack "(a16)*", $data) { if ($size) { $current_size += length($chunk); if ($current_size >= $size) { $chunk = substr $chunk, 0, 16 - ($current_size - $size); $is_last = 1; } } my $hex = unpack "H*", $chunk; $chunk =~ tr/ -~/./c; # replace unprintables $hex =~ s/(.{1,8})/$1 /gs; # insert spaces $output .= $linebreak . $ddp->maybe_colorize( sprintf("0x%08x (%05u) %-*s %s", $offset, $offset, 36, $hex, $chunk), 'filter_contenttype_hexdump', '#ffcb68' ); last if $is_last; $offset += 16; } return $output; } 1; __END__ =head1 NAME Data::Printer::Filter::ContentType - detect popular (binary) content in strings =head1 SYNOPSIS In your C<.dataprinter> file: filters = ContentType You may also customize the look and feel with the following options (defaults shown): filter_contenttype.show_size = 1 filter_contenttype.size_unit = auto # play around with these if you want to print the binary content: filter_contenttype.hexdump = 0 filter_contenttype.hexdump_size = 0 filter_contenttype.hexdump_offset = 0 filter_contenttype.hexdump_indent = 0 # you can even customize your themes: colors.filter_contenttype = #ca88dd colors.filter_contenttype_hexdump = #ffcb68 That's it! =head1 DESCRIPTION This is a filter plugin for L that looks for binary strings with signatures from popular file types. If one is detected, instead of the bogus binary dump it will print the content type and the string size. For example, let's say you've read an image file into C<$data>, maybe from a user upload or from Imager or ImageMagick. If you use Data::Printer with this filter, it will show you something like this: my $data = get_image_content_from_somewhere(); use DDP; p $data; # (PNG Image, 32K) =head2 hexdump If, for whatever reason, you want to inspect the actual content of the binary data, you may set C to true. This will pretty-print your data in hexadecimal, similar to tools like C. Once active, it will print the entire content, but you may limit the size by changing C to any value (unit == bytes), and you can even start from a different position using C. Set it to a negative value to make your offset relative to the end to the data. Finally, the default hexdump mode will not indent your content. Since it's a binary dump, we want to get as much terminal space as we can. If you rather have the dump properly indented (relative to your current dump indentation level), just set C to 1. =head2 Detected Content Below are the signatures detected by this filter. =head3 Images =over 4 =item * PNG =item * JPEG =item * GIF =item * ICO =item * TIFF =item * BMP =back =head3 Video =over 4 =item * AVI =item * MPEG =back =head3 Audio =over 4 =item * WAV =item * MP3 =item * FLAC =item * OGG =back =head3 Documents and Archives =over 4 =item * ZIP =item * GZIP =item * BZIP2 =item * PDF =item * Binary Executables (ELF and Win32) =back We don't want this list to grow into a full-blown detection system, and instead just focus on common types. So if you want to contribute with patches or open an issue for a missing type, please make sure you I (e.g. you were bit by this in your code and DDP didn't help). We want to help people debug code, not add content types just for the sake of it :) =head1 SEE ALSO L Data-Printer-1.002001/lib/Data/Printer/Filter/HASH.pm0000644000000000000000000001075614552015171020307 0ustar rootrootpackage Data::Printer::Filter::HASH; use strict; use warnings; use Data::Printer::Filter; use Data::Printer::Common; use Scalar::Util (); filter 'HASH' => \&parse; sub parse { my ($hash_ref, $ddp) = @_; my $tied = ''; if ($ddp->show_tied and my $tie = ref tied %$hash_ref) { $tied = " (tied to $tie)"; } return $ddp->maybe_colorize('{', 'brackets') . ' ' . $ddp->maybe_colorize('...', 'hash') . ' ' . $ddp->maybe_colorize('}', 'brackets') . $tied if $ddp->max_depth && $ddp->current_depth >= $ddp->max_depth; my @src_keys = keys %$hash_ref; return $ddp->maybe_colorize('{}', 'brackets') . $tied unless @src_keys; @src_keys = Data::Printer::Common::_nsort(@src_keys) if $ddp->sort_keys; my $len = 0; my $align_keys = $ddp->multiline && $ddp->align_hash; my @i = Data::Printer::Common::_fetch_indexes_for(\@src_keys, 'hash', $ddp); my %processed_keys; # first pass, preparing keys and getting largest key size: foreach my $idx (@i) { next if ref $idx; my $raw_key = $src_keys[$idx]; my $colored_key = Data::Printer::Common::_process_string($ddp, $raw_key, 'hash'); my $new_key = Data::Printer::Common::_colorstrip($colored_key); if (_needs_quote($ddp, $raw_key, $new_key)) { my $quote_char = $ddp->scalar_quotes; # foo'bar ==> 'foo\'bar' if (index($new_key, $quote_char) >= 0) { $new_key =~ s{$quote_char}{\\$quote_char}g; $colored_key =~ s{$quote_char}{\\$quote_char}g; } $new_key = $quote_char . $new_key . $quote_char; $colored_key = $ddp->maybe_colorize($quote_char, 'quotes') . $colored_key . $ddp->maybe_colorize($quote_char, 'quotes') ; } $processed_keys{$idx} = { raw => $raw_key, colored => $colored_key, nocolor => $new_key, }; if ($align_keys) { my $l = length $new_key; $len = $l if $l > $len; } } # second pass, traversing and rendering: $ddp->indent; my $total_keys = scalar @i; # yes, counting messages so ',' appear in between. #keys %processed_keys; my $string = $ddp->maybe_colorize('{', 'brackets'); foreach my $idx (@i) { $total_keys--; # $idx is a message to display, not a real index if (ref $idx) { $string .= $ddp->newline . $$idx; next; } my $key = $processed_keys{$idx}; my $original_varname = $ddp->current_name; # update 'var' to 'var{key}': $ddp->current_name( $original_varname . ($ddp->arrows eq 'all' || ($ddp->arrows eq 'first' && $ddp->current_depth == 1) ? '->' : '') . '{' . $key->{nocolor} . '}' ); my $padding = $len - length($key->{nocolor}); $padding = 0 if $padding < 0; $string .= $ddp->newline . $key->{colored} . (' ' x $padding) . $ddp->maybe_colorize($ddp->hash_separator, 'separator') ; # scalar references should be re-referenced to gain # a '\' in front of them. my $ref = ref $hash_ref->{$key->{raw}}; if ( $ref && $ref eq 'SCALAR' ) { $string .= $ddp->parse(\$hash_ref->{ $key->{raw} }, tied_parent => !!$tied); } elsif ( $ref && $ref ne 'REF' ) { $string .= $ddp->parse( $hash_ref->{ $key->{raw} }, tied_parent => !!$tied); } else { $string .= $ddp->parse(\$hash_ref->{ $key->{raw} }, tied_parent => !!$tied); } $string .= $ddp->maybe_colorize($ddp->separator, 'separator') if $total_keys > 0 || $ddp->end_separator; # restore var name back to "var" $ddp->current_name($original_varname); } $ddp->outdent; $string .= $ddp->newline . $ddp->maybe_colorize('}', 'brackets'); return $string . $tied; }; ####################################### ### Private auxiliary helpers below ### ####################################### sub _needs_quote { my ($ddp, $raw_key, $new_key) = @_; my $quote_keys = $ddp->quote_keys; my $scalar_quotes = $ddp->scalar_quotes; return 0 unless defined $quote_keys && defined $scalar_quotes;; if ($quote_keys eq 'auto' && $raw_key eq $new_key && $new_key !~ /\s|\r|\n|\t|\f/) { return 0; } return 1; } 1; Data-Printer-1.002001/lib/Data/Printer/Filter/GLOB.pm0000644000000000000000000000343714552015171020305 0ustar rootrootpackage Data::Printer::Filter::GLOB; use strict; use warnings; use Data::Printer::Filter; use Data::Printer::Common; use Scalar::Util (); use Fcntl; filter 'GLOB' => \&parse; sub parse { my ($glob, $ddp) = @_; my $string = $ddp->maybe_colorize("$$glob", 'glob'); # unfortunately, some systems (like Win32) do not # implement some of these flags (maybe not even # fcntl() itself, so we must wrap it. my $extra = ''; my $flags; eval { no warnings qw( unopened closed ); $flags = fcntl($$glob, F_GETFL, 0) }; if ($flags) { $extra .= ($flags & O_WRONLY) ? 'write-only' : ($flags & O_RDWR) ? 'read/write' : 'read-only' ; # How to avoid croaking when the system # doesn't implement one of those, without skipping # the whole thing? Maybe there's a better way. # Solaris, for example, doesn't have O_ASYNC :( my %flags = (); eval { $flags{'append'} = O_APPEND }; eval { $flags{'async'} = O_ASYNC }; # leont says this is the only one I should care for. eval { $flags{'create'} = O_CREAT }; eval { $flags{'truncate'} = O_TRUNC }; eval { $flags{'nonblocking'} = O_NONBLOCK }; if (my @flags = grep { $flags & $flags{$_} } sort keys %flags) { $extra .= ", flags: @flags"; } $extra .= ', '; } my @layers = (); # TODO: try PerlIO::Layers::get_layers (leont) my $error = Data::Printer::Common::_tryme(sub { @layers = PerlIO::get_layers $$glob }); $extra .= "layers: @layers" unless $error; $string .= " ($extra)" if $extra; if ($ddp->show_tied and my $tie = ref tied *$$glob) { $string .= " (tied to $tie)" } return $string; }; 1; Data-Printer-1.002001/lib/Data/Printer/Filter/FORMAT.pm0000644000000000000000000000034014552015171020540 0ustar rootrootpackage Data::Printer::Filter::FORMAT; use strict; use warnings; use Data::Printer::Filter; filter 'FORMAT' => \&parse; sub parse { my ($format, $ddp) = @_; return $ddp->maybe_colorize('FORMAT', 'format'); }; 1; Data-Printer-1.002001/lib/Data/Printer/Config.pm0000644000000000000000000003252314552015171017540 0ustar rootrootpackage Data::Printer::Config; use strict; use warnings; use Data::Printer::Common; sub load_rc_file { my ($filename) = @_; if (!$filename) { $filename = _get_first_rc_file_available(); } return unless $filename && -e $filename && !-d $filename; if (open my $fh, '<', $filename) { # slurp the file: my $rc_data; { local $/ = undef; $rc_data = <$fh> } close $fh; return _str2data($filename, $rc_data); } else { Data::Printer::Common::_warn(undef, "error opening '$filename': $!"); return; } } sub _get_first_rc_file_available { return $ENV{DATAPRINTERRC} if exists $ENV{DATAPRINTERRC}; # look for a .dataprinter file on the project home up until we reach '/' my $dir = _project_home(); require File::Spec; while (defined $dir) { my $file = File::Spec->catfile($dir, '.dataprinter'); return $file if -f $file; my @path = File::Spec->splitdir($dir); last unless @path; my $updir = File::Spec->catdir(@path[0..$#path-1]); last if !defined $updir || $updir eq $dir; $dir = $updir; } # still here? look for .dataprinter on the user's HOME: return File::Spec->catfile( _my_home(), '.dataprinter'); } sub _my_cwd { require Cwd; my $cwd = Cwd::getcwd(); # try harder if we can't access the current dir. $cwd = Cwd::cwd() unless defined $cwd; return $cwd; } sub _project_home { require Cwd; my $path; if ($0 eq '-e' || $0 eq '-') { my $cwd = _my_cwd(); $path = Cwd::abs_path($cwd) if defined $cwd; } else { my $script = $0; return unless -f $script; require File::Spec; require File::Basename; # we need the full path if we have chdir'd: $script = File::Spec->catfile(_my_cwd(), $script) unless File::Spec->file_name_is_absolute($script); my (undef, $maybe_path) = File::Basename::fileparse($script); $path = Cwd::abs_path($maybe_path) if defined $maybe_path; } return $path; } # adapted from File::HomeDir && File::HomeDir::Tiny sub _my_home { my ($testing) = @_; if ($testing) { require File::Temp; require File::Spec; my $BASE = File::Temp::tempdir( CLEANUP => 1 ); my $home = File::Spec->catdir( $BASE, 'my_home' ); $ENV{HOME} = $home; mkdir($home, 0755) unless -d $home; return $home; } elsif ($^O eq 'MSWin32' and "$]" < 5.016) { return $ENV{HOME} || $ENV{USERPROFILE}; } elsif ($^O eq 'MacOS') { my $error = _tryme(sub { require Mac::SystemDirectory; 1 }); return Mac::SystemDirectory::HomeDirectory() unless $error; } # this is the most common case, for most breeds of unix, as well as # MSWin32 in more recent perls. my $home = (<~>)[0]; return $home if $home; # desperate measures that should never be needed. if (exists $ENV{LOGDIR} and $ENV{LOGDIR}) { $home = $ENV{LOGDIR}; } if (not $home and exists $ENV{HOME} and $ENV{HOME}) { $home = $ENV{HOME}; } # Light desperation on any (Unixish) platform SCOPE: { $home = (getpwuid($<))[7] if not defined $home } if (defined $home and ! -d $home ) { $home = undef; } return $home; } sub _file_mode_is_restricted { my ($filename) = @_; my $mode_raw = (stat($filename))[2]; return 0 unless defined $mode_raw; my $mode = sprintf('%04o', $mode_raw & 07777); return (length($mode) == 4 && substr($mode, 2, 2) eq '00') ? 1 : 0; } sub _str2data { my ($filename, $content) = @_; my $config = { _ => {} }; my $counter = 0; my $filter; my $can_use_filters; my $ns = '_'; # based on Config::Tiny foreach ( split /(?:\015{1,2}\012|\015|\012)/, $content ) { $counter++; if (defined $filter) { if ( /^end filter\s*$/ ) { if (!defined $can_use_filters) { $can_use_filters = _file_mode_is_restricted($filename); } if ($can_use_filters) { my $sub_str = 'sub { my ($obj, $ddp) = @_; ' . $filter->{code_str} . '}' ; push @{$config->{$ns}{filters}}, +{ $filter->{name} => eval $sub_str }; } else { Data::Printer::Common::_warn(undef, "ignored filter '$filter->{name}' from rc file '$filename': file is readable/writeable by others"); } $filter = undef; } elsif ( /^begin\s+filter/ ) { Data::Printer::Common::_warn(undef, "error reading rc file '$filename' line $counter: found 'begin filter' inside another filter definition ($filter->{name}). Are you missing an 'end filter' on line " . ($counter - 1) . '?'); return {}; } else { $filter->{code_str} .= $_; } } elsif ( /^\s*(?:\#|\;|$)/ ) { next # skip comments and empty lines } elsif ( /^\s*\[\s*(.+?)\s*\]\s*$/ ) { # Create the sub-hash if it doesn't exist. # Without this, sections without keys will not # appear at all in the completed struct. $config->{$ns = $1} ||= {}; } elsif ( /^\s*([^=]+?)\s*=\s*(.*?)\s*$/ ) { # Handle properties: my ($path_str, $value) = ($1, $2); # turn a.b.c.d into {a}{b}{c}{d} my @subpath = split /\./, $path_str; my $current = $config->{$ns}; # remove single/double (enclosing) quotes $value =~ s/\A(['"])(.*)\1\z/$2/; # the root "filters" key is a special case, because we want # it to always be an arrayref. In other words: # filters = abc,def --> filters => ['abc', 'def'] # filters = abc --> filters => ['abc'] # filters = --> filters => [] if (@subpath == 1 && $subpath[0] eq 'filters') { $value = [ split /\s*,\s*/ => $value ]; } while (my $subpath = shift @subpath) { if (@subpath > 0) { $current->{$subpath} ||= {}; $current = $current->{$subpath}; } else { $current->{$subpath} = $value; } } } elsif ( /^begin\s+filter\s+([^\s]+)\s*$/ ) { my $filter_name = $1; $filter = { name => $filter_name, code_str => '' }; } else { Data::Printer::Common::_warn(undef, "error reading rc file '$filename': syntax error at line $counter: $_"); if ($counter == 1 && /\A\s*\{/s) { Data::Printer::Common::_warn( undef, "\nRC file format changed in 1.00. Usually all it takes is:\n" . " cp $filename $filename.old && perl -MData::Printer::Config -E 'say Data::Printer::Config::convert(q($filename.old))' > $filename\n" . "Please visit https://metacpan.org/pod/Data::Printer::Config for details.\n" ); } return {}; } } # now that we have loaded the config, we must expand # all existing 'rc_file' and 'profile' statements and # merge them together. foreach my $ns (keys %$config) { $config->{$ns} = _expand_profile($config->{$ns}) if exists $config->{$ns}{profile}; } return $config; } sub _merge_options { my ($old, $new) = @_; if (ref $new eq 'HASH') { my %merged; my $to_merge = ref $old eq 'HASH' ? $old : {}; foreach my $k (keys %$new, keys %$to_merge) { # if the key exists in $new, we recurse into it: if (exists $new->{$k}) { $merged{$k} = _merge_options($to_merge->{$k}, $new->{$k}); } else { # otherwise we keep the old version (recursing in case of refs) $merged{$k} = _merge_options(undef, $to_merge->{$k}); } } return \%merged; } elsif (ref $new eq 'ARRAY') { # we'll only use the array on $new, but we still need to recurse # in case array elements contain other data structures. my @merged; foreach my $element (@$new) { push @merged, _merge_options(undef, $element); } return \@merged; } else { return $new; } } sub _expand_profile { my ($options, $ddp) = @_; my $profile = delete $options->{profile}; if ($profile !~ /\A[a-zA-Z0-9:]+\z/) { Data::Printer::Common::_warn($ddp,"invalid profile name '$profile'"); } else { my $class = 'Data::Printer::Profile::' . $profile; my $error = Data::Printer::Common::_tryme(sub { my $load_error = Data::Printer::Common::_tryme("use $class; 1;"); die $load_error if defined $load_error; my $expanded = $class->profile(); die "profile $class did not return a HASH reference" unless ref $expanded eq 'HASH'; $options = Data::Printer::Config::_merge_options($expanded, $options); }); if (defined $error) { Data::Printer::Common::_warn($ddp, "unable to load profile '$profile': $error"); } } return $options; } # converts the old format to the new one sub convert { my ($filename) = @_; Data::Printer::Common::_die("please provide a .dataprinter file path") unless $filename; Data::Printer::Common::_die("file '$filename' not found") unless -e $filename && !-d $filename; open my $fh, '<', $filename or Data::Printer::Common::_die("error reading file '$filename': $!"); my $rc_data; { local $/; $rc_data = <$fh> } close $fh; my $config = eval $rc_data; if ( $@ ) { Data::Printer::Common::_die("error loading file '$filename': $@"); } elsif (!ref $config or ref $config ne 'HASH') { Data::Printer::Common::_die("error loading file '$filename': config file must return a hash reference"); } else { return _convert('', $config); } } sub _convert { my ($key_str, $value) = @_; if (ref $value eq 'HASH') { $key_str = 'colors' if $key_str eq 'color'; my $str = ''; foreach my $k (sort keys %$value) { $str .= _convert(($key_str ? "$key_str.$k" : $k), $value->{$k}); } return $str; } if ($key_str && $key_str eq 'filters.-external' && ref $value eq 'ARRAY') { return 'filters = ' . join(', ' => @$value) . "\n"; } elsif (ref $value) { Data::Printer::Common::_warn( undef, " [*] path '$key_str': expected scalar, found " . ref($value) . ". Filters must be in their own class now, loaded with 'filter'.\n" . "If you absolutely must put custom filters in, use the 'begin filter'" . " / 'end filter' options manually, as explained in the documentation," . " making sure your .dataprinter file is not readable nor writeable to" . " anyone other than your user." ); return ''; } else { $value = "'$value'" if $value =~ /\s/; return "$key_str = $value\n"; } } 1; __END__ =head1 NAME Data::Printer::Config - Load run-control (.dataprinter) files for Data::Printer =head1 DESCRIPTION This module is used internally to load C<.dataprinter> files. =head1 THE RC FILE # line comments are ok with "#" or ";" ; this is also a full line comment. ; Comments at the end of a line (inline) are not allowed multiline = 0 hash_max = 5 array_max = 5 string_max = 50 # use quotes if you need spaces to be significant: hash_separator = " => " class.show_methods = none class.internals = 0 filters = DB, Web # if you tag a class, those settings will override your basic ones # whenever you call p() inside that class. [MyApp::Some::Class] multiline = 1 show_tainted: 1 class.format_inheritance = lines filters = MyAwesomeDebugFilter [Other::Class] theme = Monokai ; use "begin filter NAME" and "end filter" to add custom filter code. ; it will expose $obj (the data structure to be parsed) and $ddp ; (data printer's object). YOU MAY ONLY DO THIS IF YOUR FILE IS ONLY ; READABLE AND WRITEABLE BY THE USER (i.e. chmod 0600). begin filter HTTP::Request return $ddp->maybe_colorize($obj->method . ' ' . $obj->uri, 'string') . $obj->decoded_content; end filter =head1 PUBLIC INTERFACE This module is not meant for public use. However, because Data::Printer changed the format of the configuration file, we provide the following public function for people to use: =head2 convert( $filename ) perl -MDDP -E 'say Data::Printer::Config::convert( q(/path/to/my/.dataprinter) )' Loads a deprecated (pre-1.0) configuration file and returns a string with a (hopefully) converted version, which you can use for newer (post-1.0) versions. Other public functions, not really meant for general consumption, are: =over 4 =item * C - loads a configuration file and returns the associated data structure. If no filename is provided, looks for C<.dataprinter>. =back =head1 SEE ALSO L Data-Printer-1.002001/lib/Data/Printer/Object.pm0000644000000000000000000015306514552015171017546 0ustar rootrootuse strict; use warnings; use Data::Printer::Common; package # hide from pause Data::Printer::Object::ClassOptions; sub parents { $_[0]->{'parents'} } sub linear_isa { $_[0]->{'linear_isa'} } sub universal { $_[0]->{'universal'} } sub expand { $_[0]->{'expand'} } sub stringify { $_[0]->{'stringify'} } sub show_reftype { $_[0]->{'show_reftype'} } sub show_overloads { $_[0]->{'show_overloads'} } sub show_methods { $_[0]->{'show_methods'} } sub sort_methods { $_[0]->{'sort_methods'} } sub show_wrapped { $_[0]->{'show_wrapped'} } sub inherited { $_[0]->{'inherited'} } sub format_inheritance { $_[0]->{'format_inheritance'} } sub parent_filters { $_[0]->{'parent_filters'} } sub internals { $_[0]->{'internals'} } sub new { my ($class, $params) = @_; my $self = { 'linear_isa' => Data::Printer::Common::_fetch_scalar_or_default($params, 'linear_isa', 'auto'), 'show_reftype' => Data::Printer::Common::_fetch_scalar_or_default($params, 'show_reftype', 0), 'show_overloads' => Data::Printer::Common::_fetch_scalar_or_default($params, 'show_overloads', 1), 'stringify' => Data::Printer::Common::_fetch_scalar_or_default($params, 'stringify', 1), 'expand' => Data::Printer::Common::_fetch_scalar_or_default($params, 'expand', 1), 'show_methods' => Data::Printer::Common::_fetch_anyof( $params, 'show_methods', 'all', [qw(none all private public)] ), 'inherited' => Data::Printer::Common::_fetch_anyof( $params, 'inherited', 'public', [qw(none all private public)] ), 'format_inheritance' => Data::Printer::Common::_fetch_anyof( $params, 'format_inheritance', 'lines', [qw(string lines)] ), 'parent_filters' => Data::Printer::Common::_fetch_scalar_or_default($params, 'parent_filters', 1), 'universal' => Data::Printer::Common::_fetch_scalar_or_default($params, 'universal', 0), 'sort_methods' => Data::Printer::Common::_fetch_scalar_or_default($params, 'sort_methods', 1), 'show_wrapped' => Data::Printer::Common::_fetch_scalar_or_default($params, 'show_wrapped', 1), 'internals' => Data::Printer::Common::_fetch_scalar_or_default($params, 'internals', 1), 'parents' => Data::Printer::Common::_fetch_scalar_or_default($params, 'parents', 1), }; return bless $self, $class; } 1; package Data::Printer::Object; use Scalar::Util (); use Data::Printer::Theme; use Data::Printer::Filter::SCALAR; # also implements LVALUE use Data::Printer::Filter::ARRAY; use Data::Printer::Filter::HASH; use Data::Printer::Filter::REF; use Data::Printer::Filter::VSTRING; use Data::Printer::Filter::GLOB; use Data::Printer::Filter::FORMAT; use Data::Printer::Filter::Regexp; use Data::Printer::Filter::CODE; use Data::Printer::Filter::OBJECT; use Data::Printer::Filter::GenericClass; # create our basic accessors: my @method_names =qw( name show_tainted show_unicode show_readonly show_lvalue show_refcount show_memsize memsize_unit print_escapes scalar_quotes escape_chars caller_info caller_message caller_message_newline caller_message_position string_max string_overflow string_preserve resolve_scalar_refs array_max array_overflow array_preserve hash_max hash_overflow hash_preserve unicode_charnames colored theme show_weak max_depth index separator end_separator class_method class hash_separator align_hash sort_keys quote_keys deparse return_value show_dualvar show_tied warnings arrows coderef_stub coderef_undefined ); foreach my $method_name (@method_names) { no strict 'refs'; *{__PACKAGE__ . "::$method_name"} = sub { $_[0]->{$method_name} = $_[1] if @_ > 1; return $_[0]->{$method_name}; } } sub extra_config { $_[0]->{extra_config} } sub current_depth { $_[0]->{_depth} } sub indent { $_[0]->{_depth}++ } sub outdent { $_[0]->{_depth}-- } sub newline { my ($self) = @_; return $self->{_linebreak} . (' ' x ($self->{_depth} * $self->{_current_indent})) . (' ' x $self->{_array_padding}) ; } sub current_name { my ($self, $new_value) = @_; if (defined $new_value) { $self->{_current_name} = $new_value; } else { $self->{_current_name} = $self->name unless defined $self->{_current_name}; } return $self->{_current_name}; } sub _init { my $self = shift; my $props = { @_ == 1 ? %{$_[0]} : @_ }; $self->{'_linebreak'} = "\n"; $self->{'_depth'} = 0; $self->{'_position'} = 0; # depth is for indentation only! $self->{'_array_padding'} = 0; $self->{'_seen'} = {}; $self->{_refcount_base} = 3; $self->{'warnings'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'warning', 1); $self->{'indent'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'indent', 4); $self->{'index'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'index', 1); $self->{'name'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'name', 'var'); $self->{'arrows'} = Data::Printer::Common::_fetch_anyof( $props, 'arrows', 'none', [qw(none first all)] ); $self->{'show_tainted'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'show_tainted', 1); $self->{'show_tied'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'show_tied', 1); $self->{'show_weak'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'show_weak', 1); $self->{'show_unicode'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'show_unicode', 0); $self->{'show_readonly'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'show_readonly', 1); $self->{'show_lvalue'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'show_lvalue', 1); $self->{'show_refcount'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'show_refcount', 0); $self->{'show_memsize'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'show_memsize', 0); $self->{'memsize_unit'} = Data::Printer::Common::_fetch_anyof( $props, 'memsize_unit', 'auto', [qw(auto b k m)] ); $self->{'print_escapes'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'print_escapes', 0); $self->{'scalar_quotes'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'scalar_quotes', q(")); $self->{'escape_chars'} = Data::Printer::Common::_fetch_anyof( $props, 'escape_chars', 'none', [qw(none nonascii nonlatin1 all)] ); $self->{'caller_info'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'caller_info', 0); $self->{'caller_message'} = Data::Printer::Common::_fetch_scalar_or_default( $props, 'caller_message', 'Printing in line __LINE__ of __FILENAME__:' ); $self->{'caller_message_newline'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'caller_message_newline', 1); $self->{'caller_message_position'} = Data::Printer::Common::_fetch_anyof($props, 'caller_message_position', 'before', [qw(before after)]); $self->{'resolve_scalar_refs'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'resolve_scalar_refs', 0); $self->{'string_max'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'string_max', 4096); $self->{'string_preserve'} = Data::Printer::Common::_fetch_anyof( $props, 'string_preserve', 'begin', [qw(begin end middle extremes none)] ); $self->{'string_overflow'} = Data::Printer::Common::_fetch_scalar_or_default( $props, 'string_overflow', '(...skipping __SKIPPED__ chars...)' ); $self->{'array_max'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'array_max', 100); $self->{'array_preserve'} = Data::Printer::Common::_fetch_anyof( $props, 'array_preserve', 'begin', [qw(begin end middle extremes none)] ); $self->{'array_overflow'} = Data::Printer::Common::_fetch_scalar_or_default( $props, 'array_overflow', '(...skipping __SKIPPED__ items...)' ); $self->{'hash_max'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'hash_max', 100); $self->{'hash_preserve'} = Data::Printer::Common::_fetch_anyof( $props, 'hash_preserve', 'begin', [qw(begin end middle extremes none)] ); $self->{'hash_overflow'} = Data::Printer::Common::_fetch_scalar_or_default( $props, 'hash_overflow', '(...skipping __SKIPPED__ keys...)' ); $self->{'unicode_charnames'} = Data::Printer::Common::_fetch_scalar_or_default( $props, 'unicode_charnames', 0 ); $self->{'colored'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'colored', 'auto'); $self->{'max_depth'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'max_depth', 0); $self->{'separator'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'separator', ','); $self->{'end_separator'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'end_separator', 0); $self->{'class_method'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'class_method', '_data_printer'); $self->{'class'} = Data::Printer::Object::ClassOptions->new($props->{'class'}); $self->{'hash_separator'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'hash_separator', ' '); $self->{'align_hash'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'align_hash', 1); $self->{'sort_keys'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'sort_keys', 1); $self->{'quote_keys'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'quote_keys', 'auto'); $self->{'deparse'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'deparse', 0); $self->{'coderef_stub'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'coderef_stub', 'sub { ... }'); $self->{'coderef_undefined'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'coderef_undefined', ''); $self->{'return_value'} = Data::Printer::Common::_fetch_anyof( $props, 'return_value', 'pass', [qw(pass dump void)] ); $self->{'show_dualvar'} = Data::Printer::Common::_fetch_anyof( $props, 'show_dualvar', 'lax', [qw(lax strict off)] ); if (exists $props->{as}) { my $msg = Data::Printer::Common::_fetch_scalar_or_default($props, 'as', ''); $self->{caller_info} = 1; $self->{caller_message} = $msg; } $self->multiline( Data::Printer::Common::_fetch_scalar_or_default($props, 'multiline', 1) ); $self->fulldump( Data::Printer::Common::_fetch_scalar_or_default($props, 'fulldump', 0) ); $self->output(defined $props->{output} ? $props->{output} : 'stderr'); $self->_load_colors($props); $self->_load_filters($props); my %extra_config; my %core_options = map { $_ => 1 } (@method_names, qw(as multiline output colors filters)); foreach my $key (keys %$props) { $extra_config{$key} = $props->{$key} unless exists $core_options{$key}; } $self->{extra_config} = \%extra_config; return $self; } sub output { my ($self, $new_output) = @_; if (@_ > 1) { $self->_load_output_handle($new_output); } return $self->{output}; } sub _load_output_handle { my ($self, $output) = @_; my %targets = ( stdout => *STDOUT, stderr => *STDERR ); my $error; my $ref = ref $output; if (!$ref and exists $targets{ lc $output }) { $self->{output} = lc $output; $self->{output_handle} = $targets{ $self->{output} }; } elsif ( ( $ref and $ref eq 'GLOB') or (!$ref and \$output =~ /GLOB\([^()]+\)$/) ) { $self->{output} = 'handle'; $self->{output_handle} = $output; } elsif (!$ref or $ref eq 'SCALAR') { if (open my $fh, '>>', $output) { $self->{output} = 'file'; $self->{output_handle} = $fh; } else { $error = "file '$output': $!"; } } else { $error = 'unknown output data'; } if ($error) { Data::Printer::Common::_warn($self, "error opening custom output handle: $error"); $self->{output_handle} = $targets{'stderr'} } return; } sub new { my $class = shift; my $self = bless {}, $class; return $self->_init(@_); } sub multiline { my ($self, $value) = @_; if (defined $value) { $self->{multiline} = !!$value; if ($value) { $self->{_linebreak} = "\n"; $self->{_current_indent} = $self->{indent}; $self->index( $self->{_original_index} ) if exists $self->{_original_index}; $self->hash_separator( $self->{_original_separator} ) if exists $self->{_original_separator}; $self->array_overflow( $self->{_original_array_overflow} ) if exists $self->{_original_array_overflow}; $self->hash_overflow( $self->{_original_hash_overflow} ) if exists $self->{_original_hash_overflow}; $self->string_overflow( $self->{_original_string_overflow} ) if exists $self->{_original_string_overflow}; } else { $self->{_original_index} = $self->index; $self->index(0); $self->{_original_separator} = $self->hash_separator; $self->hash_separator(':'); $self->{_original_array_overflow} = $self->array_overflow; $self->array_overflow('(...)'); $self->{_original_hash_overflow} = $self->hash_overflow; $self->hash_overflow('(...)'); $self->{_original_string_overflow} = $self->string_overflow; $self->string_overflow('(...)'); $self->{_linebreak} = ' '; $self->{_current_indent} = 0; } } return $self->{multiline}; } sub fulldump { my ($self, $value) = @_; if (defined $value) { $self->{fulldump} = !!$value; if ($value) { $self->{_original_string_max} = $self->string_max; $self->string_max(0); $self->{_original_array_max} = $self->array_max; $self->array_max(0); $self->{_original_hash_max} = $self->hash_max; $self->hash_max(0); } else { $self->string_max($self->{_original_string_max}) if exists $self->{_original_string_max}; $self->array_max($self->{_original_array_max}) if exists $self->{_original_array_max}; $self->hash_max($self->{_original_hash_max}) if exists $self->{_original_hash_max}; } } } sub _load_filters { my ($self, $props) = @_; # load our core filters (LVALUE is under the 'SCALAR' filter module) my @core_filters = qw(SCALAR ARRAY HASH REF VSTRING GLOB FORMAT Regexp CODE OBJECT GenericClass); foreach my $class (@core_filters) { $self->_load_external_filter($class); } my @filters; # load any custom filters provided by the user if (exists $props->{filters}) { if (ref $props->{filters} eq 'HASH') { Data::Printer::Common::_warn( $self, 'please update your code: filters => { ... } is now filters => [{ ... }]' ); push @filters, $props->{filters}; } elsif (ref $props->{filters} eq 'ARRAY') { @filters = @{ $props->{filters} }; } else { Data::Printer::Common::_warn($self, 'filters must be an ARRAY reference'); } } foreach my $filter (@filters) { my $filter_reftype = Scalar::Util::reftype($filter); if (!defined $filter_reftype) { $self->_load_external_filter($filter); } elsif ($filter_reftype eq 'HASH') { foreach my $k (keys %$filter) { if ($k eq '-external') { Data::Printer::Common::_warn( $self, 'please update your code: ' . 'filters => { -external => [qw(Foo Bar)}' . ' is now filters => [qw(Foo Bar)]' ); next; } if (Scalar::Util::reftype($filter->{$k}) eq 'CODE') { my $type = Data::Printer::Common::_filter_category_for($k); unshift @{ $self->{$type}{$k} }, $filter->{$k}; } else { Data::Printer::Common::_warn( $self, 'hash filters must point to a CODE reference' ); } } } else { Data::Printer::Common::_warn($self, 'filters must be a name or { type => sub {...} }'); } } return; } sub _load_external_filter { my ($self, $class) = @_; my $module = "Data::Printer::Filter::$class"; my $error = Data::Printer::Common::_tryme("use $module; 1;"); if ($error) { Data::Printer::Common::_warn($self, "error loading filter '$class': $error"); return; } my $from_module = $module->_filter_list; foreach my $kind (keys %$from_module) { foreach my $name (keys %{$from_module->{$kind}}) { unshift @{ $self->{$kind}{$name} }, @{ $from_module->{$kind}{$name} }; } } return; } sub _detect_color_level { my ($self) = @_; my $colored = $self->colored; my $color_level; # first we honour ANSI_COLORS_DISABLED, colored and writing to files if ( !$colored || ($colored eq 'auto' && (exists $ENV{ANSI_COLORS_DISABLED} || $self->output eq 'handle' || $self->output eq 'file' ) ) ) { $color_level = 0; } else { # NOTE: we could try `tput colors` but it may not give # the proper result, so instead we do what most terminals # currently do and rely on environment variables. if ($ENV{COLORTERM} && $ENV{COLORTERM} eq 'truecolor') { $color_level = 3; } elsif ($ENV{TERM_PROGRAM} && $ENV{TERM_PROGRAM} eq 'iTerm.app') { my $major_version = substr($ENV{TERM_PROGRAM_VERSION} || '0', 0, 1); $color_level = $major_version >= 3 ? 3 : 2; } elsif ($ENV{TERM_PROGRAM} && $ENV{TERM_PROGRAM} eq 'Apple_Terminal') { $color_level= 2; } elsif ($ENV{TERM} && $ENV{TERM} =~ /\-256(?:color)?\z/i) { $color_level = 2; } elsif ($ENV{TERM} && ($ENV{TERM} =~ /\A(?:screen|xterm|vt100|rxvt)/i || $ENV{TERM} =~ /color|ansi|cygwin|linux/i) ) { $color_level = 1; } elsif ($ENV{COLORTERM}) { $color_level = 1; } else { $color_level = $colored eq 'auto' ? 0 : 1; } } return $color_level; } sub _load_colors { my ($self, $props) = @_; $self->{_output_color_level} = $self->_detect_color_level; my $theme_object; my $default_theme = 'Material'; my $theme_name = Data::Printer::Common::_fetch_scalar_or_default($props, 'theme', $default_theme); $theme_object = Data::Printer::Theme->new( name => $theme_name, color_overrides => $props->{colors}, color_level => $self->{_output_color_level}, ddp => $self, ); if (!$theme_object) { if ($theme_name ne $default_theme) { $theme_object = Data::Printer::Theme->new( name => $default_theme, color_overrides => $props->{colors}, color_level => $self->{_output_color_level}, ddp => $self, ); } Data::Printer::Common::_die("Unable to load default theme. This should never happen - please contact the author") unless $theme_object; } $self->{theme} = $theme_object; } sub _filters_for_type { my ($self, $type) = @_; return exists $self->{type_filters}{$type} ? @{ $self->{type_filters}{$type} } : (); } sub _filters_for_class { my ($self, $type) = @_; return exists $self->{class_filters}{$type} ? @{ $self->{class_filters}{$type} } : (); } sub _filters_for_data { my ($self, $data) = @_; # we favour reftype() over ref() because you could have # a HASH.pm (or ARRAY.pm or whatever) blessing any variable. my $ref_kind = Scalar::Util::reftype($data); $ref_kind = 'SCALAR' unless $ref_kind; # ref() returns 'Regexp' but reftype() returns 'REGEXP', so we picked one: $ref_kind = 'Regexp' if $ref_kind eq 'REGEXP'; my @potential_filters; # first, try class name + full inheritance for a specific name. my $class = Scalar::Util::blessed($data); # a regular regexp is blessed, but in that case we want a # regexp filter, not a class filter. if (defined $class && $class eq 'Regexp') { if ($ref_kind eq 'Regexp' || ($] < 5.011 && $ref_kind eq 'SCALAR')) { $ref_kind = 'Regexp'; undef $class; } } if (defined $class) { if ($self->class->parent_filters) { my $linear_ISA = Data::Printer::Common::_linear_ISA_for($class, $self); foreach my $candidate_class (@$linear_ISA) { push @potential_filters, $self->_filters_for_class($candidate_class); } } else { push @potential_filters, $self->_filters_for_class($class); } # next, let any '-class' filters have a go: push @potential_filters, $self->_filters_for_class('-class'); } # then, try regular data filters push @potential_filters, $self->_filters_for_type($ref_kind); # finally, if it's neither a class nor a known core type, # we must be in a future perl with some type we're unaware of: push @potential_filters, $self->_filters_for_class('-unknown'); return @potential_filters; } # _see($data): marks data as seen if it was never seen before. # if we are showing refcounts, we return those. Initially we had # this funcionallity separated, but refcounts increase as we find # them again and because of that we were seeing weird refcounting. # So now instead we store the refcount of the variable when we # first see it. # Finally, if we have already seen the data, we return its stringified # position, like "var", "var{foo}[7]", etc. UNLESS $options{seen_override} # is set. Why seen_override? Sometimes we want to print the same data # twice, like the GenericClass filter, which prints the object's metadata # via parse() and then the internal structure via parse_as(). But if we # simply do that, we'd get the "seen" version (because we have already # visited it!) The refcount is still calculated only once though :) sub _see { my ($self, $data, %options) = @_; return {} unless ref $data; my $id = pack 'J', Scalar::Util::refaddr($data); if (!exists $self->{_seen}{$id}) { my $entry = { name => $self->current_name, refcount => ($self->show_refcount ? $self->_refcount($data) : 0), }; # the values returned by tied hashes are temporaries, so we can't # mark them as 'seen'. Ideally, we'd use something like # Hash::Util::Fieldhash::register() (see PR#179) and remove entries # from $self->{_seen} when $data is destroyed. The problem is this # adds a lot of internal magic to the data we're inspecting (we tried, # see Issue#75), effectively changing it. So we just ignore them, at # the risk of missing some circular reference. $self->{_seen}{$id} = $entry unless $options{tied_parent}; return { refcount => $entry->{refcount} }; } return { refcount => $self->{_seen}{$id}->{refcount} } if $options{seen_override}; return $self->{_seen}{$id}; } sub seen { my ($self, $data) = @_; my $id = pack 'J', Scalar::Util::refaddr($data); return exists $self->{_seen}{$id}; } sub unsee { my ($self, $data) = @_; return unless ref $data && keys %{$self->{_seen}}; my $id = pack 'J', Scalar::Util::refaddr($data); delete $self->{_seen}{$id}; return; } sub _refcount { my ($self, $data) = @_; require B; my $count; my $rv = B::svref_2object(\$data)->RV; if (ref($data) eq 'REF' && ref($$data)) { $rv = B::svref_2object($data)->RV; } # some SV's are special (represented by B::SPECIAL) # and don't have a ->REFCNT (e.g. \undef) return 0 unless $rv->can( 'REFCNT' ); # 3 is our magical number: so we return the actual reference count # minus the references we added as we were traversing: return $rv->REFCNT - $self->{_refcount_base}; } sub parse_as { my ($self, $type, $data) = @_; return $self->parse($data, force_type => $type, seen_override => 1); } # parse() must always receive a reference, never a regular copy, because # that's the only way we are able to figure whether the source data # is a weak ref or not. sub parse { my $self = shift; my $str_weak = $self->_check_weak( $_[0] ); my ($data, %options) = @_; my $parsed_string = ''; # if we've seen this structure before, we return its location # instead of going through it again. This avoids infinite loops # when parsing circular references: my $seen = $self->_see($data, %options); if (my $name = $seen->{name}) { $parsed_string .= $self->maybe_colorize( ((ref $data eq 'SCALAR' && $self->resolve_scalar_refs) ? $$data : $name ), 'repeated' ); # on repeated references, the only extra data we put # is whether this reference is weak or not. $parsed_string .= $str_weak; return $parsed_string; } $self->{_position}++; # Each filter type provides an array of potential parsers. # Once we find the right kind, we go through all of them, # from most precise match to most generic. # The first filter that returns a defined value "wins" # (even if it's an empty string) foreach my $filter ( exists $options{force_type} ? $self->_filters_for_type($options{force_type}) : $self->_filters_for_data($data) ) { if (defined (my $result = $filter->($data, $self))) { $parsed_string .= $result; last; } } # FIXME: because of prototypes, p(@data) becomes a ref (that we don't care about) # to the data (that we do care about). So we should not show refcounts, memsize # or readonly status for something guaranteed to be ephemeral. $parsed_string .= $self->_check_readonly($data); $parsed_string .= $str_weak if ref($data) ne 'REF'; $parsed_string .= $self->_check_memsize($data); if ($self->show_refcount && ref($data) ne 'SCALAR' && $seen->{refcount} > 1 ) { $parsed_string .= ' (refcount: ' . $seen->{refcount} .')'; } if (--$self->{'_position'} == 0) { $self->{'_seen'} = {}; $self->{'_refcount_base'} = 3; $self->{'_position'} = 0; } return $parsed_string; } sub _check_memsize { my ($self, $data) = @_; return '' unless $self->show_memsize && ( $self->show_memsize eq 'all' || $self->show_memsize >= $self->{_position}); my $size; my $unit; my $error = Data::Printer::Common::_tryme(sub { require Devel::Size; $size = Devel::Size::total_size($data); $unit = uc $self->memsize_unit; if ($unit eq 'M' || ($unit eq 'AUTO' && $size > 1024*1024)) { $size = $size / (1024*1024); $unit = 'M'; } elsif ($unit eq 'K' || ($unit eq 'AUTO' && $size > 1024)) { $size = $size / 1024; $unit = 'K'; } else { $unit = 'B'; } }); if ($error) { if ($error =~ m{locate Devel/Size.pm}) { Data::Printer::Common::_warn($self, "Devel::Size not found, show_memsize will be ignored") if $self->{_position} == 1; } else { Data::Printer::Common::_warn($self, "error fetching memory usage: $error"); } return ''; } return '' unless $size; my $string = ' (' . ($size < 0 ? sprintf("%.2f", $size) : int($size)) . $unit . ')'; return $self->maybe_colorize($string, 'memsize'); } sub _check_weak { my ($self) = shift; return '' unless $self->show_weak; my $realtype = Scalar::Util::reftype($_[0]); my $isweak; if ($realtype && ($realtype eq 'REF' || $realtype eq 'SCALAR')) { $isweak = Scalar::Util::isweak($_[0]); } else { $isweak = Scalar::Util::isweak($_[0]); } return '' unless $isweak; return ' ' . $self->maybe_colorize('(weak)', 'weak'); } sub _write_label { my ($self) = @_; return '' unless $self->caller_info; my @caller = caller 1; my $message = $self->caller_message; $message =~ s/\b__PACKAGE__\b/$caller[0]/g; $message =~ s/\b__FILENAME__\b/$caller[1]/g; $message =~ s/\b__LINE__\b/$caller[2]/g; my $separator = $self->caller_message_newline ? "\n" : ' '; $message = $self->maybe_colorize($message, 'caller_info'); $message = $self->caller_message_position eq 'before' ? $message . $separator : $separator . $message ; return $message; } sub maybe_colorize { my ($self, $output, $color_type, $default_color, $end_color) = @_; if ($self->{_output_color_level} && defined $color_type) { my $theme = $self->theme; my $sgr_color = $theme->sgr_color_for($color_type); if (!defined $sgr_color && defined $default_color) { $sgr_color = $theme->_parse_color($default_color); } if ($sgr_color) { $output = $sgr_color . $output . (defined $end_color ? $theme->sgr_color_for($end_color) : $theme->color_reset ); } } return $output; } sub _check_readonly { my ($self) = @_; return ' (read-only)' if $self->show_readonly && &Internals::SvREADONLY($_[1]); return ''; } 42; __END__ =head1 NAME Data::Printer::Object - underlying object for Data::Printer =head1 SYNOPSIS Unless you're writing a plugin, or looking for some L<< configuration property details|/Attributes >> the documentation you want is probably on L. Seriously! =head1 DESCRIPTION This module implements the underlying object used by Data::Printer to parse, format and print Perl data structures. It is passed to plugins so they can rely on contextual information from the caller like colors, spacing and other options. =head1 COMMON PROPERTIES / ATTRIBUTES =head2 Scalar Options =head3 show_tainted When set, will detect and let you know of any tainted data (default: 1) Note that this is a no-op unless your script is in taint mode, meaning it's running with different real and effective user/group IDs, or with the -T flag. See L for extra information. =head3 show_unicode Whether to label data that has the L set. (default: 1) =head3 show_dualvar Perl can interpret strings as numbers and vice-versa, but that doesn't mean it always gets it right. When this option is set to "lax", Data::Printer will show both values if they differ. If set to "strict", it will always show both values, and when set to "off" it will never show the second value. (default: lax) =head3 show_lvalue Lets you know whenever a value is an lvalue (default: 1) =head3 string_max The maximum number of characters to display in a string. If the string is bigger than that, Data::Printer will trim a part of the string (set by L) and replace it with the message set on L. Set C to 0 to show all characters (default: 4096) =head3 string_overflow Message to display once L is reached. Defaults to I<< "(...skipping __SKIPPED__ chars...)" >>. =head3 string_preserve When the string has more characters than L, this option defines which part of the string to preserve. Can be set to 'begin', 'middle' or 'end'. (default: 'begin') =head3 scalar_quotes Which quotation character to use when printing strings (default: ") =head3 escape_chars Use this to escape certain characters from strings, which could be useful if your terminal is in a different encoding than the data being printed. Can be set to 'nonascii', 'nonlatin1', 'all' or 'none' (default: none). =head3 unicode_charnames whether to use the character's names when escaping unicode (e.g. SNOWMAN instead of \x{2603}) (default: 0) =head3 print_escapes Whether to print invisible characters in strings, like \b, \n and \t (default: 0) =head3 resolve_scalar_refs If a reference to a scalar value is found more than once, print the resolved value. For example, you may have an object that you reuse to represent 'true' or 'false'. If you have more than one of those in your data, Data::Printer will by default print the second one as a circular reference. When this option is set to true, it will instead resolve the scalar value and keep going. (default: false) =head2 Array Options =head3 array_max The maximum number of array elements to show. If the array is bigger than that, Data::Printer will trim the offending slice (set by L) and replace it with the message set on L. Set C to 0 to show all elements in the array, regardless of array size (default: 100) =head3 array_overflow Message to display once L is reached. Defaults to C<< "(...skipping __SKIPPED__ items...)" >>. =head3 array_preserve When an array has more elements than L, this option defines which part of the array to preserve. Can be set to 'begin', 'middle' or 'end'. (default: 'begin') =head3 index When set, shows the index number before each array element. (default: 1) =head2 Hash Options =head3 align_hash If this option is set, hash keys will be vertically aligned by the length of the longest key. This is better explained with an example, so consider the hash C<< my %h = ( a => 123, aaaaaa => 456 ) >>. This would be an unaligned output: a => 123, aaaaaa => 456 and this is what it looks like with C<< align_hash = 1 >>: a => 123, aaaaaa => 456 (default: 1) =head3 hash_max The maximum number of hash key/value pairs to show. If the hash is bigger than that, Data::Printer will trim the offending slice (set by L) and replace it with the message set on L. Set C to 0 to show all elements in the hash, regardless of the total keys. (default: 100) =head3 hash_overflow Message to display once L is reached. Defaults to C<< "(...skipping __SKIPPED__ keys...)" >>. =head3 hash_preserve When a hash has more elements than L, this option defines which part of the hash to preserve. Can be set to 'begin', 'middle' or 'end'. Note that Perl makes no promises regarding key order, so this option only makes sense if keys are sorted. In other words, if you have disabled L, expect random keys to be shown regardless of which part was preserved. (default: 'begin') =head3 hash_separator What to use to separate keys from values. Default is ' ' (three spaces) =head3 sort_keys Whether to sort keys when printing the contents of a hash (default: 1) =head3 quote_keys Whether to quote hash keys or not. Can be set to 1 (always quote), 0 (never quote) or 'auto' to quote only when a key contains spaces or linebreaks. (default: 'auto') =head2 Caller Information Data::Printer can add an informational message to every call to C or C if you enable C. So for example if you write: my $var = "meep!"; p $var, caller_info => 1; this will output something like: Printing in line 2 of myapp.pl: "meep!" The following options let you customize the message and how it is displayed. =head3 caller_info Set this option to a true value to display a L next to the data being printed. (default: 0) =head3 caller_message What message to print when L is true. Defaults to "C<< Printing in line __LINE__ of __FILENAME__ >>". If the special strings C<__LINE__>, C<__FILENAME__> or C<__PACKAGE__> are present in the message, they'll be interpolated into their according value so you can customize the message at will: caller_message = "[__PACKAGE__:__LINE__]" =head3 caller_message_newline When true, skips a line when printing L. When false, only a single space is added between the message and the data. (default: 1) =head3 caller_message_position This option controls where the L will appear in relation to the code being printed. Can be set to 'before' or 'after'. A line is always skipped between the message and the data (either before or after), unless you set L to 0. (default: 'before') =head2 General Options =head3 arrows Data::Printer shows circular references as a data path, indicating where in the data that reference points to. You may use this option to control if/when should it print reference arrows. Possible values are 'all' (e.g C<< var->{x}->[y]->[z] >>), 'first' (C<< var->{x}[y][z] >>) or 'none' (C<< var{x}[y][z] >>). Default is 'none'. =head3 colored Whether to colorize the output or not. Can be set to 1 (always colorize), 0 (never colorize) or 'auto'. Default is 'auto', meaning it will colorize only when printing to STDOUT or STDERR, never to a file or to a variable. The 'auto' setting also respects the C environment variable. =head3 deparse If the data structure contains a subroutine reference (coderef), this option can be set to deparse it and print the underlying code, which hopefully resembles the original source code. (default: 0) =head3 coderef_stub If the data structure contains a subroutine reference (coderef) and the 'L' option above is set to false, Data::Printer will print this instead. (default: 'C<< sub { ... } >>') =head3 coderef_undefined If the data structure contains a subroutine reference (coderef) that has not actually been defined at the time of inspection, Data::Printer will print this instead. Set it to '0' to disable this check, in which case Data::Printer will use whatever value you set on L above. (default: ''). =head3 end_separator When set, the last item on an array or hash will always contain a trailing L. (default: 0) =head3 show_memsize Set to true and Data::Printer will show the estimate memory size of the data structure being printed. Requires Devel::Size. (default: 0) =head3 memsize_unit If L is on, this option lets you specify the unit in which to show the memory size. Can be set to "b" to show size in bytes, "k" for kilobytes, "m" for megabytes or "auto", which will use the biggest unit that makes sense. (default: auto) =head3 output Where you want the output to be printed. Can be set to the following values: =over 4 =item * C<'stderr'> - outputs to the standard error handle. =item * C<'stdout'> - outputs to the standard output handle. =item * reference to a scalar (e.g. C<\$string>) - outputs to the scalar reference. =item * file handle - any open file handle: open my $fh, '>>', '/path/to/some/file.log' or die $!; p @{[ 1,2,3 ]}, output => $fh; =item * file path - if you pass a non-empty string that is not 'stderr' nor 'stdout', Data::Printer will consider it to be a file path and create/append to it automatically for you. So you can do this in your C<.dataprinter>: output = /path/to/some/file.log By default, Data::Printer will print to the standard error (stderr). =back =head3 max_depth This setting controls how far inside the data structure we should go (default: 0 for no depth limit) =head3 return_value Whether the user wants the return value to be a pass-through of the source data ('pass'), the dump content itself ('dump') or nothing at all ('void'). Defaults to C<'pass'> since version 0.36. B: if you set it to 'dump', make sure it's not the last statement of a subroutine or that, if it is, the sub is only called in void context. =head3 separator The separator character(s) to use for arrays and hashes. The default is the comma ",". =head3 show_readonly When this option is set, Data::Printer will let you know whenever a value is read-only. (default: 1) =head3 show_refcount Whether to show data refcount it's above 1 (default: 0) =head3 show_weak When this option is set, Data::Printer will let you know whenever it finds a weak reference (default: 1) =head3 show_tied When set to true, this option will let you know whenever a tied variable is detected, including what is tied to it (default: 1) =head3 theme theme = Monokai This setting gets/sets the current color theme module. The default theme is L. Data::Printer ships with several themes for you to choose, and you can create your own theme or use any other from CPAN. =head3 warnings If something goes wrong when parsing your data or printing it to the selected output, Data::Printer by default shows you a warning from the standpoint of the actual call to C or C. To silence those warnings, set this option to 0. =head2 Class / Object Options =head3 class_method When Data::Printer is printing an object, it first looks for a method named "C<_data_printer>" and, if one is found, we call it instead of actually parsing the structure. This way, module authors can control how Data::Printer outputs their objects the best possible way by simply adding a private method instead of having to write a full filter or even adding Data::Printer as a dependency. To disable this behavior, simply set this option to false or an empty string. You can also change it to a different name and Data::Printer will look for that instead. =head3 class - class properties to override. This "namespace" gets/sets all class properties that are used by the L that ships with Data::Printer. Note that, if you are using a specific filter for that object, most (if not all) of the settings below will not apply. In your C<.dataprinter> file, the defaults would look like this: class.parents = 1 class.linear_isa = auto class.universal = 0 class.expand = 1 class.stringify = 1 class.show_reftype = 0 class.show_overloads = 1 class.show_methods = all class.sort_methods = 1 class.inherited = public class.format_inheritance = lines class.parent_filters = 1 class.internals = 1 In code, you should use the "class" namespace as a key to a hash reference: use Data::Printer class => { parents => 1, linear_isa => 'auto', universal => 0, expand => 1, stringify => 1, show_reftype => 0, show_overloads => 1, show_methods => 'all', sort_methods => 1, inherited => 'public', format_inheritance => 'lines', parent_filters => 1, internals => 1, }; Or inline: p $some_object, class => { internals => 1, ... }; =head4 parents When set, shows all superclasses of the object being printed. (default: 1) =head4 linear_isa This setting controls whether to show the linearized @ISA, which is the order of preference in which the object's methods and attributes are resolved according to its inheritance. Can be set to 1 (always show), 0 (never show) or 'auto', which shows only when the object has more than one superclass. (default: 'auto') =head4 universal Set this option to 1 to include UNIVERSAL methods to the list of public methods (like C and C). (default: 0) =head4 expand Sets how many levels to descend when printing classes, in case their internals point to other classes. Set this to 0 to never expand any objects, just show their name. Set to any integer number and when Data::Printer reaches that depth, only the class name will be printed. Set to 'all' to always expand objects found inside your object. (default: 1) =head4 stringify When this option is set, Data::Printer will check if the object being printed contains any methods named C, C or C. If it does, Data::Printer will use it as the object's output instead of the generic class plugin. (default: 1) =head4 show_reftype If set to a true value, Data::Printer will show the internal reference type of the object. (default: 0) =head4 show_overloads This option includes a list of all overloads implemented by the object. (default: 1) =head4 show_methods Controls which of the object's direct methods to show. Can be set to 'none', 'all', 'private' or 'public'. When applicable (Moo, Moose) it will also show attributes and roles. (default: 'all') =head4 sort_methods When listing methods, attributes and roles, this option will order them alphabetically, rather than on whatever order the list of methods returned. (default: 1) =head4 inherited Controls which of the object's parent methods to show. Can be set to 'none', 'all', 'private' or 'public'. (default: 'public') =head4 format_inheritance This option controls how to format the list of methods set by a parent class (and not the class itself). Setting it to C<'lines'> it will print one line for each parent, like so: public methods (5): foo, bar Parent::Class: baz, meep Other::Parent: moop Setting it to C<'string'>, it will put all methods on the same line: public methods (5): foo, bar, baz (Parent::Class), meep (Parent::CLass), moop (Other::Parent) Default is: 'lines'. =head4 parent_filters If there is no filter for the given object's class, there may still be a filter for one of its parent classes. When this option is set, Data::Printer will traverse the object's superclass and use the first filter it finds, if one is present. (default: 1) =head4 internals Shows the object's internal data structure. (default: 1) =head2 "Shortcuts" Some options are so often used together we have created shortcuts for them. =head3 as p $somevar, as => 'is this right?'; The "C" shortcut activates L and sets L to whatever you set it to. It's really useful to quickly differentiate between sequential uses of C. =head3 multiline p $somevar, multiline => 0; When set to 0, disables array index and linebreaks, uses ':' as hash separator and '(...)' as overflow for hashes, arrays and strings, and also disables 'caller_message_newline' so any caller message is shown on the same line as the variable being printed. If this is set on a global configuration or on the C<.dataprinter> file, Can be "undone" by setting it to "1". =head3 fulldump p $somevar, fulldump => 1; By default, Data::Printer limits the size of string/array/hash dumps to a (hopefully) reasonable size. Still, sometimes you really need to see everything. To completely disable such limits, just set this option to true. =head2 Methods and Accessors for Filter Writers The following attributes could be useful if you're writing your own custom filters or maybe even a non-obvious profile. Otherwise, no need to worry about any of them ;) And make sure to check out the current filter list for real usage examples! =head3 indent =head3 outdent =head3 newline These methods are used to control the indentation level of the string being created to represent your data. While C and C respectively increase and decrease the indentation level, C will add a linebreak and position the "cursor" where you are expected to continue your dump string: my $output = $ddp->newline . 'this is a new line'; $ddp->indent; $output .= $ddp->newline . 'this is indented'; $ddp->outdent; $output .= $ddp->newline . 'back to our previous indentation!'; Unless multiline was set to 0, the code above should print something like: this is a new line this is indented back to our previous indentation =head3 extra_config Data::Printer will read and pass-through any unrecognized settings in either your C<.dataprinter> file or your inline arguments inside this structure. This is useful to create custom settings for your filters. While any and all unknown settings will be readable here, we recommend you prepend them with a namespace like C as those are reserved for filters and thus guaranteed not to colide with any core Data::Printer settings now or in the future. For example, on the L we have the C option, and even though Data::Printer itself doesn't have this option, we prepend everything with the C namespace, either in the config file: filter_web.expand_headers = 1 or inline: p $http_response, filters => ['Web'], filter_web => { expand_headers => 1 }; =head3 maybe_colorize( $string, $label ) =head3 maybe_colorize( $string, $label, $default_color ) my $output = $ddp->maybe_colorize( 12.3, 'number'); Instead of simply adding raw content to your dump string, you should wrap it with this method, as it will look up colors on the current theme and print them (or not, depending on whether the terminal supports color or the user has explicitly turned them off). If you are writing a custom filter and don't want to use the core labels to colorize your content, you may want to set your own label and pass a default color. For example: my $output = $ddp->maybe_colorize( $data, 'filter_myclass', '#ffccb3' ); In the code above, if the user has C set either on the C<.dataprinter> file or the runtime hashref, that one will be used. Otherwise, Data::Printer will use C<'#ffccb3'>. =head3 current_depth Shows the current depth level, from 0 onwards. =head3 current_name Gets/sets the name for the current posistion, to be printed when the parser visits that data again. E.g. C. =head3 parse( $data_ref ) =head3 parse( $data_ref, %options ) This method receives a reference to a data structure to parse, and returns the parsed string. It will call each filter and colorize the output accordingly. Use this inside filters whenever you want to use the result of a parsed data strucure. my $output = $ddp->parse( [3,2,1] ); An optional set of parameters may be passed: =over 4 =item * C<< force_type => $type >> - forces data to be treated as that type, where $type is the name of the Perl data strucuture as returned by Scalar::Util::reftype (e.g. 'HASH', 'ARRAY' etc). This is used when a filter wants to show the internals of blessed data. Otherwise parse would just call the same filter over and over again. =item * C<< seen_override => 1 >> - Data::Printer::Object tries to remember if it has already seen a data structure before, so it can show the circular reference instead of entenring an infinite loop. However, there are cases when you want to print the same data structure twice, like when you're doing a second pass on a blessed object to print its internals, or if you're using the same object over and over again. This setting overrides the internal counter and prints the same data again. Check L below for another way to achieve this. =back =head3 parse_as( $type, $data_ref ) This is a convenience method to force some data to be interpreted as a particular type. It is the same as: $ddp->parse( $data, force_type => $type, seen_override => 1 ); =head2 unsee( $data ) Sometimes you are writing a filter for data that you know will be repeated several times, like JSON Boolean objects. To prevent Data::Printer from showing this content as repeated, you can use the C method to make the current object forget about having ever visited this data. =head1 OBJECT CONSTRUCTION You'll most like never need this unless you're planning on extending Data::Printer itself. =head2 new( %options ) Creates a new Data::Printer::Object instance. It may (optionally) receive a hash or hash reference with custom settings for any of its properties. =head1 SEE ALSO L Data-Printer-1.002001/lib/Data/Printer/Filter.pm0000644000000000000000000001613114552015171017555 0ustar rootrootpackage Data::Printer::Filter; use strict; use warnings; use Data::Printer::Common; use Scalar::Util; sub import { my $caller = caller; my %_filters_for = (); my $filter = sub { my ($name, $code) = @_; Data::Printer::Common::_die( "syntax: filter 'Class', sub { ... }" ) unless defined $name && defined $code && Scalar::Util::reftype($code) eq 'CODE'; my $target = Data::Printer::Common::_filter_category_for($name); unshift @{$_filters_for{$target}{$name}}, sub { my ($item, $ddp) = @_; $code->($item, $ddp); }; }; { no strict 'refs'; *{"$caller\::filter"} = $filter; *{"$caller\::_filter_list"} = sub { \%_filters_for }; } }; 1; __END__ =head1 NAME Data::Printer::Filter - Create powerful stand-alone filters for Data::Printer =head1 SYNOPSIS Every time you say in your C<.dataprinter> file: filters = SomeFilter, OtherFilter Data::Printer will look for C and C on your C<@INC> and load them. To load filters without a configuration file: use DDP filters => ['SomeFilter', 'OtherFilter']; Creating your own filter module is super easy: package Data::Printer::Filter::MyFilter; use Data::Printer::Filter; # this filter will run every time DDP runs into a string/number filter 'SCALAR' => sub { my ($scalar_ref, $ddp) = @_; if ($$scalar_ref =~ /password/) { return '*******'; } return; # <-- let other SCALAR filters have a go! }; # you can also filter objects of any class! filter 'Some::Class' => sub { my ($object, $ddp) = @_; if (exists $object->{some_data}) { return $ddp->parse( $object->{some_data} ); } else { return $object->some_method; } }; Later, in your main code: use DDP filters => ['MyFilter']; Or, in your C<.dataprinter> file: filters = MyFilter =head1 DESCRIPTION L lets you add custom filters to display data structures and objects as you see fit to better understand and inspect/debug its contents. While you I put your filters inline in either your C statements or your inline calls to C, like so: use DDP filters => [{ SCALAR => sub { 'OMG A SCALAR!!' } }]; p @x, filters => [{ HASH => sub { die 'oh, noes! found a hash in my array' } }]; Most of the time you probably want to create full-featured filters as a standalone module, to use in many different environments and maybe even upload and share them on CPAN. This is where C comes in. Every time you C it in a package it will export the C keyword which you can use to create your own filters. Note: the loading B. They will be called in order and the first one to return something for the data being analysed will be used. =head1 HELPER FUNCTIONS =head2 filter TYPE, sub { ... }; The C function creates a new filter for I, using the given subref. The subref receives two arguments: the item itself - be it an object or a reference to a standard Perl type - and the current L being used to parse the data. Inside your filter you are expected to either return a string with whatever you want to display for that type/object, or an empty "C" statement meaning I<"Nothing to do, my mistake, let other filters have a go"> (which includes core filters from Data::Printer itself). You may use the current L to issue formatting calls like: =over 4 =item * C<< $ddp->indent >> - adds to the current indentation level. =item * C<< $ddp->outdent >> - subtracts from the current indentation level. =item * C<< $ddp->newline >> - returns a string containing a lineabreak and the proper number of spaces for the right indentation. It also accounts for the C option so you don't have to worry about it. =item * C<< $ddp->maybe_colorize( $string, 'label', 'default_color' ) >> - returns the given string either unmodified (if the output is not colored) or with the color set for I<'label'> (e.g. "class", "array", "brackets"). You are encouraged to provide your own custom colors by labelling them C, which is guaranteed to never collide with a core color label. =item * C<< $ddp->extra_config >> - all options set by the user either in calls to DDP or in the C<.dataprinter> file that are not used by Data::Printer itself will be put here. You are encouraged to provide your own customization options by labelling them C, which is guaranteed to never collide with a local setting. =item * C<< $ddp->parse( $data ) >> - parses and returns the string output of the given data structure. =back =head1 COMPLETE ANNOTATED EXAMPLE As an example, let's create a custom filter for arrays using all the options above: filter ARRAY => sub { my ($array_ref, $ddp) = @_; my $output; if ($ddp->extra_config->{filter_array}{header}) { $output = $ddp->maybe_colorize( 'got this array:', 'filter_array_header', '#cc7fa2' ); } $ddp->indent; foreach my $element (@$ref) { $output .= $ddp->newline . $ddp->parse($element); } $ddp->outdent; return $output; }; Then whenever you pass an array to Data::Printer, it will call this code. First it checks if the user has our made up custom option I<'filter_array.header'>. It can be set either with: use DDP filter_array => { header => 1 }; Or on C<.dataprinter> as: filter_array.header = 1 If it is set, we'll start the output string with I<"got this array">, colored in whatever color was set by the user under the C color tag - and defaulting to '#cc7fa2' in this case. Then it updates the indentation, so any call to C<< $ddp->newline >> will add an extra level of indentation to our output. After that we walk through the array using C and append each element to our output string as I, where the content is whatever string was returned from C<< $ddp->parse >>. Note that, if the element or any of its subelements is an array, our filter will be called again, this time for the new content. Check L for extra documentation on the methods used above and many others! =head1 DECORATING EXISTING FILTERS It may be the case where you want to call this filter and manipulate the result. To do so, make sure you make a named subroutine for your filters instead of using an anonymous one. For instance, all of Data::Printer's filters for core types have a 'parse' public function you can use: my $str = Data::Printer::Filter::HASH::parse($ref, $ddp); =head1 AVAILABLE FILTERS Data::Printer comes with filters for all Perl data types and several filters for popular Perl modules available on CPAN. Take a look at L<< the Data::Printer::Filter namespace|https://metacpan.org/search?q=Data%3A%3APrinter%3A%3AFilter >> for a complete list! =head1 SEE ALSO L Data-Printer-1.002001/lib/Data/Printer/Profile.pm0000644000000000000000000000435714552015171017737 0ustar rootrootpackage Data::Printer::Profile; 1; __END__ =head1 NAME Data::Printer::Profile - customize your Data::Printer with code =head1 SYNOPSIS package Data::Printer::Profile::MyProfile; sub profile { return { show_tainted => 1, show_unicode => 0, array_max => 30, # ...and so on... } } 1; Then put in your '.dataprinter' file: profile = MyProfile or load it at compile time: use DDP profile => 'MyProfile'; or anytime during execution: p $some_data, profile => 'MyProfile'; =head1 DESCRIPTION Usually a C<.dataprinter> file is enough to customize Data::Printer. But sometimes you want to use actual code to create special filters and rules, like a dynamic color scheme depending on terminal background or even the hour of the day, or a custom message that includes the hostname. Who knows! Or maybe you just want to be able to upload your settings to CPAN and load them easily anywhere, as shown in the SYNOPSIS. For all those cases, use a profile class! =head2 Creating a profile class Simply create a module named C (replacing, of course, "MyProfile" for the name of your profile). That class doesn't have to inherit from C, nor add Data::Printer as a dependency. All you have to do is implement a subroutine called C that returns a hash reference with all the options you want to use. =head2 Load order Profiles are read first and expanded into their options. So if you have a profile called MyProfile with, for example: show_tainted = 0 show_lvalue = 0 And your C<< .dataprinter >> file contains something like: profile = MyProfile show_lvalue = 1 The specific 'show_lvalues = 1' will override the other setting in the profile and the final outcome will be as if your setup said: show_tainted = 0 show_lvalue = 1 However, that is of course only true when the profile is loaded together with the other settings. If you set a profile later, for instance as an argument to C or C, then the profile will override any previous settings - though it will still be overridden by other inline arguments. =head1 SEE ALSO L L Data-Printer-1.002001/lib/Data/Printer/Profile/0000755000000000000000000000000014552072607017377 5ustar rootrootData-Printer-1.002001/lib/Data/Printer/Profile/JSON.pm0000644000000000000000000001127114552015171020501 0ustar rootrootpackage Data::Printer::Profile::JSON; use strict; use warnings; sub profile { return { show_tainted => 0, show_unicode => 0, show_lvalue => 0, print_escapes => 0, scalar_quotes => q("), escape_chars => 'none', string_max => 0, unicode_charnames => 0, array_max => 0, index => 0, hash_max => 0, hash_separator => ': ', align_hash => 0, sort_keys => 0, quote_keys => 1, name => 'var', return_value => 'dump', output => 'stderr', indent => 2, show_readonly => 0, show_tied => 0, show_dualvar => 'off', show_weak => 0, show_refcount => 0, show_memsize => 0, separator => ',', end_separator => 0, caller_info => 0, colored => 0, class_method => undef, # Data::Printer doesn't provide a way to directly # decorate filters, so we do it ourselves: filters => [ { '-class' => \&_json_class_filter, 'SCALAR' => \&_json_scalar_filter, 'LVALUE' => \&_json_scalar_filter, 'CODE' => \&_json_code_filter, 'FORMAT' => \&_json_format_filter, 'GLOB' => \&_json_glob_filter, 'REF' => \&_json_ref_filter,, 'Regexp' => \&_json_regexp_filter, 'VSTRING' => \&_json_vstring_filter, }, ], }; } sub _json_class_filter { my ($obj, $ddp) = @_; Data::Printer::Common::_warn($ddp, 'json cannot express blessed objects. Showing internals only'); require Scalar::Util; my $reftype = Scalar::Util::reftype($obj); $reftype = 'Regexp' if $reftype eq 'REGEXP'; $ddp->indent; my $string = $ddp->parse_as($reftype, $obj); $ddp->outdent; return $string; } sub _json_ref_filter { my ($ref, $ddp) = @_; my $reftype = ref $$ref; if ($reftype ne 'HASH' && $reftype ne 'ARRAY') { Data::Printer::Common::_warn($ddp, 'json cannot express references to scalars. Cast to non-reference'); } require Scalar::Util; my $id = pack 'J', Scalar::Util::refaddr($$ref); if ($ddp->seen($$ref)) { Data::Printer::Common::_warn($ddp, 'json cannot express circular references. Cast to string'); return '"' . $ddp->parse($$ref) . '"'; } return $ddp->parse($$ref); } sub _json_glob_filter { my (undef, $ddp) = @_; Data::Printer::Common::_warn($ddp, 'json cannot express globs.'); return ''; } sub _json_format_filter { my $res = Data::Printer::Filter::FORMAT::parse(@_); return '"' . $res . '"'; } sub _json_regexp_filter { my ($re, $ddp) = @_; Data::Printer::Common::_warn($ddp, 'regular expression cast to string (flags removed)'); my $v = "$re"; my $mod = ""; if ($v =~ /^\(\?\^?([msixpadlun-]*):([\x00-\xFF]*)\)\z/) { $mod = $1; $v = $2; $mod =~ s/-.*//; } $v =~ s{/}{\\/}g; return '"' . "/$v/$mod" . '"'; } sub _json_vstring_filter { my ($scalar, $ddp) = @_; Data::Printer::Common::_warn($ddp, 'json cannot express vstrings. Cast to string'); my $ret = Data::Printer::Filter::VSTRING::parse(@_); return '"' . $ret . '"'; } sub _json_scalar_filter { my ($scalar, $ddp) = @_; return $ddp->maybe_colorize('null', 'undef') if !defined $$scalar; return Data::Printer::Filter::SCALAR::parse(@_); } sub _json_code_filter { my (undef, $ddp) = @_; Data::Printer::Common::_warn($ddp, 'json cannot express subroutines. Cast to string'); my $res = Data::Printer::Filter::CODE::parse(@_); return '"' . $res . '"'; } 1; __END__ =head1 NAME Data::Printer::Profile::JSON - dump variables in JSON format =head1 SYNOPSIS While loading Data::Printer: use DDP profile => 'JSON'; While asking for a print: p $var, profile => 'JSON'; or in your C<.dataprinter> file: profile = JSON =head1 DESCRIPTION This profile outputs your variables in JSON format. It's not nearly as efficient as a regular JSON module, but it may be useful, specially if you're changing the format directly in your .dataprinter. =head1 CAVEATS JSON is a super simple format that allows scalar, hashes and arrays. It doesn't support many types that could be present on Perl data structures, such as functions, globs and circular references. When printing those types, whenever possible, this module will stringify the result. Objects are also not shown, but their internal data structure is exposed. This module also attempts to render Regular expressions as plain JS regexes. While not directly supported in JSON, it should be parseable. =head1 SEE ALSO L L> Data-Printer-1.002001/lib/Data/Printer/Profile/Dumper.pm0000644000000000000000000001340714552015171021167 0ustar rootrootpackage Data::Printer::Profile::Dumper; use strict; use warnings; sub profile { return { show_tainted => 0, show_unicode => 0, show_lvalue => 0, print_escapes => 0, scalar_quotes => q('), escape_chars => 'none', string_max => 0, unicode_charnames => 0, array_max => 0, index => 0, hash_max => 0, hash_separator => ' => ', align_hash => 0, sort_keys => 0, quote_keys => 1, name => '$VAR1', arrows => 'first', return_value => 'dump', output => 'stderr', indent => 10, show_readonly => 0, show_tied => 0, show_dualvar => 'off', show_weak => 0, show_refcount => 0, show_memsize => 0, separator => ',', end_separator => 0, caller_info => 0, colored => 0, class_method => undef, # Data::Printer doesn't provide a way to directly # decorate filters, so we do it ourselves: filters => [ { '-class' => \&_data_dumper_class_filter, 'SCALAR' => \&_data_dumper_scalar_filter, 'LVALUE' => \&_data_dumper_lvalue_filter, 'HASH' => \&_data_dumper_hash_filter, 'ARRAY' => \&_data_dumper_array_filter, 'CODE' => \&_data_dumper_code_filter, 'FORMAT' => \&_data_dumper_format_filter, 'GLOB' => \&_data_dumper_glob_filter, 'REF' => \&_data_dumper_ref_filter,, 'Regexp' => \&_data_dumper_regexp_filter, 'VSTRING' => \&_data_dumper_vstring_filter, }, ], }; } sub _data_dumper_regexp_filter { my ($re, $ddp) = @_; my $v = "$re"; my $mod = ""; if ($v =~ /^\(\?\^?([msixpadlun-]*):([\x00-\xFF]*)\)\z/) { $mod = $1; $v = $2; $mod =~ s/-.*//; } $v =~ s{/}{\\/}g; return _output_wrapper($ddp, $ddp->maybe_colorize("qr/$v/$mod", 'regex')); } sub _data_dumper_glob_filter { my ($glob, $ddp) = @_; my $ret = "$$glob"; $ret =~ s|\A\*main:|\*:|; $ret =~ s|\A\*|\\*{'|; $ret .= '\'}'; return _output_wrapper($ddp, $ddp->maybe_colorize($ret, 'glob')); } sub _data_dumper_lvalue_filter { my (undef, $ddp) = @_; Data::Printer::Common::_warn($ddp, 'cannot handle ref type 10'); return _output_wrapper($ddp, ''); } sub _data_dumper_scalar_filter { my ($scalar, $ddp) = @_; my $ret = Data::Printer::Filter::SCALAR::parse(@_); return _output_wrapper($ddp, $ret); } sub _data_dumper_ref_filter { my ($scalar, $ddp) = @_; $ddp->indent; my $ret = Data::Printer::Filter::REF::parse(@_); $ret =~ s{\A[\\]+\s+}{\\}; # DDP's REF filter adds a space after refs. $ddp->outdent; return _output_wrapper($ddp, $ret); } sub _data_dumper_vstring_filter { my ($scalar, $ddp) = @_; my $ret = Data::Printer::Filter::VSTRING::parse(@_); if ($] < 5.009 && substr($ret, 0, 7) eq 'VSTRING') { $ret = $ddp->maybe_colorize('', 'vstring'); } return _output_wrapper($ddp, $ret); } sub _data_dumper_format_filter { my (undef, $ddp) = @_; Data::Printer::Common::_warn($ddp, 'cannot handle ref type 14'); return _output_wrapper($ddp, ''); } sub _data_dumper_code_filter { my (undef, $ddp) = @_; return _output_wrapper($ddp, $ddp->maybe_colorize('sub { "DUMMY" }', 'code')); } sub _data_dumper_array_filter { my ($hashref, $ddp) = @_; my $ret = Data::Printer::Filter::ARRAY::parse(@_); return _output_wrapper($ddp, $ret); } sub _data_dumper_hash_filter { my ($hashref, $ddp) = @_; my $ret = Data::Printer::Filter::HASH::parse(@_); return _output_wrapper($ddp, $ret); } sub _data_dumper_class_filter { my ($obj, $ddp) = @_; require Scalar::Util; my $reftype = Scalar::Util::reftype($obj); $reftype = 'Regexp' if $reftype eq 'REGEXP'; my ($parse_prefix, $parse_suffix) = ('', ''); if ($reftype eq 'SCALAR' || $reftype eq 'REF' || $reftype eq 'VSTRING') { $parse_prefix = 'do{\(my $o = '; $parse_prefix .= '\\' if $reftype eq 'REF'; $parse_suffix = ')}'; } $ddp->indent; my $ret = $ddp->maybe_colorize('bless( ' . $parse_prefix, 'method') . $ddp->parse_as($reftype, $obj) . $ddp->maybe_colorize($parse_suffix, 'method') . q|, '| . $ddp->maybe_colorize(ref($obj), 'class') . q|'| . $ddp->maybe_colorize(' )', 'method') ; $ddp->outdent; return _output_wrapper($ddp, $ret); } sub _output_wrapper { my ($ddp, $output) = @_; if ($ddp->current_depth == 0) { $output = '$VAR1 = ' . $output . ';'; } return $output; } 1; __END__ =head1 NAME Data::Printer::Profile::Dumper - use DDP like Data::Dumper =head1 SYNOPSIS While loading Data::Printer: use DDP profile => 'Dumper'; While asking for a print: p $var, profile => 'Dumper'; or in your C<.dataprinter> file: profile = Dumper =head1 DESCRIPTION This profile tries to simulate Data::Dumper's output as closely as possible, using Data::Printer, even skipping types unsupported by Data::Dumper like lvalues and formats. It's not guaranteed to be 100% accurate, but hopefully it's close enough :) =head2 Notable Diferences from Data::Dumper It's important to notice that this profile tries to emulate Data::Dumper's I, NOT its behaviour. As such, some things are still happening in a much DDP-ish way. * no $VAR2, ... * return value * prototypes * still called 'p' (say alias = 'Dumper' if you want) * arg is always a reference, so on the top level, references to scalars will be rendered as scalars. References to references and inner references will be rendered properly. =head1 SEE ALSO L L Data-Printer-1.002001/CONTRIBUTING.md0000644000000000000000000000527514552015171015170 0ustar rootroot### Contributing to Data::Printer Hey! Thank you for wanting to contribute 🎉 Regardless of your experience, all contributions and suggestions are welcome! #### Getting started Data::Printer has *a lot* of customization options and extensive documentation so [check it out first](). If something looks outdated or not as clear as it could be, or even if you just found a typo, please [open a ticket on Github](https://github.com/garu/Data-Printer/issues/new/choose). #### Expected behaviour on discussions The main place to discuss about DDP's bugs and features is [Github's ticketing system](https://github.com/garu/Data-Printer/issues). Whether you're sending patches or asking questions, we ask everyone to be respectful, mindful and open to collaboration, favoring a welcoming and inclusive language. In short: please be nice to each other - it goes a long way :) (if you need a better definition of "nice", you may check [here](https://github.com/stumpsyn/policies/blob/master/citizen_code_of_conduct.md)) #### Navigating through the code We have a single main branch on our git repository, where all the work is performed and/or merged into. When we make a release, we tag it. To help you naviage the codebase, below is a rough project outline: DDP.pm - an alias to Data::Printer; Data/Printer.pm - initialization, main imported functions and output handling; Data/Printer/Common.pm - shared code (string processing, try/catch, sorting, etc); Data/Printer/Config.pm - rc file loading, option merging; Data/Printer/Object.pm - stores options, dispatches data to active filters; Data/Printer/Filter.pm - used in filters, exports the 'filter' command; Data/Printer/Filter/*.pm - filters that print each data type; Data/Printer/Theme.pm - handles color themes; Data/Printer/Theme/*.pm - each contain a theme's color settings; #### Submitting your patch / pull request Getting your hands dirty is even better than opening an issue 🥰 Before you send your Pull Request, please make sure you create a test case for the new behaviour. We expect all patches to have been properly tested before they can be accepted and merged. Oh! And make sure you add your name to the "CONTRIBUTORS" list as part of your patch. Bug fixes are usually accepted quickly, but if you're adding a new feature or changing Data::Printer's behaviour, please note your changes may take some time to be merged or *may even not be merged at all* - not because there's anything wrong with it, but simply because it may not be aligned with the project's long-term vision. If you are unsure as to whether the feature you're trying to implement adheres to that vision, talk to us by opening an issue on Github. That's it! Thank you for your work, and have fun! Data-Printer-1.002001/MANIFEST0000644000000000000000000000367014552072607014074 0ustar rootrootChanges CONTRIBUTING.md examples/try_me.pl lib/Data/Printer.pm lib/Data/Printer/Common.pm lib/Data/Printer/Config.pm lib/Data/Printer/Filter.pm lib/Data/Printer/Filter/ARRAY.pm lib/Data/Printer/Filter/CODE.pm lib/Data/Printer/Filter/ContentType.pm lib/Data/Printer/Filter/DateTime.pm lib/Data/Printer/Filter/DB.pm lib/Data/Printer/Filter/Digest.pm lib/Data/Printer/Filter/FORMAT.pm lib/Data/Printer/Filter/GenericClass.pm lib/Data/Printer/Filter/GLOB.pm lib/Data/Printer/Filter/HASH.pm lib/Data/Printer/Filter/OBJECT.pm lib/Data/Printer/Filter/REF.pm lib/Data/Printer/Filter/Regexp.pm lib/Data/Printer/Filter/SCALAR.pm lib/Data/Printer/Filter/VSTRING.pm lib/Data/Printer/Filter/Web.pm lib/Data/Printer/Object.pm lib/Data/Printer/Profile.pm lib/Data/Printer/Profile/Dumper.pm lib/Data/Printer/Profile/JSON.pm lib/Data/Printer/Theme.pm lib/Data/Printer/Theme/Classic.pm lib/Data/Printer/Theme/Material.pm lib/Data/Printer/Theme/Monokai.pm lib/Data/Printer/Theme/Solarized.pm lib/DDP.pm Makefile.PL MANIFEST This list of files MANIFEST.SKIP README.md t/000-load.t t/000.0-nsort.t t/000.1-home.t t/000.2-warn.t t/001-object.t t/002-scalar.t t/003-ref.t t/004-vstring.t t/005-lvalue.t t/006-glob.t t/007.format.t t/008-regex.t t/009-array.t t/010-hashes.t t/011-class.t t/011.1-attributes.t t/011.2-roles.t t/011.3-object_pad.t t/012-code.t t/013-refcount.t t/014-memsize.t t/015-multiline.t t/016-merge_options.t t/017-rc_file.t t/018-alias.t t/019-output.t t/020-return_value.t t/021-p_vs_object.t t/022-no_prototypes.t t/023-filters.t t/024-tied.t t/025-profiles.t t/026-caller_message.t t/027-nativeperlclass.t t/100-filter_datetime.t t/101-filter_db.t t/102-filter_digest.t t/103-filter_contenttype.t t/104-filter_web.t t/998-color.t t/999-themes.t xt/changes.t xt/pod-coverage.t xt/pod.t xt/whitespaces.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Data-Printer-1.002001/MANIFEST.SKIP0000644000000000000000000000035014552015171014622 0ustar rootroot^\.git ^[^/]+\.p[lm]$ ^ignore.txt ^_build ^Build$ ^blib ^Data-Printer ~$ \.bak$ cover_db ^nytprof \..*\.sw.?$ ^Makefile$ ^pm_to_blib$ ^blibdirs$ \.old \.png \.gif ^#.*#$ ^\.# ^TODO$ ^\._.*$ ^\.travis\.yml ^MYMETA\.yml ^MYMETA\.json Data-Printer-1.002001/Changes0000644000000000000000000011364414552072424014236 0ustar rootrootRevision history for Data-Printer 1.2.1 2024-01-21 BUG FIXES: - Ensure that core boolean support doesn't fail on perls older than 5.36 (Paul Evans) 1.2.0 2024-01-21 NEW FEATURES: - support the core boolean type (true/false) in perl >= 5.36.0 OTHER: - doc fixes and improvements (Florian Schlichting, Andre Klärner) 1.1.1 2023-07-30 BUG FIXES: - explicitly mentions that native perl classes (perl 5.38) do not have internals. - 'quiet' now returns the data properly when return_value is 'pass'. - cope with import and unimport in perl 5.39 UNIVERSAL (Graham Knop) - fix tie issue (thank you Curtis 'Ovid' Poe for reporting and Leon Timmermans for providing a patch) - doc fixes and improvements (Matthias Muth, Elvin Aslanov) 1.1.0 2022-12-22 NEW FEATURES: - new option 'coderef_stub' letting you customize what to show on non-deparsed coderefs (default: 'sub { ... }') - new option 'coderef_undefined' that checks if a given coderef points to an existing reference at the time of inspection. Defaults to ''. Set to 0 to disable this check. - basic Object::Pad support. - new option class.show_wrapped to expose methods modified with before, after, around (Moose only for now) - new option 'quiet' to avoid traversal and silence all output from p() and np(). - new option 'live_update' to reload .dataprinter whenever you make changes to it, applying them without needing to restart your code. BUG FIXES: - properly shows inherited Moo(se) attributes. - fix $@ clobbering when checking available modules. - class.sort_methods also sorts attributes and roles. - improved color reset. - $DDP::VERSION is now hardcoded to avoid issues with PAUSE. 1.0.4 2021-03-03 BUG FIXES: - fix DBIx::Class print when literal SQL is present (Veesh Goldman) 1.0.3 2021-03-02 OTHER: - fixup documentation on how to convert from the old .dataprinter format to the new one (GH#157) - test fixes 1.0.2 2021-02-28 OTHER: - Material's color for caller_info and code is now a bit brighter to improve readability on terminals with dark background. - improve MS Windows support - increase test coverage 1.0.1 2021-02-25 BUG FIXES: - properly parse the "n" option in regexes - fix unwrap of __PACKAGE__, __FILENAME__ and __LINE__ on caller_message (GH#156) - add a single space between caller message and data when caller_message_newline is false - proper colorization on caller message. OTHER: - improve documentation on caller message behavior - document caveat of printing array/hash slices (GH#152) - fix broken link in documentation (GH#155) - improve tip on how to make a drop-in replacement to Data::Dumper (GH#154) 1.0.0 2021-02-24 We are really excited to finally bring to you Data::Printer 1.0.0 \o/ This release includes all modifications from the 0.99_* series as described below. 0.99_026 2021-02-19 BUG FIXES: - test fixes/updates - improved support for Cpanel::JSON::XS::Boolean 0.99_025 2021-02-18 BUG FIXES: - improved support for perl 5.8.9 (thank you cpantesters!) 0.99_024 2021-02-17 NEW FEATURES: - fix rc file conversor to change 'color' to 'colors' (thanks Buddy Burden for reporting the issue!) OTHER: - massive documentation rewrite. - drop support for "ignore_keys" for now. 0.99_023 2021-02-01 NEW FEATURES: - profiles! Now you make complex settings using Perl code. - allow .dataprinter files on the project home and subdirs. - new option 'warnings', when set to 0 will make DDP silence (almost) all warnings such as theme/profile not found. Default is 1. - filter for the 'Date' module (the evolution of Panda::Date) BUG FIXES: - properly show roles' attributes from Role::Tiny, Moo and Moose; - 'quote_keys' also quotes the path of circular references and found elements. - when 'quote_keys' is set, hash keys are quoted with whatever 'scalar_quotes' is set to. - escape quote characters in quoted strings and hash keys - blessed regexps (in objects different than the native 'Regexp') are now properly displayed as objects of their class. OTHER: - new string_max default: 4096 - new array_max default: 100 - new hash_max default: 100 - dropped filter support for the deprecated Panda::Date dist - dropped filter support for the Date::Pcalc dist (buggy in recent perls) - lowercased all words in class dump for output consistency 0.99_022 2020-09-26 BUG FIXES: - fix test case of rc option containing spaces 0.99_021 2020-09-26 NEW FEATURES: - 'caller_message_position' option to control whether to show labels 'before' or 'after' the dump (defaults to 'before'); - 'caller_message_newline' puts an automatic "\n" after the message; - 'resolve_scalar_refs' option to show values instead of just the reference indicator; - when multiline is false, string/hash/array overflow become "(...)"; - filter loading errors are not fatal anymore, unless you set the 'die_on_filter_error' option; BUG FIXES: - allow quoted values when parsing .dataprinter; - np() is never colored on 'auto' colors; - printing to a file or to a variable is never colored on 'auto' colors; - fulldump typo fix; - fix filter test failure when Mojo::JSON loads ::XS backends (GH#136); - do not call 'stringify' on PDF::API2 objects as it's a destructive op; - allow code filters in the new .dataprinter format, but only if the file meets certain permissions criteria; - 'dump' mode working as expected again; OTHER: - simplified homedir logic for MSWin32, Linux and MacOS (Karen Etheridge); - new 'contributing to' data; - minor color adjustments on Material theme to improve legibility on lighter terminals; 0.99_020 2018-06-30 NEW FEATURES: - new 'fulldump' option to ignore max string/array/hash. - also stringify on to_string() - ContentType filter shows utf8 symbol for image/audio/video/etc - ContentType filter now has its own color - ContentType filter understands Sereal binaries BUG FIXES: - prevent 'undefined' warning in ContentType filter - fix test on old HTTP::Headers OTHER: - improved documentation 0.99_019 2018-06-27 BUG FIXES: - more filter fixes on different module versions (many thanks to Slaven Rezić and all other CPAN testers). 0.99_018 2018-06-25 BUG FIXES: - fix filter test on older HTTP::Message 0.99_017 2018-06-25 BUG FIXES: - fix filter test failure on older Mojolicious - fix filter test failure on older Digest::MD5 0.99_016 2018-06-25 NEW FEATURES: - unsee() method in DDP objects to ignore visits - new Web filter bundle parsing JSON, Cookies and HTTP Request/Response. - DateTime filter now understands Time::Seconds and Time::Moment. BUG FIXES: - fixed show_tied, which was not working properly since the refactor. - prevent non-ref counters from being refcounted - fix floating point test error in unusual hardware/OS combinations. OTHER: - improved implementation of "seen" counter - improved documentation - removed unused code 0.99_015 2018-06-14 NEW FEATURES: - new ContentType filter to detect popular binaries in strings, like images, videos and documents. OTHER: - code tidying - greatly improved documentation - test coverage increased BUG FIXES: - DateTime/Digest/DB filters now honor colorization from themes - test fixes 0.99_014 2018-06-08 BUG FIXES: - DateTime filter: fix Class::Date test on systems that treat GMT as UTC. 0.99_013 2018-06-08 NEW FEATURES: - dualvar lax mode accepts leading/trailing whitespace in numbers - DB filter: improve display of replication lag - DB filter: list unique constraints on DBIC - DB filter: improved parsing of DBIC sources/resultsets/rows BUG FIXES: - filter listings in RC file now always an array ref - DateTime filter: fix parsing of old Mojo::Date objects - DB filter: test fixes - Digest filter updated and re-added OTHER: - DB filter: improve documentation - DB filter: increase test coverage - Digest filter: show class name by default on parsing digests 0.99_012 2018-05-25 NEW FEATURES: - show_dualvar now accepts 'strict', 'lax' and 'off'. Default is 'lax', ignoring decimal zeroes to the right (e.g. 1.00 and '1', '1.10' and 1.1) - multiline => 0 now also shortens the hash separator OTHER: - test improvements - improved documentation 0.99_011 2018-05-24 BUG FIXES: - proper color downgrade on terminals who only support 256 colors. - fixed colorization tests - fixed DB external filters 0.99_010 2018-05-21 BUG FIXES: - extra debug info for failed colorization tests - another fix for Panda::Date (Slaven Rezić) 0.99_009 2018-05-20 BUG FIXES: - fix dualvar test on different locales (Slaven Rezić) - fix Panda::Date test when en_US locale not present (Slaven Rezić) 0.99_008 2018-05-20 NEW FEATURES: - show_dualvar (defaults to true) lets you know whenever both numeric and string values of a variable are set to a different thing (Philippe "BooK" Bruhat) - maybe_colorize() accepts a 'default color' so filters can use it. - extra_config() provies all non-core settings passed to Data::Printer, so filters can use them. - DateTime filter for Panda::Date (Sergey Aleynikov) BUG FIXES: - fixed DateTime external filters - fix issue with dereferencing code refs (Håkon Hægland) - fix 'pass' on globs, regexes and code references (Håkon Hægland, Sergey Aleynikov) OTHER: - documentation improvements 0.99_007 2018-05-17 BUG FIXES: - fix regex parsing in 5.10.1 - test fixes for 5.11 0.99_006 2018-05-17 BUG FIXES: - fix longstanding issue of displaying weirdly-named objects like 'HASH' or "0" (github issue #105) (bessarabov + dur-randir) - fix test for UNIVERSAL::DOES OTHER: - documentation improvements - remove undocumented and unsupported extra option in external filters. 0.99_005 2018-05-13 BUG FIXES: - fix regex filter on perl 5.8 - improve ISA detection in perl 5.8 without MRO::Compat 0.99_004 2018-05-12 BUG FIXES: - fix tests on win32 0.99_003 2018-05-11 BUG FIXES: - fix test plan issue on some versions of Test::More - die from caller perspective on filter error - drop support for Sort::Naturally::XS 0.99_002 2018-05-10 BUG FIXES: - fix tests when bogus RC file is present - fix colored tests on travis - fix refcount test on perls <= 5.12 - reset internal state after parsing - when scouting for methods, ensure GVs are named - synced p() and np() code so they behave exactly the same - fix use_prototypes => 0 - prevent "double plan" warninga on tests OTHER: - extra tests to increase code coverage - improved error handling in themes - function to convert old RC format to the new one - improved README - extra debug info on test failures - cleanup on unreachable code 0.99_001 2018-04-21 BACKWARDS-INCOMPATIBLE CHANGE - new format for the .dataprinterrc file NEW FEATURES: - Data::Printer::Object available for public usage! (big thanks to frew && rjbs) - use DDP; p $foo, as => 'this is a label'; Hopefully this helps people tag their debug code without having to write caller_info => 1, caller_message => '...' - theme => 'XXX' will try and load Data::Printer::Theme::XXX, which you can create to share your colour scheme with the world! - speaking of colours, you can now use up to 256 of them (if your terminal supports them, of course) - print only a slice of arrays and hashes with: - array_max => 10 (default is 50, set it to 0 for unlimited) - array_overflow => '(...skipping __SKIPPED__ items...)' - array_preserve => 'begin' if the array has more than array_max elements, preserve the first array_max elements and replace the rest with '(...skipping XX items...)'. Other available options are 'end', 'middle', 'extremes', and 'none'. - hash_max / hash_overflow / hash_preserve (same! note however that preserved keys will only be the same if hash keys are sorted) Defaults to 50. - ignore_keys to skip their dump (feature by Eugen Konkov) - string_max/string_overflow/string_preserve to limit string entries (scalars), just like arrays and hashes. Defaults to 1024 and 'begin'. Set it to 0 for unlimited size. - new 'separator', 'brackets' and 'overflow' colors to control - unicode_charnames, when set to 1 (together with escape_chars) will try and use the Unicode name when escaping strings. So `$s = "\x{2603}"; p $s` will output "\N{SNOWMAN}" - show_refcount => 1 exposes the reference count for the data structure (and inner data) if the count is greater than 1. (default 0, showing no refcounts). - show_memsize => 1 shows the (approximated) amount of memory the variable occupies for all variables on that level. This means that '1' will show the size of the entire data structure, while 2 will also show sizes of inner data, 3 will go even deeper and so on. To get the size of everything, use 'all' - though usually you'll probably want to just use '1'. This requires Devel::Size, so the default is 0 for none. - memsize_unit defined in which unit to show the memory usage. Can be set to 'b'(ytes), 'k'(ilobytes), 'm'(egabytes) or 'auto' (the default). - new property 'format_inheritance', defaults to "lines", a shiny and much clearer new way to displays methods per inherited package. You may also set it to 'string' to preserve the old behaviour. - inheritance tree is considered when filtering objects unless you disable it with 'parent_filters => 0' (Ovid) - new option 'stringify' (default: 1) will return the stringified version of the object, if one is available. It will try overloaded strings/numbers, as_string() and stringify() calls, respectively. Note that this will efectivelly ignore all other class details you may have chosen. (Sergey Aleynikov, Benct Philip Jonsson) - new option show_overloads (default: 1) will list all overloads from the object's class. - the standard class filter is now able to show internals in blessed subs - support for faster natural sorting via Sort::Key::Natural if the user has it installed (feature request by @grr on github) BUG FIXES: - fix array subelement alignment when index is shown (GARU) - show UNIVERSAL in linear ISA if it's on (GARU) - use "\n" instead of $/ as default line separator (Håkon Hægland && Chung-Kuan Tsai) - less magic added to internal Perl representation of variables (Jarrod Funnell, Sergey Aleynikov, Michael Conrad, Nicolas R.) - show_methods is now independent from show_inherited, meaning you can check all inherited methods and no local ones, or any combination thereof. This is the expected behaviour from the documentation, but was not happening. 0.40 2017-08-01 BUG FIXES: - fix tied hash test on blead perl (5.27.3) https://rt.perl.org/Ticket/Display.html?id=131824 Thanks Jim Keenan, Dave Mitchell and Zefram for reporting and debugging! 0.39 2016-04-15 BUG FIXES: - display '-' as a string, not a number (Ivan Bessarabov) - display "123\n" as a string, not a number (Ivan Bessarabov) - fix test failures on newer perls (Sergey Aleynikov) OTHER: - document availability of np() on Data::Printer::Filter (Olaf Alders) 0.38 2016-01-28 BUG FIXES: - removed Test::Most unlisted dependency (thanks Marco Masetti for reporting) 0.37 2016-01-28 NEW FEATURES: - Support for displaying scalar's unicode flag (Michael Conrad) BUG FIXES: - Fixed test failure due to leaking environment variables (Thomas Sibley) - class_method only works if it's actually something we can call (RenatoCRON) - Attempt to fix a taint error on old Win32 systems (Baldur Kristinsson) - Prevent some 5.8 errors caused by the version module (Baldur Kristinsson) - Data::Printer::Filter should imports np() as well (Olaf Alders) - Multiline property is now properly propagated (Adam Rosenstein) OTHER: - Removed some trailing whitespaces (Ivan Bessarabov) - Extended tests for finding trailing whitespaces (Ivan Bessarabov) - Documented caveat of using p() in variable declarations (vividsnow) - Documented that the 'DB' filter supports DBIx::Class (Olaf Alders) - New .gitignore file (David Lowe) - Updated .travis.yml (Ivan Bessarabov) 0.36 2015-05-29 Bumping 0.35_01 to stable. Below is the (repeated) changelog, with the single addition of the 'scalar_quotes' patch. BACKWARDS-INCOMPATIBLE CHANGE - p()'s return value now defaults to 'pass'. Please see https://github.com/garu/Data-Printer/issues/16 for the full discussion. THIS WILL BREAK CODE RELYING ON p() TO RETURN A STRING. To fix your code, please set 'return_value' to 'dump' explicitly, or use the experimental np() function. NEW HIGHLY EXPERIMENTAL FEATURE: - np(), a version of p() that always returns the string instead of printing it. NEW FEATURES: - Add 'escape_chars' to allow \x{...} printing for chars (patch by Mark Fowler) - 'scalar_quotes' let you specify the quote to use when, well, quoting (Ivan Bessarabov) - Class::Date support in the DateTime filter (Ivan Bessarabov) BUG FIXES: - fixed crash in esoteric classes (github issue #41, thanks Ivan Bessarabov for reporting) - removed support for Digest::Haval256, as it can't really be observed without damaging the original data. If future versions provide a clone() function, it can be added again. - Being extra loud when rc files fail to load (RT#89203, thanks Caleb Cushing for reporting). - Prevents PERL5OPT from interfering with deparse tests (github issue #55, thanks David Precious for reporting) OTHER: - more tests - new external filter indexed: PDL 0.35_01 2014-12-22 BACKWARDS-INCOMPATIBLE CHANGE - p()'s return value now defaults to 'pass'. Please see https://github.com/garu/Data-Printer/issues/16 for the full discussion. THIS WILL BREAK CODE RELYING ON p() TO RETURN A STRING. To fix your code, please set 'return_value' to 'dump' explicitly, or use the experimental np() function. NEW HIGHLY EXPERIMENTAL FEATURE: - np(), a version of p() that always returns the string instead of printing it. NEW FEATURES: - Add 'escape_chars' to allow \x{...} printing for chars (patch by Mark Fowler) - Class::Date support in the DateTime filter (Ivan Bessarabov) BUG FIXES: - fixed crash in esoteric classes (github issue #41, thanks Ivan Bessarabov for reporting) - removed support for Digest::Haval256, as it can't really be observed without damaging the original data. If future versions provide a clone() function, it can be added again. - Being extra loud when rc files fail to load (RT#89203, thanks Caleb Cushing for reporting). - Prevents PERL5OPT from interfering with deparse tests (github issue #55, thanks David Precious for reporting) OTHER: - more tests - new external filter indexed: PDL 0.35 2012-11-25 BUG FIXES: - fixed escaped chars colorization issue in bleadperl (thanks Andreas Koenig for reporting!) OTHER: - more tests added 0.34 2012-11-11 NEW FEATURES: - improved display of DBIC ResultSets - 'Digest' filter now works on any Digest::base modules [RT#80039] - enclosing quotes on strings are displayed using a different colour (patch by Ivan Bessarabov) OTHER: - new tip by dirk: creating fiddling filters - updated documentation including external filters (JSON, ClassicRegex, URI) 0.33 2012-08-20 BUG FIXES: - fixed warning in external filters for some perl versions (thanks Stanislaw Pusep for reporting). - prevented repeated tie display OTHER: - removed deprecated escape_chars, as promised in version 0.30. 0.32 2012-08-11 BUG FIXES: - fixed (other) test failures in 5.8 - pod fix in DDP.pm (nuno carvalho) NEW HIGHLY EXPERIMENTAL FEATURE: - extra options for external filters. Right now the only available one is 'show_repeated', to let filters override Data::Printer's behaviour of not showing duplicate variables. 0.31 2012-08-09 BUG FIXES: - fixed test failures in 5.8 OTHER: - releasing as stable version 0.30_06 2012-07-22 NEW FEATURES: - new filter for DateTime::Tiny OTHER: - new tip: using DDP with Template Toolkit 0.30_05 2012-07-21 NEW FEATURES: - Add support for FORMAT and LVALUE refs (Rebecca Turner) BUG FIXES: - prevent warning when dumping refs to unopened or closed file handles (Rebecca Turner) - on Win32, it is allowed to use an RC file without read-only permissions 0.30_04 2012-07-08 NEW FEATURES: - Improved support for unknown core datatypes (Rebecca Turner) BUG FIXES: - fixed indentation when using colored output (Stanislaw Pusep) - fixed t/05-obj.t on older perls (Mike Doherty) - fixed dev-only pod tests - Issue warning (carp) when color/colour is not a hashref 0.30_03 2012-07-05 NEW FEATURES: - new class property 'universal', letting you choose whether to include UNIVERSAL methods during inheritance display or not (default is 1, meaning to show). - support for VSTRINGs (Rebecca Turner) NEW ***EXPERIMENTAL*** FEATURES: - new 'show_readonly' property, off by default, to show variables marked as read-only (scalars only for now, patches welcome!) BUG FIXES: - fixed issue with t/05-obj.t - minor pod fixes (Rebecca Turner, myself) - Protect against unknown core data types that don't implement "can" (Rebecca Turner) 0.30_02 2012-07-02 BUG FIXES: - RC file under taint mode should be properly parsed now. OTHER: - Rob Hoeltz and Stephen Thirlwall added to the contributors list. Thanks guys! 0.30_01 2012-07-02 CHANGES THAT BREAK BACKWARDS COMPATIBILITY: - linear_isa option is now set to 'auto' by default (see below) NEW FEATURES: - linear_isa can now be set to 'auto', in which case it will show the @ISA only if the object has more than one parent. Other values are 0 (never show) and 1 (always show) - new "Digest" filter bundle, for MD5, SHA and other Digest objects! - separate colours for classes and methods (feature request by Ivan Bessarabov) - environment variable DATAPRINTERRC overrides .dataprinter and lets you pick different RCs at will (Stephen Thirlwall) - new option 'separator' lets you pick a custom separator for array/hash elements, including none (''). Default is ','. - new option 'end_separator' can be set to 1 to show the last item of an array or hash with a separator (Ivan Bessarabov) - DateTime filter bundle now also handles DateTime::TimeZone objects (RT#77755) BUG FIXES: - RC file now works under taint mode, with restrictions (feature request by Rob Hoelz) - class_method call now includes properties hashref (Joel Berger) OTHER: - Replacement of dependencies to permit pure perl operation: Class::MOP is replaced with mro and Package::Stash Clone is replaced with Clone::PP Hash::FieldHash is replaced with Hash::Util::FieldHash Note that if <5.10 is detected, Data::Printer also requires: MRO::Compat to provide mro Hash::Util::FieldHash::Compat to provide Hash::Util::FieldHash As a result, Data::Printer should now be fatpackable (cpan:MSTROUT) - new /examples dir, with a sample file to let you easily try different color schemes (Yanick Champoux) - pod coverage tests (developer only) 0.30 2012-02-13 CHANGES THAT BREAK BACKWARDS COMPATIBILITY: - 'escape_chars' was renamed 'print_escapes' to avoid ambiguity. The old name will work until v0.32, but will trigger a warning so you can update your code. Sorry for the inconvenience, the previous name was hard to figure out because 'escape' could be interpreted as a noun or as an adjective (perigrin++ for suggesting the new name). NEW FEATURES: - in hashes, surround key names with quotes if they contain spaces (feature request by Maxim Vuets) - escape_chars also works for hash keys now. - new 'quote_keys' property to add quotes in hash keys. Defaults to 'auto' which means it will quote keys containing spaces (and empty keys) BUG FIXES: - fixed temporary file handling during tests. Thanks Andy Bach for reporting and providing a patch. OTHER: - added documentation for the new 'rc_file' feature introduced in the previous version. 0.29 2012-01-25 NEW FEATURES: - custom rc file names via the new 'rc_file' property (many thanks to Maxim Vuets for the idea and the original implementation) BUG FIXES: - fixed unescaped null character during colored output (reported by bowtie++) 0.28 2012-01-23 NEW FEATURES: - new 'escape_chars' property to show '\t', '\n' escaped (default is 1, meaning escape, which will render the actual character instead). Note that the '\0' special character is never escaped. - new 'escaped' colour, defaults to bright red. OTHER: - fixed Changes file for compliance against latest CPAN::Changes specification 0.27 2012-01-22 BUG FIXES: - properly escape nulls in strings (oylenshpeegul) NEW FEATURES: - control the output target with the 'output' property. It can be set to 'stdout', 'stderr', a file name, a file handle or even a scalar reference! Default, as usual, is 'stderr' OTHER: - added tests for auto-coloring (DOY) - updated link to Any::Renderer::Data::Printer (Allan Whiteford) 0.26 2011-11-23 BUG FIXES: - colored => 'auto' properly detects terminals again 0.25 2011-11-20 BUG FIXES: - Increased version requirement for Test::Pod to 1.41 (Fitz Elliott) - Updated tests to handle newer Class::MOP installations (J Mash) OTHER: - POD tests enabled only for developers - Updated Class::MOP version requirement to 0.81 since ActiveState was complaining about ancient versions. 0.24 2011-10-23 NEW FEATURES: - link to the external URI filter (by SYP) - display object's reference type (Denis Howe) OTHER: - only load Class::MOP when inspecting objects. 0.23 2011-08-30 NEW FEATURES: - control the return value with the 'return_value' property. This can be set to 'void', 'dump', and 'pass' (for pass-through). Default is 'dump', which behaves exactly like previous versions. Note that, as usual, the 'dump' mode will only print the dump if called in void context. Otherwise, it will only return it. (MST, GARU) OTHER: - more extra tips (HANEKOMU, RANDIR, MST) - updated documentation 0.22 2011-07-19 NEW FEATURES: - display taint information via the 'show_tainted' display customization (default true) - control weak information display via 'show_weak' customization (default true) OTHER: - major documentation overhaul and update - more extra tips (MST, HANEKOMU) 0.21 2011-07-01 BUG FIXES: - removed legacy dependency on Object::ID - increased Term::ANSIColor version (David Raab) - switched to EU:MM to make people happy :) (seriously though, M:I was being too clever while resolving dependencies) OTHER: - adding bugtracker meta information 0.20 2011-06-23 CHANGES THAT BREAK BACKWARDS COMPATIBILITY: - respect ANSI_COLORS_DISABLED if colored => 'auto', but force color codes if colored => 1. - colored => 'auto' prints colored output only in void mode, not when returning a string. In other words, doing p($var) will show colors, but my $out = p($var) will not (unless you force it via colored => 1). This behavior differs from previous versions, but is more consistent and we consider the previous way to have been a bug. Many thanks to SZABGAB, CSJEWELL and specially RANDIR for detecting, analyzing and helping to come up with a solution, initially addressed as a Microsoft Windows issue (RT#68630). OTHER: - reduced some dependencies to make installation even easier. 0.19 2011-06-08 NEW FEATURES: - toggle 'parents' class display, activated by default (RANDIR) - toggle 'show_methods' class display, activated by default (RANDIR, GARU) - toggle 'linear_isa' class display, activated by default BUG FIXES: - specific class filters now fallback to generic -class filters when used (RANDIR) - show flags from handles even when not all flags are implemented on the target system (DOHERTY, GARU) 0.18 2011-06-07 NEW FEATURES: - toggle timezone display on DateTime filters (Elliot Shank) - showing weak references (RANDIR) - more concise output for empty structures (RANDIR) OTHER: - extra tip on unified dumping interfaces (cat|grep) - extra tip on using Data::Printer with Devel::REPL 0.17 2011-06-06 NEW FEATURES: - filter fallback also for Perl types (RANDIR, GARU) - no need to pass arrayref in -external filters if you only have one. - new "use_prototypes" option, defaults to 1. Set to 0 to stop using prototypes in p(), which will let you do p( { foo => "bar" } ); but you'll have to pass the data to be printed as a reference. BUG FIXES: - corrected filter order (should be LIFO, not FIFO) - fixed edge-case behavior of p() within standalone filters - make sure filter output is defined, not just true (RANDIR) - fixed filter tests for Date::Calc & Date::Pcalc (SUGYAN, GARU) OTHER: - more tests - big internal refactoring - extra tips on circumveinting prototypes (DAMS, GARU) - extra tips on loading p() across all loaded modules (Árpád Szász) 0.16 2011-05-31 BUG FIXES: - patch to make it work on 5.8.8 again (RANDIR) 0.15 2011-05-30 OTHERS: - updating filters docs - adding default color for DateTime filter 0.14 2011-05-30 NEW FEATURES: - allowing 'colored' display customization to control colored output. Default is 'auto', showing colors only when output is not being piped. You may also set this to 0 to disable colors completely, or 1 to enable output coloring all the time (even when piped). - new 'caller_info' display customization. - default 'class_method' is now set to '_data_printer', so your modules and apps can be aware of Data::Printer automatically. BUG FIXES: - Skipping calls to fcntl() in systems that don't support it. 0.13 2011-05-24 CHANGES THAT ***BREAK*** BACKWARDS COMPATIBILITY: - 'external' is now called '-external' to avoid name clash with a potential "external.pm" class; - filters for the same type/class are now stacked and called in order. The first one that returns a defined value (string) is used, otherwise it will forward the call to the next filter. In earlier versions, the last declared filter would be the one used. Note that this feature is only available for stand-alone filters, since inline filters are actually a hash. NEW FEATURES: - use a specific dump method via the 'class_method' display customization (default undef) - display tie information via the 'show_tied' display customization (default true) - display extra information (mode, flags, layers) on I/O handles - new '-class' type (note the dash) called when we find a non-native type (i.e. an object). If you return anything at all - even an empty string - the filter will succeed. Otherwise it will forward the call to the next '-class' filter, in order. - new DDP package alias OTHERS: - improved test suite - improved documentation 0.12 2011-05-03 BUG FIXES: - fixed failing filter test due to timezone/epoch issues 0.11 2011-05-03 NEW FEATURES: - allowing 'sort_keys' display customization (default true) - allowing 'sort_methods' class display customization (default true) - now you can add options to Data::Printer as a plain hash, not just as a hash ref (feature request by edenc) NEW ***EXPERIMENTAL*** FEATURES: - Data::Printer::Filter, enabling separate filter classes - filter for modules handling date and time (DateTime & friends) - filter for database modules (DBI only for now) OTHERS: - more tests - improved documentation, including how to turn output to HTML - some internal refactorings 0.10 2011-04-18 NEW FEATURES: - allowing toggle for array indices - allowing 'multiline' display customization - allowing 'deparse' display customization - allowing 'max_depth' display customization - allowing 'inherited' class display customization - allowing 'expand' class display customization, defaults to 1 (expand only the object itself) OTHERS: - removed ending comma from arrays and hashes - showing parents/ISA information only when it's there - default separator for key/values reduced to 3 spaces for improved readability. - improved test suite 0.09 2011-04-13 NEW FEATURES: - allowing for 'internals' display customization BUG FIXES: - improving test suite - improving documentation 0.08 2011-04-11 BUG FIXES: - improving test suite (was still failing on NetBSD) - Improved handling of extended regexps (thanks Getty for reporting) 0.07 2011-04-02 BUG FIXES: - Making sure File::HomeDir is 0.91 or higher - Making tests stricter, since they were failing on Win32 0.06 2011-03-31 BUG FIXES: - if you want to call p() from within a filter, the argument to p() must be passed as a *reference*. This is now enforced to avoid users shooting themselves in the foot. - more tests added 0.05 2011-03-23 NEW FEATURES: - local configuration file support ($HOME/.dataprinter) - you can now alias p() to whatever name you like 0.04 2011-02-21 NEW FEATURE (or BUGFIX depending on how you look at it): - supporting the new (5.13.6) perl regex modifiers syntax 0.03 2011-02-14 BUG FIXES: - reseting colors before starting 0.02 2011-02-13 CHANGES THAT BREAK BACKWARDS COMPATIBILITY: - d() function removed. You can now call p($var) in void context to print, or as "my $output = p($var)" to retrieve results without printing. NEW FEATURES: - new import syntax, use Data::Printer { option => value } - new "filters" property available to filter certain types. - updated documentation. NEW ***EXPERIMENTAL*** FEATURES - local properties setting, p($var, key => value). BUG FIXES: - properly handles GLOB references - colors now work on Win32 as well. - uncolors piped output, for "less" & friends (thanks Getty for reporting). - added all possible regex modifiers to the regex output. - more tests added. 0.01 2011-01-20 - First version, released on an unsuspecting world. Data-Printer-1.002001/Makefile.PL0000644000000000000000000000325514552015171014705 0ustar rootrootuse strict; use warnings; use ExtUtils::MakeMaker; my %options = ( NAME => 'Data::Printer', AUTHOR => 'Breno G. de Oliveira ', VERSION_FROM => 'lib/Data/Printer.pm', ABSTRACT_FROM => 'lib/Data/Printer.pm', LICENSE => 'perl', PL_FILES => {}, PREREQ_PM => { 'Test::More' => 0, 'Scalar::Util' => 0, 'version' => 0.77, # handling VSTRINGS 'File::Spec' => 0, 'File::Temp' => 0, 'Fcntl' => 0, }, META_MERGE => { resources => { license => 'http://dev.perl.org/licenses/', bugtracker => 'https://github.com/garu/Data-Printer/issues/', repository => 'https://github.com/garu/Data-Printer', }, }, dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, clean => { FILES => 'Data-Printer-*' }, ); if ($^O =~ /Win32/i) { $options{PREREQ_PM}{'Win32::Console::ANSI'} = 1.0; } if ($ENV{DDPTESTCOVERAGE}) { foreach my $p (qw( DBI DBD::SQLite DBIx::Class Time::Piece DateTime::TimeZone DateTime::Incomplete DateTime::Tiny Date::Tiny Date::Calc Date::Pcalc Date::Handler Date::Handler::Delta Date::Simple Date::Manip Panda::Date DateTime DateTime::Duration Mojolicious Class::Date Class::Date::Rel Digest::MD5 Digest::SHA Digest::MD2 Digest::MD4 JSON::PP JSON::XS JSON JSON::Any JSON::MaybeXS JSON::DWIW JSON::SL Pegex::JSON Cpanel::JSON::XS JSON::Tiny JSON::Typist Dancer Dancer2 HTTP::Message )) { $options{PREREQ_PM}{$p} = 0; } } WriteMakefile( %options ); Data-Printer-1.002001/META.yml0000644000000000000000000000153114552072607014206 0ustar rootroot--- abstract: 'colored & full-featured pretty print of Perl data structures and objects' author: - 'Breno G. de Oliveira ' build_requires: ExtUtils::MakeMaker: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.70, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Data-Printer no_index: directory: - t - inc requires: Fcntl: '0' File::Spec: '0' File::Temp: '0' Scalar::Util: '0' Test::More: '0' version: '0.77' resources: bugtracker: https://github.com/garu/Data-Printer/issues/ license: http://dev.perl.org/licenses/ repository: https://github.com/garu/Data-Printer version: '1.002001' x_serialization_backend: 'CPAN::Meta::YAML version 0.018'