r12991 - in /branches/upstream/libdata-visitor-perl/current: Changes META.yml Makefile.PL SIGNATURE lib/Data/Visitor.pm lib/Data/Visitor/Callback.pm t/circular_refs.t

gregoa-guest at users.alioth.debian.org gregoa-guest at users.alioth.debian.org
Fri Jan 18 21:55:59 UTC 2008


Author: gregoa-guest
Date: Fri Jan 18 21:55:59 2008
New Revision: 12991

URL: http://svn.debian.org/wsvn/?sc=1&rev=12991
Log:
[svn-upgrade] Integrating new upstream version, libdata-visitor-perl (0.15)

Modified:
    branches/upstream/libdata-visitor-perl/current/Changes
    branches/upstream/libdata-visitor-perl/current/META.yml
    branches/upstream/libdata-visitor-perl/current/Makefile.PL
    branches/upstream/libdata-visitor-perl/current/SIGNATURE
    branches/upstream/libdata-visitor-perl/current/lib/Data/Visitor.pm
    branches/upstream/libdata-visitor-perl/current/lib/Data/Visitor/Callback.pm
    branches/upstream/libdata-visitor-perl/current/t/circular_refs.t

Modified: branches/upstream/libdata-visitor-perl/current/Changes
URL: http://svn.debian.org/wsvn/branches/upstream/libdata-visitor-perl/current/Changes?rev=12991&op=diff
==============================================================================
--- branches/upstream/libdata-visitor-perl/current/Changes (original)
+++ branches/upstream/libdata-visitor-perl/current/Changes Fri Jan 18 21:55:59 2008
@@ -1,5 +1,19 @@
+0.15
+	- Fixed a compilation warning under 5.6.2
+	- Disabled consistent replacement of values when assigning to $_ under
+	  5.6.2 due to a limitation. 5.8 is required for that feature to work
+	  properly. Instead, a warning will be issued and the value will be
+	  revisited.
+
+0.14
+	- Refactored to use Tie::ToObject instead of a custom class
+	- Simple tracing added, enable by setting $DEBUG
+	- added the object_no_class callback
+	- no longer uses $string->can("isa") to figure out if that's a class
+
 0.13
 	- Add support for preserving tied()ness, and for visiting
+
 0.12
 	- _register_mapping was not called for each class callback result
 

Modified: branches/upstream/libdata-visitor-perl/current/META.yml
URL: http://svn.debian.org/wsvn/branches/upstream/libdata-visitor-perl/current/META.yml?rev=12991&op=diff
==============================================================================
--- branches/upstream/libdata-visitor-perl/current/META.yml (original)
+++ branches/upstream/libdata-visitor-perl/current/META.yml Fri Jan 18 21:55:59 2008
@@ -1,6 +1,6 @@
 --- #YAML:1.0
 name:                Data-Visitor
-version:             0.13
+version:             0.15
 abstract:            ~
 license:             ~
 author:              ~
@@ -11,6 +11,7 @@
     Test::MockObject:              1.04
     Test::More:                    0
     Test::use::ok:                 0
+    Tie::ToObject:                 0.01
 meta-spec:
     url:     http://module-build.sourceforge.net/META-spec-v1.3.html
     version: 1.3

Modified: branches/upstream/libdata-visitor-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/branches/upstream/libdata-visitor-perl/current/Makefile.PL?rev=12991&op=diff
==============================================================================
--- branches/upstream/libdata-visitor-perl/current/Makefile.PL (original)
+++ branches/upstream/libdata-visitor-perl/current/Makefile.PL Fri Jan 18 21:55:59 2008
@@ -8,7 +8,8 @@
 		'Class::Accessor'  => '0',
 		'Test::MockObject' => '1.04',
 		'Test::More'       => '0',
-		'Test::use::ok'    => '0'
+		'Test::use::ok'    => '0',
+		'Tie::ToObject'    => '0.01',
 	},
 	'INSTALLDIRS' => 'site',
 	'PL_FILES'    => {},

Modified: branches/upstream/libdata-visitor-perl/current/SIGNATURE
URL: http://svn.debian.org/wsvn/branches/upstream/libdata-visitor-perl/current/SIGNATURE?rev=12991&op=diff
==============================================================================
--- branches/upstream/libdata-visitor-perl/current/SIGNATURE (original)
+++ branches/upstream/libdata-visitor-perl/current/SIGNATURE Fri Jan 18 21:55:59 2008
@@ -14,24 +14,24 @@
 -----BEGIN PGP SIGNED MESSAGE-----
 Hash: SHA1
 
-SHA1 3a6fda6318bc6d6ca26bb79d386947eedd0ad390 Changes
+SHA1 99c6de4b23e086da4b204cedc40314873fa6e388 Changes
 SHA1 f0cf3ccc1cd7b0f3215f358edc7fa0099b437aba MANIFEST
 SHA1 ddb918d4e02cc06f4b9fe77adeca65403f8fdd56 MANIFEST.SKIP
