r12993 - in /trunk/libdata-visitor-perl: Changes META.yml Makefile.PL SIGNATURE debian/changelog 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:58:01 UTC 2008
Author: gregoa-guest
Date: Fri Jan 18 21:58:01 2008
New Revision: 12993
URL: http://svn.debian.org/wsvn/?sc=1&rev=12993
Log:
New upstream release.
Modified:
trunk/libdata-visitor-perl/Changes
trunk/libdata-visitor-perl/META.yml
trunk/libdata-visitor-perl/Makefile.PL
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
Modified: trunk/libdata-visitor-perl/Changes
URL: http://svn.debian.org/wsvn/trunk/libdata-visitor-perl/Changes?rev=12993&op=diff
==============================================================================
--- trunk/libdata-visitor-perl/Changes (original)
+++ trunk/libdata-visitor-perl/Changes Fri Jan 18 21:58:01 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: trunk/libdata-visitor-perl/META.yml
URL: http://svn.debian.org/wsvn/trunk/libdata-visitor-perl/META.yml?rev=12993&op=diff
==============================================================================
--- trunk/libdata-visitor-perl/META.yml (original)
+++ trunk/libdata-visitor-perl/META.yml Fri Jan 18 21:58:01 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: trunk/libdata-visitor-perl/Makefile.PL
URL: http://svn.debian.org/wsvn/trunk/libdata-visitor-perl/Makefile.PL?rev=12993&op=diff
==============================================================================
--- trunk/libdata-visitor-perl/Makefile.PL (original)
+++ trunk/libdata-visitor-perl/Makefile.PL Fri Jan 18 21:58:01 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: trunk/libdata-visitor-perl/SIGNATURE
URL: http://svn.debian.org/wsvn/trunk/libdata-visitor-perl/SIGNATURE?rev=12993&op=diff
==============================================================================
--- trunk/libdata-visitor-perl/SIGNATURE (original)
+++ trunk/libdata-visitor-perl/SIGNATURE Fri Jan 18 21:58:01 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: trunk/libdata-visitor-perl/debian/changelog
URL: http://svn.debian.org/wsvn/trunk/libdata-visitor-perl/debian/changelog?rev=12993&op=diff
==============================================================================
--- trunk/libdata-visitor-perl/debian/changelog (original)
+++ trunk/libdata-visitor-perl/debian/changelog Fri Jan 18 21:58:01 2008
@@ -1,3 +1,9 @@
+libdata-visitor-perl (0.15-1) UNRELEASED; urgency=low
+
+ * New upstream release.
+
+ -- gregor herrmann <gregor+debian at comodo.priv.at> Fri, 18 Jan 2008 22:56:01 +0100
+
libdata-visitor-perl (0.13-1) unstable; urgency=low
[ gregor herrmann ]
Modified: trunk/libdata-visitor-perl/lib/Data/Visitor.pm
URL: http://svn.debian.org/wsvn/trunk/libdata-visitor-perl/lib/Data/Visitor.pm?rev=12993&op=diff
==============================================================================
--- trunk/libdata-visitor-perl/lib/Data/Visitor.pm (original)
+++ trunk/libdata-visitor-perl/lib/Data/Visitor.pm Fri Jan 18 21:58:01 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: trunk/libdata-visitor-perl/lib/Data/Visitor/Callback.pm
URL: http://svn.debian.org/wsvn/trunk/libdata-visitor-perl/lib/Data/Visitor/Callback.pm?rev=12993&op=diff
==============================================================================
--- trunk/libdata-visitor-perl/lib/Data/Visitor/Callback.pm (original)
+++ trunk/libdata-visitor-perl/lib/Data/Visitor/Callback.pm Fri Jan 18 21:58:01 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: trunk/libdata-visitor-perl/t/circular_refs.t
URL: http://svn.debian.org/wsvn/trunk/libdata-visitor-perl/t/circular_refs.t?rev=12993&op=diff
==============================================================================
--- trunk/libdata-visitor-perl/t/circular_refs.t (original)
+++ trunk/libdata-visitor-perl/t/circular_refs.t Fri Jan 18 21:58:01 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