r59647 - in /branches/upstream/libdata-dump-perl/current: Changes MANIFEST META.yml Makefile.PL README lib/Data/Dump.pm lib/Data/Dump/FilterContext.pm lib/Data/Dump/Filtered.pm t/dump.t t/filtered.t t/hash.t t/tied.t
eloy at users.alioth.debian.org
eloy at users.alioth.debian.org
Mon Jun 21 10:03:35 UTC 2010
Author: eloy
Date: Mon Jun 21 10:03:06 2010
New Revision: 59647
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=59647
Log:
[svn-upgrade] new version libdata-dump-perl (1.17)
Added:
branches/upstream/libdata-dump-perl/current/lib/Data/Dump/FilterContext.pm
branches/upstream/libdata-dump-perl/current/lib/Data/Dump/Filtered.pm
branches/upstream/libdata-dump-perl/current/t/filtered.t
branches/upstream/libdata-dump-perl/current/t/hash.t
Modified:
branches/upstream/libdata-dump-perl/current/Changes
branches/upstream/libdata-dump-perl/current/MANIFEST
branches/upstream/libdata-dump-perl/current/META.yml
branches/upstream/libdata-dump-perl/current/Makefile.PL
branches/upstream/libdata-dump-perl/current/README
branches/upstream/libdata-dump-perl/current/lib/Data/Dump.pm
branches/upstream/libdata-dump-perl/current/t/dump.t
branches/upstream/libdata-dump-perl/current/t/tied.t
Modified: branches/upstream/libdata-dump-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libdata-dump-perl/current/Changes?rev=59647&op=diff
==============================================================================
--- branches/upstream/libdata-dump-perl/current/Changes (original)
+++ branches/upstream/libdata-dump-perl/current/Changes Mon Jun 21 10:03:06 2010
@@ -1,3 +1,41 @@
+2010-06-12 Gisle Aas <gisle at ActiveState.com>
+
+ Release 1.17
+
+ Fix dump of "1\n" (the newline was lost) [RT#56595]
+
+ Start using the range operator to shorten list dumps.
+ For instance dump(1,2,3,4,5) now returns '(1 .. 5)'.
+
+ CODE references now dumped as 'sub { ... }'.
+ Potetential compatibility issue as perl-5.12 or better
+ to eval such strings.
+
+ Fix how multiline hash values are indented.
+
+ Make indentation configurable
+
+ Improved documentation
+
+
+
+2010-06-09 Gisle Aas <gisle at ActiveState.com>
+
+ Release 1.16
+
+ Add support for filter callbacks
+ - filters can modify how selected objects are dumped
+
+ Various enhancements to how/when hash keys are quoted
+ - don't quote keywords
+ - don't quote words prefixed with "-"
+ - don't quote long identifier keys
+ - quote all hash keys if one needs quoting for better alignment
+
+ Use case-insensitive sorting for hash keys
+
+
+
2009-07-26 Gisle Aas <gisle at ActiveState.com>
Release 1.15
Modified: branches/upstream/libdata-dump-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libdata-dump-perl/current/MANIFEST?rev=59647&op=diff
==============================================================================
--- branches/upstream/libdata-dump-perl/current/MANIFEST (original)
+++ branches/upstream/libdata-dump-perl/current/MANIFEST Mon Jun 21 10:03:06 2010
@@ -1,13 +1,17 @@
Changes
lib/Data/Dump.pm
lib/Data/Dump/Trace.pm
+lib/Data/Dump/Filtered.pm
+lib/Data/Dump/FilterContext.pm
Makefile.PL
MANIFEST
README
t/dd.t
t/dump.t
t/eval.t
+t/filtered.t
t/glob.t
+t/hash.t
t/quote-unicode.t
t/quote.t
t/ref.t
Modified: branches/upstream/libdata-dump-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libdata-dump-perl/current/META.yml?rev=59647&op=diff
==============================================================================
--- branches/upstream/libdata-dump-perl/current/META.yml (original)
+++ branches/upstream/libdata-dump-perl/current/META.yml Mon Jun 21 10:03:06 2010
@@ -1,20 +1,27 @@
--- #YAML:1.0
name: Data-Dump
-version: 1.15
-abstract: ~
-author: []
-license: unknown
+version: 1.17
+abstract: Pretty printing of data structures
+author:
+ - Gisle Aas <gisle at activestate.com>
+license: perl
distribution_type: module
configure_requires:
ExtUtils::MakeMaker: 0
build_requires:
- ExtUtils::MakeMaker: 0
-requires: {}
+ Test: 0
+requires:
+ perl: 5.006
+ Symbol: 0
+resources:
+ repository: http://github.com/gisle/data-dump
no_index:
directory:
- t
- inc
-generated_by: ExtUtils::MakeMaker version 6.55_02
+generated_by: ExtUtils::MakeMaker version 6.56
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: 1.4
+recommends:
+ MIME::Base64: 0
Modified: branches/upstream/libdata-dump-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libdata-dump-perl/current/Makefile.PL?rev=59647&op=diff
==============================================================================
--- branches/upstream/libdata-dump-perl/current/Makefile.PL (original)
+++ branches/upstream/libdata-dump-perl/current/Makefile.PL Mon Jun 21 10:03:06 2010
@@ -2,6 +2,47 @@
use ExtUtils::MakeMaker;
WriteMakefile(
- NAME => "Data::Dump",
+ NAME => "Data::Dump",
VERSION_FROM => "lib/Data/Dump.pm",
+ ABSTRACT_FROM => "lib/Data/Dump.pm",
+ AUTHOR => 'Gisle Aas <gisle at activestate.com>',
+ LICENSE => "perl",
+ MIN_PERL_VERSION => 5.006,
+ PREREQ_PM => {
+ Symbol => 0,
+ },
+ META_MERGE => {
+ resources => {
+ repository => 'http://github.com/gisle/data-dump',
+ },
+ recommends => {
+ 'MIME::Base64' => 0,
+ },
+ },
+ BUILD_REQUIRES => {
+ Test => 0,
+ },
);
+
+BEGIN {
+ # compatibility with older versions of MakeMaker
+ my $developer = -d "eg";
+ my %mm_req = (
+ LICENCE => 6.31,
+ META_MERGE => 6.45,
+ META_ADD => 6.45,
+ MIN_PERL_VERSION => 6.48,
+ BUILD_REQUIRES => 6.45,
+ );
+ undef(*WriteMakefile);
+ *WriteMakefile = sub {
+ my %arg = @_;
+ for (keys %mm_req) {
+ unless (eval { ExtUtils::MakeMaker->VERSION($mm_req{$_}) }) {
+ warn "$_ $@" if $developer;
+ delete $arg{$_};
+ }
+ }
+ ExtUtils::MakeMaker::WriteMakefile(%arg);
+ };
+}
Modified: branches/upstream/libdata-dump-perl/current/README
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libdata-dump-perl/current/README?rev=59647&op=diff
==============================================================================
--- branches/upstream/libdata-dump-perl/current/README (original)
+++ branches/upstream/libdata-dump-perl/current/README Mon Jun 21 10:03:06 2010
@@ -34,7 +34,7 @@
The "Data::Dump" module is written by Gisle Aas <gisle at aas.no>, based on
"Data::Dumper" by Gurusamy Sarathy <gsar at umich.edu>.
- Copyright 1998-2000,2003-2004,2008 Gisle Aas.
+ Copyright 1998-2010 Gisle Aas.
Copyright 1996-1998 Gurusamy Sarathy.
This library is free software; you can redistribute it and/or modify it
Modified: branches/upstream/libdata-dump-perl/current/lib/Data/Dump.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libdata-dump-perl/current/lib/Data/Dump.pm?rev=59647&op=diff
==============================================================================
--- branches/upstream/libdata-dump-perl/current/lib/Data/Dump.pm (original)
+++ branches/upstream/libdata-dump-perl/current/lib/Data/Dump.pm Mon Jun 21 10:03:06 2010
@@ -7,43 +7,16 @@
require Exporter;
*import = \&Exporter::import;
@EXPORT = qw(dd ddx);
- at EXPORT_OK = qw(dump pp quote);
-
-$VERSION = "1.15";
+ at EXPORT_OK = qw(dump pp dumpf quote);
+
+$VERSION = "1.17";
$DEBUG = 0;
use overload ();
-use vars qw(%seen %refcnt @dump @fixup %require $TRY_BASE64);
+use vars qw(%seen %refcnt @dump @fixup %require $TRY_BASE64 @FILTERS $INDENT);
$TRY_BASE64 = 50 unless defined $TRY_BASE64;
-
-my %is_perl_keyword = map { $_ => 1 }
-qw( __FILE__ __LINE__ __PACKAGE__ __DATA__ __END__ AUTOLOAD BEGIN CORE
-DESTROY END EQ GE GT INIT LE LT NE abs accept alarm and atan2 bind
-binmode bless caller chdir chmod chomp chop chown chr chroot close
-closedir cmp connect continue cos crypt dbmclose dbmopen defined
-delete die do dump each else elsif endgrent endhostent endnetent
-endprotoent endpwent endservent eof eq eval exec exists exit exp fcntl
-fileno flock for foreach fork format formline ge getc getgrent
-getgrgid getgrnam gethostbyaddr gethostbyname gethostent getlogin
-getnetbyaddr getnetbyname getnetent getpeername getpgrp getppid
-getpriority getprotobyname getprotobynumber getprotoent getpwent
-getpwnam getpwuid getservbyname getservbyport getservent getsockname
-getsockopt glob gmtime goto grep gt hex if index int ioctl join keys
-kill last lc lcfirst le length link listen local localtime lock log
-lstat lt m map mkdir msgctl msgget msgrcv msgsnd my ne next no not oct
-open opendir or ord pack package pipe pop pos print printf prototype
-push q qq qr quotemeta qw qx rand read readdir readline readlink
-readpipe recv redo ref rename require reset return reverse rewinddir
-rindex rmdir s scalar seek seekdir select semctl semget semop send
-setgrent sethostent setnetent setpgrp setpriority setprotoent setpwent
-setservent setsockopt shift shmctl shmget shmread shmwrite shutdown
-sin sleep socket socketpair sort splice split sprintf sqrt srand stat
-study sub substr symlink syscall sysopen sysread sysseek system
-syswrite tell telldir tie tied time times tr truncate uc ucfirst umask
-undef unless unlink unpack unshift untie until use utime values vec
-wait waitpid wantarray warn while write x xor y);
-
+$INDENT = " " unless defined $INDENT;
sub dump
{
@@ -51,6 +24,8 @@
local %refcnt;
local %require;
local @fixup;
+
+ require Data::Dump::FilterContext if @FILTERS;
my $name = "a";
my @dump;
@@ -92,7 +67,7 @@
if (%refcnt || %require) {
$out .= ";\n";
- $out =~ s/^/ /gm; # indent
+ $out =~ s/^/$INDENT/gm;
$out = "do {\n$out}";
}
@@ -117,13 +92,18 @@
print $out;
}
+sub dumpf {
+ require Data::Dump::Filtered;
+ goto &Data::Dump::Filtered::dump_filtered;
+}
+
sub _dump
{
my $ref = ref $_[0];
my $rval = $ref ? $_[0] : \$_[0];
shift;
- my($name, $idx, $dont_remember) = @_;
+ my($name, $idx, $dont_remember, $pclass, $pidx) = @_;
my($class, $type, $id);
if (overload::StrVal($rval) =~ /^(?:([^=]+)=)?([A-Z]+)\(0x([^\)]+)\)$/) {
@@ -137,6 +117,50 @@
$type = "REF" if $ref eq "REF";
}
warn "\$$name(@$idx) $class $type $id ($ref)" if $DEBUG;
+
+ my $out;
+ my $comment;
+ my $hide_keys;
+ if (@FILTERS) {
+ my $pself = "";
+ $pself = fullname("self", [@$idx[$pidx..(@$idx - 1)]]) if $pclass;
+ my $ctx = Data::Dump::FilterContext->new($rval, $class, $type, $ref, $pclass, $pidx, $idx);
+ my @bless;
+ for my $filter (@FILTERS) {
+ if (my $f = $filter->($ctx, $rval)) {
+ if (my $v = $f->{object}) {
+ local @FILTERS;
+ $out = _dump($v, $name, $idx, 1);
+ $dont_remember++;
+ }
+ if (defined(my $c = $f->{bless})) {
+ push(@bless, $c);
+ }
+ if (my $c = $f->{comment}) {
+ $comment = $c;
+ }
+ if (defined(my $c = $f->{dump})) {
+ $out = $c;
+ $dont_remember++;
+ }
+ if (my $h = $f->{hide_keys}) {
+ if (ref($h) eq "ARRAY") {
+ $hide_keys = sub {
+ for my $k (@$h) {
+ return 1 if $k eq $_[0];
+ }
+ return 0;
+ };
+ }
+ }
+ }
+ }
+ push(@bless, "") if defined($out) && !@bless;
+ if (@bless) {
+ $class = shift(@bless);
+ warn "More than one filter callback tried to bless object" if @bless;
+ }
+ }
unless ($dont_remember) {
if (my $s = $seen{$id}) {
@@ -154,8 +178,15 @@
$seen{$id} = [$name, $idx];
}
- my $out;
- if ($type eq "SCALAR" || $type eq "REF" || $type eq "REGEXP") {
+ if ($class) {
+ $pclass = $class;
+ $pidx = @$idx;
+ }
+
+ if (defined $out) {
+ # keep it
+ }
+ elsif ($type eq "SCALAR" || $type eq "REF" || $type eq "REGEXP") {
if ($ref) {
if ($class && $class eq "Regexp") {
my $v = "$rval";
@@ -188,14 +219,14 @@
}
else {
delete $seen{$id} if $type eq "SCALAR"; # will be seen again shortly
- my $val = _dump($$rval, $name, [@$idx, "\$"]);
+ my $val = _dump($$rval, $name, [@$idx, "\$"], 0, $pclass, $pidx);
$out = $class ? "do{\\(my \$o = $val)}" : "\\$val";
}
} else {
if (!defined $$rval) {
$out = "undef";
}
- elsif ($$rval =~ /^-?[1-9]\d{0,9}$/ || $$rval eq "0") {
+ elsif ($$rval =~ /^-?[1-9]\d{0,9}\z/ || $$rval eq "0") {
$out = $$rval;
}
else {
@@ -213,7 +244,7 @@
elsif ($type eq "GLOB") {
if ($ref) {
delete $seen{$id};
- my $val = _dump($$rval, $name, [@$idx, "*"]);
+ my $val = _dump($$rval, $name, [@$idx, "*"], 0, $pclass, $pidx);
$out = "\\$val";
if ($out =~ /^\\\*Symbol::/) {
$require{Symbol}++;
@@ -229,7 +260,7 @@
next if $k eq "SCALAR" && ! defined $$gval; # always there
my $f = scalar @fixup;
push(@fixup, "RESERVED"); # overwritten after _dump() below
- $gval = _dump($gval, $name, [@$idx, "*{$k}"]);
+ $gval = _dump($gval, $name, [@$idx, "*{$k}"], 0, $pclass, $pidx);
$refcnt{$name}++;
my $gname = fullname($name, $idx);
$fixup[$f] = "$gname = $gval"; #XXX indent $gval
@@ -241,7 +272,7 @@
my $tied = tied_str(tied(@$rval));
my $i = 0;
for my $v (@$rval) {
- push(@vals, _dump($v, $name, [@$idx, "[$i]"], $tied));
+ push(@vals, _dump($v, $name, [@$idx, "[$i]"], $tied, $pclass, $pidx));
$i++;
}
$out = "[" . format_list(1, $tied, @vals) . "]";
@@ -256,31 +287,38 @@
my $kstat_sum2 = 0;
my @orig_keys = keys %$rval;
+ if ($hide_keys) {
+ @orig_keys = grep !$hide_keys->($_), @orig_keys;
+ }
my $text_keys = 0;
for (@orig_keys) {
$text_keys++, last unless /^[-+]?(?:0|[1-9]\d*)(?:\.\d+)?\z/;
}
if ($text_keys) {
- @orig_keys = sort @orig_keys;
+ @orig_keys = sort { lc($a) cmp lc($b) } @orig_keys;
}
else {
@orig_keys = sort { $a <=> $b } @orig_keys;
}
+ my $quote;
for my $key (@orig_keys) {
- my $val = \$rval->{$key};
- $key = quote($key) if $is_perl_keyword{$key} ||
- !($key =~ /^[a-zA-Z_]\w{0,19}\z/ ||
- $key =~ /^-?[1-9]\d{0,8}\z/
- );
-
+ next if $key =~ /^-?[a-zA-Z_]\w*\z/;
+ next if $key =~ /^-?[1-9]\d{0,8}\z/;
+ $quote++;
+ last;
+ }
+
+ for my $key (@orig_keys) {
+ my $val = \$rval->{$key}; # capture value before we modify $key
+ $key = quote($key) if $quote;
$kstat_max = length($key) if length($key) > $kstat_max;
$kstat_sum += length($key);
$kstat_sum2 += length($key)*length($key);
push(@keys, $key);
- push(@vals, _dump($$val, $name, [@$idx, "{$key}"], $tied));
+ push(@vals, _dump($$val, $name, [@$idx, "{$key}"], $tied, $pclass, $pidx));
}
my $nl = "";
my $klen_pad = 0;
@@ -310,20 +348,21 @@
}
}
$out = "{$nl";
- $out .= " # $tied$nl" if $tied;
+ $out .= "$INDENT# $tied$nl" if $tied;
while (@keys) {
my $key = shift @keys;
my $val = shift @vals;
- my $pad = " " x ($klen_pad + 6);
- $val =~ s/\n/\n$pad/gm;
- $key = " $key" . " " x ($klen_pad - length($key)) if $nl;
- $out .= " $key => $val,$nl";
+ my $vpad = $INDENT . (" " x ($klen_pad ? $klen_pad + 4 : 0));
+ $val =~ s/\n/\n$vpad/gm;
+ my $kpad = $nl ? $INDENT : " ";
+ $key .= " " x ($klen_pad - length($key)) if $nl;
+ $out .= "$kpad$key => $val,$nl";
}
$out =~ s/,$/ / unless $nl;
$out .= "}";
}
elsif ($type eq "CODE") {
- $out = 'sub { "???" }';
+ $out = 'sub { ... }';
}
else {
warn "Can't handle $type data";
@@ -332,6 +371,12 @@
if ($class && $ref) {
$out = "bless($out, " . quote($class) . ")";
+ }
+ if ($comment) {
+ $comment =~ s/^/# /gm;
+ $comment .= "\n" unless $comment =~ /\n\z/;
+ $comment =~ s/^#[ \t]+\n/\n/;
+ $out = "$comment$out";
}
return $out;
}
@@ -386,11 +431,39 @@
my $paren = shift;
my $comment = shift;
my $indent_lim = $paren ? 0 : 1;
+ if (@_ > 3) {
+ # can we use range operator to shorten the list?
+ my $i = 0;
+ while ($i < @_) {
+ my $j = $i + 1;
+ my $v = $_[$i];
+ while ($j < @_) {
+ # XXX allow string increment too?
+ if ($v eq "0" || $v =~ /^-?[1-9]\d{0,9}\z/) {
+ $v++;
+ }
+ elsif ($v =~ /^"([A-Za-z]{1,3}\d*)"\z/) {
+ $v = $1;
+ $v++;
+ $v = qq("$v");
+ }
+ else {
+ last;
+ }
+ last if $_[$j] ne $v;
+ $j++;
+ }
+ if ($j - $i > 3) {
+ splice(@_, $i, $j - $i, "$_[$i] .. $_[$j-1]");
+ }
+ $i++;
+ }
+ }
my $tmp = "@_";
if ($comment || (@_ > $indent_lim && (length($tmp) > 60 || $tmp =~ /\n/))) {
my @elem = @_;
- for (@elem) { s/^/ /gm; } # indent
- return "\n" . ($comment ? " # $comment\n" : "") .
+ for (@elem) { s/^/$INDENT/gm; }
+ return "\n" . ($comment ? "$INDENT# $comment\n" : "") .
join(",\n", @elem, "");
} else {
return join(", ", @_);
@@ -479,17 +552,17 @@
=head1 SYNOPSIS
- use Data::Dump qw(dump ddx);
+ use Data::Dump qw(dump);
$str = dump(@list);
@copy_of_list = eval $str;
# or use it for easy debug printout
- ddx localtime;
+ use Data::Dump; dd localtime;
=head1 DESCRIPTION
-This module provide functions that takes a list of values as their
+This module provide a few functions that traverse their
argument and produces a string as its result. The string contains
Perl code that, when C<eval>ed, produces a deep copy of the original
arguments.
@@ -502,7 +575,7 @@
Produces:
- (1, [2, 3], { 4 => 5 })
+ "(1, [2, 3], { 4 => 5 })"
If you dump just a little data, it is output on a single line. If
you dump data that is more complex or there is a lot of it, line breaks
@@ -548,7 +621,8 @@
It differs from C<dump($string)> in that it will quote even numbers and
not try to come up with clever expressions that might shorten the
-output.
+output. If a non-scalar argument is provided then it's just stringified
+instead of traversed.
=item dd( ... )
@@ -563,13 +637,43 @@
number where it was called. This is meant to be useful for debug
printouts of state within programs.
+=item dumpf( ..., \&filter )
+
+Short hand for calling the dump_filtered() function of L<Data::Dump::Filtered>.
+This works like dump(), but the last argument should be a filter callback
+function. As objects are visited the filter callback is invoked and it
+can modify how the objects are dumped.
+
=back
+=head1 CONFIGURATION
+
+There are a few global variables that can be set to modify the output
+generated by the dump functions. It's wise to localize the setting of
+these.
+
+=over
+
+=item $Data::Dump::INDENT
+
+This holds the string that's used for indenting multiline data structures.
+It's default value is " " (two spaces). Set it to "" to suppress indentation.
+Setting it to "| " makes for nice visuals even if the dump output then fails to
+be valid Perl.
+
+=item $Data::Dump::TRY_BASE64
+
+How long must a binary string be before we try to use the base64 encoding
+for the dump output. The default is 50. Set it to 0 to disable base64 dumps.
+
+=back
+
=head1 LIMITATIONS
-Code references will be displayed as simply 'sub { "???" }' when
-dumped. Thus, C<eval>ing them will not reproduce the original routine.
+Code references will be dumped as C<< sub { ... } >>. Thus, C<eval>ing them will
+not reproduce the original routine. The C<...>-operator used will also require
+perl-5.12 or better to be evaled.
If you forget to explicitly import the C<dump> function, your code will
core dump. That's because you just called the builtin C<dump> function
@@ -583,23 +687,24 @@
are shared with Sarathy's module.
The C<Data::Dump> module provides a much simpler interface than
-C<Data::Dumper>. No OO interface is available and there are no
-configuration options to worry about (yet :-). The other benefit is
+C<Data::Dumper>. No OO interface is available and there are fewer
+configuration options to worry about. The other benefit is
that the dump produced does not try to set any variables. It only
returns what is needed to produce a copy of the arguments. This means
-that C<dump("foo")> simply returns C<"foo">, and C<dump(1..5)> simply
-returns C<(1, 2, 3, 4, 5)>.
+that C<dump("foo")> simply returns C<'"foo"'>, and C<dump(1..3)> simply
+returns C<'(1, 2, 3)'>.
=head1 SEE ALSO
-L<Data::Dumper>, L<Storable>
+L<Data::Dump::Filtered>, L<Data::Dump::Trace>, L<Data::Dumper>, L<JSON>,
+L<Storable>
=head1 AUTHORS
The C<Data::Dump> module is written by Gisle Aas <gisle at aas.no>, based
on C<Data::Dumper> by Gurusamy Sarathy <gsar at umich.edu>.
- Copyright 1998-2000,2003-2004,2008 Gisle Aas.
+ Copyright 1998-2010 Gisle Aas.
Copyright 1996-1998 Gurusamy Sarathy.
This library is free software; you can redistribute it and/or
Added: branches/upstream/libdata-dump-perl/current/lib/Data/Dump/FilterContext.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libdata-dump-perl/current/lib/Data/Dump/FilterContext.pm?rev=59647&op=file
==============================================================================
--- branches/upstream/libdata-dump-perl/current/lib/Data/Dump/FilterContext.pm (added)
+++ branches/upstream/libdata-dump-perl/current/lib/Data/Dump/FilterContext.pm Mon Jun 21 10:03:06 2010
@@ -1,0 +1,81 @@
+package Data::Dump::FilterContext;
+
+sub new {
+ my($class, $obj, $oclass, $type, $ref, $pclass, $pidx, $idx) = @_;
+ return bless {
+ object => $obj,
+ class => $ref && $oclass,
+ reftype => $type,
+ is_ref => $ref,
+ pclass => $pclass,
+ pidx => $pidx,
+ idx => $idx,
+ }, $class;
+}
+
+sub object_ref {
+ my $self = shift;
+ return $self->{object};
+}
+
+sub class {
+ my $self = shift;
+ return $self->{class} || "";
+}
+
+*is_blessed = \&class;
+
+sub reftype {
+ my $self = shift;
+ return $self->{reftype};
+}
+
+sub is_scalar {
+ my $self = shift;
+ return $self->{reftype} eq "SCALAR";
+}
+
+sub is_array {
+ my $self = shift;
+ return $self->{reftype} eq "ARRAY";
+}
+
+sub is_hash {
+ my $self = shift;
+ return $self->{reftype} eq "HASH";
+}
+
+sub is_code {
+ my $self = shift;
+ return $self->{reftype} eq "CODE";
+}
+
+sub is_ref {
+ my $self = shift;
+ return $self->{is_ref};
+}
+
+sub container_class {
+ my $self = shift;
+ return $self->{pclass} || "";
+}
+
+sub container_self {
+ my $self = shift;
+ return "" unless $self->{pclass};
+ my $idx = $self->{idx};
+ my $pidx = $self->{pidx};
+ return Data::Dump::fullname("self", [@$idx[$pidx..(@$idx - 1)]]);
+}
+
+sub object_isa {
+ my($self, $class) = @_;
+ return $self->{class} && $self->{class}->isa($class);
+}
+
+sub container_isa {
+ my($self, $class) = @_;
+ return $self->{pclass} && $self->{pclass}->isa($class);
+}
+
+1;
Added: branches/upstream/libdata-dump-perl/current/lib/Data/Dump/Filtered.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libdata-dump-perl/current/lib/Data/Dump/Filtered.pm?rev=59647&op=file
==============================================================================
--- branches/upstream/libdata-dump-perl/current/lib/Data/Dump/Filtered.pm (added)
+++ branches/upstream/libdata-dump-perl/current/lib/Data/Dump/Filtered.pm Mon Jun 21 10:03:06 2010
@@ -1,0 +1,193 @@
+package Data::Dump::Filtered;
+
+use Data::Dump ();
+use Carp ();
+
+use base 'Exporter';
+our @EXPORT_OK = qw(add_dump_filter remove_dump_filter dump_filtered);
+
+sub add_dump_filter {
+ my $filter = shift;
+ die unless ref($filter) eq "CODE";
+ push(@Data::Dump::FILTERS, $filter);
+ return $filter;
+}
+
+sub remove_dump_filter {
+ my $filter = shift;
+ @Data::Dump::FILTERS = grep $_ ne $filter, @Data::Dump::FILTERS;
+}
+
+sub dump_filtered {
+ my $filter = pop;
+ if (defined($filter) && ref($filter) ne "CODE") {
+ Carp::croak("Last argument to dump_filtered must be undef or a code reference");
+ }
+ local @Data::Dump::FILTERS = ($filter ? $filter : ());
+ return &Data::Dump::dump;
+}
+
+1;
+
+=head1 NAME
+
+Data::Dump::Filtered - Pretty printing with filtering
+
+=head1 DESCRIPTION
+
+The following functions are provided:
+
+=over
+
+=item add_dump_filter( \&filter )
+
+This registers a filter function to be used by the regular Data::Dump::dump()
+function. By default no filters are active.
+
+Since registering filters has a global effect is might be more appropriate
+to use the dump_filtered() function instead.
+
+=item remove_dump_filter( \&filter )
+
+Unregister the given callback function as filter callback.
+This undoes the effect of L<add_filter>.
+
+=item dump_filtered(..., \&filter )
+
+Works like Data::Dump::dump(), but the last argument should
+be a filter callback function. As objects are visited the
+filter callback is invoked at it might influence how objects are dumped.
+
+Any filters registered with L<add_filter()> are ignored when
+this interface is invoked. Actually, passing C<undef> as \&filter
+is allowed and C<< dump_filtered(..., undef) >> is the official way to
+force unfiltered dumps.
+
+=back
+
+=head2 Filter callback
+
+A filter callback is a function that will be invoked with 2 arguments;
+a context object and reference to the object currently visited. The return
+value should either be a hash reference or C<undef>.
+
+ sub filter_callback {
+ my($ctx, $object_ref) = @_;
+ ...
+ return { ... }
+ }
+
+If the filter callback returns C<undef> (or nothing) then normal
+processing and formatting of the visited object happens.
+If the filter callback returns a hash it might replace
+or annotate the representation of the current object.
+
+=head2 Filter context
+
+The context object provide methods that can be used to determine what kind of
+object is currently visited and where it's located. The context object has the
+following interface:
+
+=over
+
+=item $ctx->object_ref
+
+Alternative way to obtain a reference to the current object
+
+=item $ctx->class
+
+If the object is blessed this return the class. Returns ""
+for objects not blessed.
+
+=item $ctx->reftype
+
+Returns what kind of object this is. It's a string like "SCALAR",
+"ARRAY", "HASH", "CODE",...
+
+=item $ctx->is_ref
+
+Returns true if a reference was provided.
+
+=item $ctx->is_blessed
+
+Returns true if the object is blessed. Actually, this is just an alias
+for C<< $ctx->class >>.
+
+=item $ctx->is_array
+
+Returns true if the object is an array
+
+=item $ctx->is_hash
+
+Returns true if the object is a hash
+
+=item $ctx->is_scalar
+
+Returns true if the object is a scalar (a string or a number)
+
+=item $ctx->is_code
+
+Returns true if the object is a function (aka subroutine)
+
+=item $ctx->container_class
+
+Returns the class of the innermost container that contains this object.
+Returns "" if there is no blessed container.
+
+=item $ctx->container_self
+
+Returns an textual expression relative to the container object that names this
+object. The variable C<$self> in this expression is the container itself.
+
+=item $ctx->object_isa( $class )
+
+Returns TRUE if the current object is of the given class or is of a subclass.
+
+=item $ctx->container_isa( $class )
+
+Returns TRUE if the innermost container is of the given class or is of a
+subclass.
+
+=back
+
+=head2 Filter return hash
+
+The following elements has significance in the returned hash:
+
+=over
+
+=item dump => $string
+
+incorporate the given string as the representation for the
+current value
+
+=item object => $value
+
+dump the given value instead of the one visited and passed in as $object.
+Basically the same as specifying C<< dump => Data::Dump::dump($value) >>.
+
+=item comment => $comment
+
+prefix the value with the given comment string
+
+=item bless => $class
+
+make it look as if the current object is of the given $class
+instead of the class it really has (if any). The internals of the object
+is dumped in the regular way. The $class can be the empty string
+to make Data::Dump pretend the object wasn't blessed at all.
+
+=item hide_keys => ['key1', 'key2',...]
+
+=item hide_keys => \&code
+
+If the $object is a hash dump is as normal but pretend that the
+listed keys did not exist. If the argument is a function then
+the function is called to determine if the given key should be
+hidden.
+
+=back
+
+=head1 SEE ALSO
+
+L<Data::Dump>
Modified: branches/upstream/libdata-dump-perl/current/t/dump.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libdata-dump-perl/current/t/dump.t?rev=59647&op=diff
==============================================================================
--- branches/upstream/libdata-dump-perl/current/t/dump.t (original)
+++ branches/upstream/libdata-dump-perl/current/t/dump.t Mon Jun 21 10:03:06 2010
@@ -2,12 +2,13 @@
use strict;
use Test qw(plan ok);
-plan tests => 23;
+plan tests => 30;
use Data::Dump qw(dump);
ok(dump(), "()");
ok(dump("abc"), qq("abc"));
+ok(dump("1\n"), qq("1\\n"));
ok(dump(undef), "undef");
ok(dump(0), "0");
ok(dump(1234), "1234");
@@ -16,8 +17,14 @@
ok(dump(-33), "-33");
ok(dump(-1.5), "\"-1.5\"");
ok(dump("0123"), qq("0123"));
-ok(dump(1..5), "(1, 2, 3, 4, 5)");
-ok(dump([1..5]), "[1, 2, 3, 4, 5]");
+ok(dump(1..2), "(1, 2)");
+ok(dump(1..3), "(1, 2, 3)");
+ok(dump(1..4), "(1 .. 4)");
+ok(dump(1..5,6,8,9), "(1 .. 6, 8, 9)");
+ok(dump(1..5,4..8), "(1 .. 5, 4 .. 8)");
+ok(dump([-2..2]), "[-2 .. 2]");
+ok(dump(["a0" .. "z9"]), qq(["a0" .. "z9"]));
+ok(dump(["x", 0, 1, 2, 3, "a", "b", "c", "d"]), qq(["x", 0 .. 3, "a" .. "d"]));
ok(dump({ a => 1, b => 2 }), "{ a => 1, b => 2 }");
ok(dump({ 1 => 1, 2 => 1, 10 => 1 }), "{ 1 => 1, 2 => 1, 10 => 1 }");
ok(dump({ 0.14 => 1, 1.8 => 1, -0.5 => 1 }), qq({ "-0.5" => 1, "0.14" => 1, "1.8" => 1 }));
@@ -53,4 +60,4 @@
# stranger stuff
ok(dump({ a => \&Data::Dump::dump, aa => do {require Symbol; Symbol::gensym()}}),
- "do {\n require Symbol;\n { a => sub { \"???\" }, aa => Symbol::gensym() };\n}");
+ "do {\n require Symbol;\n { a => sub { ... }, aa => Symbol::gensym() };\n}");
Added: branches/upstream/libdata-dump-perl/current/t/filtered.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libdata-dump-perl/current/t/filtered.t?rev=59647&op=file
==============================================================================
--- branches/upstream/libdata-dump-perl/current/t/filtered.t (added)
+++ branches/upstream/libdata-dump-perl/current/t/filtered.t Mon Jun 21 10:03:06 2010
@@ -1,0 +1,58 @@
+#!perl -w
+
+use strict;
+use Test qw(plan ok);
+plan tests => 37;
+
+use Data::Dump qw(dumpf);
+
+ok(dumpf("foo", sub { return { dump => "x" }}), 'x');
+ok(dumpf("foo", sub { return { object => "x" }}), '"x"');
+ok(dumpf("foo", sub { return { comment => "x" }}), "# x\n\"foo\"");
+ok(dumpf({}, sub { return { bless => "x"}}), "bless({}, \"x\")");
+ok(dumpf({a => 1, b => 2}, sub { return { hide_keys => ["b"] }}), "{ a => 1 }");
+ok(dumpf("foo", sub { return }), '"foo"');
+
+my $cb_count = 0;
+ok(dumpf("foo", sub {
+ my($ctx, $obj) = @_;
+ $cb_count++;
+ ok($$obj, "foo");
+ ok($ctx->object_ref, $obj);
+ ok($ctx->class, "");
+ ok(!$ctx->object_isa("SCALAR"));
+ ok($ctx->container_class, "");
+ ok(!$ctx->container_isa("SCALAR"));
+ ok($ctx->container_self, "");
+ ok(!$ctx->is_ref);
+ ok(!$ctx->is_blessed);
+ ok(!$ctx->is_array);
+ ok(!$ctx->is_hash);
+ ok( $ctx->is_scalar);
+ ok(!$ctx->is_code);
+ return;
+}), '"foo"');
+ok($cb_count, 1);
+
+$cb_count = 0;
+ok(dumpf(bless({ a => 1, b => bless {}, "Bar"}, "Foo"), sub {
+ my($ctx, $obj) = @_;
+ $cb_count++;
+ return unless $ctx->object_isa("Bar");
+ ok(ref($obj), "Bar");
+ ok($ctx->object_ref, $obj);
+ ok($ctx->class, "Bar");
+ ok($ctx->object_isa("Bar"));
+ ok(!$ctx->object_isa("Foo"));
+ ok($ctx->container_class, "Foo");
+ ok($ctx->container_isa("Foo"));
+ ok($ctx->container_self, '$self->{b}');
+ ok($ctx->is_ref);
+ ok($ctx->is_blessed);
+ ok(!$ctx->is_array);
+ ok($ctx->is_hash);
+ ok(!$ctx->is_scalar);
+ ok(!$ctx->is_code);
+ return;
+}) =~ /^bless\(.*, "Foo"\)\z/);
+ok($cb_count, 3);
Added: branches/upstream/libdata-dump-perl/current/t/hash.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libdata-dump-perl/current/t/hash.t?rev=59647&op=file
==============================================================================
--- branches/upstream/libdata-dump-perl/current/t/hash.t (added)
+++ branches/upstream/libdata-dump-perl/current/t/hash.t Mon Jun 21 10:03:06 2010
@@ -1,0 +1,34 @@
+#!perl -w
+
+use strict;
+use Test;
+plan tests => 9;
+
+use Data::Dump qw(dump);
+
+my $DOTS = "." x 20;
+
+ok(dump({}), "{}");
+ok(dump({ a => 1}), "{ a => 1 }");
+ok(dump({ 1 => 1}), "{ 1 => 1 }");
+ok(dump({strict => 1, shift => 2, abc => 3, -f => 4 }),
+ "{ -f => 4, abc => 3, shift => 2, strict => 1 }");
+ok(dump({supercalifragilisticexpialidocious => 1, a => 2}),
+ "{ a => 2, supercalifragilisticexpialidocious => 1 }");
+ok(dump({supercalifragilisticexpialidocious => 1, a => 2, b => $DOTS})."\n", <<EOT);
+{
+ a => 2,
+ b => "$DOTS",
+ supercalifragilisticexpialidocious => 1,
+}
+EOT
+ok(dump({aa => 1, B => 2}), "{ aa => 1, B => 2 }");
+ok(dump({a => 1, bar => $DOTS, baz => $DOTS, foo => 2 })."\n", <<EOT);
+{
+ a => 1,
+ bar => "$DOTS",
+ baz => "$DOTS",
+ foo => 2,
+}
+EOT
+ok(dump({a => 1, "b-z" => 2}), qq({ "a" => 1, "b-z" => 2 }));
Modified: branches/upstream/libdata-dump-perl/current/t/tied.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libdata-dump-perl/current/t/tied.t?rev=59647&op=diff
==============================================================================
--- branches/upstream/libdata-dump-perl/current/t/tied.t (original)
+++ branches/upstream/libdata-dump-perl/current/t/tied.t Mon Jun 21 10:03:06 2010
@@ -58,10 +58,7 @@
ok(nl(dump(\@array)), <<EOT);
[
# tied MyTie
- "v0",
- "v1",
- "v2",
- "v3",
+ "v0" .. "v3",
]
EOT
More information about the Pkg-perl-cvs-commits
mailing list