-SHA1 4011724801055a360b0591ee960cfe89829014a4 META.yml
-SHA1 7e820fe45a90871dcc686bd3ffd7897444a6ea30 Makefile.PL
-SHA1 2bf99b3370e53fc483a1dba0605c12e9a611922c lib/Data/Visitor.pm
-SHA1 73c8a9efabb1e933ab138266fafc2ae45711df83 lib/Data/Visitor/Callback.pm
+SHA1 c10d2cf90c8b1a39cf643273ff603ee0a15b0f5e META.yml
+SHA1 667bc3455c456f2f3bf2ba21eaf728c93057d253 Makefile.PL
+SHA1 44849ce59c8c0231bf8e50474c7ce94b4651fa86 lib/Data/Visitor.pm
+SHA1 55ff49624c0c47b9534e414f0a11f1a17a8180d3 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 8498703c0e3e9f3265237d5288bec4c33ed3b3f6 t/circular_refs.t
+SHA1 15b2b82eaf4a4aff00ced084f494100b75d7f0b3 t/circular_refs.t
 SHA1 54affd2088fa25d8eec562fb8d39e1abd0d123c7 t/globs.t
 SHA1 8f1c6b34b0cb03dcb358c71cec520e8f1c723a99 t/magic.t
 -----BEGIN PGP SIGNATURE-----
 Version: GnuPG v1.4.7 (Darwin)
 
-iD8DBQFHg5v2VCwRwOvSdBgRAtBqAKCk2rcs2MLF9Xes4CF0XuIv7V7whACgkaCD
-ZxFCfFWlaMVraAk4h3mTDfc=
-=bMjC
+iD8DBQFHjRRHVCwRwOvSdBgRAjNWAJ9JRhYyqS4eUiI3oB0lqDYolM8UnwCfS3W8
+uPpFSd0UiURleXrk0y/pC5g=
+=fwUd
 -----END PGP SIGNATURE-----

Modified: branches/upstream/libdata-visitor-perl/current/lib/Data/Visitor.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libdata-visitor-perl/current/lib/Data/Visitor.pm?rev=12991&op=diff
==============================================================================
--- branches/upstream/libdata-visitor-perl/current/lib/Data/Visitor.pm (original)
+++ branches/upstream/libdata-visitor-perl/current/lib/Data/Visitor.pm Fri Jan 18 21:55:59 2008
@@ -10,17 +10,46 @@
 use overload ();
 use Symbol ();
 
+use Tie::ToObject;
+
 __PACKAGE__->mk_accessors(qw(tied_as_objects));
 
-our $VERSION = "0.13";
+# the double not works makes this no longer undef, so exempt from useless constant warnings in older perls
+use constant DEBUG => not not our $DEBUG || $ENV{DATA_VISITOR_DEBUG};
+
+sub trace {
+	my ( $self, $category, @msg ) = @_;
+
+	our %DEBUG;
+
+	if ( $DEBUG{$category} or !exists($DEBUG{$category}) ) {
+		$self->_print_trace("$self: " . join("",
+			( "    " x ( $self->{depth} - 1 ) ),
+			( join(" ", "$category:", map { overload::StrVal($_) } @msg) ),
+		));
+	}
+}
+
+sub _print_trace {
+	my ( $self, @msg ) = @_;
+	warn "@msg\n";
+}
+
+our $VERSION = "0.15";
 
 sub visit {
 	my ( $self, $data ) = @_;
+
+	local $self->{depth} = (($self->{depth}||0) + 1) if DEBUG;
+	$self->trace( flow => visit => $data ) if DEBUG;
 
 	my $seen_hash = local $self->{_seen} = ($self->{_seen} || {}); # delete it after we're done with the whole visit
 	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
+		} else {
+			$self->trace( mapping => no_mapping => $data ) if DEBUG;
 		}
 	}
 
@@ -35,6 +64,7 @@
 sub _register_mapping {
 	my ( $self, $data, $new_data ) = @_;
 	return $new_data unless ref $data;
+	$self->trace( mapping => register_mapping => from => $data, to => $new_data, in => (caller(1))[3] ) if DEBUG;
 	$self->{_seen}{ refaddr($data) } = $new_data;
 }
 
