r59653 - in /trunk/libdata-dump-perl: lib/Data/Dump/FilterContext.pm lib/Data/Dump/Filtered.pm t/filtered.t t/hash.t
eloy at users.alioth.debian.org
eloy at users.alioth.debian.org
Mon Jun 21 10:15:44 UTC 2010
Author: eloy
Date: Mon Jun 21 10:15:27 2010
New Revision: 59653
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=59653
Log:
missing files added
Added:
trunk/libdata-dump-perl/lib/Data/Dump/FilterContext.pm
trunk/libdata-dump-perl/lib/Data/Dump/Filtered.pm
trunk/libdata-dump-perl/t/filtered.t
trunk/libdata-dump-perl/t/hash.t
Added: trunk/libdata-dump-perl/lib/Data/Dump/FilterContext.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdata-dump-perl/lib/Data/Dump/FilterContext.pm?rev=59653&op=file
==============================================================================
--- trunk/libdata-dump-perl/lib/Data/Dump/FilterContext.pm (added)
+++ trunk/libdata-dump-perl/lib/Data/Dump/FilterContext.pm Mon Jun 21 10:15:27 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: trunk/libdata-dump-perl/lib/Data/Dump/Filtered.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdata-dump-perl/lib/Data/Dump/Filtered.pm?rev=59653&op=file
==============================================================================
--- trunk/libdata-dump-perl/lib/Data/Dump/Filtered.pm (added)
+++ trunk/libdata-dump-perl/lib/Data/Dump/Filtered.pm Mon Jun 21 10:15:27 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>
Added: trunk/libdata-dump-perl/t/filtered.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdata-dump-perl/t/filtered.t?rev=59653&op=file
==============================================================================
--- trunk/libdata-dump-perl/t/filtered.t (added)
+++ trunk/libdata-dump-perl/t/filtered.t Mon Jun 21 10:15:27 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: trunk/libdata-dump-perl/t/hash.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdata-dump-perl/t/hash.t?rev=59653&op=file
==============================================================================
--- trunk/libdata-dump-perl/t/hash.t (added)
+++ trunk/libdata-dump-perl/t/hash.t Mon Jun 21 10:15:27 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 }));
More information about the Pkg-perl-cvs-commits
mailing list