r23426 - in /trunk/libdata-visitor-perl: Changes META.yml SIGNATURE debian/changelog lib/Data/Visitor.pm lib/Data/Visitor/Callback.pm t/circular_refs.t t/magic.t
gregoa at users.alioth.debian.org
gregoa at users.alioth.debian.org
Sun Jul 20 12:47:05 UTC 2008
Author: gregoa
Date: Sun Jul 20 12:47:03 2008
New Revision: 23426
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=23426
Log:
New upstream release.
Modified:
trunk/libdata-visitor-perl/Changes
trunk/libdata-visitor-perl/META.yml
trunk/libdata-visitor-perl/SIGNATURE
trunk/libdata-visitor-perl/debian/changelog
trunk/libdata-visitor-perl/lib/Data/Visitor.pm
trunk/libdata-visitor-perl/lib/Data/Visitor/Callback.pm
trunk/libdata-visitor-perl/t/circular_refs.t
trunk/libdata-visitor-perl/t/magic.t
Modified: trunk/libdata-visitor-perl/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdata-visitor-perl/Changes?rev=23426&op=diff
==============================================================================
--- trunk/libdata-visitor-perl/Changes (original)
+++ trunk/libdata-visitor-perl/Changes Sun Jul 20 12:47:03 2008
@@ -1,3 +1,14 @@
+0.17
+ - More void context correctness fixes WRT tied values
+ - Overzealous seen value mappings made by Callback were removed
+
+0.16
+ - Fix passing of void context when visiting hashes/arrays (perf
+ optimization to avoid unnecessary cloning)
+ - Added 'visit_seen' and a 'seen' callback for circular structures
+ - Class callbacks are now fired from least derived to most derived, not in
+ hash key order
+
0.15
- Fixed a compilation warning under 5.6.2
- Disabled consistent replacement of values when assigning to $_ under
Modified: trunk/libdata-visitor-perl/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdata-visitor-perl/META.yml?rev=23426&op=diff
==============================================================================
--- trunk/libdata-visitor-perl/META.yml (original)
+++ trunk/libdata-visitor-perl/META.yml Sun Jul 20 12:47:03 2008
@@ -1,10 +1,10 @@
--- #YAML:1.0
name: Data-Visitor
-version: 0.15
+version: 0.17
abstract: ~
license: ~
author: ~
-generated_by: ExtUtils::MakeMaker version 6.42
+generated_by: ExtUtils::MakeMaker version 6.44
distribution_type: module
requires:
Class::Accessor: 0
Modified: trunk/libdata-visitor-perl/SIGNATURE
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdata-visitor-perl/SIGNATURE?rev=23426&op=diff
==============================================================================
--- trunk/libdata-visitor-perl/SIGNATURE (original)
+++ trunk/libdata-visitor-perl/SIGNATURE Sun Jul 20 12:47:03 2008
@@ -14,24 +14,24 @@
-----BEGIN PGP SIGNED MESSAGE-----
Hash: SHA1
-SHA1 99c6de4b23e086da4b204cedc40314873fa6e388 Changes
+SHA1 0e2884144c30d1570281a34f27d49f8541518e7a Changes
SHA1 f0cf3ccc1cd7b0f3215f358edc7fa0099b437aba MANIFEST
SHA1 ddb918d4e02cc06f4b9fe77adeca65403f8fdd56 MANIFEST.SKIP
-SHA1 c10d2cf90c8b1a39cf643273ff603ee0a15b0f5e META.yml
+SHA1 1b052f87f5a7653682e9cee2d894ddee979a3be6 META.yml
SHA1 667bc3455c456f2f3bf2ba21eaf728c93057d253 Makefile.PL
-SHA1 44849ce59c8c0231bf8e50474c7ce94b4651fa86 lib/Data/Visitor.pm
-SHA1 55ff49624c0c47b9534e414f0a11f1a17a8180d3 lib/Data/Visitor/Callback.pm
+SHA1 a0b3f7ec66e1b212a685377b780d12bbc1449a67 lib/Data/Visitor.pm
+SHA1 f4787d6f132bc389bc9c74809969b9c6a18044af lib/Data/Visitor/Callback.pm
SHA1 dfba09a3df7adaf6d0369a4745e6e336272c405d t/base.t
SHA1 257c858e1bc12c1039e93cac62a0d37f2e0d804d t/bugs.t
SHA1 e4b813021fa680c61cb4229a9ddeb0a22ec5bf82 t/callback.t
SHA1 3836b0eeb006cc4984e80dec1a537b808c3173d2 t/callback_aliasing.t
-SHA1 15b2b82eaf4a4aff00ced084f494100b75d7f0b3 t/circular_refs.t
+SHA1 b36e070cd6929ab17feab46e6265729c901cc394 t/circular_refs.t
SHA1 54affd2088fa25d8eec562fb8d39e1abd0d123c7 t/globs.t
-SHA1 8f1c6b34b0cb03dcb358c71cec520e8f1c723a99 t/magic.t
+SHA1 a3a3ead5cdb91a600fb6c7ae585bfe98fcf82bbf t/magic.t
-----BEGIN PGP SIGNATURE-----
Version: GnuPG v1.4.7 (Darwin)
-iD8DBQFHjRRHVCwRwOvSdBgRAjNWAJ9JRhYyqS4eUiI3oB0lqDYolM8UnwCfS3W8
-uPpFSd0UiURleXrk0y/pC5g=
-=fwUd
+iD8DBQFIgi+YVCwRwOvSdBgRAuauAJ4+WcizMBKaeWyFSVz9B5V7C+m2IwCfQECi
+wQy0Fj1Pbsx5EaKQHisUHDY=
+=7VJK
-----END PGP SIGNATURE-----
Modified: trunk/libdata-visitor-perl/debian/changelog
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdata-visitor-perl/debian/changelog?rev=23426&op=diff
==============================================================================
--- trunk/libdata-visitor-perl/debian/changelog (original)
+++ trunk/libdata-visitor-perl/debian/changelog Sun Jul 20 12:47:03 2008
@@ -1,3 +1,9 @@
+libdata-visitor-perl (0.17-1) UNRELEASED; urgency=low
+
+ * New upstream release.
+
+ -- gregor herrmann <gregoa at debian.org> Sun, 20 Jul 2008 14:46:16 +0200
+
libdata-visitor-perl (0.15-1) unstable; urgency=low
[ Krzysztof Krzyżaniak (eloy) ]
Modified: trunk/libdata-visitor-perl/lib/Data/Visitor.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdata-visitor-perl/lib/Data/Visitor.pm?rev=23426&op=diff
==============================================================================
--- trunk/libdata-visitor-perl/lib/Data/Visitor.pm (original)
+++ trunk/libdata-visitor-perl/lib/Data/Visitor.pm Sun Jul 20 12:47:03 2008
@@ -35,7 +35,7 @@
warn "@msg\n";
}
-our $VERSION = "0.15";
+our $VERSION = "0.17";
sub visit {
my ( $self, $data ) = @_;
@@ -47,13 +47,18 @@
if ( ref $data ) { # only references need recursion checks
if ( exists $seen_hash->{ refaddr($data) } ) {
$self->trace( mapping => found_mapping => from => $data, to => $seen_hash->{ refaddr($data) } ) if DEBUG;
- return $seen_hash->{ refaddr($data) }; # return whatever it was mapped to
+ return $self->visit_seen( $data, $seen_hash->{refaddr($data)} );
} else {
$self->trace( mapping => no_mapping => $data ) if DEBUG;
}
}
return $self->visit_no_rec_check( $data );
+}
+
+sub visit_seen {
+ my ( $self, $data, $result ) = @_;
+ return $result;
}
sub _get_mapping {
@@ -76,7 +81,7 @@
} elsif ( ref $data ) {
return $self->visit_ref($data);
}
-
+
return $self->visit_value($data);
}
@@ -97,14 +102,9 @@
$reftype = "SCALAR" if $reftype =~ /^(?:REF|LVALUE|VSTRING)$/;
- my $method = lc "visit_$reftype";
-
- if ( $self->can($method) ) {
- return $self->_register_mapping( $data, $self->$method($data) );
- } else {
- return $self->_register_mapping( $data, $self->visit_value($data) );
- }
-
+ my $method = $self->can(lc "visit_$reftype") || "visit_value";
+
+ return $self->$method($data);
}
sub visit_value {
@@ -120,13 +120,21 @@
if ( not defined wantarray ) {
$self->_register_mapping( $hash, $hash );
- $self->visit_hash_entries($hash);
+
+ my $tied = tied(%$hash);
+ if ( ref($tied) and $self->tied_as_objects ) {
+ $self->visit_tied($tied, $hash);
+ } else {
+ $self->visit_hash_entries($hash);
+ }
+
+ return;
} else {
my $new_hash = {};
$self->_register_mapping( $hash, $new_hash );
my $tied = tied(%$hash);
- if ( $tied and $self->tied_as_objects and blessed(my $new_tied = $self->visit_tied($tied, $hash)) ) {
+ if ( ref($tied) and $self->tied_as_objects and blessed(my $new_tied = $self->visit_tied($tied, $hash)) ) {
$self->trace( data => tying => var => $new_hash, to => $new_tied ) if DEBUG;
tie %$new_hash, 'Tie::ToObject', $new_tied;
} else {
@@ -139,8 +147,12 @@
sub visit_hash_entries {
my ( $self, $hash ) = @_;
- no warnings 'void';
- map { $self->visit_hash_entry( $_, $hash->{$_}, $hash ) } keys %$hash;
+
+ if ( not defined wantarray ) {
+ $self->visit_hash_entry( $_, $hash->{$_}, $hash ) for keys %$hash;
+ } else {
+ return map { $self->visit_hash_entry( $_, $hash->{$_}, $hash ) } keys %$hash;
+ }
}
sub visit_hash_entry {
@@ -148,10 +160,15 @@
$self->trace( flow => visit_hash_entry => key => $key, value => $value ) if DEBUG;
- return (
- $self->visit_hash_key($key,$value,$hash),
- $self->visit_hash_value($_[2],$key,$hash) # retain aliasing semantics
- );
+ if ( not defined wantarray ) {
+ $self->visit_hash_key($key,$value,$hash);
+ $self->visit_hash_value($_[2],$key,$hash); # retain aliasing semantics
+ } else {
+ return (
+ $self->visit_hash_key($key,$value,$hash),
+ $self->visit_hash_value($_[2],$key,$hash) # retain aliasing semantics
+ );
+ }
}
sub visit_hash_key {
@@ -169,14 +186,21 @@
if ( not defined wantarray ) {
$self->_register_mapping( $array, $array );
- $self->visit_array_entries($array);
- $self->visit_array_entry( $array->[$_], $_, $array ) for 0 .. $#$array
+
+ my $tied = tied(@$array);
+ if ( ref($tied) and $self->tied_as_objects ) {
+ $self->visit_tied($tied, $array);
+ } else {
+ $self->visit_array_entries($array);
+ }
+
+ return;
} else {
my $new_array = [];
$self->_register_mapping( $array, $new_array );
my $tied = tied(@$array);
- if ( $tied and $self->tied_as_objects and blessed(my $new_tied = $self->visit_tied($tied, $array)) ) {
+ if ( ref($tied) and $self->tied_as_objects and blessed(my $new_tied = $self->visit_tied($tied, $array)) ) {
$self->trace( data => tying => var => $new_array, to => $new_tied ) if DEBUG;
tie @$new_array, 'Data::Visitor::TieToObject', $new_tied;
} else {
@@ -189,8 +213,12 @@
sub visit_array_entries {
my ( $self, $array ) = @_;
- no warnings 'void';
- map { $self->visit_array_entry( $array->[$_], $_, $array ) } 0 .. $#$array;
+
+ if ( not defined wantarray ) {
+ $self->visit_array_entry( $array->[$_], $_, $array ) for 0 .. $#$array;
+ } else {
+ return map { $self->visit_array_entry( $array->[$_], $_, $array ) } 0 .. $#$array;
+ }
}
sub visit_array_entry {
@@ -201,18 +229,31 @@
sub visit_scalar {
my ( $self, $scalar ) = @_;
- my $new_scalar;
- $self->_register_mapping( $scalar, \$new_scalar );
-
- my $tied = tied($$scalar);
- if ( $tied and $self->tied_as_objects and blessed(my $new_tied = $self->visit_tied($tied, $scalar)) ) {
- $self->trace( data => tying => var => $new_scalar, to => $new_tied ) if DEBUG;
- tie $new_scalar, 'Data::Visitor::TieToObject', $new_tied;
- } else {
- $new_scalar = $self->visit( $$scalar );
- }
-
- return $self->retain_magic( $scalar, \$new_scalar );
+ if ( not defined wantarray ) {
+ $self->_register_mapping( $scalar, $scalar );
+
+ my $tied = tied($$scalar);
+ if ( ref($tied) and $self->tied_as_objects ) {
+ $self->visit_tied($tied, $scalar);
+ } else {
+ $self->visit($$scalar);
+ }
+
+ return;
+ } else {
+ my $new_scalar;
+ $self->_register_mapping( $scalar, \$new_scalar );
+
+ my $tied = tied($$scalar);
+ if ( ref($tied) and $self->tied_as_objects and blessed(my $new_tied = $self->visit_tied($tied, $scalar)) ) {
+ $self->trace( data => tying => var => $new_scalar, to => $new_tied ) if DEBUG;
+ tie $new_scalar, 'Data::Visitor::TieToObject', $new_tied;
+ } else {
+ $new_scalar = $self->visit( $$scalar );
+ }
+
+ return $self->retain_magic( $scalar, \$new_scalar );
+ }
}
sub visit_code {
@@ -223,20 +264,33 @@
sub visit_glob {
my ( $self, $glob ) = @_;
- my $new_glob = Symbol::gensym();
-
- $self->_register_mapping( $glob, $new_glob );
-
- my $tied = tied(*$glob);
- if ( $tied and $self->tied_as_objects and blessed(my $new_tied = $self->visit_tied($tied, $glob)) ) {
- $self->trace( data => tying => var => $new_glob, to => $new_tied ) if DEBUG;
- tie *$new_glob, 'Data::Visitor::TieToObject', $new_tied;
- } else {
- no warnings 'misc'; # Undefined value assigned to typeglob
- *$new_glob = $self->visit( *$glob{$_} || next ) for qw/SCALAR ARRAY HASH/;
- }
-
- return $self->retain_magic( $glob, $new_glob );
+ if ( not defined wantarray ) {
+ $self->_register_mapping( $glob, $glob );
+
+ my $tied = tied(*$glob);
+ if ( ref($tied) and $self->tied_as_objects ) {
+ $self->visit_tied($tied, $glob);
+ } else {
+ $self->visit( *$glob{$_} || next ) for qw/SCALAR ARRAY HASH/;
+ }
+
+ return;
+ } else {
+ my $new_glob = Symbol::gensym();
+
+ $self->_register_mapping( $glob, $new_glob );
+
+ my $tied = tied(*$glob);
+ if ( ref($tied) and $self->tied_as_objects and blessed(my $new_tied = $self->visit_tied($tied, $glob)) ) {
+ $self->trace( data => tying => var => $new_glob, to => $new_tied ) if DEBUG;
+ tie *$new_glob, 'Data::Visitor::TieToObject', $new_tied;
+ } else {
+ no warnings 'misc'; # Undefined value assigned to typeglob
+ *$new_glob = $self->visit( *$glob{$_} || next ) for qw/SCALAR ARRAY HASH/;
+ }
+
+ return $self->retain_magic( $glob, $new_glob );
+ }
}
sub retain_magic {
@@ -254,6 +308,7 @@
sub visit_tied {
my ( $self, $tied, $var ) = @_;
+ $self->trace( flow => visit_tied => $tied ) if DEBUG;
$self->visit($tied); # as an object eventually
}
@@ -304,6 +359,13 @@
It has a main dispatcher method, C<visit>, which takes a single perl value and
then calls the methods appropriate for that value.
+It can recursively map (cloning as necessary) or just traverse most structures,
+with support for per object behavior, circular structures, visiting tied
+structures, and all ref types (hashes, arrays, scalars, code, globs).
+
+L<Data::Visitor> is meant to be subclassed, but also ships with a callback
+driven subclass, L<Data::Visitor::Callback>.
+
=head1 METHODS
=over 4
@@ -311,7 +373,27 @@
=item visit $data
This method takes any Perl value as it's only argument, and dispatches to the
-various other visiting methods, based on the data's type.
+various other visiting methods using C<visit_no_rec_check>, based on the data's
+type.
+
+If the value is a reference and has already been seen then C<visit_seen> is
+called.
+
+=item visit_seen $data, $first_result
+
+When an already seen value is encountered again it's typically replaced with
+the result of the first visitation of that value. The value and the result of
+the first visitation are passed as arguments.
+
+Returns C<$first_result>.
+
+=item visit_no_rec_check $data
+
+Called for any value that has not yet been seen. Does the actual type based
+dispatch for C<visit>.
+
+Should not be called directly unless forcing a circular structure to be
+unfolded. Use with caution as this may cause infinite recursion.
=item visit_object $object
@@ -334,6 +416,8 @@
=item visit_glob $glob_ref
+=item visit_code $code_ref
+
=item visit_scalar $scalar_ref
These methods are called for the corresponding container type.
@@ -343,6 +427,8 @@
If the value is anything else, this method is called. The base implementation
will return $value.
+=item visit_hash_entries $hash
+
=item visit_hash_entry $key, $value, $hash
Delegates to C<visit_hash_key> and C<visit_hash_value>. The value is passed as
@@ -355,6 +441,8 @@
=item visit_hash_value $value, $key, $hash
The value will be aliased (passed as C<$_[1]>).
+
+=item visit_array_entries $array
=item visit_array_entry $value, $index, $array
@@ -375,6 +463,19 @@
This is because tying to the same class and performing the tie operations will
not yield the same results in many cases.
+=item retain_magic $orig, $copy
+
+Copies over magic from C<$orig> to C<$copy>.
+
+Currently only handles C<bless>. In the future this might be expanded using
+L<Variable::Magic> but it isn't clear what the correct semantics for magic
+copying should be.
+
+=item trace
+
+Called if the C<DEBUG> constant is set with a trace message.
+
+
=back
=head1 RETURN VALUE
Modified: trunk/libdata-visitor-perl/lib/Data/Visitor/Callback.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdata-visitor-perl/lib/Data/Visitor/Callback.pm?rev=23426&op=diff
==============================================================================
--- trunk/libdata-visitor-perl/lib/Data/Visitor/Callback.pm (original)
+++ trunk/libdata-visitor-perl/lib/Data/Visitor/Callback.pm Sun Jul 20 12:47:03 2008
@@ -34,11 +34,15 @@
# performed later. Anything that cold plausibly be a class name
# should be included in the list, even if the class doesn't
# actually exist.
- m{ :: | ^[A-Z] }x
+
+ m{ :: | ^[A-Z] }x # if it looks kinda lack a class name
or
- scalar keys %{"${_}::"}
+ scalar keys %{"${_}::"} # or it really is a class
} keys %callbacks;
};
+
+ # sort from least derived to most derived
+ @class_callbacks = sort { !$a->isa($b) <=> !$b->isa($a) } @class_callbacks;
$class->SUPER::new({
tied_as_objects => $tied_as_objects,
@@ -69,6 +73,19 @@
$replaced_hash->{ refaddr($data) } = $_ if ref $data and ( not ref $_ or refaddr($data) ne refaddr($_) );
return $ret;
+}
+
+sub visit_seen {
+ my ( $self, $data, $result ) = @_;
+
+ my $mapped = $self->callback( seen => $data, $result );
+
+ no warnings 'uninitialized';
+ if ( refaddr($mapped) == refaddr($data) ) {
+ return $result;
+ } else {
+ return $mapped;
+ }
}
sub visit_value {
@@ -121,7 +138,14 @@
my ( $self, $data ) = @_;
my $new_data = $self->callback_and_reg( '.$reftype.' => $data );
if ( "'.uc($reftype).'" eq (reftype($new_data)||"") ) {
- return $self->_register_mapping( $data, $self->SUPER::visit_'.$reftype.'( $new_data ) );
+ my $visited = $self->SUPER::visit_'.$reftype.'( $new_data );
+
+ no warnings "uninitialized";
+ if ( refaddr($visited) != refaddr($data) ) {
+ return $self->_register_mapping( $data, $visited );
+ } else {
+ return $visited;
+ }
} else {
return $self->_register_mapping( $data, $self->visit( $new_data ) );
}
@@ -148,15 +172,18 @@
my $new_data = $self->callback( $name, $data, @args );
unless ( $self->ignore_return_values ) {
- return $self->_register_mapping( $data, $new_data );
- } else {
- return $data;
- }
+ no warnings 'uninitialized';
+ if ( refaddr($data) != refaddr($new_data) ) {
+ return $self->_register_mapping( $data, $new_data );
+ }
+ }
+
+ return $data;
}
sub visit_tied {
my ( $self, $tied, @args ) = @_;
- $self->SUPER::visit_tied( $self->callback_and_reg( tied => $tied, @args ) );
+ $self->SUPER::visit_tied( $self->callback_and_reg( tied => $tied, @args ), @args );
}
__PACKAGE__;
@@ -273,6 +300,9 @@
If the object C<isa> the class then the callback will fire.
+These callbacks are called from least derived to most derived by comparing the
+classes' C<isa> at construction time.
+
=item object_no_class
Called for every object that did not have a class callback.
Modified: trunk/libdata-visitor-perl/t/circular_refs.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdata-visitor-perl/t/circular_refs.t?rev=23426&op=diff
==============================================================================
--- trunk/libdata-visitor-perl/t/circular_refs.t (original)
+++ trunk/libdata-visitor-perl/t/circular_refs.t Sun Jul 20 12:47:03 2008
@@ -3,7 +3,7 @@
use strict;
use warnings;
-use Test::More tests => 11;
+use Test::More tests => 12;
use ok "Data::Visitor";
@@ -91,3 +91,25 @@
is_deeply( $copy, $orig, "structure retained" );
}
+
+{
+ my $orig = [
+ { obj => bless {}, "blah" },
+ ];
+
+ $orig->[0]{self} = $orig;
+ $orig->[1] = $orig->[0];
+
+ my $c = Data::Visitor::Callback->new( seen => sub { "seen" } );
+
+ my $copy = $c->visit( $orig );
+
+ is_deeply(
+ $copy,
+ [
+ { obj => bless({}, "blah"), self => "seen" },
+ "seen",
+ ],
+ "seen callback",
+ );
+}
Modified: trunk/libdata-visitor-perl/t/magic.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdata-visitor-perl/t/magic.t?rev=23426&op=diff
==============================================================================
--- trunk/libdata-visitor-perl/t/magic.t (original)
+++ trunk/libdata-visitor-perl/t/magic.t Sun Jul 20 12:47:03 2008
@@ -19,7 +19,7 @@
$h->{foo}{[1, 2, 3]} = "blart";
-my $v = Data::Visitor::Callback->new( tied_as_objects => 1 );
+my $v = Data::Visitor::Callback->new( tied_as_objects => 1, object => "visit_ref" ); # deep clone the refhash tied
my $copy = $v->visit($h);
@@ -27,6 +27,8 @@
isnt( $copy->{foo}, $h->{foo}, "the tied hash is a copy, too" );
is( $copy->{foo}, $copy->{bar}{gorch}, "identity preserved" );
ok( tied %{ $copy->{foo} }, "the subhash is tied" );
+isa_ok( tied(%{ $copy->{foo} }), 'Tie::RefHash', 'tied to correct class' );
+isnt( tied(%{ $copy->{foo} }), tied(%{ $h->{foo} }), "tied is different" );
ok( ref( ( keys %{ $copy->{foo} } )[0] ), "the key is a ref" );
is_deeply([ keys %{ $copy->{foo} } ], [ keys %{ $h->{foo} } ], "keys eq deeply" );
More information about the Pkg-perl-cvs-commits
mailing list