@@ -52,12 +82,16 @@
 
 sub visit_object {
 	my ( $self, $object ) = @_;
-
+	$self->trace( flow => visit_object => $object ) if DEBUG;
 	return $self->_register_mapping( $object, $self->visit_value($object) );
 }
 
 sub visit_ref {
 	my ( $self, $data ) = @_;
+
+	local $self->{depth} = (($self->{depth}||0) + 1) if DEBUG;
+
+	$self->trace( flow => visit_ref => $data ) if DEBUG;
 
 	my $reftype = reftype $data;
 
@@ -75,12 +109,14 @@
 
 sub visit_value {
 	my ( $self, $value ) = @_;
-
+	$self->trace( flow => visit_value => $value ) if DEBUG;
 	return $value;
 }
 
 sub visit_hash {
 	my ( $self, $hash ) = @_;
+
+	local $self->{depth} = (($self->{depth}||0) + 1) if DEBUG;
 
 	if ( not defined wantarray ) {
 		$self->_register_mapping( $hash, $hash );
@@ -91,7 +127,8 @@
 
 		my $tied = tied(%$hash);
 		if ( $tied and $self->tied_as_objects and blessed(my $new_tied = $self->visit_tied($tied, $hash)) ) {
-			tie %$new_hash, 'Data::Visitor::TieToObject', $new_tied;
+			$self->trace( data => tying => var => $new_hash, to => $new_tied ) if DEBUG;
+			tie %$new_hash, 'Tie::ToObject', $new_tied;
 		} else {
 			%$new_hash = $self->visit_hash_entries($hash);
 		}
@@ -108,6 +145,8 @@
 
 sub visit_hash_entry {
 	my ( $self, $key, $value, $hash ) = @_;
+
+	$self->trace( flow => visit_hash_entry => key => $key, value => $value ) if DEBUG;
 
 	return (
 		$self->visit_hash_key($key,$value,$hash),
@@ -138,6 +177,7 @@
 
 		my $tied = tied(@$array);
 		if ( $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 {
 			@$new_array = $self->visit_array_entries($array);
@@ -166,6 +206,7 @@
 
 	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 );
@@ -188,6 +229,7 @@
 
 	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
@@ -201,6 +243,7 @@
 	my ( $self, $proto, $new ) = @_;
 
 	if ( blessed($proto) and !blessed($new) ) {
+		$self->trace( data => blessing => $new, ref $proto ) if DEBUG;
 		bless $new, ref $proto;
 	}
 
@@ -212,21 +255,6 @@
 sub visit_tied {
 	my ( $self, $tied, $var ) = @_;
 	$self->visit($tied); # as an object eventually
-}
-
-{
-	package Data::Visitor::TieToObject;
-
-	sub AUTOLOAD {
-		my ( $self, $tied ) = @_;
-		my ( $method ) = ( our $AUTOLOAD =~ /([^:]+)$/ );
-
-		if ( $method =~ /^TIE/ ) {
-			return $tied;
-		} else {
-			die "Unsupported method for $method";
-		}
-	}
 }
 
 __PACKAGE__;

Modified: branches/upstream/libdata-visitor-perl/current/lib/Data/Visitor/Callback.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libdata-visitor-perl/current/lib/Data/Visitor/Callback.pm?rev=12991&op=diff
==============================================================================
--- branches/upstream/libdata-visitor-perl/current/lib/Data/Visitor/Callback.pm (original)
+++ branches/upstream/libdata-visitor-perl/current/lib/Data/Visitor/Callback.pm Fri Jan 18 21:55:59 2008
@@ -6,9 +6,13 @@
 use strict;
 use warnings;
 
-use Scalar::Util qw/blessed refaddr/;
+use Carp qw(carp);
+use Scalar::Util qw/blessed refaddr reftype/;
 
 __PACKAGE__->mk_accessors( qw/callbacks class_callbacks ignore_return_values/ );
+
+use constant DEBUG => Data::Visitor::DEBUG();
+use constant FIVE_EIGHT => ( $] >= 5.008 );
 
 sub new {
 	my ( $class, %callbacks ) = @_;
@@ -23,7 +27,18 @@
 		$tied_as_objects = delete $callbacks{tied_as_objects};
 	}
 
-	my @class_callbacks = grep { $_->can("isa") } keys %callbacks;
+	my @class_callbacks = do {
+		no strict 'refs';
+		grep {
+			# this check can be half assed because an ->isa check will be
+			# 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
+				or
+			scalar keys %{"${_}::"}
+		} keys %callbacks;
+	};
 
 	$class->SUPER::new({
 		tied_as_objects => $tied_as_objects,
@@ -41,14 +56,19 @@
 	local *_ = \$_[1]; # alias $_
 
 	if ( ref $data and exists $replaced_hash->{ refaddr($data) } ) {
-		return $_[1] = $replaced_hash->{ refaddr($data) };
-	} else {
-		my $ret = $self->SUPER::visit( $self->callback( visit => $data ) );
-
-		$replaced_hash->{ refaddr($data) } = $_ if ref $data and ( not ref $_ or refaddr($data) ne refaddr($_) );
-
-		return $ret;
-	}
+		if ( FIVE_EIGHT ) {
+			$self->trace( mapping => replace => $data, with => $replaced_hash->{ refaddr($data) } ) if DEBUG;
+			return $_[1] = $replaced_hash->{ refaddr($data) };
+		} else {
+			carp(q{Assignment of replacement value for already seen reference } . overload::StrVal($data) . q{ to container doesn't work on Perls older than 5.8, structure shape may have lost integrity.});
+		}
+	}
+
+	my $ret = $self->SUPER::visit( $self->callback( visit => $data ) );
+
+	$replaced_hash->{ refaddr($data) } = $_ if ref $data and ( not ref $_ or refaddr($data) ne refaddr($_) );
+
+	return $ret;
 }
 
 sub visit_value {
@@ -61,14 +81,22 @@
 sub visit_object {
 	my ( $self, $data ) = @_;
 
+	$self->trace( flow => visit_object => $data ) if DEBUG;
+
 	$data = $self->callback_and_reg( object => $data );
+
+	my $class_cb = 0;
 
 	foreach my $class ( @{ $self->class_callbacks } ) {
 		last unless blessed($data);
 		next unless $data->isa($class);
-
+		$self->trace( flow => class_callback => $class, on => $data ) if DEBUG;
+
+		$class_cb++;
 		$data = $self->callback_and_reg( $class => $data );
 	}
+
+	$data = $self->callback_and_reg( object_no_class => $data ) unless $class_cb;
 
 	$data = $self->callback_and_reg( object_final => $data )
 		if blessed($data);
@@ -76,20 +104,29 @@
 	$data;
 }
 
+sub subname { $_[1] }
+
 BEGIN {
+	eval {
+		require Sub::Name;
+		no warnings 'redefine';
+		*subname = \&Sub::Name::subname;
+	};
+
 	foreach my $reftype ( qw/array hash glob scalar code/ ) {
+		my $name = "visit_$reftype";
 		no strict 'refs';
-		*{"visit_$reftype"} = eval '
+		*$name = subname(__PACKAGE__ . "::$name", eval '
 			sub {
 				my ( $self, $data ) = @_;
 				my $new_data = $self->callback_and_reg( '.$reftype.' => $data );
-				if ( "'.uc($reftype).'" eq ref $new_data ) {
+				if ( "'.uc($reftype).'" eq (reftype($new_data)||"") ) {
 					return $self->_register_mapping( $data, $self->SUPER::visit_'.$reftype.'( $new_data ) );
 				} else {
 					return $self->_register_mapping( $data, $self->visit( $new_data ) );
 				}
 			}
-		' || die $@;
+		' || die $@);
 	}
 }
 
@@ -97,6 +134,7 @@
 	my ( $self, $name, $data, @args ) = @_;
 
 	if ( my $code = $self->callbacks->{$name} ) {
+		$self->trace( flow => callback => $name, on => $data ) if DEBUG;
 		my $ret = $self->$code( $data, @args );
 		return $self->ignore_return_values ? $data : $ret ;
 	} else {
@@ -225,13 +263,24 @@
 delegate to C<visit_ref>, you can specify C<visit_ref> as the callback for
 C<object> in order to enter objects.
 
-It is reccomended that you specify the classes you want though, instead of just
-visiting any object forcefully.
+It is reccomended that you specify the classes (or base classes) you want
+though, instead of just visiting any object forcefully.
 
 =item Some::Class
 
-You can use any class name as a callback. This is clled only after the
+You can use any class name as a callback. This is colled only after the
 C<object> callback.
+
+If the object C<isa> the class then the callback will fire.
+
+=item object_no_class
+
+Called for every object that did not have a class callback.
+
+=item object_final
+
+The last callback called for objects, useful if you want to post process the
+output of any class callbacks.
 
 =item array
 

Modified: branches/upstream/libdata-visitor-perl/current/t/circular_refs.t
URL: http://svn.debian.org/wsvn/branches/upstream/libdata-visitor-perl/current/t/circular_refs.t?rev=12991&op=diff
==============================================================================
--- branches/upstream/libdata-visitor-perl/current/t/circular_refs.t (original)
+++ branches/upstream/libdata-visitor-perl/current/t/circular_refs.t Fri Jan 18 21:55:59 2008
@@ -66,7 +66,10 @@
 
 	$c->visit( $orig );
 
-	is( $orig->[0][0], $orig->[1][0], "equality preserved" );
+	{
+		local $TODO = "broken in older perls" unless Data::Visitor::Callback::FIVE_EIGHT();
+		is( $orig->[0][0], $orig->[1][0], "equality preserved" );
+	}
 
 	isnt( $orig->[0][0], $hash, "original replaced" );
 




More information about the Pkg-perl-cvs-commits mailing list