Data-Printer-0.38/000755 000765 000024 00000000000 12652453306 014045 5ustar00garustaff000000 000000 Data-Printer-0.38/.travis.yml000644 000765 000024 00000000127 12652255310 016151 0ustar00garustaff000000 000000 language: perl perl: - "5.10" - "5.12" - "5.14" - "5.16" - "5.18" - "5.20" Data-Printer-0.38/Changes000644 000765 000024 00000052225 12652453133 015344 0ustar00garustaff000000 000000 Revision history for Data-Printer 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-0.38/examples/000755 000765 000024 00000000000 12652453305 015662 5ustar00garustaff000000 000000 Data-Printer-0.38/lib/000755 000765 000024 00000000000 12652453305 014612 5ustar00garustaff000000 000000 Data-Printer-0.38/Makefile.PL000644 000765 000024 00000002747 12532157340 016025 0ustar00garustaff000000 000000 use 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.88, 'Term::ANSIColor' => 3.0, # introduces 'bright_*' colors 'Scalar::Util' => 0, 'version' => 0.77, # handling VSTRINGS 'Sort::Naturally' => 0, 'Package::Stash' => 0.30, 'Carp' => 0, 'Clone::PP' => 0, 'File::HomeDir' => 0.91, # introduces File::HomeDir::Test 'File::Spec' => 0, 'File::Temp' => 0, 'Fcntl' => 0, ($] >= 5.010 ? () : ( 'MRO::Compat' => 0.09, 'Hash::Util::FieldHash::Compat' => 0.03, ) ), }, 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; } WriteMakefile( %options ); Data-Printer-0.38/MANIFEST000644 000765 000024 00000003014 12652453306 015174 0ustar00garustaff000000 000000 .travis.yml Changes examples/try_me.pl lib/Data/Printer.pm lib/Data/Printer/Filter.pm lib/Data/Printer/Filter/DateTime.pm lib/Data/Printer/Filter/DB.pm lib/Data/Printer/Filter/Digest.pm lib/DDP.pm Makefile.PL MANIFEST This list of files MANIFEST.SKIP README.md t/00-load.t t/00.2-begin_load.t t/01-p.t t/02-colors.t t/02.2-autocolor.t t/03-conf.t t/03-conf_not_ref.t t/04-multiline.t t/04-multiline2.t t/05-obj.t t/06-obj2.t t/07-sort.t t/08-deparse.t t/09-alias.t t/10-filter.t t/11-aliased_with_filter.t t/12-filter_class.t t/13-filter_datetime.t t/13.2-filter_db.t t/13.3-filter_digest.t t/14-local_conf.t t/15-rc_file.t t/16-rc_file2.t t/16.2-rc_overwrite.t t/16.3-rc_env.t t/16.4-rc_env2.t t/16.5-rc_env3.t t/17-parallel.t t/18-class_method.t t/19-tied.t t/20-handles.t t/21-ddp.t t/22-class_method.t t/23-caller_info.t t/24-no_prototypes.t t/25-weak.t t/26-tainted.t t/26.2-tainted_rc.t t/26.7-unicode.t t/27-pass_through.t t/27.2-pass_through.t t/27.3-pass_through-DDP.t t/27.4-pass_through-DDP.t t/28-void_return.t t/29-output.t t/30-print_escapes.t t/31-bad_parameters.t t/32-quote_keys.t t/33-end_separator.t t/33-separator.t t/34-show_readonly.t t/35-vstrings.t t/36-valign.t t/37-format.t t/38-lvalue.t t/39-seen_override.t t/40-escape_chars.t t/41-yaml.t t/42-alignment.t t/43-_is_number.t t/44-number-colors.t t/45-np.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-0.38/MANIFEST.SKIP000644 000765 000024 00000000304 12652267134 015742 0ustar00garustaff000000 000000 ^\.git ^[^/]+\.pl$ ^\ignore.txt ^_build ^Build$ ^blib ^Data-Printer ~$ \.bak$ cover_db \..*\.sw.?$ ^Makefile$ ^pm_to_blib$ ^blibdirs$ \.old$ ^#.*#$ ^\.# ^TODO$ ^\._.*$ ^MYMETA.yml$ ^MYMETA\.json$ Data-Printer-0.38/META.json000644 000765 000024 00000003021 12652453306 015462 0ustar00garustaff000000 000000 { "abstract" : "colored pretty-print of Perl data structures and objects", "author" : [ "Breno G. de Oliveira " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.142690", "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" : { "Carp" : "0", "Clone::PP" : "0", "Fcntl" : "0", "File::HomeDir" : "0.91", "File::Spec" : "0", "File::Temp" : "0", "Package::Stash" : "0.3", "Scalar::Util" : "0", "Sort::Naturally" : "0", "Term::ANSIColor" : "3", "Test::More" : "0.88", "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" : "0.38" } Data-Printer-0.38/META.yml000644 000765 000024 00000001611 12652453305 015314 0ustar00garustaff000000 000000 --- abstract: 'colored 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.04, CPAN::Meta::Converter version 2.142690' 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: Carp: '0' Clone::PP: '0' Fcntl: '0' File::HomeDir: '0.91' File::Spec: '0' File::Temp: '0' Package::Stash: '0.3' Scalar::Util: '0' Sort::Naturally: '0' Term::ANSIColor: '3' Test::More: '0.88' 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: '0.38' Data-Printer-0.38/README.md000644 000765 000024 00000003147 12372305646 015333 0ustar00garustaff000000 000000 ## Data::Printer ## Data::Printer is a Perl module to pretty-print Perl data structures and objects in full color. It is meant to display variables on screen, properly formatted to be inspected by a human. Data::Printer is highly customizable, from indentation size to depth level. You can even rename the exported p() function! Data::Printer also lets you create filters to help debugging your objects easily. ### INSTALLATION ### # from CPAN $ cpan Data::Printer # from cpanm $ cpanm Data::Printer # cloning the repository $ git clone git://github.com/garu/Data-Printer.git # manual installation, after downloading perl Build.PL ./Build ./Build test ./Build install ### USAGE ### use Data::Printer; p $data; Please refer to http://search.cpan.org/perldoc?Data::Printer for complete documentation, or type: perldoc Data::Printer after the installation. ### SUPPORT AND DOCUMENTATION ### You can also look for information at: RT, CPAN's request tracker http://rt.cpan.org/NoAuth/Bugs.html?Dist=Data-Printer AnnoCPAN, Annotated CPAN documentation http://annocpan.org/dist/Data-Printer CPAN Ratings http://cpanratings.perl.org/d/Data-Printer Search CPAN http://search.cpan.org/dist/Data-Printer/ ### LICENSE AND COPYRIGHT ### Copyright (C) 2011 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-0.38/t/000755 000765 000024 00000000000 12652453305 014307 5ustar00garustaff000000 000000 Data-Printer-0.38/xt/000755 000765 000024 00000000000 12652453305 014477 5ustar00garustaff000000 000000 Data-Printer-0.38/xt/pod-coverage.t000644 000765 000024 00000000313 12372305646 017237 0ustar00garustaff000000 000000 use strict; use warnings; use Test::More; use Test::Pod::Coverage 1.04; all_pod_coverage_ok({ also_private => [ qr/^(?:SCALAR|ARRAY|CODE|GLOB|HASH|REF|VSTRING|Regexp|FORMAT|LVALUE)$/, qr/^np$/ ], }); Data-Printer-0.38/xt/pod.t000644 000765 000024 00000000123 12372305646 015445 0ustar00garustaff000000 000000 use strict; use warnings; use Test::More; use Test::Pod 1.41; all_pod_files_ok(); Data-Printer-0.38/xt/whitespaces.t000644 000765 000024 00000000226 12532170426 017200 0ustar00garustaff000000 000000 use strict; use warnings; use Test::Whitespaces { dirs => [ qw( examples lib t ) ], }; Data-Printer-0.38/t/00-load.t000644 000765 000024 00000000343 12372305646 015633 0ustar00garustaff000000 000000 #!perl use Test::More tests => 1; BEGIN { diag( "Beginning Data::Printer tests in $^O with Perl $], $^X" ); use_ok( 'Data::Printer' ) || print "Bail out! "; } diag( "Testing Data::Printer $Data::Printer::VERSION" ); Data-Printer-0.38/t/00.2-begin_load.t000644 000765 000024 00000000631 12445753544 017144 0ustar00garustaff000000 000000 use strict; use warnings; my $res; BEGIN { $ENV{ANSI_COLORS_DISABLED} = 1; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter } BEGIN { use Test::More; use Data::Printer return_value => 'dump', colored => 0, multiline => 0, index => 0; my @data = ( 1 .. 3 ); $res = p @data; } is $res, '[ 1, 2, 3 ]', 'DDP wihtin a BEGIN block'; done_testing; Data-Printer-0.38/t/01-p.t000644 000765 000024 00000014312 12532167456 015160 0ustar00garustaff000000 000000 use strict; use warnings; use Test::More; BEGIN { $ENV{ANSI_COLORS_DISABLED} = 1; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter }; use Data::Printer return_value => 'dump'; my $scalar = 'test'; is( p($scalar), '"test"', 'simple scalar' ); my $scalar_ref = \$scalar; is( p($scalar_ref), '\\ "test"', 'scalar ref' ); my $refref = \$scalar_ref; is( p($refref), '\\ \\ "test"', 'reference of reference'); $scalar = "\0"; is( p($scalar), '"\0"', 'handling the null character' ); $scalar = "\0foo\0bar \0 baz\0"; is( p($scalar), '"\0foo\0bar \0 baz\0"', 'handling several null characters' ); $scalar = "\0foo\n\0bar\0 baz\n\0"; is( p($scalar), '"\0foo \0bar\0 baz \0"', 'null characters in newlines' ); $scalar = 42; is( p($scalar), '42', 'simple numeric scalar' ); $scalar = -4.2; is( p($scalar), '-4.2', 'negative float scalar' ); $scalar = '4.2'; is( p($scalar), '4.2', 'stringified float scalar' ); $scalar = 7; is( p($scalar_ref), '\\ 7', 'simple numeric ref' ); my @array = (); is( p(@array), '[]', 'empty array' ); undef @array; is( p(@array), '[]', 'undefined array' ); @array = (1 .. 3); is( p(@array), '[ [0] 1, [1] 2, [2] 3 ]', 'simple array'); @array = ( 1, $scalar_ref ); is( p(@array), '[ [0] 1, [1] \\ 7 ]', 'simple array with scalar ref'); $scalar = 4.2; @array = ( 1 .. 11 ); is( p(@array), '[ [0] 1, [1] 2, [2] 3, [3] 4, [4] 5, [5] 6, [6] 7, [7] 8, [8] 9, [9] 10, [10] 11 ]', 'simple array alignment'); $array[2] = [ 'foo', 7 ]; $array[5] = [ -6, [ 64 ], 'one', \$scalar ]; is( p(@array), '[ [0] 1, [1] 2, [2] [ [0] "foo", [1] 7 ], [3] 4, [4] 5, [5] [ [0] -6, [1] [ [0] 64 ], [2] "one", [3] \\ 4.2 ], [6] 7, [7] 8, [8] 9, [9] 10, [10] 11 ]', 'nested array'); my %hash = (); is( p(%hash), '{}', 'empty hash'); undef %hash; is( p(%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; } is( p(%hash), '{ 1 undef }', 'evil hash of doom'); %hash = ( foo => 33, bar => 99 ); is( p(%hash), '{ bar 99, foo 33 }', 'simple hash'); $hash{$scalar} = \$scalar; $hash{hash} = { 1 => 2, 3 => { 4 => 5 }, 10 => 11 }; $hash{something} = [ 3 .. 5 ]; $hash{zelda} = 'moo'; is( p(%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'); @array = ( { 1 => 2 }, 3, { 4 => 5 } ); is( p(@array), '[ [0] { 1 2 }, [1] 3, [2] { 4 5 } ]', 'array of hashes'); my $array_ref = [ 1..2 ]; @array = ( 7, \$array_ref, 8 ); is( p(@array), '[ [0] 7, [1] \\ [ [0] 1, [1] 2 ], [2] 8 ]', 'reference of an array reference'); my $hash_ref = { c => 3 }; %hash = ( a => 1, b => \$hash_ref, d => 4 ); is( p(%hash), '{ a 1, b \\ { c 3 }, d 4 }', 'reference of a hash reference'); is( p($array_ref), '\\ [ [0] 1, [1] 2 ]', 'simple array ref' ); is( p($hash_ref), '\\ { c 3 }', 'simple hash ref' ); # null tests $scalar = undef; $scalar_ref = \$scalar; is( p($scalar), 'undef', 'null test' ); is( p($scalar_ref), '\\ undef', 'null ref' ); @array = ( undef, undef, [ undef ], undef ); is( p(@array), '[ [0] undef, [1] undef, [2] [ [0] undef ], [3] undef ]', 'array with undefs' ); %hash = ( 'undef' => undef, foo => { 'meep' => undef }, zed => 26 ); is( p(%hash), '{ foo { meep undef }, undef undef, zed 26 }', 'hash with undefs' ); my $sub = sub { 0 }; is( p($sub), '\ sub { ... }', 'subref test' ); $array[0] = sub { 1 }; $array[2][1] = sub { 2 }; is( p(@array), '[ [0] sub { ... }, [1] undef, [2] [ [0] undef, [1] sub { ... } ], [3] undef ]', 'array with subrefs' ); $hash{foo}{bar} = sub { 3 }; $hash{'undef'} = sub { 4 }; is( p(%hash), '{ foo { bar sub { ... }, meep undef }, undef sub { ... }, zed 26 }', 'hash with subrefs' ); my $regex = qr{(?:moo(\d|\s)*[a-z]+(.?))}i; is( p($regex), '\\ (?:moo(\d|\s)*[a-z]+(.?)) (modifiers: i)', 'regex with modifiers' ); $regex = qr{(?:moo(\d|\s)*[a-z]+(.?))}; is( p($regex), '\ (?:moo(\d|\s)*[a-z]+(.?))', 'plain regex' ); $regex = qr{ | ^ \s* go \s }x; is( p($regex), "\\ \n |\n ^ \\s* go \\s\n (modifiers: x)", 'creepy regex' ); $array[0] = qr{\d(\W)[\s]*}; $array[2][1] = qr{\d(\W)[\s]*}; is( p(@array), '[ [0] \d(\W)[\s]*, [1] undef, [2] [ [0] undef, [1] \d(\W)[\s]* ], [3] undef ]', 'array with regex' ); $hash{foo}{bar} = qr{\d(\W)[\s]*}; $hash{'undef'} = qr{\d(\W)[\s]*}; is( p(%hash), '{ foo { bar \d(\W)[\s]*, meep undef }, undef \d(\W)[\s]*, zed 26 }', 'hash with regex' ); $scalar = 3; $scalar_ref = \$scalar; my $ref2 = \$scalar; @array = ($scalar, $scalar_ref, $ref2); is( p(@array), '[ [0] 3, [1] \\ 3, [2] \\ var[1] ]', 'scalar refs in array' ); @array = (); $array_ref = []; $hash_ref = {}; $regex = qr{test}; $scalar = 'foobar'; $array[0] = \@array; # 'var' $array[1] = $array_ref; $array[1][0] = $hash_ref; $array[1][1] = $array_ref; # 'var[1]' $array[1][0]->{foo} = $sub; $array[1][2] = $regex; $array[2] = $sub; # 'var[1][0]{foo}' $array[3] = $regex; # 'var[1][2]' $array[4] = $scalar; $array[5] = $scalar_ref; $array[6] = $scalar_ref; $array[7] = \$scalar; is( p(@array), '[ [0] var, [1] [ [0] { foo sub { ... } }, [1] var[1], [2] test ], [2] var[1][0]{foo}, [3] var[1][2], [4] "foobar", [5] \\ "foobar", [6] \\ var[5], [7] \\ var[5] ]', 'handling repeated and circular references' ); done_testing; Data-Printer-0.38/t/02-colors.t000644 000765 000024 00000003055 12445754001 016214 0ustar00garustaff000000 000000 use strict; use warnings; use Test::More; BEGIN { delete $ENV{ANSI_COLORS_DISABLED}; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter use_ok ('Term::ANSIColor'); use_ok ('Data::Printer', colored => 1, return_value => 'dump'); }; my $number = 3.14; is( p($number), color('reset') . colored($number, 'bright_blue'), 'colored number'); my $string = 'test'; is( p($string), color('reset') . q["] . colored('test', 'bright_yellow') . q["], 'colored string'); my $undef = undef; is( p($undef), color('reset') . colored('undef', 'bright_red'), 'colored undef'); my $regex = qr{1}; is( p($regex), color('reset') . '\\ ' . colored('1', 'yellow'), 'colored regex'); my $code = sub {}; is( p($code), color('reset') . '\\ ' . colored('sub { ... }', 'green'), 'colored code'); my @array = (1); is( p(@array), color('reset') . "[$/ " . colored('[0] ', 'bright_white') . colored(1, 'bright_blue') . "$/]" , 'colored array'); my %hash = (1=>2); is( p(%hash), color('reset') . "{$/ " . colored(1, 'magenta') . ' ' . colored(2, 'bright_blue') . "$/}" , 'colored hash'); my $circular = []; $circular->[0] = $circular; is( p($circular), color('reset') . "\\ [$/ " . colored('[0] ', 'bright_white') . colored('var', 'white on_red') . "$/]" , 'colored circular ref'); # testing 'colored' property is( p($number, colored => 0), $number, 'uncolored number'); done_testing; Data-Printer-0.38/t/02.2-autocolor.t000644 000765 000024 00000001465 12445754063 017075 0ustar00garustaff000000 000000 use strict; use warnings; use Test::More; BEGIN { delete $ENV{ANSI_COLORS_DISABLED}; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter use Term::ANSIColor; }; eval 'use IO::Pty::Easy'; plan skip_all => 'IO::Pty::Easy required for auto-colored tests' if $@; my $client_script = <<'EOSCRIPT'; BEGIN { delete $ENV{ANSI_COLORS_DISABLED}; use File::HomeDir::Test; # avoid user's .dataprinter use Data::Printer return_value => 'dump'; }; my $num = 3.14; p $num; EOSCRIPT my $pty = IO::Pty::Easy->new; $pty->spawn( "$^X", "-e", $client_script ); my $output = $pty->read; my $colored = color('reset') . colored('3.14', 'bright_blue') . $/; is $output, $colored, 'p() auto colors the output properly' ; done_testing; Data-Printer-0.38/t/03-conf.t000644 000765 000024 00000001276 12445754201 015646 0ustar00garustaff000000 000000 use strict; use warnings; use Test::More; BEGIN { $ENV{ANSI_COLORS_DISABLED} = 1; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter }; use Data::Printer { 'return_value' => 'dump', 'name' => 'TEST', 'indent' => 2, 'index' => 0, 'hash_separator' => ' => ', 'max_depth' => 2, 'print_escapes' => 1, }; my $data = [ 1, 2, { foo => 3, bar => { 1 => 2}, baz => [0, 1] }, "\0\n\f\t\bmeep\b\t\f\n\0" ]; push @$data, $data->[2]; is( p($data), '\\ [ 1, 2, { bar => { ... }, baz => [ ... ], foo => 3 }, "\0\n\f\t\bmeep\b\t\f\n\0", TEST[2] ]', 'customization' ); done_testing; Data-Printer-0.38/t/03-conf_not_ref.t000644 000765 000024 00000001146 12445754240 017361 0ustar00garustaff000000 000000 use strict; use warnings; use Test::More; BEGIN { $ENV{ANSI_COLORS_DISABLED} = 1; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter }; use Data::Printer 'return_value' => 'dump', 'name' => 'TEST', 'indent' => 2, 'index' => 0, 'hash_separator' => ' => ', 'max_depth' => 2, ; my $data = [ 1, 2, { foo => 3, bar => { 1 => 2}, baz => [0, 1] } ]; push @$data, $data->[2]; is( p($data), '\\ [ 1, 2, { bar => { ... }, baz => [ ... ], foo => 3 }, TEST[2] ]', 'customization' ); done_testing; Data-Printer-0.38/t/04-multiline.t000644 000765 000024 00000000653 12445754266 016735 0ustar00garustaff000000 000000 use strict; use warnings; use Test::More; BEGIN { $ENV{ANSI_COLORS_DISABLED} = 1; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter }; use Data::Printer { 'return_value' => 'dump', 'multiline' => 0, }; my $data = [ 1, 2, { foo => 3, bar => 4 } ]; push @$data, $data->[2]; is( p($data), '\\ [ 1, 2, { bar 4, foo 3 }, var[2] ]', 'single-line dump' ); done_testing; Data-Printer-0.38/t/04-multiline2.t000644 000765 000024 00000002203 12652452625 017002 0ustar00garustaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More tests => 10; BEGIN { $ENV{ANSI_COLORS_DISABLED} = 1; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter }; use Data::Printer multiline => 1, return_value => 'dump'; my $x = {a=>1,b=>2}; like p($x) , qr/\n/, 'Default with linebreaks'; unlike p($x,multiline=>0), qr/\n/, 'Override no linebreaks'; like p($x) , qr/\n/, 'Back to default with linebreaks'; unlike p($x,multiline=>0), qr/\n/, 'Override no linebreaks'; like p($x,multiline=>1), qr/\n/, 'Override with linebreaks'; ############################ $SIG{__WARN__} = sub {}; require ( delete $INC{'Data/Printer.pm'} ); Data::Printer->import( multiline => 0, return_value => 'dump' ); $SIG{__WARN__} = undef; ############################ unlike p($x) , qr/\n/, 'Default without linebreaks'; like p($x,multiline=>1), qr/\n/, 'Override with linebreaks'; unlike p($x) , qr/\n/, 'Back to default without linebreaks'; like p($x,multiline=>1), qr/\n/, 'Override with linebreaks'; unlike p($x,multiline=>0), qr/\n/, 'Override without linebreaks'; Data-Printer-0.38/t/05-obj.t000644 000765 000024 00000013265 12532166513 015476 0ustar00garustaff000000 000000 use strict; use warnings; BEGIN { $ENV{ANSI_COLORS_DISABLED} = 1; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter }; package Bar; sub 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 { 42 } 1; package Meep; our @ISA = qw(Foo Baz); 1; package ParentLess; sub new { bless {}, shift } 1; package main; use Test::More; use Data::Printer return_value => 'dump'; my $obj = Foo->new; is( p($obj), 'Foo { Parents Bar public methods (4) : baz, borg, foo, new private methods (1) : _other internals: { test 42 } }', 'testing objects' ); is( p($obj, class => { linear_isa => 1 }), 'Foo { Parents Bar Linear @ISA Foo, Bar public methods (4) : baz, borg, foo, new private methods (1) : _other internals: { test 42 } }', 'testing objects, forcing linear @ISA' ); is( p($obj, class => { parents => 0 }), 'Foo { public methods (4) : baz, borg, foo, new private methods (1) : _other internals: { test 42 } }', 'testing objects (parents => 0)' ); is( p($obj, class => { show_methods => 'none' }), 'Foo { Parents Bar internals: { test 42 } }', 'testing objects (no methods)' ); is( p($obj, class => { show_methods => 'public' }), 'Foo { Parents Bar public methods (4) : baz, borg, foo, new internals: { test 42 } }', 'testing objects (only public methods)' ); is( p($obj, class => { show_methods => 'private' }), 'Foo { Parents Bar private methods (1) : _other internals: { test 42 } }', 'testing objects (only private methods)' ); is( p($obj, class => { show_methods => 'all' }), 'Foo { Parents Bar public methods (4) : baz, borg, foo, new private methods (1) : _other internals: { test 42 } }', 'testing objects (explicitly asking for all methods)' ); is( p($obj, class => { internals => 0 } ), 'Foo { Parents Bar public methods (4) : baz, borg, foo, new private methods (1) : _other }', 'testing objects (no internals)' ); is( p($obj, class => { inherited => 0 }), 'Foo { Parents Bar public methods (4) : baz, borg, foo, new private methods (1) : _other internals: { test 42 } }', 'testing objects (inherited => 0)' ); my ($n, $extra_field) = $] < 5.010 ? (8, '') : (9, ' DOES (UNIVERSAL),'); is( p($obj, class => { inherited => 'all' }), "Foo { Parents Bar public methods ($n) : bar (Bar), baz, borg, can (UNIVERSAL),$extra_field foo, isa (UNIVERSAL), new, VERSION (UNIVERSAL) private methods (2) : _moo (Bar), _other internals: { test 42 } }", 'testing objects (inherited => "all")' ); is( p($obj, class => { inherited => 'all', universal => 0 }), "Foo { Parents Bar public methods (5) : bar (Bar), baz, borg, foo, new private methods (2) : _moo (Bar), _other internals: { test 42 } }", 'testing objects (inherited => "all", universal => 0)' ); is( p($obj, class => { inherited => 'public' }), "Foo { Parents Bar public methods ($n) : bar (Bar), baz, borg, can (UNIVERSAL),$extra_field foo, isa (UNIVERSAL), new, VERSION (UNIVERSAL) private methods (1) : _other internals: { test 42 } }", 'testing objects (inherited => "public")' ); is( p($obj, class => { inherited => 'public', universal => 0 }), "Foo { Parents Bar public methods (5) : bar (Bar), baz, borg, foo, new private methods (1) : _other internals: { test 42 } }", 'testing objects (inherited => "public", universal => 0)' ); is( p($obj, class => { inherited => 'private' }), 'Foo { Parents Bar public methods (4) : baz, borg, foo, new private methods (2) : _moo (Bar), _other internals: { test 42 } }', 'testing objects (inherited => "private")' ); is( p($obj, class => { expand => 0 }), 'Foo', 'testing objects without expansion' ); $obj->borg( Foo->new ); is( p($obj), 'Foo { Parents Bar public methods (4) : baz, borg, foo, new private methods (1) : _other internals: { borg Foo, test 42 } }', 'testing nested objects' ); is( p($obj, class => { expand => 'all'} ), '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; is( p($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' ); is( p($obj_with_isa, class => { linear_isa => 0 }), 'Meep { Parents Foo, Baz public methods (0) private methods (0) internals: { test 42 } }', 'testing objects with @ISA, opting out the @ISA' ); is( p($obj_with_isa, class => { linear_isa => 0 }), 'Meep { Parents Foo, Baz public methods (0) private methods (0) internals: { test 42 } }', 'testing objects with @ISA' ); my $parentless = ParentLess->new; is( p($parentless), 'ParentLess { public methods (1) : new private methods (0) internals: {} }', 'testing parentless object' ); done_testing; Data-Printer-0.38/t/06-obj2.t000644 000765 000024 00000002334 12532166513 015554 0ustar00garustaff000000 000000 use strict; use warnings; BEGIN { $ENV{ANSI_COLORS_DISABLED} = 1; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter }; package FooArray; sub new { bless [], shift } sub foo { } package FooScalar; sub new { my $val = 42; bless \$val, shift } sub foo { } package FooCode; sub new { my $ref = sub {}; bless $ref, shift } sub foo { } package main; use Test::More; use Data::Printer return_value => 'dump'; my $scalar = FooScalar->new; my $array = FooArray->new; my $code = FooCode->new; is( p($scalar), 'FooScalar { public methods (2) : foo, new private methods (0) internals: 42 }', 'testing blessed scalar' ); is( p($array ), 'FooArray { public methods (2) : foo, new private methods (0) internals: [] }', 'testing blessed array' ); SKIP: { skip 'no internals in blessed subs yet', 1; is( p($code), 'FooCode { public methods (2) : foo, new private methods (0) internals: sub { ... } }', 'testing blessed code' ); }; is( p($scalar, class => { show_reftype => 1 } ), 'FooScalar (SCALAR) { public methods (2) : foo, new private methods (0) internals: 42 }', 'testing blessed scalar with reftype' ); done_testing; Data-Printer-0.38/t/07-sort.t000644 000765 000024 00000002410 12445754363 015714 0ustar00garustaff000000 000000 use strict; use warnings; package MyClass; sub bbb { }; sub new { bless {}, shift } sub aaa { }; sub _ccc { }; sub _zzz { }; sub _ddd { }; 1; package main; use Test::More; BEGIN { $ENV{ANSI_COLORS_DISABLED} = 1; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter }; use Data::Printer { 'return_value' => 'dump', 'sort_keys' => 0, 'class' => { 'sort_methods' => 1, }, }; my $data = { foo => 3, bar => 2, baz => 1 }; my $string = "\\ {\n"; # perl does not guarantee that hash keys are # returned in the same order for each build, # but it should be the same order for the # same perl. my @keys = keys %$data; foreach my $i ( 0 .. $#keys) { my $key = $keys[$i]; $string .= " $key " . $data->{$key}; $string .= ($i == $#keys ? "\n" : ",\n"); } $string .= '}'; is( p($data), $string, 'sort_keys => 0' ); my $obj = MyClass->new; my $res = p($obj); ok( $res =~ m/public methods \(3\) : (.+)/, 'found public methods' ); my $method_list = $1; is($method_list, 'aaa, bbb, new', 'ordered public methods' ); ok( $res =~ m/private methods \(3\) : (.+)/, 'found private methods' ); $method_list = $1; is($method_list, '_ccc, _ddd, _zzz', 'ordered private methods' ); done_testing; Data-Printer-0.38/t/08-deparse.t000644 000765 000024 00000001013 12445754417 016347 0ustar00garustaff000000 000000 #use strict; #use warnings; use Test::More; BEGIN { $ENV{ANSI_COLORS_DISABLED} = 1; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter }; use 5.008; # <-- prevents PERL5OPT from kicking in and mangling B::Deparse use Data::Printer { 'return_value' => 'dump', 'deparse' => 1, 'deparseopts' => [], }; my $data = [ 6, sub { print 42 }, 10 ]; is( p($data), '\\ [ [0] 6, [1] sub { print 42; }, [2] 10 ]', 'deparsing' ); done_testing; Data-Printer-0.38/t/09-alias.t000644 000765 000024 00000000640 12445754454 016024 0ustar00garustaff000000 000000 use strict; use warnings; use Test::More; BEGIN { $ENV{ANSI_COLORS_DISABLED} = 1; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter }; use Data::Printer { alias => 'Dumper', 'return_value' => 'dump' }; my $scalar = 'test'; is( Dumper($scalar), '"test"', 'aliasing p()' ); eval { p( $scalar ); }; ok($@, 'aliased Data::Printer does not export p()'); done_testing; Data-Printer-0.38/t/10-filter.t000644 000765 000024 00000003742 12445754511 016210 0ustar00garustaff000000 000000 use strict; use warnings; use Test::More; BEGIN { $ENV{ANSI_COLORS_DISABLED} = 1; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter }; use Data::Printer { return_value => 'dump', filters => { 'My::Module' => sub { $_[0]->test }, 'SCALAR' => sub { 'found!!' }, -class => sub { '1, 2, 3' }, 'ARRAY' => sub { my $ref = shift; return join ':', map { p(\$_) } @$ref; }, 'HASH' => sub { my $ref = shift; return 'list => ' . p($ref->{items}); }, }, }; package My::Module; sub new { bless {}, shift } sub test { return 'this is a test' } package Other::Module; sub new { bless {}, shift } package main; my $obj = My::Module->new; is( p($obj), 'this is a test', 'testing filter for object' ); is p($obj, filters => { 'My::Module' => sub { return 'mo' }}), 'mo', 'overriding My::Module filter'; is p($obj), 'this is a test', 'testing filter restoration for object'; is p($obj, filters => { 'My::Module' => sub { return } }), 'this is a test', 'filter override with fallback'; my $obj2 = Other::Module->new; is p($obj2, filters => { 'Other::Module' => sub { return } }), '1, 2, 3', '-class filters can have a go if specific filter failed'; my $scalar = 42; is( p($scalar), 'found!!', 'testing filter for SCALAR' ); is( p($scalar, filters => { SCALAR => sub { return 'a' } }), 'a', 'overriding SCALAR filter' ); is( p($scalar), 'found!!', "inline filters shouldn't stick" ); is( p($scalar, filters => { SCALAR => sub { return } }), 'found!!', 'SCALAR filter fallback' ); my $scalar_ref = \$scalar; is( p($scalar_ref), '\\ found!!', 'testing filter for SCALAR (passing a ref instead)' ); my @list = (1 .. 3); is( p(@list), 'found!!:found!!:found!!', 'testing filters referencing p()' ); my %hash = ( items => \@list ); is( p(%hash), 'list => found!!:found!!:found!!', 'testing filters passing a list into p()' ); done_testing; Data-Printer-0.38/t/11-aliased_with_filter.t000644 000765 000024 00000001415 12445754542 020725 0ustar00garustaff000000 000000 use strict; use warnings; use Test::More; BEGIN { $ENV{ANSI_COLORS_DISABLED} = 1; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter }; use Data::Printer { return_value => 'dump', alias => 'Dumper', filters => { 'ARRAY' => sub { my $ref = shift; return join ':', map { Dumper(\$_) } @$ref; }, 'HASH' => sub { my $ref = shift; my %hash = %$ref; return Dumper(%hash); # wrong, should fail (needs ref) }, }, }; my @list = (1 .. 3); is( Dumper(@list), '1:2:3', 'filter with aliased p()' ); eval { my %hash = (1 => 2); Dumper(%hash); }; like($@, qr/^\QWhen calling p() without prototypes, please pass arguments as references\E/, 'proper exception'); done_testing; Data-Printer-0.38/t/12-filter_class.t000644 000765 000024 00000003074 12652263156 017375 0ustar00garustaff000000 000000 use strict; use warnings; use Test::More; BEGIN { $ENV{ANSI_COLORS_DISABLED} = 1; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter }; use Data::Printer::Filter; my $filters = _filter_list(); is $filters, undef, 'no filters set'; my $properties = { return_value => 'dump', indent => 5, _current_indent => 0, _linebreak => "\n", }; sub test { is scalar @_, 2, 'got two elements'; is $_[0], 'SCALAR', 'first element'; is_deeply $_[1], $properties, 'second element is properties'; indent(); is $_[1]->{_current_indent}, 5, 'indent()'; is newline, "\n ", 'newline()'; indent(); is $_[1]->{_current_indent}, 10, 'indent() again'; outdent; is $_[1]->{_current_indent}, 5, 'outdent()'; return 'test'; } sub test2 { 'other test for: ' . p($_[0], $_[1]) } filter 'SCALAR', \&test; filter 'SCALAR', \&test2; filter HASH => \&test2; $filters = _filter_list(); is scalar keys %$filters, 2, 'filters set'; ok exists $filters->{SCALAR}, 'SCALAR filter set'; ok exists $filters->{HASH}, 'HASH filter set'; is scalar @{ $filters->{SCALAR} }, 2, 'two scalar filters'; is scalar @{ $filters->{HASH} }, 1, 'only one hash filter'; is $filters->{SCALAR}->[1]->('SCALAR', $properties), 'test', 'SCALAR filter called'; is $filters->{SCALAR}->[0]->('SCALAR', $properties), 'other test for: "SCALAR"', 'SCALAR filter called again'; is $filters->{HASH}->[0]->('HASH', $properties), 'other test for: "HASH"', 'HASH filter with p()'; my $foo = 1; ok( np( $foo ), 'np is imported' ); done_testing; Data-Printer-0.38/t/13-filter_datetime.t000644 000765 000024 00000012014 12445755334 020063 0ustar00garustaff000000 000000 use strict; use warnings; use Test::More; my $has_timepiece; BEGIN { $ENV{ANSI_COLORS_DISABLED} = 1; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter # Time::Piece is only able to overload # localtime() if it's loaded during compile-time eval 'use Time::Piece'; $has_timepiece = $@ ? 0 : 1; }; use Data::Printer { return_value => 'dump', filters => { -external => [ 'DateTime' ], HASH => sub { 'this is a hash' } }, }; 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'; my @list = ($t, { foo => 1 } ); # we can't use a literal in our tests because of # timezone and epoch issues my $time_str = $t->cdate; is ( p($t), $time_str, 'Time::Piece' ); is ( p($t, datetime => { show_class_name => 1 }), "$time_str (Time::Piece)", 'Time::Piece with class name' ); is ( p(@list), "[ [0] $time_str, [1] this is a hash ]", 'inline and class filters together (Time::Piece)' ); }; SKIP: { eval 'use DateTime'; skip 'DateTime not available', 4 if $@; my $d1 = DateTime->new( year => 1981, month => 9, day => 29 ); my $d2 = DateTime->new( year => 1984, month => 11, day => 15 ); my $diff = $d2 - $d1; is( p($d1), '1981-09-29T00:00:00 [floating]', 'DateTime' ); is( p($d1, datetime => { show_timezone => 0 }), '1981-09-29T00:00:00', 'DateTime without TZ data' ); is( p($diff), '3y 1m 16d 0h 0m 0s', 'DateTime::Duration' ); my @list = ($d1, { foo => 1 }); is( p(@list), '[ [0] 1981-09-29T00:00:00 [floating], [1] this is a hash ]', 'inline and class filters together (DateTime)' ); }; SKIP: { eval 'use DateTime::TimeZone'; skip 'DateTime::TimeZone not available', 2 if $@; my $d = DateTime::TimeZone->new( name => 'America/Sao_Paulo' ); is( p($d), 'America/Sao_Paulo', 'DateTime::TimeZone' ); my @list = ($d, { foo => 1 }); is( p(@list), '[ [0] America/Sao_Paulo, [1] this is a hash ]', 'inline and class filters together (DateTime::TimeZone)' ); }; SKIP: { eval 'use DateTime::Incomplete'; skip 'DateTime::Incomplete not available', 2 if $@; my $d = DateTime::Incomplete->new( year => 2003 ); is( p($d), '2003-xx-xxTxx:xx:xx', 'DateTime::Incomplete' ); my @list = ($d, { foo => 1 }); is( p(@list), '[ [0] 2003-xx-xxTxx:xx:xx, [1] this is a hash ]', 'inline and class filters together (DateTime::Incomplete)' ); }; SKIP: { eval 'use DateTime::Tiny'; skip 'DateTime::Tiny not available', 2 if $@; my $d = DateTime::Tiny->new( year => 2003, month => 3, day => 11 ); is( p($d), '2003-03-11T00:00:00', 'DateTime::Tiny' ); my @list = ($d, { foo => 1 }); is( p(@list), '[ [0] 2003-03-11T00:00:00, [1] this is a hash ]', 'inline and class filters together (DateTime::Tiny)' ); }; SKIP: { eval 'use Class::Date'; skip 'Class::Date not available', 2 if $@; my $d = Class::Date::date({ year => 2003, month => 3, day => 11 }, 'GMT'); is( p($d), '2003-03-11 00:00:00 [GMT]', 'Class::Date' ); my @list = ($d, { foo => 1 }); is( p(@list), '[ [0] 2003-03-11 00:00:00 [GMT], [1] this is a hash ]', 'inline and class filters together (Class::Date)' ); }; SKIP: { eval 'use Date::Calc::Object'; skip 'Date::Calc::Object not available', 2 if $@; my $d = Date::Calc::Object->localtime( 1234567890 ); my $string = $d->string(2); is( p($d), $string, 'Date::Calc::Object' ); my @list = ($d, { foo => 1 }); is( p(@list), "[ [0] $string, [1] this is a hash ]", 'inline and class filters together (Date::Calc::Object)' ); }; SKIP: { eval 'use Date::Pcalc::Object'; skip 'Date::Pcalc::Object not available', 2 if $@; my $d = Date::Pcalc::Object->localtime( 1234567890 ); my $string = $d->string(2); is( p($d), $string, 'Date::Pcalc::Object' ); my @list = ($d, { foo => 1 }); is( p(@list), "[ [0] $string, [1] this is a hash ]", 'inline and class filters together (Date::Pcalc::Object)' ); }; SKIP: { my $how_many = 4; eval 'use Date::Handler'; skip 'Date::Handler not available', $how_many if $@; eval 'use Date::Handler::Delta'; skip 'Date::Handler::Delta not available', $how_many if $@; my $d = Date::Handler->new( date => 1234567890 ); my $string = "$d"; is( p($d), $string, 'Date::Handler' ); my @list = ($d, { foo => 1 }); is( p(@list), "[ [0] $string, [1] this is a hash ]", 'inline and class filters together (Date::Handler)' ); my $delta = Date::Handler->new( date => 1234567893 ) - $d; $string = $delta->AsScalar; is( p($delta), $string, 'Date::Handler::Delta' ); @list = ($delta, { foo => 1 }); is( p(@list), "[ [0] $string, [1] this is a hash ]", 'inline and class filters together (Date::Handler::Delta)' ); }; done_testing; Data-Printer-0.38/t/13.2-filter_db.t000644 000765 000024 00000006036 12532166513 017013 0ustar00garustaff000000 000000 use strict; use warnings; use Test::More; my $has_timepiece; BEGIN { $ENV{ANSI_COLORS_DISABLED} = 1; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; }; use Data::Printer { return_value => 'dump', filters => { -external => 'DB', # testing simpler syntax # (list syntax is tested in datetime) }, }; eval 'use DBI'; plan skip_all => 'DBI not available' if $@; my $dir = -d 't' ? 't/' : './'; my $dbh = DBI->connect('dbi:DBM(RaiseError=1):', undef, undef, {f_dir => $dir }); is( p($dbh), 'DBM 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( p($dbh), 'DBM 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( p($sth), 'CREATE TABLE foo ( bar TEXT, baz TEXT )', 'STH output' ); SKIP: { eval { $sth->execute }; skip 'error running query', 5 if $@; is( p($sth), 'CREATE TABLE foo ( bar TEXT, baz TEXT )', 'STH output' ); my $sth2 = $dbh->prepare('SELECT * FROM foo WHERE bar = ?'); is( p($dbh), 'DBM 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( p($sth2), 'SELECT * FROM foo WHERE bar = ? (bindings unavailable)', 'STH-2 output' ); is( p($dbh), 'DBM 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( p($dbh), 'DBM Database Handle (disconnected) { Auto Commit: 1 Statement Handles: 1 (1 active) Last Statement: SELECT * FROM foo WHERE bar = ? }', 'DBH output (after disconnecting)' ); }; cleanup(); ################ ## DBIx::Class my $packages = <<'EOPACKAGES'; package MyTest::Schema; use base 'DBIx::Class::Schema'; __PACKAGE__->load_namespaces; 1; package MyTest::Schema::Result::Foo; use base 'DBIx::Class::Core'; __PACKAGE__->table('foo'); __PACKAGE__->add_columns(qw/ bar baz /); 1; EOPACKAGES SKIP: { eval "$packages"; skip "DBIx::Class not available: $@", 1 if $@; package main; my $schema = MyTest::Schema->connect( 'dbi:DBM(RaiseError=1):', undef, undef, {f_dir => $dir } ); is p($schema), 'MyTest::Schema DBIC Schema with \ DBM Database Handle (connected) { Auto Commit: 1 Statement Handles: 0 Last Statement: - }', 'dumping DBIC schema'; }; ok 2, 'still here, cleaning up'; cleanup(); sub cleanup { use File::Spec; foreach my $ext (qw(dir lck pag)) { my $file = File::Spec->catfile( $dir, "foo.$ext" ); if (-e $file) { unlink $file; } else { note("error removing $file"); } } } done_testing; Data-Printer-0.38/t/13.3-filter_digest.t000644 000765 000024 00000002512 12532166513 017701 0ustar00garustaff000000 000000 use strict; use warnings; use Test::More; BEGIN { $ENV{ANSI_COLORS_DISABLED} = 1; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter }; use Data::Printer { return_value => 'dump', filters => { -external => [ 'Digest' ], HASH => sub { 'this is a hash' } }, }; 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"; skip "$module not available", 1 if $@; my $digest = $module->new; skip "$module is not a Digest::base subclass", 1 unless $digest->isa('Digest::base'); $digest->add( $data ); my $dump = p $digest; my $named_dump = p $digest, digest => { show_class_name => 1 }; my @list = ($digest, { foo => 1 }); my $list_dump = p @list; my $hex = $digest->hexdigest; is( $dump, $hex, $module ); is( $named_dump, "$hex ($module)", "$module with class name" ); is( $list_dump, "[ [0] $hex, [1] this is a hash ]", "inline and class filters together ($module)" ); is( p($digest), $digest->hexdigest . ' [reset]', "reset $module"); }; } done_testing; Data-Printer-0.38/t/14-local_conf.t000644 000765 000024 00000002003 12445755527 017023 0ustar00garustaff000000 000000 use strict; use warnings; use Test::More; BEGIN { delete $ENV{ANSI_COLORS_DISABLED}; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter use_ok 'Term::ANSIColor'; use_ok 'Data::Printer', colored => 1, return_value => 'dump'; }; my %hash = ( key => 'value' ); is( p(%hash), color('reset') . "{$/ " . colored('key', 'magenta') . ' ' . q["] . colored('value', 'bright_yellow') . q["] . "$/}" , 'default hash'); is( p(%hash, color => { hash => 'red' }, hash_separator => ' + ' ), color('reset') . "{$/ " . colored('key', 'red') . ' + ' . q["] . colored('value', 'bright_yellow') . q["] . "$/}" , 'hash keys are now red'); is( p(%hash), color('reset') . "{$/ " . colored('key', 'magenta') . ' ' . q["] . colored('value', 'bright_yellow') . q["] . "$/}" , 'still default hash'); done_testing; Data-Printer-0.38/t/15-rc_file.t000644 000765 000024 00000003540 12445755604 016333 0ustar00garustaff000000 000000 use strict; use warnings; use Test::More; my $file; BEGIN { delete $ENV{ANSI_COLORS_DISABLED}; delete $ENV{DATAPRINTERRC}; use Term::ANSIColor; use File::HomeDir::Test; use File::HomeDir; use File::Spec; $file = File::Spec->catfile( File::HomeDir->my_home, '.dataprinter' ); if (-e $file) { plan skip_all => 'File .dataprinter should not be in test homedir'; } umask 0022; open my $fh, '>', $file or plan skip_all => "error opening .dataprinter: $!"; print {$fh} '{ colored => 1, color => { hash => "red" }, hash_separator => " + "}' or plan skip_all => "error writing to .dataprinter: $!"; close $fh; # file created and in place, let's load up our # module and see if it overrides the default conf # with our .dataprinter RC file use_ok ('Data::Printer', return_value => 'dump'); unlink $file or fail('error removing test file'); # let's see if we can call p() from within the BEGIN block itself. # prototypes aren't available in here :( my $h = { a => 42 }; is( p($h), color('reset') . "{$/ " . colored('a', 'red') . ' + ' . colored('42', 'bright_blue') . "$/}" , 'hash keys are now red' ); }; my %hash = ( key => 'value' ); is( p(%hash), color('reset') . "{$/ " . colored('key', 'red') . ' + ' . q["] . colored('value', 'bright_yellow') . q["] . "$/}" , 'hash keys are now red' ); is( p(%hash, color => { hash => 'blue' }, hash_separator => ' * ' ), color('reset') . "{$/ " . colored('key', 'blue') . ' * ' . q["] . colored('value', 'bright_yellow') . q["] . "$/}" , 'local configuration overrides our rc file'); done_testing; Data-Printer-0.38/t/16-rc_file2.t000644 000765 000024 00000002726 12445755652 016426 0ustar00garustaff000000 000000 use strict; use warnings; use Test::More; my $file; BEGIN { delete $ENV{ANSI_COLORS_DISABLED}; delete $ENV{DATAPRINTERRC}; use_ok ('Term::ANSIColor'); use_ok ('File::HomeDir::Test'); use_ok ('File::HomeDir'); use_ok ('File::Spec'); $file = File::Spec->catfile( File::HomeDir->my_home, '.dataprinter' ); if (-e $file) { plan skip_all => 'File .dataprinter should not be in test homedir'; } umask 0022; open my $fh, '>', $file or plan skip_all => "error opening .dataprinter: $!"; print {$fh} '{ colored => 1, color => { hash => "red" }, hash_separator => " + "}' or plan skip_all => "error writing to .dataprinter: $!"; close $fh; # file created and in place, let's load up our # module and see if it overrides the default conf # with our .dataprinter RC file use_ok ('Data::Printer', { return_value => 'dump', color => { hash => 'blue' }, hash_separator => ' * ', }); unlink $file or fail('error removing test file'); }; my %hash = ( key => 'value' ); is( p(%hash, color => { hash => 'blue' }, hash_separator => ' * ' ), color('reset') . "{$/ " . colored('key', 'blue') . ' * ' . q["] . colored('value', 'bright_yellow') . q["] . "$/}" , 'global configuration overrides our rc file'); done_testing; Data-Printer-0.38/t/16.2-rc_overwrite.t000644 000765 000024 00000002073 12445755712 017603 0ustar00garustaff000000 000000 use strict; use warnings; use Test::More; my $file; BEGIN { delete $ENV{ANSI_COLORS_DISABLED}; delete $ENV{DATAPRINTERRC}; use Term::ANSIColor; use File::HomeDir::Test; use File::HomeDir; use File::Spec; $file = File::Spec->catfile( File::HomeDir->my_home, 'my_rc_file' ); if (-e $file) { plan skip_all => 'File my_rc_file should not be in test homedir'; } umask 0022; open my $fh, '>', $file or plan skip_all => "error opening .dataprinter: $!"; print {$fh} '{ colored => 0, multiline => 0, hash_separator => "+"}' or plan skip_all => "error writing to .dataprinter: $!"; close $fh; # file created and in place, let's load up our # module and see if it overrides the default conf # with our .dataprinter RC file use_ok ('Data::Printer', rc_file => $file, return_value => 'dump' ); unlink $file or fail('error removing test file'); }; my %hash = ( key => 'value' ); is( p(%hash), '{ key+"value" }', 'overwritten rc file' ); done_testing; Data-Printer-0.38/t/16.3-rc_env.t000644 000765 000024 00000003627 12445755746 016363 0ustar00garustaff000000 000000 use strict; use warnings; use Test::More; sub create_rc_file { my ($filename, $content) = @_; my $file = File::Spec->catfile( File::HomeDir->my_home, $filename ); if (-e $file) { plan skip_all => "File $filename should not be in test homedir"; } umask 0022; open my $fh, '>', $file or plan skip_all => "error opening $filename: $!"; print {$fh} $content or plan skip_all => "error writing to $filename: $!"; close $fh; return $file; } my $standard_rcfile; my $custom_rcfile; BEGIN { delete $ENV{ANSI_COLORS_DISABLED}; use_ok ('Term::ANSIColor'); use_ok ('File::HomeDir::Test'); use_ok ('File::HomeDir'); use_ok ('File::Spec'); $standard_rcfile = create_rc_file('.dataprinter', '{ colored => 1, color => { hash => "red" }, hash_separator => " + "}' ); $custom_rcfile = create_rc_file('.customrc', '{ colored => 1, color => { hash => "green" }, hash_separator => " % "}' ); $ENV{DATAPRINTERRC} = $custom_rcfile; # standard and custom rc files created # check that the custom rc overrides the standard one use_ok ('Data::Printer', return_value => 'dump'); unlink $standard_rcfile or fail('error removing test file'); unlink $custom_rcfile or fail('error removing test file'); }; my %hash = ( key => 'value' ); is( p(%hash), color('reset') . "{$/ " . colored('key', 'green') . ' % ' . q["] . colored('value', 'bright_yellow') . q["] . "$/}" , 'custom rc file overrides standard rc file'); is( p(%hash, color => { hash => 'blue' }, hash_separator => ' * ' ), color('reset') . "{$/ " . colored('key', 'blue') . ' * ' . q["] . colored('value', 'bright_yellow') . q["] . "$/}" , 'in-code configuration overrides custom rc file'); done_testing; Data-Printer-0.38/t/16.4-rc_env2.t000644 000765 000024 00000002575 12445755773 016447 0ustar00garustaff000000 000000 use strict; use warnings; use Test::More; my $file; BEGIN { delete $ENV{ANSI_COLORS_DISABLED}; use_ok ('Term::ANSIColor'); use_ok ('File::HomeDir::Test'); use_ok ('File::HomeDir'); use_ok ('File::Spec'); $file = File::Spec->catfile( File::HomeDir->my_home, '.customrc' ); if (-e $file) { plan skip_all => 'File .customrc should not be in test homedir'; } umask 0022; open my $fh, '>', $file or plan skip_all => "error opening .customrc: $!"; print {$fh} '{ colored => 1, color => { hash => "red" }, hash_separator => " + "}' or plan skip_all => "error writing to .customrc: $!"; close $fh; $ENV{DATAPRINTERRC} = $file; # file created and in place, check that the explicit configuration below # overrides the custom rc file use_ok ('Data::Printer', { return_value => 'dump', color => { hash => 'blue' }, hash_separator => ' * ', }); unlink $file or fail('error removing test file'); }; my %hash = ( key => 'value' ); is( p(%hash), color('reset') . "{$/ " . colored('key', 'blue') . ' * ' . q["] . colored('value', 'bright_yellow') . q["] . "$/}" , 'global configuration overrides our custom rc file'); done_testing; Data-Printer-0.38/t/16.5-rc_env3.t000644 000765 000024 00000003224 12445756024 016427 0ustar00garustaff000000 000000 use strict; use warnings; use Test::More; sub create_rc_file { my ($filename, $content) = @_; my $file = File::Spec->catfile( File::HomeDir->my_home, $filename ); if (-e $file) { plan skip_all => "File $filename should not be in test homedir"; } umask 0022; open my $fh, '>', $file or plan skip_all => "error opening $filename: $!"; print {$fh} $content or plan skip_all => "error writing to $filename: $!"; close $fh; return $file; } my $code_rcfile; my $env_rcfile; BEGIN { delete $ENV{ANSI_COLORS_DISABLED}; use_ok ('Term::ANSIColor'); use_ok ('File::HomeDir::Test'); use_ok ('File::HomeDir'); use_ok ('File::Spec'); $code_rcfile = create_rc_file('.coderc', '{ colored => 1, color => { hash => "red" }, hash_separator => " + "}' ); $env_rcfile = create_rc_file('.envrc', '{ colored => 1, color => { hash => "green" }, hash_separator => " % "}' ); $ENV{DATAPRINTERRC} = $env_rcfile; # code and env rc files created # check that the rc file specified with rc_file overrides the one # specified with $ENV{DATAPRINTERRC} use_ok ('Data::Printer', rc_file => $code_rcfile, return_value => 'dump'); unlink $code_rcfile or fail('error removing test file'); unlink $env_rcfile or fail('error removing test file'); }; my %hash = ( key => 'value' ); is( p(%hash), color('reset') . "{$/ " . colored('key', 'red') . ' + ' . q["] . colored('value', 'bright_yellow') . q["] . "$/}" , 'custom configuration overrides standard rc file'); done_testing; Data-Printer-0.38/t/17-parallel.t000644 000765 000024 00000002642 12445756237 016533 0ustar00garustaff000000 000000 use strict; use warnings; BEGIN { delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter use Term::ANSIColor; }; package Foo; use Data::Printer { return_value => 'dump', colored => 1, color => { number => 'green' } }; sub foo { p($_[0]) } package Bar; use Data::Printer { return_value => 'dump', colored => 1, color => { number => 'yellow' } }; sub bar { p($_[0]) } package main; use Test::More; use Data::Printer { return_value => 'dump', colored => 1, color => { number => 'blue' } }; delete $ENV{ANSI_COLORS_DISABLED}; my $data = 42; plan skip_all => 'failed color sanity check' if $data eq colored($data, 'blue'); # IMPORTANT NOTE: # this "overriding" was because I felt the end # user should be the one deciding how to output # the data. These "nested custom dumps" look to me # like something quite rare and unlikely to happen # in the Real World (tm). But if you have a # compelling argument on why this behavior should # change, please drop me a line - but note that you # *CAN* customize Data::Printer within modules # simply by overriding any options when calling p() is(p($data), color('reset') . colored($data, 'blue'), 'main::p should be blue' ); is(Foo::foo($data), color('reset') . colored($data, 'blue'), 'main overrides customization in Foo' ); is(Bar::bar($data), color('reset') . colored($data, 'blue'), 'main overrides customization in Bar' ); done_testing; Data-Printer-0.38/t/18-class_method.t000644 000765 000024 00000000756 12445756265 017412 0ustar00garustaff000000 000000 use strict; use warnings; BEGIN { $ENV{ANSI_COLORS_DISABLED} = 1; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter }; package Foo; sub bar { "I exist with " . scalar @_ . " arguments" } sub _moo { } sub new { bless {}, shift } 1; package main; use Test::More tests => 1; use Data::Printer return_value => 'dump', class_method => 'bar'; my $obj = Foo->new; is p($obj), 'I exist with 2 arguments', 'printing object via class_method "bar()"'; Data-Printer-0.38/t/19-tied.t000644 000765 000024 00000005254 12445756315 015665 0ustar00garustaff000000 000000 use strict; use warnings; BEGIN { $ENV{ANSI_COLORS_DISABLED} = 1; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter }; 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; } sub SCALAR { } package Tie::Fighter::Handle; sub TIEHANDLE { my $i; return bless \$i, shift; } sub PRINT { } sub READ { return 'foo' } sub READLINE { return 'foo' } package main; use Test::More; use Data::Printer return_value => 'dump'; my $var = 42; is p($var), '42', 'untied scalar shows only the scalar'; tie $var, 'Tie::Fighter::Scalar'; is p($var), '1 (tied to Tie::Fighter::Scalar)', 'tied scalar contains tied message'; untie $var; is p($var), '1', 'cleared (untied) scalar again shows no tie information'; my @var = (1); is p(@var), '[ [0] 1 ]', 'untied array shows only the array'; tie @var, 'Tie::Fighter::Array'; is p(@var), '[ [0] 2, [1] 3 ] (tied to Tie::Fighter::Array)', 'tied array contains tied message'; untie @var; is p(@var), '[ [0] 1 ]', 'cleared (untied) array again shows no tie information'; my %var = ( foo => 'bar' ); is p(%var), '{ foo "bar" }', 'untied hash shows only the hash'; tie %var, 'Tie::Fighter::Hash'; is p(%var), '{ test 42 } (tied to Tie::Fighter::Hash)', 'tied hash contains tied message'; untie %var; is p(%var), '{ foo "bar" }', 'cleared (untied) hash again shows no tie information'; $var = *DATA; like p($var), qr/\*main::DATA/, 'untied handle properly referenced'; unlike p($var), qr/tied to/, 'untied handle shows only the handle itself'; tie *$var, 'Tie::Fighter::Handle'; like p($var), qr/tied to Tie::Fighter::Handle/, 'tied handle contains tied message'; untie *$var; unlike p($var), qr/tied to/, 'cleared (untied) handle again shows no tie information'; done_testing; __DATA__ test file! Data-Printer-0.38/t/20-handles.t000644 000765 000024 00000002634 12532166513 016335 0ustar00garustaff000000 000000 use strict; use warnings; my ($var, $filename); BEGIN { $ENV{ANSI_COLORS_DISABLED} = 1; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter use File::HomeDir; use File::Spec; use Test::More; use Fcntl; $filename = File::Spec->catfile( File::HomeDir->my_home, 'test_file.dat' ); }; use Data::Printer return_value => 'dump'; if ( open $var, '>', $filename ) { my $str = p $var; my @layers = (); eval { @layers = PerlIO::get_layers $var }; close $var; unless ($@) { 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 $var, '>', $filename; my $flags; eval { $flags = fcntl($var, F_GETFL, 0) }; skip 'fcntl not fully supported', 4 if $@ or !$flags; like p($var), qr{write-only}, 'write-only handle'; close $var; skip "error appending to $filename: $!", 3 unless open $var, '+>>', $filename; like p($var), qr{read/write}, 'read/write handle'; like p($var), qr/flags:[^,]+append/, 'append flag'; close $var; skip "error reading from $filename: $!", 1 unless open $var, '<', $filename; like p($var), qr{read-only}, 'read-only handle'; close $var; }; done_testing(); Data-Printer-0.38/t/21-ddp.t000644 000765 000024 00000001504 12445756421 015470 0ustar00garustaff000000 000000 use strict; use warnings; BEGIN { $ENV{ANSI_COLORS_DISABLED} = 1; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter use Test::More; use_ok( 'DDP', return_value => 'dump', filters => { SCALAR => sub { '...' } } ) or plan skip_all => 'unable to load DDP'; } my $scalar = 'test'; is( p($scalar), '...', 'simple filtered scalar' ); my %hash = ( foo => 33, bar => 'moo', test => \$scalar, hash => { 1 => 2, 3 => { 4 => 5 }, 10 => 11 }, something => [ 3 .. 5 ], ); is( p(%hash), '{ bar ..., foo ..., hash { 1 ..., 3 { 4 ... }, 10 ... }, something [ [0] ..., [1] ..., [2] ... ], test \\ ... }', 'nested hash'); done_testing; Data-Printer-0.38/t/22-class_method.t000644 000765 000024 00000001125 12445756450 017370 0ustar00garustaff000000 000000 use strict; use warnings; BEGIN { $ENV{ANSI_COLORS_DISABLED} = 1; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter }; package Foo; sub new { bless {}, shift } sub foo { return 42 } sub _data_printer { my $self = shift; return 'foo is ' . $self->foo } 1; package main; use Test::More; use Data::Printer return_value => 'dump'; my $obj = Foo->new; is p($obj), 'foo is 42', '_data_printer() called as default class dumper'; is p($obj, class_method => 'foo'), 42, 'class_method overrides default class dumper'; done_testing; Data-Printer-0.38/t/23-caller_info.t000644 000765 000024 00000002075 12445756502 017204 0ustar00garustaff000000 000000 use strict; use warnings; BEGIN { delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter use Term::ANSIColor; }; use Test::More; use Data::Printer return_value => 'dump', caller_info => 1; sub _get_path { my (undef, $filename) =caller; return $filename } my $filepath = _get_path(); my $var = [ 1, { foo => 'bar' } ]; is p($var), "Printing in line " . __LINE__ . " of $filepath: \\ [ [0] 1, [1] { foo \"bar\" } ]", 'output with caller info'; $var = 3; # simplify output is p($var, caller_message => 'also, a __PACKAGE__'), 'also, a main 3', 'output with custom caller message'; is p($var, colored => 1), color('reset') . colored("Printing in line " . (__LINE__ - 1) . " of $filepath:", 'bright_cyan') . "\n" . colored($var, 'bright_blue') , 'colored caller message'; is p( $var, colored => 1, color => { caller_info => 'red' } ), color('reset') . colored("Printing in line " . (__LINE__ - 1) . " of $filepath:", 'red') . "\n" . colored($var, 'bright_blue') , 'custom colored caller message'; done_testing; Data-Printer-0.38/t/24-no_prototypes.t000644 000765 000024 00000000734 12445756527 017663 0ustar00garustaff000000 000000 use strict; use warnings; use Test::More; BEGIN { $ENV{ANSI_COLORS_DISABLED} = 1; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter }; use Data::Printer return_value => 'dump', use_prototypes => 0; is p(\"test"), '"test"', 'scalar 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'; done_testing; Data-Printer-0.38/t/25-weak.t000644 000765 000024 00000005325 12445756556 015672 0ustar00garustaff000000 000000 use strict; use warnings; use Test::More; BEGIN { delete $ENV{ANSI_COLORS_DISABLED}; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter use_ok ('Term::ANSIColor'); use_ok ('Scalar::Util', qw(weaken)); use_ok ('Data::Printer', return_value => 'dump', colored => 1); }; my $number = 3.14; my $n_ref = \$number; weaken($n_ref); is( p($n_ref), color('reset') . '\\ ' . colored($number, 'bright_blue') . ' ' . colored('(weak)', 'cyan') , 'weakened ref'); my %h = ( foo => $n_ref ); weaken( $h{foo} ); is( p(%h), color('reset') . "{$/ " . colored('foo', 'magenta') . ' \\ ' . colored('3.14', 'bright_blue') . ' ' . colored('(weak)', 'cyan') . "$/}" , 'weakened ref inside hash' ); my @a = ( $n_ref, 42 ); weaken( $a[0] ); is( p(@a), color('reset') . "[$/ " . colored('[0] ', 'bright_white') . '\\ ' . colored('3.14', 'bright_blue') . ' ' . colored('(weak)', 'cyan') . ",$/ " . colored('[1] ', 'bright_white') . colored('42', 'bright_blue') . "$/]" , 'weakened ref inside array' ); my $circular = []; $circular->[0] = $circular; weaken($circular->[0]); is( p($circular), color('reset') . "\\ [$/ " . colored('[0] ', 'bright_white') . colored('var', 'white on_red') . ' ' . colored('(weak)', 'cyan') . "$/]" , 'weakened circular array ref'); my %hash = (); $hash{key} = \%hash; weaken($hash{key}); is( p(%hash), color('reset') . "{$/ " . colored('key', 'magenta') . ' ' . colored('var', 'white on_red') . ' ' . colored('(weak)', 'cyan') . "$/}" , 'weakened circular hash ref'); package Foo; sub new {my $s = bless [], shift; $s->[0] = $s; Scalar::Util::weaken($s->[0]); return $s } package Bar; sub new {bless {}, shift}; package main; my $obj = Foo->new; is( p($obj), color('reset') . colored('Foo', 'bright_green') . ' { public methods (1) : ' . colored('new', 'bright_green') . ' private methods (0) internals: [ ' . colored('[0] ', 'bright_white') . colored('var', 'white on_red') . ' ' . colored('(weak)', 'cyan').' ] }', 'circular weak ref to object' ); $obj = Bar->new; my $weak_obj = $obj; weaken( $weak_obj ); is( p($weak_obj), color('reset') . colored('Bar', 'bright_green') . ' { public methods (1) : ' . colored('new', 'bright_green') . ' private methods (0) internals: {} }'. ' ' . colored('(weak)', 'cyan') , 'weak object' ); done_testing; Data-Printer-0.38/t/26-tainted.t000644 000765 000024 00000001316 12445756610 016357 0ustar00garustaff000000 000000 #!perl -T use strict; use warnings; use Test::More; use Scalar::Util qw(tainted); my $path; BEGIN { # we only catch 1 char to avoid leaking # user information on test results $path = substr $ENV{PATH}, 0, 1; plan skip_all => 'tainted sample not found. Skipping...' unless tainted($path); delete $ENV{ANSI_COLORS_DISABLED}; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter use_ok ('Term::ANSIColor'); }; use Data::Printer return_value => 'dump', colored => 1; is( p($path), color('reset') . q["] . colored($path, 'bright_yellow') . q["] . ' ' . colored('(TAINTED)', 'red'), 'tainted scalar' ); done_testing; Data-Printer-0.38/t/26.2-tainted_rc.t000644 000765 000024 00000002123 12652255310 017167 0ustar00garustaff000000 000000 #!perl -T use strict; use warnings; use Test::More; my $file; BEGIN { delete $ENV{ANSI_COLORS_DISABLED}; use Term::ANSIColor; use File::HomeDir::Test; use File::HomeDir; use File::Spec; $file = File::Spec->catfile( File::HomeDir->my_home, '.dataprinter' ); # untaint - only necessary for old Win32 ($file) = $file =~ /^(.*)$/; if (-e $file) { plan skip_all => 'File .dataprinter should not be in test homedir'; } open my $fh, '>', $file or plan skip_all => "error opening .dataprinter: $!"; print {$fh} '{ colored => 0, hash_separator => "-"}' or plan skip_all => "error writing to .dataprinter: $!"; close $fh; # file created and in place, let's load up our # module and see if it overrides the default conf # with our .dataprinter RC file use_ok ('Data::Printer', return_value => 'dump'); unlink $file or fail('error removing test file'); }; my %hash = ( key => 'value' ); isnt( p(%hash), '{ key-"value" }', 'could NOT read rc file in taint mode' ); done_testing; Data-Printer-0.38/t/26.7-unicode.t000644 000765 000024 00000001352 12652255310 016511 0ustar00garustaff000000 000000 use strict; use warnings; use Test::More; BEGIN { delete $ENV{ANSI_COLORS_DISABLED}; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter use_ok ('Term::ANSIColor'); use_ok ( 'Data::Printer', colored => 1, return_value => 'dump', show_unicode => 1, ); }; my $uni_str= "\x{2603}"; my $ascii_str= "\x{ff}"; is( p($uni_str), color('reset') . q["] . colored($uni_str, 'bright_yellow') . q["] . ' ' . colored('(U)', 'bright_yellow'), 'unicode scalar gets suffix' ); is( p($ascii_str), color('reset') . q["] . colored($ascii_str, 'bright_yellow') . q["], 'ascii scalar without suffix' ); done_testing; Data-Printer-0.38/t/27-pass_through.t000644 000765 000024 00000006737 12532171467 017450 0ustar00garustaff000000 000000 use strict; use warnings; use Test::More; BEGIN { $ENV{ANSI_COLORS_DISABLED} = 1; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter }; use Data::Printer return_value => 'pass'; eval { require Capture::Tiny; 1; } or plan skip_all => 'Capture::Tiny not found'; ############## ### hashes ### ############## my %foo = ( answer => 42 ); my $expected = <<'EOT'; { answer 42 } 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)'; like $return_scalar, qr{^1/\d+$}, 'pass-through return (hash scalar)'; ############## ### arrays ### ############## my @return_list; my @foo = qw(foo bar); $expected = <<'EOT'; [ [0] "foo", [1] "bar" ] EOT ($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)'; ############## ### scalar ### ############## my $foo = 'how much wood would a woodchuck chuck if a woodchuck could chuck wood?'; $expected = qq{"$foo"$/}; ($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)'; ####################### ### 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; $expected =<<'EOT'; Foo { public methods (4) : bar, baz, biff, new private methods (0) internals: { meep 2 } } EOT $foo = Foo->new; ($stdout, $stderr) = Capture::Tiny::capture( sub { (Data::Printer::p $foo->bar->baz)->biff; }); is $stdout, '', 'STDOUT should be empty after p() (object, direct)'; 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)'; done_testing; Data-Printer-0.38/t/27.2-pass_through.t000644 000765 000024 00000006702 12372305646 017600 0ustar00garustaff000000 000000 use strict; use warnings; use Test::More; BEGIN { $ENV{ANSI_COLORS_DISABLED} = 1; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter }; use Data::Printer use_prototypes => 0, return_value => 'pass'; eval { require Capture::Tiny; 1; } or plan skip_all => 'Capture::Tiny not found'; ############## ### hashes ### ############## my %foo = ( answer => 42 ); my $expected = <<'EOT'; { answer 42 } 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)'; like $return_scalar, qr{^1/\d+$}, 'pass-through return (hash scalar)'; ############## ### arrays ### ############## my @return_list; my @foo = qw(foo bar); $expected = <<'EOT'; [ [0] "foo", [1] "bar" ] EOT ($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)'; ############## ### scalar ### ############## my $foo = 'how much wood would a woodchuck chuck if a woodchuck could chuck wood?'; $expected = qq{"$foo"$/}; ($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)'; ####################### ### 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; $expected =<<'EOT'; Foo { public methods (4) : bar, baz, biff, new private methods (0) internals: { meep 2 } } EOT $foo = Foo->new; ($stdout, $stderr) = Capture::Tiny::capture( sub { (Data::Printer::p $foo->bar->baz)->biff; }); is $stdout, '', 'STDOUT should be empty after p() (object)'; is $stderr, $expected, 'pass-through STDERR (object)'; is $foo->{meep}, 3, 'pass-through return (object)'; # 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)'; is $stderr, $expected, 'pass-through STDERR (object)'; is $foo->{meep}, 3, 'pass-through return (object)'; done_testing; Data-Printer-0.38/t/27.3-pass_through-DDP.t000644 000765 000024 00000006701 12372305646 020205 0ustar00garustaff000000 000000 use strict; use warnings; use Test::More; BEGIN { $ENV{ANSI_COLORS_DISABLED} = 1; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter }; use DDP return_value => 'pass'; eval { require Capture::Tiny; 1; } or plan skip_all => 'Capture::Tiny not found'; ############## ### hashes ### ############## my %foo = ( answer => 42 ); my $expected = <<'EOT'; { answer 42 } 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)'; like $return_scalar, qr{^1/\d+$}, 'pass-through return (hash scalar)'; ############## ### arrays ### ############## my @return_list; my @foo = qw(foo bar); $expected = <<'EOT'; [ [0] "foo", [1] "bar" ] EOT ($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)'; ############## ### scalar ### ############## my $foo = 'how much wood would a woodchuck chuck if a woodchuck could chuck wood?'; $expected = qq{"$foo"$/}; ($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)'; ####################### ### 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; $expected =<<'EOT'; Foo { public methods (4) : bar, baz, biff, new private methods (0) internals: { meep 2 } } EOT $foo = Foo->new; ($stdout, $stderr) = Capture::Tiny::capture( sub { (DDP::p $foo->bar->baz)->biff; }); is $stdout, '', 'STDOUT should be empty after p() (object, direct)'; 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->DDP::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)'; done_testing; Data-Printer-0.38/t/27.4-pass_through-DDP.t000644 000765 000024 00000006644 12372305646 020214 0ustar00garustaff000000 000000 use strict; use warnings; use Test::More; BEGIN { $ENV{ANSI_COLORS_DISABLED} = 1; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter }; use DDP use_prototypes => 0, return_value => 'pass'; eval { require Capture::Tiny; 1; } or plan skip_all => 'Capture::Tiny not found'; ############## ### hashes ### ############## my %foo = ( answer => 42 ); my $expected = <<'EOT'; { answer 42 } 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)'; like $return_scalar, qr{^1/\d+$}, 'pass-through return (hash scalar)'; ############## ### arrays ### ############## my @return_list; my @foo = qw(foo bar); $expected = <<'EOT'; [ [0] "foo", [1] "bar" ] EOT ($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)'; ############## ### scalar ### ############## my $foo = 'how much wood would a woodchuck chuck if a woodchuck could chuck wood?'; $expected = qq{"$foo"$/}; ($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)'; ####################### ### 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; $expected =<<'EOT'; Foo { public methods (4) : bar, baz, biff, new private methods (0) internals: { meep 2 } } EOT $foo = Foo->new; ($stdout, $stderr) = Capture::Tiny::capture( sub { (DDP::p $foo->bar->baz)->biff; }); is $stdout, '', 'STDOUT should be empty after p() (object)'; is $stderr, $expected, 'pass-through STDERR (object)'; is $foo->{meep}, 3, 'pass-through return (object)'; # once again, but this time in indirect object notation $foo = Foo->new; ($stdout, $stderr) = Capture::Tiny::capture( sub { $foo->bar->baz->DDP::p->biff; }); is $stdout, '', 'STDOUT should be empty after p() (object)'; is $stderr, $expected, 'pass-through STDERR (object)'; is $foo->{meep}, 3, 'pass-through return (object)'; done_testing; Data-Printer-0.38/t/28-void_return.t000644 000765 000024 00000001272 12372305646 017270 0ustar00garustaff000000 000000 use strict; use warnings; use Test::More; BEGIN { $ENV{ANSI_COLORS_DISABLED} = 1; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter }; use Data::Printer return_value => 'void'; eval { require Capture::Tiny; 1; } or plan skip_all => 'Capture::Tiny not found'; my $string = 'All your base are belong to us.'; my $expected = qq{"$string"$/}; my $return = 1; my ($stdout, $stderr) = Capture::Tiny::capture( sub { $return = p $string; }); is $stdout, '', 'STDOUT should be empty after p() (scalar, scalar)'; is $stderr, $expected, 'pass-through STDERR (scalar, scalar)'; is $return, undef, 'pass-through return (scalar scalar)'; done_testing; Data-Printer-0.38/t/29-output.t000644 000765 000024 00000003563 12372305646 016276 0ustar00garustaff000000 000000 use strict; use warnings; use Test::More; BEGIN { $ENV{ANSI_COLORS_DISABLED} = 1; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter }; use Data::Printer return_value => 'void'; use Fcntl; use File::Temp qw( :seekable tempfile ); eval { require Capture::Tiny; 1; } or plan skip_all => 'Capture::Tiny not found'; ; #===================== # 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'; done_testing; Data-Printer-0.38/t/30-print_escapes.t000644 000765 000024 00000005565 12445757054 017576 0ustar00garustaff000000 000000 use strict; use warnings; use Test::More; BEGIN { delete $ENV{ANSI_COLORS_DISABLED}; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter use_ok ('Term::ANSIColor'); use_ok ( 'Data::Printer', return_value => 'dump', colored => 1, print_escapes => 1, ); }; my @stuff = ( { original => "\0", unescaped => '\0', }, { original => "\n", unescaped => '\n', }, { original => "\t", unescaped => '\t', }, { original => "\b", unescaped => '\b', }, { original => "\e", unescaped => '\e', }, { original => "\r", unescaped => '\r', }, { original => "\f", unescaped => '\f', }, { original => "\a", unescaped => '\a', }, ); my $mixed = (); foreach my $item (@stuff) { my $colored = color('bright_red') . $item->{unescaped} . color('bright_yellow') ; $mixed->{original} .= $item->{original}; $mixed->{unescaped} .= $item->{unescaped}; $mixed->{colored} .= $colored; is( p( $item->{original} ), color('reset') . '"' . color('bright_yellow') . $colored . color('reset') . '"', 'testing escape sequence for ' . $item->{unescaped} ); } is( p( $mixed->{original} ), color('reset') . '"' . color('bright_yellow') . $mixed->{colored} . color('reset') . '"', 'testing escape sequence for ' . $mixed->{unescaped} ); my %hash_with_escaped_keys = ( ' ' => 1, ); is( p( %hash_with_escaped_keys ), color('reset') . "{$/ " . q['] . colored(' ', 'magenta') . q['] . ' ' . colored(1, 'bright_blue') . "$/}", 'testing hash key with spaces' ); %hash_with_escaped_keys = ( "\n" => 1, ); is( p( %hash_with_escaped_keys ), color('reset') . "{$/ " . q['] . color('magenta') . color('bright_red') . '\n' . color('magenta') . color('reset') . q['] . ' ' . colored(1, 'bright_blue') . "$/}", 'testing escaped hash keys' ); %hash_with_escaped_keys = ( '' => 1, ); is( p( %hash_with_escaped_keys ), color('reset') . "{$/ " . q['] . colored('', 'magenta') . q['] . ' ' . colored(1, 'bright_blue') . "$/}", 'quoting empty hash key' ); %hash_with_escaped_keys = ( "\t" => 1, ); is( p( %hash_with_escaped_keys, print_escapes => 0 ), color('reset') . "{$/ " . q['] . colored("\t", 'magenta') . q['] . ' ' . colored(1, 'bright_blue') . "$/}", 'testing hash key with spaces (print_escapes => 0)' ); done_testing; Data-Printer-0.38/t/31-bad_parameters.t000644 000765 000024 00000000561 12372305646 017673 0ustar00garustaff000000 000000 use strict; use warnings; use Test::More; BEGIN { $ENV{ANSI_COLORS_DISABLED} = 1; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter }; eval 'use Data::Printer 0.1'; ok !$@, 'could load with version number'; eval 'use Data::Printer qw(meep)'; like $@, qr/either a hash/, 'croaked with proper error message'; done_testing; Data-Printer-0.38/t/32-quote_keys.t000644 000765 000024 00000001360 12445757133 017114 0ustar00garustaff000000 000000 use strict; use warnings; use Test::More; BEGIN { delete $ENV{ANSI_COLORS_DISABLED}; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter use_ok ('Term::ANSIColor'); use_ok ( 'Data::Printer', return_value => 'dump', colored => 0, ); }; my %hash = ( '' => 1, a => 1, ); is( p(%hash), "{ '' 1, a 1 }", 'auto quote_keys (implicit)' ); is( p(%hash, quote_keys => 'auto'), "{ '' 1, a 1 }", 'auto quote_keys (explicit)' ); is( p(%hash, quote_keys => 1), "{ '' 1, 'a' 1 }", 'quote_keys active' ); is( p(%hash, quote_keys => 0), "{ 1, a 1 }", 'quote_keys inactive' ); done_testing; Data-Printer-0.38/t/33-end_separator.t000644 000765 000024 00000001235 12532166513 017545 0ustar00garustaff000000 000000 use strict; use warnings; use Test::More tests => 1; BEGIN { $ENV{ANSI_COLORS_DISABLED} = 1; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter }; use Data::Printer return_value => 'dump', end_separator => 1, separator => '--'; my $structure = [ 1, 2, { a => 1, b => 2, long_line => 3, }, ]; my $end_comma_output = '\ [ [0] 1-- [1] 2-- [2] { a 1-- b 2-- long_line 3-- }-- ]'; is( p($structure), $end_comma_output, "Got correct structure with end_separator => 1 and separator => '--'", ); Data-Printer-0.38/t/33-separator.t000644 000765 000024 00000002014 12445757207 016724 0ustar00garustaff000000 000000 use strict; use warnings; use Test::More tests => 3; BEGIN { $ENV{ANSI_COLORS_DISABLED} = 1; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter }; use Data::Printer return_value => 'dump', separator => '--'; my $structure = [ 1, 2, { a => 1, b => 2, long_line => 3, }, ]; my $end_comma_output = '\ [ [0] 1-- [1] 2-- [2] { a 1-- b 2-- long_line 3 } ]'; is( p($structure), $end_comma_output, "Got correct structure with separator => '--'", ); $end_comma_output = '\ [ [0] 1 [1] 2 [2] { a 1 b 2 long_line 3 } ]'; is( p($structure, separator => ''), $end_comma_output, "Got correct structure with no separator", ); is( p($structure, separator => '', end_separator => 1), $end_comma_output, "Got correct structure with no separator, even with end_separator set to 1", ); Data-Printer-0.38/t/34-show_readonly.t000644 000765 000024 00000000753 12445757264 017615 0ustar00garustaff000000 000000 ###################################### ######## EXPERIMENTAL FEATURE ######## ###################################### use strict; use warnings; use Test::More tests => 1; BEGIN { $ENV{ANSI_COLORS_DISABLED} = 1; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter }; use Data::Printer return_value => 'dump', show_readonly => 1; my $foo = 42; &Internals::SvREADONLY( \$foo, 1 ); is p($foo), '42 (read-only)', 'readonly variables (experimental)'; Data-Printer-0.38/t/35-vstrings.t000644 000765 000024 00000000676 12445757321 016616 0ustar00garustaff000000 000000 use strict; use warnings; BEGIN { $ENV{ANSI_COLORS_DISABLED} = 1; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter use Test::More; } use Data::Printer return_value => 'dump'; plan skip_all => 'Older perls do not have VSTRING support' if $] < 5.010; my $scalar = v1.2.3; eval { is( p($scalar), 'v1.2.3', "VSTRINGs" ); }; if ($@) { fail( "VSTRINGs" ); diag( $@ ); } done_testing(); Data-Printer-0.38/t/36-valign.t000644 000765 000024 00000000613 12532166513 016201 0ustar00garustaff000000 000000 # making sure data is properly aligned use strict; use warnings; use Test::More tests => 1; BEGIN { $ENV{ANSI_COLORS_DISABLED} = 1; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter }; use Data::Printer return_value => 'dump'; my $var = { q[foo bar],2,3,4}; is( p($var), q{\ { 3 4, 'foo bar' 2 }}, 'colored alignment' ); Data-Printer-0.38/t/37-format.t000644 000765 000024 00000000650 12445757366 016232 0ustar00garustaff000000 000000 use strict; use warnings; BEGIN { $ENV{ANSI_COLORS_DISABLED} = 1; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter use Test::More; } use Data::Printer return_value => 'dump'; format TEST = . my $form = *TEST{FORMAT}; my $test_name = "FORMAT refs"; eval { is( p($form), 'FORMAT', $test_name ); }; if ($@) { fail( $test_name ); diag( $@ ); } done_testing(); Data-Printer-0.38/t/38-lvalue.t000644 000765 000024 00000000756 12445757406 016235 0ustar00garustaff000000 000000 use strict; use warnings; BEGIN { $ENV{ANSI_COLORS_DISABLED} = 1; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter use Test::More; } use Data::Printer return_value => 'dump'; my $scalar = \substr( "abc", 2); my $test_name = "LVALUE refs"; eval { is( p($scalar), '"c" (LVALUE)', $test_name ); is( p($scalar, show_lvalue => 0), '"c"', 'disabled ' . $test_name ); }; if ($@) { fail( $test_name ); diag( $@ ); } done_testing(); Data-Printer-0.38/t/39-seen_override.t000644 000765 000024 00000002120 12372305646 017554 0ustar00garustaff000000 000000 use strict; use warnings; use Test::More; BEGIN { $ENV{ANSI_COLORS_DISABLED} = 1; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter }; use Data::Printer::Filter; my $filters = _filter_list(); is $filters, undef, 'no filters set'; my $extras = _extra_options(); is $extras, undef, 'no extra options for filters yet'; my $properties = { indent => 5, _current_indent => 0, _linebreak => \"\n", }; sub test { is scalar @_, 2, 'got two elements'; is $_[0], 'SCALAR', 'first element'; is_deeply $_[1], $properties, 'second element is properties'; return 'test'; } filter 'SCALAR', sub { return 'test' }, { show_repeated => 1 }; $filters = _filter_list(); $extras = _extra_options(); ok exists $filters->{SCALAR}, 'SCALAR filter set'; is scalar @{ $filters->{SCALAR} }, 1, 'two scalar filters'; ok exists $extras->{SCALAR}, 'extras set for SCALAR'; is $extras->{SCALAR}{show_repeated}, 1, 'extra hash ok for SCALAR filter'; is $filters->{SCALAR}->[0]->('SCALAR', $properties), 'test', 'SCALAR filter called'; done_testing; Data-Printer-0.38/t/40-escape_chars.t000644 000765 000024 00000003450 12445757535 017353 0ustar00garustaff000000 000000 use strict; use warnings; use Test::More; BEGIN { delete $ENV{ANSI_COLORS_DISABLED}; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter use_ok ('Term::ANSIColor'); use_ok ( 'Data::Printer', return_value => 'dump', colored => 1, print_escapes => 1, ); }; my $string = "L\x{e9}on likes to build a m\x{f8}\x{f8}se \x{2603} with \x{2744}\x{2746}"; my %hash = ( $string => $string ); sub col(@) { my $return = color('bright_red'); $return .= '\\x{' . shift . '}' while @_; $return .= color('bright_yellow'); return $return; } sub str($) { return color('reset') . '"' . color('bright_yellow') . shift . color('reset') . '"'; } ### none ### is( p( $string ), str($string), "Testing 'none'" ); ### nonascii ### use_ok ( 'Data::Printer', colored => 1, print_escapes => 1, escape_chars => "nonascii", ); is( p( $string ), str "L@{[col 'e9']}on likes to build a m@{[col 'f8','f8']}se @{[col '2603']} with @{[col '2744','2746']}", "Testing 'nonascii'" ); ### nonlatin1 ### use_ok ( 'Data::Printer', colored => 1, print_escapes => 1, escape_chars => "nonlatin1", ); is( p( $string ), str "L\x{e9}on likes to build a m\x{f8}\x{f8}se @{[col '2603']} with @{[col '2744','2746']}", "Testing 'nonlatin1'" ); ### all ### use_ok ( 'Data::Printer', colored => 1, print_escapes => 1, escape_chars => "all", ); is( p( $string ), str( color('bright_red') . join('',map { (sprintf '\x{%02x}', ord($_)) } split //, $string) . color('bright_yellow') ), "Testing 'all'" ); done_testing; Data-Printer-0.38/t/41-yaml.t000644 000765 000024 00000001324 12532166513 015657 0ustar00garustaff000000 000000 use strict; use warnings; use Test::More; BEGIN { $ENV{ANSI_COLORS_DISABLED} = 1; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter }; use DDP return_value => 'dump'; eval 'use YAML::Syck'; if ($@) { plan skip_all => 'YAML::Syck not found.'; } else { plan tests => 1; } my $yaml = qq{--- sample: - !!some.method name: 'foo' value: 'bar' }; my $data = YAML::Syck::Load($yaml); is p($data), '\ { sample [ [0] some.method { public methods (0) private methods (0) internals: { name "foo", value "bar" } } ] }', 'testing odd objects (YAML::Syck)'; Data-Printer-0.38/t/42-alignment.t000644 000765 000024 00000001331 12445757600 016700 0ustar00garustaff000000 000000 use strict; use warnings; use Test::More tests => 2; BEGIN { $ENV{ANSI_COLORS_DISABLED} = 1; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter }; use Data::Printer return_value => 'dump'; my $structure = { a => 1, bb => 2, long_line => 3, }; my $output_with_alignment = '\ { a 1, bb 2, long_line 3 }'; is( p($structure), $output_with_alignment, "Got correct structure with default settings", ); my $output_without_alignment = '\ { a 1, bb 2, long_line 3 }'; is( p($structure, align_hash => 0), $output_without_alignment, "Got correct structure with disabled alignment", ); Data-Printer-0.38/t/43-_is_number.t000644 000765 000024 00000001447 12445757623 017062 0ustar00garustaff000000 000000 use strict; use warnings; use Test::More; BEGIN { $ENV{ANSI_COLORS_DISABLED} = 1; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter }; use Data::Printer return_value => 'dump'; pass('Loaded ok'); my @numbers = ( -1, 0, 1, 1.23, 1.23e+38, 1.23e-38, 123, ); foreach my $number (@numbers) { ok( Data::Printer::_is_number($number), "_is_number('$number') return true", ); } my @strings = ( "", "+0123", "+1", "-0123", "0 but true", "0123", "Inf", "Infinity", "NaN", "abc", '1_000', ); foreach my $not_a_number (@strings) { ok( not(Data::Printer::_is_number($not_a_number)), "_is_number('$not_a_number') return false", ); } done_testing(); Data-Printer-0.38/t/44-number-colors.t000644 000765 000024 00000005537 12445757652 017536 0ustar00garustaff000000 000000 use strict; use warnings; use Test::More tests => 4; BEGIN { delete $ENV{ANSI_COLORS_DISABLED}; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter use_ok ('Term::ANSIColor'); use_ok ('Data::Printer', return_value => 'dump', colored => 1); }; pass('Loaded ok'); my $data = { not_a_number_1 => "0123", not_a_number_2 => "Inf", not_a_number_3 => "Infinity", not_a_number_4 => "NaN", not_a_number_5 => "0 but true", not_a_number_6 => "-0123", not_a_number_7 => "+0123", not_a_number_8 => "", not_a_number_9 => "abc", not_a_number_10 => "+1", not_a_number_11 => '1_000', number_1 => 123, number_2 => 0, number_3 => 1, number_4 => -1, number_7 => 1.23, number_8 => 1.23e+38, number_9 => 1.23e-38, }; my $space = ' 'x4; my $expected_output = color('reset') . "\\ {\n" . ' 'x4 . colored('not_a_number_1', 'magenta') . ' 'x4 . '"' . colored('0123', 'bright_yellow') . '",' . "\n" . ' 'x4 . colored('not_a_number_2', 'magenta') . ' 'x4 . '"' . colored("Inf", 'bright_yellow') . '",' . "\n" . ' 'x4 . colored('not_a_number_3', 'magenta') . ' 'x4 . '"' . colored("Infinity", 'bright_yellow') . '",' . "\n" . ' 'x4 . colored('not_a_number_4', 'magenta') . ' 'x4 . '"' . colored("NaN", 'bright_yellow') . '",' . "\n" . ' 'x4 . colored('not_a_number_5', 'magenta') . ' 'x4 . '"' . colored("0 but true", 'bright_yellow') . '",' . "\n" . ' 'x4 . colored('not_a_number_6', 'magenta') . ' 'x4 . '"' . colored("-0123", 'bright_yellow') . '",' . "\n" . ' 'x4 . colored('not_a_number_7', 'magenta') . ' 'x4 . '"' . colored("+0123", 'bright_yellow') . '",' . "\n" . ' 'x4 . colored('not_a_number_8', 'magenta') . ' 'x4 . '"' . colored("", 'bright_yellow') . '",' . "\n" . ' 'x4 . colored('not_a_number_9', 'magenta') . ' 'x4 . '"' . colored("abc", 'bright_yellow') . '",' . "\n" . ' 'x4 . colored('not_a_number_10', 'magenta') . ' 'x3 . '"' . colored("+1", 'bright_yellow') . '",' . "\n" . ' 'x4 . colored('not_a_number_11', 'magenta') . ' 'x3 . '"' . colored('1_000', 'bright_yellow') . '",' . "\n" . ' 'x4 . colored('number_1', 'magenta') . ' 'x10 . colored(123, 'bright_blue') . ",\n" . ' 'x4 . colored('number_2', 'magenta') . ' 'x10 . colored(0, 'bright_blue') . ",\n" . ' 'x4 . colored('number_3', 'magenta') . ' 'x10 . colored(1, 'bright_blue') . ",\n" . ' 'x4 . colored('number_4', 'magenta') . ' 'x10 . colored(-1, 'bright_blue') . ",\n" . ' 'x4 . colored('number_7', 'magenta') . ' 'x10 . colored(1.23, 'bright_blue') . ",\n" . ' 'x4 . colored('number_8', 'magenta') . ' 'x10 . colored(1.23e+38, 'bright_blue') . ",\n" . ' 'x4 . colored('number_9', 'magenta') . ' 'x10 . colored(1.23e-38, 'bright_blue') . "\n" . "}" ; is( p($data), $expected_output, "Numbers and strings are written as expected", ); Data-Printer-0.38/t/45-np.t000644 000765 000024 00000000564 12532171247 015343 0ustar00garustaff000000 000000 use strict; use warnings; use Test::More tests => 2; BEGIN { $ENV{ANSI_COLORS_DISABLED} = 1; delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter }; use Data::Printer; my $scalar = 'test'; is( np($scalar), '"test"', 'np() returns string' ); is( np($scalar, return_value => 'void'), '"test"', 'np() always returns strings' ); Data-Printer-0.38/lib/Data/000755 000765 000024 00000000000 12652453305 015463 5ustar00garustaff000000 000000 Data-Printer-0.38/lib/DDP.pm000644 000765 000024 00000001022 12532166513 015551 0ustar00garustaff000000 000000 package DDP; use strict; use warnings; use Data::Printer; BEGIN { push our @ISA, 'Data::Printer'; our $VERSION = $Data::Printer::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-0.38/lib/Data/Printer/000755 000765 000024 00000000000 12652453305 017106 5ustar00garustaff000000 000000 Data-Printer-0.38/lib/Data/Printer.pm000644 000765 000024 00000206506 12652453171 017456 0ustar00garustaff000000 000000 package Data::Printer; use strict; use warnings; use Term::ANSIColor qw(color colored); use Scalar::Util; use Sort::Naturally; use Carp qw(croak); use Clone::PP qw(clone); use Package::Stash; use if $] >= 5.010, 'Hash::Util::FieldHash' => qw(fieldhash); use if $] < 5.010, 'Hash::Util::FieldHash::Compat' => qw(fieldhash); use File::Spec; use File::HomeDir (); use Fcntl; # This causes strangeness wrt UNIVERSAL on Perl 5.8 with some versions of version.pm. # Instead, we now require version in the VSTRING() method. # use version 0.77 (); our $VERSION = '0.38'; BEGIN { if ($^O =~ /Win32/i) { require Win32::Console::ANSI; Win32::Console::ANSI->import; } } # defaults my $properties = { 'name' => 'var', 'indent' => 4, 'index' => 1, 'max_depth' => 0, 'multiline' => 1, 'sort_keys' => 1, 'deparse' => 0, 'hash_separator' => ' ', 'align_hash' => 1, 'separator' => ',', 'end_separator' => 0, 'show_tied' => 1, 'show_tainted' => 1, 'show_unicode' => 0, 'show_weak' => 1, 'show_readonly' => 0, 'show_lvalue' => 1, 'print_escapes' => 0, 'escape_chars' => 'none', 'quote_keys' => 'auto', 'scalar_quotes' => '"', 'use_prototypes' => 1, 'output' => 'stderr', 'return_value' => 'pass', # also 'dump' or 'void' 'colored' => 'auto', # also 0 or 1 'caller_info' => 0, 'caller_message' => 'Printing in line __LINE__ of __FILENAME__:', 'class_method' => '_data_printer', # use a specific dump method, if available 'color' => { 'array' => 'bright_white', 'number' => 'bright_blue', 'string' => 'bright_yellow', 'class' => 'bright_green', 'method' => 'bright_green', 'undef' => 'bright_red', 'hash' => 'magenta', 'regex' => 'yellow', 'code' => 'green', 'glob' => 'bright_cyan', 'vstring' => 'bright_blue', 'lvalue' => 'bright_white', 'format' => 'bright_cyan', 'repeated' => 'white on_red', 'caller_info' => 'bright_cyan', 'weak' => 'cyan', 'tainted' => 'red', 'unicode' => 'bright_yellow', 'escaped' => 'bright_red', 'unknown' => 'bright_yellow on_blue', }, 'class' => { inherited => 'none', # also 'all', 'public' or 'private' universal => 1, parents => 1, linear_isa => 'auto', expand => 1, # how many levels to expand. 0 for none, 'all' for all internals => 1, export => 1, sort_methods => 1, show_methods => 'all', # also 'none', 'public', 'private' show_reftype => 0, _depth => 0, # used internally }, 'filters' => { # The IO ref type isn't supported as you can't actually create one, # any handle you make is automatically blessed into an IO::* object, # and those are separately handled. SCALAR => [ \&SCALAR ], ARRAY => [ \&ARRAY ], HASH => [ \&HASH ], REF => [ \&REF ], CODE => [ \&CODE ], GLOB => [ \&GLOB ], VSTRING => [ \&VSTRING ], LVALUE => [ \&LVALUE ], FORMAT => [ \&FORMAT ], Regexp => [ \&Regexp ], -unknown=> [ \&_unknown ], -class => [ \&_class ], }, _output => *STDERR, # used internally _current_indent => 0, # used internally _linebreak => "\n", # used internally _seen => {}, # used internally _seen_override => {}, # used internally _depth => 0, # used internally _tie => 0, # used internally }; sub import { my $class = shift; my $args; if (scalar @_) { $args = @_ == 1 ? shift : {@_}; croak 'Data::Printer can receive either a hash or a hash reference.' unless ref $args and ref $args eq 'HASH'; } # the RC file overrides the defaults, # (and we load it only once) unless( exists $properties->{_initialized} ) { _load_rc_file($args); $properties->{_initialized} = 1; } # and 'use' arguments override the RC file if ($args) { $properties = _merge( $args ); } my $exported = ($properties->{use_prototypes} ? \&p : \&p_without_prototypes ); my $imported = $properties->{alias} || 'p'; my $caller = caller; no strict 'refs'; *{"$caller\::$imported"} = $exported; *{"$caller\::np"} = \&np; } sub p (\[@$%&];%) { return _print_and_return( $_[0], _data_printer(!!defined wantarray, @_) ); } sub np (\[@$%&];%) { my ($dump, $p) = _data_printer(1, @_); return $dump; } # 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 $item = shift; if (!ref $item && @_ == 0) { my $item_value = $item; $item = \$item_value; } return _print_and_return( $item, _data_printer(!!defined wantarray, $item, @_) ); } sub _print_and_return { my ($item, $dump, $p) = @_; if ( $p->{return_value} eq 'pass' ) { print { $p->{_output} } $dump . $/; my $ref = ref $item; if ($ref eq 'ARRAY') { return @{ $item }; } elsif ($ref eq 'HASH') { return %{ $item }; } elsif ( grep { $ref eq $_ } qw(REF SCALAR CODE Regexp GLOB VSTRING) ) { return $$item; } else { return $item; } } elsif ( $p->{return_value} eq 'void' ) { print { $p->{_output} } $dump . $/; return; } else { print { $p->{_output} } $dump . $/ unless defined wantarray; return $dump; } } sub _data_printer { my $wantarray = shift; croak 'When calling p() without prototypes, please pass arguments as references' unless ref $_[0]; my ($item, %local_properties) = @_; local %ENV = %ENV; my $p = _merge(\%local_properties); unless ($p->{multiline}) { $p->{'_linebreak'} = ' '; $p->{'indent'} = 0; $p->{'index'} = 0; } # We disable colors if colored is set to false. # If set to "auto", we disable colors if the user # set ANSI_COLORS_DISABLED or if we're either # returning the value (instead of printing) or # being piped to another command. if ( !$p->{colored} or ($p->{colored} eq 'auto' and (exists $ENV{ANSI_COLORS_DISABLED} or $wantarray or not -t $p->{_output} ) ) ) { $ENV{ANSI_COLORS_DISABLED} = 1; } else { delete $ENV{ANSI_COLORS_DISABLED}; } my $out = color('reset'); if ( $p->{caller_info} and $p->{_depth} == 0 ) { $out .= _get_info_message($p); } $out .= _p( $item, $p ); return ($out, $p); } sub _p { my ($item, $p) = @_; my $ref = (defined $p->{_reftype} ? $p->{_reftype} : ref $item); my $tie; my $string = ''; # Object's unique ID, avoiding circular structures my $id = _object_id( $item ); if ( exists $p->{_seen}->{$id} ) { if ( not defined $p->{_reftype} ) { return colored($p->{_seen}->{$id}, $p->{color}->{repeated}); } } # some filters don't want us to show their repeated refs elsif( !exists $p->{_seen_override}{$ref} ) { $p->{_seen}->{$id} = $p->{name}; } delete $p->{_reftype}; # abort override # globs don't play nice $ref = 'GLOB' if "$item" =~ /GLOB\([^()]+\)$/; # filter item (if user set a filter for it) my $found; if ( exists $p->{filters}->{$ref} ) { foreach my $filter ( @{ $p->{filters}->{$ref} } ) { if ( defined (my $result = $filter->($item, $p)) ) { $string .= $result; $found = 1; last; } } } if (not $found and Scalar::Util::blessed($item) ) { # let '-class' filters have a go foreach my $filter ( @{ $p->{filters}->{'-class'} } ) { if ( defined (my $result = $filter->($item, $p)) ) { $string .= $result; $found = 1; last; } } } if ( not $found ) { # if it's not a class and not a known core type, we must be in # a future perl with some type we're unaware of foreach my $filter ( @{ $p->{filters}->{'-unknown'} } ) { if ( defined (my $result = $filter->($item, $p)) ) { $string .= $result; last; } } } if ($p->{show_tied} and $p->{_tie} ) { $string .= ' (tied to ' . $p->{_tie} . ')'; $p->{_tie} = ''; } return $string; } ###################################### ## Default filters ###################################### sub SCALAR { my ($item, $p) = @_; my $string = ''; if (not defined $$item) { $string .= colored('undef', $p->{color}->{'undef'}); } elsif (_is_number($$item)) { $string .= colored($$item, $p->{color}->{'number'}); } else { my $val = _escape_chars($$item, $p->{color}{string}, $p); $string .= $p->{scalar_quotes} . colored($val, $p->{color}->{'string'}) . $p->{scalar_quotes}; } $string .= ' ' . colored('(TAINTED)', $p->{color}->{'tainted'}) if $p->{show_tainted} and Scalar::Util::tainted($$item); $string .= ' ' . colored('(U)', $p->{color}->{'unicode'}) if $p->{show_unicode} and utf8::is_utf8($$item); $p->{_tie} = ref tied $$item; if ($p->{show_readonly} and &Internals::SvREADONLY( $item )) { $string .= ' (read-only)'; } return $string; } sub _is_number { my ($maybe_a_number) = @_; # Scalar values that start from zero is strings, but not numbers. # You can write `my $foo = 0123`, but then `$foo` will be 83, # (numbers starting with zero is octal integers) return '' if $maybe_a_number =~ /^-?0[0-9]/; my $is_number = $maybe_a_number =~ m/ ^ -? # number can start with minus, but can't start with plus # is scalar starts with plus it is not number [0-9-]+ # then there should be some numbers ( \. [0-9]+ )? # there can be decimal part, which is optional ( e [+-] [0-9]+ )? # then there can be optional exponential notation part $ /x; return $is_number; } sub _escape_chars { my ($str, $orig_color, $p) = @_; $orig_color = color( $orig_color ); my $esc_color = color( $p->{color}{escaped} ); # if we're escaping everything then we don't need to keep swapping # colors in and out, and we need to return right away because # we no longer need to print_escapes if ($p->{escape_chars} eq 'all') { return $esc_color . join('', map { sprintf '\x{%02x}', ord $_ } split //, $str) . $orig_color } $str =~ s/\e/$esc_color\\e$orig_color/g if $p->{print_escapes}; if ($p->{escape_chars} eq 'nonascii') { $str =~ s{([^\x{00}-\x{7f}]+)}{ $esc_color . (join '', map { sprintf '\x{%02x}', ord $_ } split //, $1) . $orig_color }ge; } elsif ($p->{escape_chars} eq 'nonlatin1') { $str =~ s{([^\x{00}-\x{ff}]+)}{ $esc_color . (join '', map { sprintf '\x{%02x}', ord $_ } split //, $1) . $orig_color }ge; } if ($p->{print_escapes}) { my %escaped = ( "\n" => '\n', "\r" => '\r', "\t" => '\t', "\f" => '\f', "\b" => '\b', "\a" => '\a', ); foreach my $k ( keys %escaped ) { $str =~ s/$k/$esc_color$escaped{$k}$orig_color/g; } } # always escape the null character $str =~ s/\0/$esc_color\\0$orig_color/g; return $str; } sub ARRAY { my ($item, $p) = @_; my $string = ''; $p->{_depth}++; if ( $p->{max_depth} and $p->{_depth} > $p->{max_depth} ) { $string .= '[ ... ]'; } elsif (not @$item) { $string .= '[]'; } else { $string .= "[$p->{_linebreak}"; $p->{_current_indent} += $p->{indent}; foreach my $i (0 .. $#{$item} ) { $p->{name} .= "[$i]"; my $array_elem = $item->[$i]; $string .= (' ' x $p->{_current_indent}); if ($p->{'index'}) { $string .= colored( sprintf("%-*s", 3 + length($#{$item}), "[$i]"), $p->{color}->{'array'} ); } my $ref = ref $array_elem; # scalar references should be re-referenced # to gain a '\' sign in front of them if (!$ref or $ref eq 'SCALAR') { $string .= _p( \$array_elem, $p ); } else { $string .= _p( $array_elem, $p ); } $string .= ' ' . colored('(weak)', $p->{color}->{'weak'}) if $ref and Scalar::Util::isweak($item->[$i]) and $p->{show_weak}; $string .= $p->{separator} if $i < $#{$item} || $p->{end_separator}; $string .= $p->{_linebreak}; my $size = 2 + length($i); # [10], [100], etc substr $p->{name}, -$size, $size, ''; } $p->{_current_indent} -= $p->{indent}; $string .= (' ' x $p->{_current_indent}) . "]"; } $p->{_tie} = ref tied @$item; $p->{_depth}--; return $string; } sub REF { my ($item, $p) = @_; my $string = ''; # look-ahead, add a '\' only if it's not an object if (my $ref_ahead = ref $$item ) { $string .= '\\ ' if grep { $_ eq $ref_ahead } qw(SCALAR CODE Regexp ARRAY HASH GLOB REF); } $string .= _p($$item, $p); $string .= ' ' . colored('(weak)', $p->{color}->{'weak'}) if Scalar::Util::isweak($$item) and $p->{show_weak}; return $string; } sub CODE { my ($item, $p) = @_; my $string = ''; my $code = 'sub { ... }'; if ($p->{deparse}) { $code = _deparse( $item, $p ); } $string .= colored($code, $p->{color}->{'code'}); return $string; } sub HASH { my ($item, $p) = @_; my $string = ''; $p->{_depth}++; if ( $p->{max_depth} and $p->{_depth} > $p->{max_depth} ) { $string .= '{ ... }'; } elsif (not keys %$item) { $string .= '{}'; } else { $string .= "{$p->{_linebreak}"; $p->{_current_indent} += $p->{indent}; my $total_keys = scalar keys %$item; my $len = 0; my $multiline = $p->{multiline}; my $hash_color = $p->{color}{hash}; my $quote_keys = $p->{quote_keys}; my @keys = (); # first pass, preparing keys to display (and getting largest key size) foreach my $key ($p->{sort_keys} ? nsort keys %$item : keys %$item ) { my $new_key = _escape_chars($key, $hash_color, $p); my $colored = colored( $new_key, $hash_color ); # wrap in uncolored single quotes if there's # any space or escaped characters if ( $quote_keys and ( $quote_keys ne 'auto' or ( $key eq q() or $new_key ne $key or $new_key =~ /\s|\n|\t|\r/ ) ) ) { $colored = qq['$colored']; } push @keys, { raw => $key, colored => $colored, }; # length of the largest key is used for indenting if ($multiline and $p->{align_hash}) { my $l = length $colored; $len = $l if $l > $len; } } # second pass, traversing and rendering foreach my $key (@keys) { my $raw_key = $key->{raw}; my $colored_key = $key->{colored}; my $element = $item->{$raw_key}; $p->{name} .= "{$raw_key}"; $string .= (' ' x $p->{_current_indent}) . sprintf("%-*s", $len, $colored_key) . $p->{hash_separator} ; my $ref = ref $element; # scalar references should be re-referenced # to gain a '\' sign in front of them if (!$ref or $ref eq 'SCALAR') { $string .= _p( \$element, $p ); } else { $string .= _p( $element, $p ); } $string .= ' ' . colored('(weak)', $p->{color}->{'weak'}) if $ref and $p->{show_weak} and Scalar::Util::isweak($item->{$raw_key}); $string .= $p->{separator} if --$total_keys > 0 || $p->{end_separator}; $string .= $p->{_linebreak}; my $size = 2 + length($raw_key); # {foo}, {z}, etc substr $p->{name}, -$size, $size, ''; } $p->{_current_indent} -= $p->{indent}; $string .= (' ' x $p->{_current_indent}) . "}"; } $p->{_tie} = ref tied %$item; $p->{_depth}--; return $string; } sub Regexp { my ($item, $p) = @_; my $string = ''; my $val = "$item"; # a regex to parse a regex. Talk about full circle :) # note: we are not validating anything, just grabbing modifiers if ($val =~ m/\(\?\^?([uladxismpogce]*)(?:\-[uladxismpogce]+)?:(.*)\)/s) { my ($modifiers, $val) = ($1, $2); $string .= colored($val, $p->{color}->{'regex'}); if ($modifiers) { $string .= " (modifiers: $modifiers)"; } } else { croak "Unrecognized regex $val. Please submit a bug report for Data::Printer."; } return $string; } sub VSTRING { my ($item, $p) = @_; eval { require version }; my $string = ''; # This will raise an error if we have version < 0.77; $string .= colored(version->declare($$item)->normal, $p->{color}->{'vstring'}); return $string; } sub FORMAT { my ($item, $p) = @_; my $string = ''; $string .= colored('FORMAT', $p->{color}->{'format'}); return $string; } sub LVALUE { my ($item, $p) = @_; my $string = SCALAR( $item, $p ); $string .= colored( ' (LVALUE)', $p->{color}{lvalue} ) if $p->{show_lvalue}; return $string; } sub GLOB { my ($item, $p) = @_; my $string = ''; $string .= colored("$$item", $p->{color}->{'glob'}); my $extra = ''; # unfortunately, some systems (like Win32) do not # implement some of these flags (maybe not even # fcntl() itself, so we must wrap it. my $flags; eval { no warnings qw( unopened closed ); $flags = fcntl($$item, 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{$_} } keys %flags) { $extra .= ", flags: @flags"; } $extra .= ', '; } my @layers = (); eval { @layers = PerlIO::get_layers $$item }; # TODO: try PerlIO::Layers::get_layers (leont) unless ($@) { $extra .= "layers: @layers"; } $string .= " ($extra)" if $extra; $p->{_tie} = ref tied *$$item; return $string; } sub _unknown { my($item, $p) = @_; my $ref = ref $item; my $string = ''; $string = colored($ref, $p->{color}->{'unknown'}); return $string; } sub _class { my ($item, $p) = @_; my $ref = ref $item; # if the user specified a method to use instead, we do that if ( $p->{class_method} and my $method = $item->can($p->{class_method}) ) { return $method->($item, $p) if ref $method eq 'CODE'; } my $string = ''; $p->{class}{_depth}++; $string .= colored($ref, $p->{color}->{'class'}); if ( $p->{class}{show_reftype} ) { $string .= ' (' . colored( Scalar::Util::reftype($item), $p->{color}->{'class'} ) . ')'; } if ($p->{class}{expand} eq 'all' or $p->{class}{expand} >= $p->{class}{_depth} ) { $string .= " {$p->{_linebreak}"; $p->{_current_indent} += $p->{indent}; if ($] >= 5.010) { require mro; } else { require MRO::Compat; } # Package::Stash dies on blessed XS eval { my $stash = Package::Stash->new($ref); if ( my @superclasses = @{$stash->get_symbol('@ISA')||[]} ) { if ($p->{class}{parents}) { $string .= (' ' x $p->{_current_indent}) . 'Parents ' . join(', ', map { colored($_, $p->{color}->{'class'}) } @superclasses ) . $p->{_linebreak}; } if ( $p->{class}{linear_isa} and ( ($p->{class}{linear_isa} eq 'auto' and @superclasses > 1) or ($p->{class}{linear_isa} ne 'auto') ) ) { $string .= (' ' x $p->{_current_indent}) . 'Linear @ISA ' . join(', ', map { colored( $_, $p->{color}->{'class'}) } @{mro::get_linear_isa($ref)} ) . $p->{_linebreak}; } } }; if ($@) { warn "*** WARNING *** Could not get superclasses for $ref: $@" unless $@ =~ / is not a module name at /; } $string .= _show_methods($ref, $p) if $p->{class}{show_methods} and $p->{class}{show_methods} ne 'none'; if ( $p->{'class'}->{'internals'} ) { $string .= (' ' x $p->{_current_indent}) . 'internals: '; local $p->{_reftype} = Scalar::Util::reftype $item; $string .= _p($item, $p); $string .= $p->{_linebreak}; } $p->{_current_indent} -= $p->{indent}; $string .= (' ' x $p->{_current_indent}) . "}"; } $p->{class}{_depth}--; return $string; } ###################################### ## Auxiliary (internal) subs ###################################### # All glory to Vincent Pit for coming up with this implementation, # to Goro Fuji for Hash::FieldHash, and of course to Michael Schwern # and his "Object::ID", whose code is copied almost verbatim below. { fieldhash my %IDs; my $Last_ID = "a"; sub _object_id { my $self = shift; # This is 15% faster than ||= return $IDs{$self} if exists $IDs{$self}; return $IDs{$self} = ++$Last_ID; } } sub _show_methods { my ($ref, $p) = @_; my $string = ''; my $methods = { public => [], private => [], }; my $inherited = $p->{class}{inherited} || 'none'; require B; my $methods_of = sub { my ($name) = @_; map { my $m; if ($_ and $m = B::svref_2object($_) and $m->isa('B::CV') and not $m->GV->isa('B::Special') ) { [ $m->GV->STASH->NAME, $m->GV->NAME ] } else { () } } values %{Package::Stash->new($name)->get_all_symbols('CODE')} }; my %seen_method_name; # Package::Stash dies on blessed XS my @all_methods = (); eval { @all_methods = map $methods_of->($_), @{mro::get_linear_isa($ref)}, $p->{class}{universal} ? 'UNIVERSAL' : () }; if ($@) { warn "*** WARNING *** Could not get all_methods for $ref: $@" unless $@ =~ / is not a module name at /; } METHOD: foreach my $method (@all_methods) { my ($package_string, $method_string) = @$method; next METHOD if $seen_method_name{$method_string}++; my $type = substr($method_string, 0, 1) eq '_' ? 'private' : 'public'; if ($package_string ne $ref) { next METHOD unless $inherited ne 'none' and ($inherited eq 'all' or $type eq $inherited); $method_string .= ' (' . $package_string . ')'; } push @{ $methods->{$type} }, $method_string; } # render our string doing a natural sort by method name my $show_methods = $p->{class}{show_methods}; foreach my $type (qw(public private)) { next unless $show_methods eq 'all' or $show_methods eq $type; my @list = ($p->{class}{sort_methods} ? nsort @{$methods->{$type}} : @{$methods->{$type}}); $string .= (' ' x $p->{_current_indent}) . "$type methods (" . scalar @list . ')' . (@list ? ' : ' : '') . join(', ', map { colored($_, $p->{color}->{method}) } @list ) . $p->{_linebreak}; } return $string; } sub _deparse { my ($item, $p) = @_; require B::Deparse; my $i = $p->{indent}; my $deparseopts = ["-sCi${i}v'Useless const omitted'"]; my $sub = 'sub ' . B::Deparse->new($deparseopts)->coderef2text($item); my $pad = "\n" . (' ' x ($p->{_current_indent} + $i)); $sub =~ s/\n/$pad/gse; return $sub; } sub _get_info_message { my $p = shift; my @caller = caller 2; my $message = $p->{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; return colored($message, $p->{color}{caller_info}) . $p->{_linebreak}; } sub _merge { my $p = shift; my $clone = clone $properties; if ($p) { foreach my $key (keys %$p) { if ($key eq 'as') { $clone->{caller_info} = 1; $clone->{caller_message} = $p->{$key}; } elsif ($key eq 'color' or $key eq 'colour') { my $color = $p->{$key}; if ( not ref $color or ref $color ne 'HASH' ) { Carp::carp q['color' should be a HASH reference. Did you mean 'colored'?]; $clone->{color} = {}; } else { foreach my $target ( keys %$color ) { $clone->{color}->{$target} = $p->{$key}->{$target}; } } } elsif ($key eq 'class') { foreach my $item ( keys %{$p->{class}} ) { $clone->{class}->{$item} = $p->{class}->{$item}; } } elsif ($key eq 'filters') { my $val = $p->{$key}; foreach my $item (keys %$val) { my $filters = $val->{$item}; # EXPERIMENTAL: filters in modules if ($item eq '-external') { my @external = ( ref($filters) ? @$filters : ($filters) ); foreach my $class ( @external ) { my $module = "Data::Printer::Filter::$class"; eval "use $module"; if ($@) { warn "Error loading filter '$module': $@"; } else { my %from_module = %{$module->_filter_list}; my %extras = %{$module->_extra_options}; foreach my $k (keys %from_module) { unshift @{ $clone->{filters}->{$k} }, @{ $from_module{$k} }; $clone->{_seen_override}{$k} = 1 if $extras{$k}{show_repeated}; } } } } else { my @filter_list = ( ref $filters eq 'CODE' ? ( $filters ) : @$filters ); unshift @{ $clone->{filters}->{$item} }, @filter_list; } } } elsif ($key eq 'output') { my $out = $p->{output}; my $ref = ref $out; $clone->{output} = $out; my %output_target = ( stdout => *STDOUT, stderr => *STDERR, ); my $error; if (!$ref and exists $output_target{ lc $out }) { $clone->{_output} = $output_target{ lc $out }; } elsif ( ( $ref and $ref eq 'GLOB') or (!$ref and \$out =~ /GLOB\([^()]+\)$/) ) { $clone->{_output} = $out; } elsif ( !$ref or $ref eq 'SCALAR' ) { if( open my $fh, '>>', $out ) { $clone->{_output} = $fh; } else { $error = 1; } } else { $error = 1; } if ($error) { Carp::carp 'Error opening custom output handle.'; $clone->{_output} = $output_target{ 'stderr' }; } } else { $clone->{$key} = $p->{$key}; } } } return $clone; } sub _load_rc_file { my $args = shift || {}; my $file = exists $args->{rc_file} ? $args->{rc_file} : exists $ENV{DATAPRINTERRC} ? $ENV{DATAPRINTERRC} : File::Spec->catfile(File::HomeDir->my_home,'.dataprinter'); return unless -e $file; my $mode = (stat $file )[2]; if ($^O !~ /Win32/i && ($mode & 0020 || $mode & 0002) ) { warn "*** WARNING *** rc file '$file' must NOT be writeable to other users. Skipping.\n"; return; } if ( -l $file || (!-f _) || -p _ || -S _ || -b _ || -c _ ) { warn "*** WARNING *** rc file '$file' doesn't look like a plain file. Skipping.\n"; return; } unless (-o $file) { warn "*** WARNING *** rc file '$file' must be owned by your (effective) user. Skipping.\n"; return; } if ( open my $fh, '<', $file ) { my $rc_data; { local $/; $rc_data = <$fh> } close $fh; if( ${^TAINT} != 0 ) { if ( $args->{allow_tainted} ) { warn "*** WARNING *** Reading tainted file '$file' due to user override.\n"; $rc_data =~ /(.+)/s; # very bad idea - god help you $rc_data = $1; } else { warn "*** WARNING *** taint mode on: skipping rc file '$file'.\n"; return; } } my $config = eval $rc_data; if ( $@ ) { warn "*** WARNING *** Error loading $file: $@\n"; } elsif (!ref $config or ref $config ne 'HASH') { warn "*** WARNING *** Error loading $file: config file must return a hash reference\n"; } else { $properties = _merge( $config ); } } else { warn "*** WARNING *** error opening '$file': $!\n"; } } 1; __END__ =encoding utf8 =head1 NAME Data::Printer - colored 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 Data::Printer; # or just "use DDP" for short p @array; # no need to pass references Code above might output something like this (with colors!): [ [0] "a", [1] "b", [2] undef, [3] "c", ] You can also inspect objects: my $obj = SomeClass->new; p($obj); Which might give you something like: \ SomeClass { Parents Moose::Object Linear @ISA SomeClass, Moose::Object public methods (3) : bar, foo, meta private methods (0) internals: { _something => 42, } } Data::Printer is fully customizable. If you want to change how things are displayed, or even its standard behavior. Take a look at the L<< available customizations|/"CUSTOMIZATION" >>. Once you figure out your own preferences, create a L<< configuration file|/"CONFIGURATION FILE (RUN CONTROL)" >> for yourself and Data::Printer will automatically use it! B<< That's about it! Feel free to stop reading now and start dumping your data structures! For more information, including feature set, how to create filters, and general tips, just keep reading :) >> Oh, if you are just experimenting and/or don't want to use a configuration file, you can set all options during initialization, including coloring, indentation and filters! use Data::Printer { color => { 'regex' => 'blue', 'hash' => 'yellow', }, filters => { 'DateTime' => sub { $_[0]->ymd }, 'SCALAR' => sub { "oh noes, I found a scalar! $_[0]" }, }, }; The first C<{}> block is just syntax sugar, you can safely omit it if it makes things easier to read: use DDP colored => 1; use Data::Printer deparse => 1, sort_keys => 0; =head1 FEATURES Here's what Data::Printer has to offer to Perl developers, out of the box: =over 4 =item * Very sane defaults (I hope!) =item * Highly customizable (in case you disagree with me :) =item * Colored output by default =item * Human-friendly output, with array index and custom separators =item * Full object dumps including methods, inheritance and internals =item * Exposes extra information such as tainted data and weak references =item * Ability to easily create filters for objects and regular structures =item * Ability to load settings from a C<.dataprinter> file so you don't have to write anything other than "use DDP;" in your code! =back =head1 RATIONALE Data::Dumper is a fantastic tool, meant to stringify data structures in a way they are suitable for being C'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 B use those modules for that, it doesn't mean you B. This is where Data::Printer comes in. It is meant to do one thing and one thing only: I<< display Perl variables and objects on screen, properly formatted >> (to be inspected by a human) If you want to serialize/store/restore Perl data structures, this module will NOT help you. Try L, L, L, or whatever. CPAN is full of such solutions! =head1 THE p() FUNCTION Once you load Data::Printer, the C function will be imported into your namespace and available to you. It will pretty-print into STDERR (or any other output target) whatever variable you pass to it. =head2 Changing output targets By default, C will be set to use STDERR. As of version 0.27, you can set up the 'output' property so Data::Printer outputs to several different places: =over 4 =item * C<< output => 'stderr' >> - Standard error. Same as *STDERR =item * C<< output => 'stdout' >> - Standard output. Same as *STDOUT =item * C<< output => $filename >> - Appends to filename. =item * C<< output => $file_handle >> - Appends to opened handle =item * C<< output => \$scalar >> - Appends to that variable's content =back =head2 Return Value As of version 0.36, Data::Printer's return value defaults to "pass-through", meaning it will dump the variable to STDERR (or wherever you set the output to) and will return the variable itself. If for whatever reason you want to mangle with the output string instead of printing it, you can either use the (also exported) C function which always returns the string to be printed: use DDP; # move to a string my $string = np @some_array; # send as a warning warn np($some_string); # output to STDOUT instead of STDERR print np(%some_hash); or change the return value to 'dump' and ask for p()'s return value instead: value: use DDP return_value => 'dump'; # move to a string my $string = p @some_array; # output to STDOUT instead of STDERR; print p(%some_hash); Note that, in this case, Data::Printer will not colorize the returned string unless you explicitly set the C option to 1: print p(%some_hash, colored => 1); # now with colors! You can - and should - of course, set this during you "C" call: use Data::Printer colored => 1; print p( %some_hash ); # will be colored Or by adding the setting to your C<.dataprinter> file. As most of Data::Printer, the return value is also configurable. You do this by setting the C option. There are three options available: =over 4 =item * C<'dump'> p %var; # prints the dump to STDERR (void context) my $string = p %var; # returns the dump *without* printing =item * C<'void'>: p %var; # prints the dump to STDERR, never returns. my $string = p %var; # $string is undef. Data still printed in STDERR =item * C<'pass'> (default as of 0.36): p %var; # prints the dump to STDERR, returns %var my %copy = p %var; # %copy = %var. Data still printed in STDERR =back =head1 COLORS AND COLORIZATION Below are all the available colorizations and their default values. Note that both spellings ('color' and 'colour') will work. use Data::Printer { color => { 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) 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 escaped => 'bright_red', # escaped characters (\t, \n, etc) # potential new Perl datatypes, unknown to Data::Printer unknown => 'bright_yellow on_blue', }, }; Don't fancy colors? Disable them with: use Data::Printer colored => 0; By default, 'colored' is set to C<"auto">, which means Data::Printer will colorize only when not being used to return the dump string, nor when the output (default: STDERR) is being piped. If you're not seeing colors, try forcing it with: use Data::Printer colored => 1; Also worth noticing that Data::Printer I honor the C environment variable unless you force a colored output by setting 'colored' to 1. Remember to put your preferred settings in the C<.dataprinter> file so you never have to type them at all! =head1 ALIASING Data::Printer provides the nice, short, C function to dump your data structures and objects. In case you rather use a more explicit name, already have a C function (why?) in your code and want to avoid clashing, or are just used to other function names for that purpose, you can easily rename it: use Data::Printer alias => 'Dumper'; Dumper( %foo ); =head1 CUSTOMIZATION I tried to provide sane defaults for Data::Printer, so you'll never have to worry about anything other than typing C<< "p( $var )" >> in your code. That said, and besides coloring and filtering, there are several other customization options available, as shown below (with default values): use Data::Printer { name => 'var', # name to display on cyclic references indent => 4, # how many spaces in each indent hash_separator => ' ', # what separates keys from values align_hash => 1, # align values in hash colored => 'auto', # colorize output (1 for always, 0 for never) index => 1, # display array indices multiline => 1, # display in multiple lines (see note below) max_depth => 0, # how deep to traverse the data (0 for all) sort_keys => 1, # sort hash keys deparse => 0, # use B::Deparse to expand (expose) subroutines show_tied => 1, # expose tied variables show_tainted => 1, # expose tainted variables show_unicode => 0, # show unicode flag if it exists show_weak => 1, # expose weak references show_readonly => 0, # expose scalar variables marked as read-only show_lvalue => 1, # expose lvalue types print_escapes => 0, # print non-printable chars as "\n", "\t", etc. escape_chars => 'none', # escape chars into \x{...} form. Values are # "none", "nonascii", "nonlatin1", "all" quote_keys => 'auto', # quote hash keys (1 for always, 0 for never). # 'auto' will quote when key is empty/space-only. scalar_quotes => '"', # the quote symbols to enclose scalar values separator => ',', # uses ',' to separate array/hash elements end_separator => 0, # prints the separator after last element in array/hash. # the default is 0 that means not to print caller_info => 0, # include information on what's being printed use_prototypes => 1, # allow p(%foo), but prevent anonymous data return_value => 'dump', # what should p() return? See 'Return Value' above. output => 'stderr',# where to print the output. See # 'Changing output targets' above. class_method => '_data_printer', # make classes aware of Data::Printer # and able to dump themselves. class => { internals => 1, # show internal data structures of classes inherited => 'none', # show inherited methods, # can also be 'all', 'private', or 'public'. universal => 1, # include UNIVERSAL methods in inheritance list parents => 1, # show parents, if there are any linear_isa => 'auto', # show the entire @ISA, linearized, whenever # the object has more than one parent. Can # also be set to 1 (always show) or 0 (never). expand => 1, # how deep to traverse the object (in case # it contains other objects). Defaults to # 1, meaning expand only itself. Can be any # number, 0 for no class expansion, and 'all' # to expand everything. sort_methods => 1, # sort public and private methods show_methods => 'all' # method list. Also 'none', 'public', 'private' }, }; Note: setting C to C<0> will also set C and C to C<0>. =head1 FILTERS Data::Printer offers you the ability to use filters to override any kind of data display. The filters are placed on a hash, where keys are the types - or class names - and values are anonymous subs that receive two arguments: the item itself as first parameter, and the properties hashref (in case your filter wants to read from it). This lets you quickly override the way Data::Printer handles and displays data types and, in particular, objects. use Data::Printer filters => { 'DateTime' => sub { $_[0]->ymd }, 'HTTP::Request' => sub { $_[0]->uri }, }; Perl types are named as C calls them: I, I, I, I, I, I and I. As for objects, just use the class' name, as shown above. As of version 0.13, you may also use the '-class' filter, which will be called for all non-perl types (objects). Your filters are supposed to return a defined value (usually, the string you want to print). If you don't, Data::Printer will let the next filter of that same type have a go, or just fallback to the defaults. You can also use an array reference to pass more than one filter for the same type or class. B: If you plan on calling C from I an inline filter, please make sure you are passing only REFERENCES as arguments. See L below. You may also like to specify standalone filter modules. Please see L for further information on a more powerful filter interface for Data::Printer, including useful filters that are shipped as part of this distribution. =head1 MAKING YOUR CLASSES DDP-AWARE (WITHOUT ADDING ANY DEPS) Whenever printing the contents of a class, Data::Printer first checks to see if that class implements a sub called '_data_printer' (or whatever you set the "class_method" option to in your settings, see L below). If a sub with that exact name is available in the target object, 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, $properties) = @_; return 'Hey, no peeking! But foo contains ' . $self->foo; } Notice you don't have to depend on Data::Printer at all, just write your sub and it will use that to pretty-print your objects. If you want to use colors and filter helpers, and still not add Data::Printer to your dependencies, remember you can import them during runtime: sub _data_printer { require Data::Printer::Filter; Data::Printer::Filter->import; # now we have 'indent', outdent', 'linebreak', 'p' and 'colored' my ($self, $properties) = @_; ... } Having a filter for that particular class will of course override this setting. =head1 CONFIGURATION FILE (RUN CONTROL) Data::Printer tries to let you easily customize as much as possible regarding the visualization of your data structures and objects. But we don't want you to keep repeating yourself every time you want to use it! To avoid this, you can simply create a file called C<.dataprinter> in your home directory (usually C in Linux), and put your configuration hash reference in there. This way, instead of doing something like: use Data::Printer { colour => { array => 'bright_blue', }, filters => { 'Catalyst::Request' => sub { my $req = shift; return "Cookies: " . p($req->cookies) }, }, }; You can create a .dataprinter file that looks like this: { colour => { array => 'bright_blue', }, filters => { 'Catalyst::Request' => sub { my $req = shift; return "Cookies: " . p($req->cookies) }, }, }; Note that all we did was remove the "use Data::Printer" bit when writing the C<.dataprinter> file. From then on all you have to do while debugging scripts is: use Data::Printer; and it will load your custom settings every time :) =head2 Loading RC files in custom locations If your RC file is somewhere other than C<.dataprinter> in your home dir, you can load whichever file you want via the C<'rc_file'> parameter: use Data::Printer rc_file => '/path/to/my/rcfile.conf'; You can even set this to undef or to a non-existing file to disable your RC file at will. The RC file location can also be specified with the C environment variable. Using C in code will override the environment variable. =head2 RC File Security The C<.dataprinter> RC file is nothing but a Perl hash that gets C'd back into the code. This means that whatever is in your RC file B. This can be quite worrying if you're not the one in control of the RC file. For this reason, Data::Printer takes extra precaution before loading the file: =over 4 =item * The file has to be in your home directory unless you specifically point elsewhere via the 'C' property or the DATAPRINTERRC environment variable; =item * The file B be a plain file, never a symbolic link, named pipe or socket; =item * The file B be owned by you (i.e. the effective user id that ran the script using Data::Printer); =item * The file B be read-only for everyone but your user. This usually means permissions C<0644>, C<0640> or C<0600> in Unix-like systems. B; =item * The file will B be loaded in Taint mode, unless you specifically load Data::Printer with the 'allow_tainted' option set to true. And even if you do that, Data::Printer will still issue a warning before loading the file. But seriously, don't do that. =back Failure to comply with the security rules above will result in the RC file not being loaded (likely with a warning on what went wrong). =head1 THE "DDP" PACKAGE ALIAS You're likely to add/remove Data::Printer from source code being developed and debugged all the time, and typing it might feel too long. Because of this, the 'DDP' package is provided as a shorter alias to Data::Printer: use DDP; p %some_var; =head1 CALLER INFORMATION If you set caller_info to a true value, Data::Printer will prepend every call with an informational message. For example: use Data::Printer caller_info => 1; my $var = 42; p $var; will output something like: Printing in line 4 of myapp.pl: 42 The default message is C<< 'Printing in line __LINE__ of __FILENAME__:' >>. The special strings C<__LINE__>, C<__FILENAME__> and C<__PACKAGE__> will be interpolated into their according value so you can customize them at will: use Data::Printer caller_info => 1, caller_message => "Okay, __PACKAGE__, let's dance!" color => { caller_info => 'bright_red', }; As shown above, you may also set a color for "caller_info" in your color hash. Default is cyan. =head1 EXPERIMENTAL FEATURES The following are volatile parts of the API which are subject to change at any given version. Use them at your own risk. =head2 Local Configuration (experimental!) You can override global configurations by writing them as the second parameter for p(). For example: p( %var, color => { hash => 'green' } ); =head2 Filter classes As of Data::Printer 0.11, you can create complex filters as a separate module. Those can even be uploaded to CPAN and used by other people! See L for further information. =head1 CAVEATS You can't pass more than one variable at a time. p($foo, $bar); # wrong p($foo); # right 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 The default mode is to use prototypes, in which you are supposed to pass variables, not anonymous structures: p( { foo => 'bar' } ); # wrong p %somehash; # right p $hash_ref; # also right To pass anonymous structures, set "use_prototypes" option to 0. But remember you'll have to pass your variables as references: use Data::Printer use_prototypes => 0; p( { foo => 'bar' } ); # was wrong, now is right. p( %foo ); # was right, but fails without prototypes p( \%foo ); # do this instead If you are using inline filters, and calling p() (or whatever name you aliased it to) from inside those filters, you B pass the arguments to C as a reference: use Data::Printer { filters => { ARRAY => sub { my $listref = shift; my $string = ''; foreach my $item (@$listref) { $string .= p( \$item ); # p( $item ) will not work! } return $string; }, }, }; This happens because your filter function is compiled I Data::Printer itself loads, so the filter does not see the function prototype. As a way to avoid unpleasant surprises, if you forget to pass a reference, Data::Printer will generate an exception for you with the following message: 'When calling p() without prototypes, please pass arguments as references' Another way to avoid this is to use the much more complete L interface for standalone filters. =head1 EXTRA TIPS =head2 Circumventing prototypes The C function uses prototypes by default, allowing you to say: p %var; instead of always having to pass references, like: p \%var; There are cases, however, where you may want to pass anonymous structures, like: p { foo => $bar }; # this blows up, don't use and because of prototypes, you can't. If this is your case, just set "use_prototypes" option to 0. Note, with this option, you B have to pass your variables as references: use Data::Printer use_prototypes => 0; p { foo => 'bar' }; # doesn't blow up anymore, works just fine. p %var; # but now this blows up... p \%var; # ...so do this instead p [ $foo, $bar, \@baz ]; # this way you can even pass # several variables at once Versions prior to 0.17 don't have the "use_prototypes" option. If you're stuck in an older version you can write C<&p()> instead of C to circumvent prototypes and pass elements (including anonymous variables) as B. This notation, however, requires enclosing parentheses: &p( { foo => $bar } ); # this is ok, use at will &p( \"DEBUGGING THIS BIT" ); # this works too Or you could just create a very simple wrapper function: sub pp { p @_ }; And use it just as you use C. =head2 Minding the return value of p() I<< (contributed by Matt S. Trout (mst)) >> There is a reason why explicit return statements are recommended unless you know what you're doing. By default, Data::Printer's return value depends on how it was called. When not in void context, it returns the serialized form of the dump. It's tempting to trust your own p() calls with that approach, but if this is your I statement in a function, you should keep in mind your debugging code will behave differently depending on how your function was called! To prevent that, set the C property to either 'void' or 'pass'. You won't be able to retrieve the dumped string but, hey, who does that anyway :) Assuming you have set the pass-through ('pass') property in your C<.dataprinter> file, another stunningly useful thing you can do with it is change code that says: return $obj->foo; with: use DDP; return p $obj->foo; You can even add it to chained calls if you wish to see the dump of a particular state, changing this: $obj->foo->bar->baz; to: $obj->foo->DDP::p->bar->baz And things will "Just Work". =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 great advantage that if you leave one p() call in by accident, it will fail 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 wish 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 famous ones out there is L. If you use it, now you can also see its output with Data::Printer! 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( p($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 Unified interface for Data::Printer and other debug formatters I<< (contributed by Kevin McGrath (catlgrep)) >> If you are porting your code to use Data::Printer instead of Data::Dumper or similar, you can just replace: use Data::Dumper; with: use Data::Printer alias => 'Dumper'; # use Data::Dumper; making sure to provide Data::Printer with the proper alias for the previous dumping function. If, however, you want a really unified approach where you can 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(p $_->{args}[1]) if $_->{args}[1] } call "MyObj::name" & !cflow("MyObj::read")' myapp.pl You can check you 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. =head2 creating fiddling filters I<< (contributed by dirk) >> Sometimes, you may want to take advantage of Data::Printer's original dump, but add/change some of the original data to enhance your debugging ability. Say, for example, you have an C object you want to print but the content is encoded. The basic approach, of course, would be to just dump the decoded content: use DDP filter { 'HTTP::Response' => sub { p( \shift->decoded_content, %{shift} ); }; But what if you want to see the rest of the original object? Dumping it would be a no-go, because you would just recurse forever in your own filter. Never fear! When you create a filter in Data::Printer, you're not replacing the original one, you're just stacking yours on top of it. To forward your data to the original filter, all you have to do is return an undefined value. This means you can rewrite your C filter like so, if you want: use DDP filters => { 'HTTP::Response' => sub { my ($res, $p) = @_; # been here before? Switch to original handler return if exists $res->{decoded_content}; # first timer? Come on in! my $clone = $res->clone; $clone->{decoded_content} = $clone->decoded_content; return p($clone, %$p); } }; And voilà! Your fiddling filter now works like a charm :) =head1 BUGS If you find any, please file a bug report. =head1 SEE ALSO L L L L L L =head1 AUTHOR Breno G. de Oliveira C<< >> =head1 CONTRIBUTORS Many thanks to everyone that helped design and develop this module with patches, bug reports, wishlists, comments and tests. They are (alphabetically): =over 4 =item * Adam Rosenstein =item * Allan Whiteford =item * Andreas König =item * Andy Bach =item * Árpád Szász =item * Athanasios Douitsis (aduitsis) =item * Baldur Kristinsson =item * brian d foy =item * Chad Granum (exodist) =item * Chris Prather (perigrin) =item * David D Lowe (Flimm) =item * David Golden (xdg) =item * David Precious (bigpresh) =item * David Raab =item * Damien Krotkine (dams) =item * Denis Howe =item * Dotan Dimet =item * Eden Cardim (edenc) =item * Elliot Shank (elliotjs) =item * Fernando Corrêa (SmokeMachine) =item * Fitz Elliott =item * Frew Schmidt (frew) =item * Ivan Bessarabov (bessarabv) =item * J Mash =item * Jay Allen (jayallen) =item * Jesse Luehrs (doy) =item * Joel Berger (jberger) =item * John S. Anderson (genehack) =item * Kartik Thakore (kthakore) =item * Kevin Dawson (bowtie) =item * Kevin McGrath (catlgrep) =item * Kip Hampton (ubu) =item * Marcel Grünauer (hanekomu) =item * Marco Masetti (grubert65) =item * Mark Fowler (Trelane) =item * Matt S. Trout (mst) =item * Maxim Vuets =item * Michael Conrad =item * Mike Doherty (doherty) =item * Nuba Princigalli (nuba) =item * Olaf Alders (oalders) =item * Paul Evans (LeoNerd) =item * Pedro Melo (melo) =item * Przemysław Wesołek (jest) =item * Rebecca Turner (iarna) =item * Renato Cron (renatoCRON) =item * Ricardo Signes (rjbs) =item * Rob Hoelz (hoelzro) =item * sawyer =item * Sebastian Willing (Sewi) =item * Sergey Aleynikov (randir) =item * Stanislaw Pusep (syp) =item * Stephen Thirlwall (sdt) =item * sugyan =item * Tatsuhiko Miyagawa (miyagawa) =item * Thomas Sibley (tsibley) =item * Tim Heaney (oylenshpeegul) =item * Torsten Raudssus (Getty) =item * Tokuhiro Matsuno (tokuhirom) =item * vividsnow =item * Wesley Dal`Col (blabos) =item * Yanick Champoux (yanick) =back If I missed your name, please drop me a line! =head1 LICENSE AND COPYRIGHT Copyright 2011 Breno G. de Oliveira C<< >>. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. =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-0.38/lib/Data/Printer/Filter/000755 000765 000024 00000000000 12652453305 020333 5ustar00garustaff000000 000000 Data-Printer-0.38/lib/Data/Printer/Filter.pm000644 000765 000024 00000023754 12652263010 020674 0ustar00garustaff000000 000000 package Data::Printer::Filter; use strict; use warnings; use Clone::PP qw(clone); require Carp; require Data::Printer; my %_filters_for = (); my %_extras_for = (); sub import { my $caller = caller; my $id = Data::Printer::_object_id( \$caller ); my %properties = (); my $filter = sub { my ($type, $code, $extra) = @_; Carp::croak( "syntax: filter 'Class', sub { ... }" ) unless $type and $code and ref $code eq 'CODE'; if ($extra) { Carp::croak( 'extra filter field must be a hashref' ) unless ref $extra and ref $extra eq 'HASH'; $_extras_for{$id}{$type} = $extra; } else { $_extras_for{$id}{$type} = {}; } unshift @{ $_filters_for{$id}{$type} }, sub { my ($item, $p) = @_; # send our closured %properties var instead # so newline(), indent(), etc can work it %properties = %{ clone $p }; delete $properties{filters}; # no need to rework filters $code->($item, \%properties); }; }; my $filters = sub { return $_filters_for{$id}; }; my $extras = sub { return $_extras_for{$id}; }; my $newline = sub { return $properties{_linebreak} . (' ' x $properties{_current_indent}); }; my $indent = sub { $properties{_current_indent} += $properties{indent}; $properties{_depth}++; return; }; my $outdent = sub { $properties{_current_indent} -= $properties{indent}; $properties{_depth}--; return; }; my $imported_p = sub (\[@$%&];%) { my ($item, $p) = @_; return Data::Printer::p( $item, %properties ); }; my $imported_np = sub (\[@$%&];%) { my ($item, $p) = @_; return Data::Printer::np( $item, %properties ); }; { no strict 'refs'; *{"$caller\::filter"} = $filter; *{"$caller\::indent"} = $indent; *{"$caller\::outdent"} = $outdent; *{"$caller\::newline"} = $newline; *{"$caller\::np"} = $imported_np; *{"$caller\::p"} = $imported_p; *{"$caller\::_filter_list"} = $filters; *{"$caller\::_extra_options"} = $extras; } }; 1; __END__ =head1 NAME Data::Printer::Filter - Create powerful stand-alone filters for Data::Printer =head1 SYNOPSIS Create your filter module: package Data::Printer::Filter::MyFilter; use strict; use warnings; use Data::Printer::Filter; # type filter filter 'SCALAR', sub { my ($ref, $properties) = @_; my $val = $$ref; if ($val > 100) { return 'too big!!'; } else { return $val; } }; # you can also filter objects of any class filter 'Some::Class', sub { my ($object, $properties) = @_; return $ref->some_method; # or whatever # see 'HELPER FUNCTIONS' below for # customization options, including # proper indentation. }; 1; Later, in your main code: use Data::Printer { filters => { -external => [ 'MyFilter', 'OtherFilter' ], # you can still add regular (inline) filters SCALAR => sub { ... } }, }; =head1 WARNING - ALPHA CODE (VERY LOOSE API) We are still experimenting with the standalone filter syntax, so B<< filters written like so may break in the future without any warning! >> B<< If you care, or have any suggestions >>, please drop me a line via RT, email, or find me ('garu') on irc.perl.org. You have been warned. =head1 DESCRIPTION L lets you add custom filters to display data structures and objects, by either specifying them during "use", in the C<.dataprinter> configuration file, or even in runtime customizations. But there are times when you may want to group similar filters, or make them standalone in order to be easily reutilized in other environments and applications, or even upload them to CPAN so other people can benefit from a cleaner - and clearer - object/structure dump. This is where C comes in. It B into your package's namespace the L function, along with some helpers to create custom filter packages. L recognizes all filters in the C namespace. You can load them by specifying them in the '-external' filter list (note the dash, to avoid clashing with a potential class or pragma labelled 'external'): use Data::Printer { filters => { -external => 'MyFilter', }, }; This will load all filters defined by the C module. If there are more than one filter, use an array reference instead: -external => [ 'MyFilter', 'MyOtherFilter' ] B<< IMPORTANT: THIS WAY OF LOADING EXTERNAL PLUGINS IS EXPERIMENTAL AND SUBJECT TO SUDDEN CHANGE! IF YOU CARE, AND/OR HAVE IDEAS ON A BETTER API, PLEASE LET US KNOW >> =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 properties in effect (so you can inspect for certain options, etc). The subroutine is expected to return a string containing whatever it wants C to display on screen. =head2 p() This is the same as C's p(), only you can't rename it. You can use this to throw some data structures back at C and use the results in your own return string - like when manipulating hashes or arrays. =head2 newline() This helper returns a string using the linebreak as specified by the caller's settings. For instance, it provides the proper indentation level of spaces for you and considers the C option to avoid line breakage. In other words, if you do this: filter ARRAY => { my ($ref, $p) = @_; my $string = "Hey!! I got this array:"; foreach my $val (@$ref) { $string .= newline . p($val); } return $string; }; ... your C returns will be properly indented, vertically aligned to your level of the data structure, while simply using "\n" would just make things messy if your structure has more than one level of depth. =head2 indent() =head2 outdent() These two helpers let you increase/decrease the indentation level of your data display, for C and nested C calls inside your filters. For example, the filter defined in the C explanation above would show the values on the same (vertically aligned) level as the "I got this array" message. If you wanted your array to be one level further deep, you could use this instead: filter ARRAY => { my ($ref, $p) = @_; my $string = "Hey!! I got this array:"; indent; foreach my $val (@$ref) { $string .= newline . p($val); } outdent; return $string; }; =head1 COLORIZATION You can use L's C' for string colorization. Data::Printer will automatically enable/disable colors for you. =head1 EXISTING FILTERS This is meant to provide a complete list of standalone filters for Data::Printer available on CPAN. If you write one, please put it under the C namespace, and drop me a line so I can add it to this list! =head2 Databases L provides filters for Database objects. So far only DBI is covered, but more to come! =head2 Dates & Times L pretty-prints several date and time objects (not just DateTime) for you on the fly, including duration/delta objects! =head2 Digest L displays a string containing the hash of the actual message digest instead of the object. Works on C, C, any digest class that inherits from C and some others that implement their own thing! =head2 ClassicRegex L changes the way Data::Printer dumps regular expressions, doing it the classic C way that got popular in C. =head2 JSON L, by Nuba Princigalli, lets you see your JSON structures replacing boolean objects with simple C strings! =head2 URIs L filters through several L manipulation classes and displays the URI as a colored string. A very nice addition by Stanislaw Pusep (SYP). =head2 Perl Data Language (PDL) L, by Zakariyya Mughal, lets you quickly see the relevant contents of a PDL variable. =head1 USING MORE THAN ONE FILTER FOR THE SAME TYPE/CLASS As of version 0.13, standalone filters let you stack together filters for the same type or class. Filters of the same type are called in order, until one of them returns a string. This lets you have several filters inspecting the same given value until one of them decides to actually treat it somehow. If your filter caught a value and you don't want to treat it, simply return and the next filter will be called. If there are no other filters for that particular class or type available, the standard Data::Printer calls will be used. For example: filter SCALAR => sub { my ($ref, $properties) = @_; if ( Scalar::Util::looks_like_number $$ref ) { return sprintf "%.8d", $$ref; } return; # lets the other SCALAR filter have a go }; filter SCALAR => sub { my ($ref, $properties) = @_; return qq["$$ref"]; }; Note that this "filter stack" is not possible on inline filters, since it's a hash and keys with the same name are overwritten. Instead, you can pass them as an array reference: use Data::Printer filters => { SCALAR => [ sub { ... }, sub { ... } ], }; =head1 SEE ALSO L =head1 LICENSE AND COPYRIGHT Copyright 2011 Breno G. de Oliveira C<< >>. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. Data-Printer-0.38/lib/Data/Printer/Filter/DateTime.pm000644 000765 000024 00000006115 12532166513 022367 0ustar00garustaff000000 000000 package Data::Printer::Filter::DateTime; use strict; use warnings; use Data::Printer::Filter; use Term::ANSIColor; filter 'Time::Piece', sub { return _format($_[0]->cdate, @_ ); }; filter 'DateTime', sub { my ($obj, $p) = @_; my $string = "$obj"; if ( not exists $p->{datetime}{show_timezone} or $p->{datetime}{show_timezone} ) { $string .= ' [' . $obj->time_zone->name . ']'; } return _format( $string, @_ ); }; # DateTime::TimeZone filters filter '-class' => sub { my ($obj, $properties) = @_; if ( $obj->isa('DateTime::TimeZone' ) ) { return $obj->name; } else { return; } }; filter 'DateTime::Incomplete', sub { return _format( $_[0]->iso8601, @_ ); }; filter 'DateTime::Duration', sub { my ($object, $p) = @_; my @dur = $object->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 'DateTime::Tiny', sub { return _format( $_[0]->as_string, @_ ); }; filter 'Class::Date', sub { my ($object, $p) = @_; my $string = $object->strftime("%Y-%m-%d %H:%M:%S") . " [" . $object->tzdst . "]"; return _format( $string, @_ ); }; filter 'Date::Calc::Object', sub { return _format( $_[0]->string(2), @_ ); }; filter 'Date::Pcalc::Object', sub { return _format( $_[0]->string(2), @_ ); }; filter 'Date::Handler', sub { return _format( "$_[0]", @_ ); }; filter 'Date::Handler::Delta', sub { return _format( $_[0]->AsScalar, @_ ); }; sub _format { my ($str, $obj, $p) = @_; if ( $p->{datetime}{show_class_name} ) { $str .= ' (' . ref($obj) . ')'; } my $color = $p->{color}{datetime}; $color = 'bright_green' unless defined $color; return colored( $str, $color ); } 1; __END__ =head1 NAME Data::Printer::Filter::DateTime - pretty-printing date and time objects (not just DateTime!) =head1 SYNOPSIS In your program: use Data::Printer filters => { -external => [ 'DateTime' ], }; or, in your C<.dataprinter> file: { filters => { -external => [ 'DateTime' ], }, }; You can also setup color and display details: use Data::Printer filters => { -external => [ 'DateTime' ], }, color => { datetime => 'bright_green', } datetime => { show_class_name => 1, # default is 0 show_timezone => 0, # default is 1 (only works for DateTime objects) }, }; =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 =item * L =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. =head1 SEE ALSO L Data-Printer-0.38/lib/Data/Printer/Filter/DB.pm000644 000765 000024 00000013376 12652255310 021164 0ustar00garustaff000000 000000 package Data::Printer::Filter::DB; use strict; use warnings; use Data::Printer::Filter; use Term::ANSIColor; filter 'DBI::db', sub { my ($dbh, $p) = @_; my $name = $dbh->{Driver}{Name}; my $string = "$name Database Handle (" . ($dbh->{Active} ? colored('connected', 'bright_green') : colored('disconnected', 'bright_red')) . ') {' ; indent; my %dsn = split( /[;=]/, $dbh->{Name} ); foreach my $k (keys %dsn) { $string .= newline . "$k: " . $dsn{$k}; } $string .= newline . 'Auto Commit: ' . $dbh->{AutoCommit}; my $kids = $dbh->{Kids}; $string .= newline . 'Statement Handles: ' . $kids; if ($kids > 0) { $string .= ' (' . $dbh->{ActiveKids} . ' active)'; } if ( defined $dbh->err ) { $string .= newline . 'Error: ' . $dbh->errstr; } $string .= newline . 'Last Statement: ' . colored( ($dbh->{Statement} || '-'), 'bright_yellow'); outdent; $string .= newline . '}'; return $string; }; filter 'DBI::st', sub { my ($sth, $properties) = @_; my $str = colored( ($sth->{Statement} || '-'), 'bright_yellow'); if ($sth->{NUM_OF_PARAMS} > 0) { my $values = $sth->{ParamValues}; if ($values) { $str .= ' (' . join(', ', map { my $v = $values->{$_}; $v || 'undef'; } 1 .. $sth->{NUM_OF_PARAMS} ) . ')'; } else { $str .= colored(' (bindings unavailable)', 'yellow'); } } return $str; }; # DBIx::Class filters filter '-class' => sub { my ($obj, $properties) = @_; # TODO: if it's a Result, show columns and relationships (anything that # doesn't involve touching the database if ( $obj->isa('DBIx::Class::Schema') ) { return ref($obj) . ' DBIC Schema with ' . p( $obj->storage->dbh ); # TODO: show a list of all class_mappings available for the schema # (a.k.a. tables) } elsif ( grep { $obj->isa($_) } qw(DBIx::Class::ResultSet DBIx::Class::ResultSetColumn) ) { my $str = colored( ref($obj), $properties->{color}{class} ); $str .= ' (' . $obj->result_class . ')' if $obj->can( 'result_class' ); if (my $query_data = $obj->as_query) { my @query_data = @$$query_data; indent; my $sql = shift @query_data; $str .= ' {' . newline . colored($sql, 'bright_yellow') . newline . join ( newline, map { $_->[1] . ' (' . $_->[0]{sqlt_datatype} . ')' } @query_data ) ; outdent; $str .= newline . '}'; } return $str; } else { return; } }; 1; __END__ =head1 NAME Data::Printer::Filter::DB - pretty printing database objects =head1 SYNOPSIS In your program: use Data::Printer filters => { -external => [ 'DB' ], }; or, in your C<.dataprinter> file: { filters => { -external => [ 'DB' ], }, }; =head1 DESCRIPTION This is a filter plugin for L. It filters through L's handlers (dbh) and statement (sth) objects displaying relevant information for the user. It also filters any object which inherits from L, L or L. =head2 DBI Sample Output L is an extremely powerful and complete database interface. But it does a lot of magic under the hood, making their objects somewhat harder to debug. This filter aims to fix that :) For instance, say you want to debug something like this: use DBI; my $dbh = DBI->connect('dbi:DBM(RaiseError=1):', undef, undef ); A regular Data::Dumper output gives you absolutely nothing: $VAR1 = bless( {}, 'DBI::db' ); L makes it better, but only to debug the class itself, not helpful at all to see its contents and debug your own code: DBI::db { Parents DBI::common Linear @ISA DBI::db, DBI::common public methods (48) : begin_work, clone, column_info, commit, connected, data_sources, disconnect, do, foreign_key_info, get_info, last_insert_id, ping, prepare, prepare_cached, preparse, primary_key, primary_key_info, quote, quote_identifier, rollback, rows, selectall_arrayref, selectall_hashref, selectcol_arrayref, selectrow_array, selectrow_arrayref, selectrow_hashref, sqlite_backup_from_file, sqlite_backup_to_file, sqlite_busy_timeout, sqlite_collation_needed, sqlite_commit_hook, sqlite_create_aggregate, sqlite_create_collation, sqlite_create_function, sqlite_enable_load_extension, sqlite_last_insert_rowid, sqlite_progress_handler, sqlite_register_fts3_perl_tokenizer, sqlite_rollback_hook, sqlite_set_authorizer, sqlite_update_hook, statistics_info, table_info, tables, take_imp_data, type_info, type_info_all private methods (0) internals: { } } Fear no more! If you use this filter, here's what you'll see: SQLite Database Handle (connected) { dbname: file.db Auto Commit: 1 Statement Handles: 0 Last Statement: - } Much better, huh? :) Statement handlers are even better. Imagine you continued your code with something like: my $sth = $dbh->prepare('SELECT * FROM foo WHERE bar = ?'); $sth->execute(42); With this filter, instead of an empty dump or full method information, you'll get exactly what you came for: 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. =head1 SEE ALSO L, L Data-Printer-0.38/lib/Data/Printer/Filter/Digest.pm000644 000765 000024 00000006220 12532166513 022107 0ustar00garustaff000000 000000 package Data::Printer::Filter::Digest; use strict; use warnings; use Data::Printer::Filter; use Term::ANSIColor; foreach my $digest ( qw(Digest::MD2 Digest::MD4) ) { filter $digest => \&_print_digest; } filter '-class', sub { my ($obj, $p) = @_; return unless $obj->isa( 'Digest::base' ); return _print_digest( $obj, $p ); }; sub _print_digest { my ($obj, $p) = @_; my $digest = $obj->clone->hexdigest; my $str = $digest; my $ref = ref $obj; if ( $p->{digest}{show_class_name} ) { $str .= " ($ref)"; } unless ( exists $p->{digest}{show_reset} and !$p->{digest}{show_reset} ) { if ($digest eq $ref->new->hexdigest) { $str .= ' [reset]'; } } my $color = $p->{color}{digest}; $color = 'bright_green' unless defined $color; return colored( $str, $color ); } 1; __END__ =head1 NAME Data::Printer::Filter::Digest - pretty-printing MD5, SHA and friends =head1 SYNOPSIS In your program: use Data::Printer filters => { -external => [ 'Digest' ], }; or, in your C<.dataprinter> file: { filters => { -external => [ 'Digest' ], }, }; You can also setup color and display details: use Data::Printer filters => { -external => [ 'Digest' ], }, color => { digest => 'bright_green', } digest => { show_class_name => 0, # default. show_reset => 1, # default. }, }; =head1 DESCRIPTION This is a filter plugin for L. It filters through several digest classes and displays their current value in hexadecimal format as a string. =head2 Parsed Modules =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 Set this to true to display the class name right next to the hexadecimal digest. Default is 0 (false). =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 cloned 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-0.38/examples/try_me.pl000644 000765 000024 00000001332 12532166513 017514 0ustar00garustaff000000 000000 #!/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::SampleClass; 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, }, regexp => qr/foo.*bar/i, glob => \*STDOUT, code => sub { return 42 }, class => $obj, ); $sample{ref} = \%sample; weaken $sample{ref}; use DDP; p %sample;