r12587 - in /branches/upstream/libdata-visitor-perl/current: Changes MANIFEST META.yml SIGNATURE lib/Data/Visitor.pm lib/Data/Visitor/Callback.pm t/magic.t
ghostbar-guest at users.alioth.debian.org
ghostbar-guest at users.alioth.debian.org
Sat Jan 12 17:44:41 UTC 2008
Author: ghostbar-guest
Date: Sat Jan 12 17:44:41 2008
New Revision: 12587
URL: http://svn.debian.org/wsvn/?sc=1&rev=12587
Log:
[svn-upgrade] Integrating new upstream version, libdata-visitor-perl (0.13)
Added:
branches/upstream/libdata-visitor-perl/current/t/magic.t
Modified:
branches/upstream/libdata-visitor-perl/current/Changes
branches/upstream/libdata-visitor-perl/current/MANIFEST
branches/upstream/libdata-visitor-perl/current/META.yml
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
Modified: branches/upstream/libdata-visitor-perl/current/Changes
URL: http://svn.debian.org/wsvn/branches/upstream/libdata-visitor-perl/current/Changes?rev=12587&op=diff
==============================================================================
--- branches/upstream/libdata-visitor-perl/current/Changes (original)
+++ branches/upstream/libdata-visitor-perl/current/Changes Sat Jan 12 17:44:41 2008
@@ -1,3 +1,5 @@
+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/MANIFEST
URL: http://svn.debian.org/wsvn/branches/upstream/libdata-visitor-perl/current/MANIFEST?rev=12587&op=diff
==============================================================================
--- branches/upstream/libdata-visitor-perl/current/MANIFEST (original)
+++ branches/upstream/libdata-visitor-perl/current/MANIFEST Sat Jan 12 17:44:41 2008
@@ -11,4 +11,5 @@
t/callback_aliasing.t
t/circular_refs.t
t/globs.t
+t/magic.t
SIGNATURE Public-key signature (added by MakeMaker)
Modified: branches/upstream/libdata-visitor-perl/current/META.yml
URL: http://svn.debian.org/wsvn/branches/upstream/libdata-visitor-perl/current/META.yml?rev=12587&op=diff
==============================================================================
--- branches/upstream/libdata-visitor-perl/current/META.yml (original)
+++ branches/upstream/libdata-visitor-perl/current/META.yml Sat Jan 12 17:44:41 2008
@@ -1,6 +1,6 @@
--- #YAML:1.0
name: Data-Visitor
-version: 0.12
+version: 0.13
abstract: ~
license: ~
author: ~
Modified: branches/upstream/libdata-visitor-perl/current/SIGNATURE
URL: http://svn.debian.org/wsvn/branches/upstream/libdata-visitor-perl/current/SIGNATURE?rev=12587&op=diff
==============================================================================
--- branches/upstream/libdata-visitor-perl/current/SIGNATURE (original)
+++ branches/upstream/libdata-visitor-perl/current/SIGNATURE Sat Jan 12 17:44:41 2008
@@ -14,23 +14,24 @@
-----BEGIN PGP SIGNED MESSAGE-----
Hash: SHA1
-SHA1 c1e09f5d4abd0ebd5d974e7685413c7ec7cd3469 Changes
-SHA1 adbdb1d57cfa058d1ced16b5767527d0dfb6a253 MANIFEST
+SHA1 3a6fda6318bc6d6ca26bb79d386947eedd0ad390 Changes
+SHA1 f0cf3ccc1cd7b0f3215f358edc7fa0099b437aba MANIFEST
SHA1 ddb918d4e02cc06f4b9fe77adeca65403f8fdd56 MANIFEST.SKIP
-SHA1 2bb039af3c3549d34d99550130893f00f375440e META.yml
+SHA1 4011724801055a360b0591ee960cfe89829014a4 META.yml
SHA1 7e820fe45a90871dcc686bd3ffd7897444a6ea30 Makefile.PL
-SHA1 5004053a3513228302b5d5e32d62bbb01f80f7fb lib/Data/Visitor.pm
-SHA1 b47da60abe8faea57006f9a6306d7eee213a953c lib/Data/Visitor/Callback.pm
+SHA1 2bf99b3370e53fc483a1dba0605c12e9a611922c lib/Data/Visitor.pm
+SHA1 73c8a9efabb1e933ab138266fafc2ae45711df83 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 54affd2088fa25d8eec562fb8d39e1abd0d123c7 t/globs.t
+SHA1 8f1c6b34b0cb03dcb358c71cec520e8f1c723a99 t/magic.t
-----BEGIN PGP SIGNATURE-----
Version: GnuPG v1.4.7 (Darwin)
-iD8DBQFHgu3XVCwRwOvSdBgRAky1AJ9mSwUDBFNFHJXfXGEtI0SQk/kXqgCfcEwM
-hUhkzrwTAhAOaac/icA5DjY=
-=vx/H
+iD8DBQFHg5v2VCwRwOvSdBgRAtBqAKCk2rcs2MLF9Xes4CF0XuIv7V7whACgkaCD
+ZxFCfFWlaMVraAk4h3mTDfc=
+=bMjC
-----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=12587&op=diff
==============================================================================
--- branches/upstream/libdata-visitor-perl/current/lib/Data/Visitor.pm (original)
+++ branches/upstream/libdata-visitor-perl/current/lib/Data/Visitor.pm Sat Jan 12 17:44:41 2008
@@ -10,7 +10,9 @@
use overload ();
use Symbol ();
-our $VERSION = "0.12";
+__PACKAGE__->mk_accessors(qw(tied_as_objects));
+
+our $VERSION = "0.13";
sub visit {
my ( $self, $data ) = @_;
@@ -32,6 +34,7 @@
sub _register_mapping {
my ( $self, $data, $new_data ) = @_;
+ return $new_data unless ref $data;
$self->{_seen}{ refaddr($data) } = $new_data;
}
@@ -81,15 +84,26 @@
if ( not defined wantarray ) {
$self->_register_mapping( $hash, $hash );
- foreach my $key ( keys %$hash ) {
- $self->visit_hash_entry( $key, $hash->{$key}, $hash );
- }
+ $self->visit_hash_entries($hash);
} else {
my $new_hash = {};
$self->_register_mapping( $hash, $new_hash );
- %$new_hash = map { $self->visit_hash_entry( $_, $hash->{$_}, $hash ) } keys %$hash;
+
+ 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;
+ } else {
+ %$new_hash = $self->visit_hash_entries($hash);
+ }
+
return $self->retain_magic( $hash, $new_hash );
}
+}
+
+sub visit_hash_entries {
+ my ( $self, $hash ) = @_;
+ no warnings 'void';
+ map { $self->visit_hash_entry( $_, $hash->{$_}, $hash ) } keys %$hash;
}
sub visit_hash_entry {
@@ -116,13 +130,27 @@
if ( not defined wantarray ) {
$self->_register_mapping( $array, $array );
+ $self->visit_array_entries($array);
$self->visit_array_entry( $array->[$_], $_, $array ) for 0 .. $#$array
} else {
my $new_array = [];
$self->_register_mapping( $array, $new_array );
- @$new_array = map { $self->visit_array_entry( $array->[$_], $_, $array ) } 0 .. $#$array;
+
+ my $tied = tied(@$array);
+ if ( $tied and $self->tied_as_objects and blessed(my $new_tied = $self->visit_tied($tied, $array)) ) {
+ tie @$new_array, 'Data::Visitor::TieToObject', $new_tied;
+ } else {
+ @$new_array = $self->visit_array_entries($array);
+ }
+
return $self->retain_magic( $array, $new_array );
}
+}
+
+sub visit_array_entries {
+ my ( $self, $array ) = @_;
+ no warnings 'void';
+ map { $self->visit_array_entry( $array->[$_], $_, $array ) } 0 .. $#$array;
}
sub visit_array_entry {
@@ -132,9 +160,17 @@
sub visit_scalar {
my ( $self, $scalar ) = @_;
+
my $new_scalar;
$self->_register_mapping( $scalar, \$new_scalar );
- $new_scalar = $self->visit( $$scalar );
+
+ my $tied = tied($$scalar);
+ if ( $tied and $self->tied_as_objects and blessed(my $new_tied = $self->visit_tied($tied, $scalar)) ) {
+ tie $new_scalar, 'Data::Visitor::TieToObject', $new_tied;
+ } else {
+ $new_scalar = $self->visit( $$scalar );
+ }
+
return $self->retain_magic( $scalar, \$new_scalar );
}
@@ -150,8 +186,13 @@
$self->_register_mapping( $glob, $new_glob );
- no warnings 'misc'; # Undefined value assigned to typeglob
- *$new_glob = $self->visit( *$glob{$_} || next ) for qw/SCALAR ARRAY HASH/;
+ my $tied = tied(*$glob);
+ if ( $tied and $self->tied_as_objects and blessed(my $new_tied = $self->visit_tied($tied, $glob)) ) {
+ 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 );
}
@@ -166,6 +207,26 @@
# FIXME real magic, too
return $new;
+}
+
+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__;
@@ -272,6 +333,20 @@
Delegates to C<visit> on value. The value is passed as C<$_[1]> to retain
aliasing.
+=item visit_tied $object, $var
+
+When C<tied_as_objects> is enabled and a tied variable (hash, array, glob or
+scalar) is encountered this method will be called on the tied object. If a
+valid mapped value is returned, the newly constructed result container will be
+tied to the return value and no iteration of the contents of the data will be
+made (since all storage is delegated to the tied object).
+
+If a non blessed value is returned from C<visit_tied> then the structure will
+be iterated normally, and the result container will not be tied at all.
+
+This is because tying to the same class and performing the tie operations will
+not yield the same results in many cases.
+
=back
=head1 RETURN VALUE
@@ -305,15 +380,11 @@
Expand C<retain_magic> to support tying at the very least, or even more with
L<Variable::Magic> if possible.
-Tied values might be redirected to an alternate handler that builds a new empty
-value, and ties it to a visited clone of the object the original is tied to
-using a trampoline class. Look into this.
-
=back
=head1 SEE ALSO
-L<Tree::Simple::VisitorFactory>, L<Data::Traverse>
+L<Data::Rmap>, L<Tree::Simple::VisitorFactory>, L<Data::Traverse>
L<http://en.wikipedia.org/wiki/Visitor_pattern>,
L<http://www.ninebynine.org/Software/Learning-Haskell-Notes.html#functors>,
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=12587&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 Sat Jan 12 17:44:41 2008
@@ -18,9 +18,15 @@
$ignore_ret = delete $callbacks{ignore_return_values};
}
+ my $tied_as_objects = 0;
+ if ( exists $callbacks{tied_as_objects} ) {
+ $tied_as_objects = delete $callbacks{tied_as_objects};
+ }
+
my @class_callbacks = grep { $_->can("isa") } keys %callbacks;
$class->SUPER::new({
+ tied_as_objects => $tied_as_objects,
ignore_return_values => $ignore_ret,
callbacks => \%callbacks,
class_callbacks => \@class_callbacks,
@@ -48,31 +54,24 @@
sub visit_value {
my ( $self, $data ) = @_;
- $self->callback( value => $data );
- $self->callback( ( ref($data) ? "ref_value" : "plain_value" ) => $data );
+ $data = $self->callback_and_reg( value => $data );
+ $self->callback_and_reg( ( ref($data) ? "ref_value" : "plain_value" ) => $data );
}
sub visit_object {
my ( $self, $data ) = @_;
- my $ignore = $self->ignore_return_values;
-
- my $new_data = $self->callback( object => $data );
- unless ( $ignore ) {
- $self->_register_mapping( $data, $new_data );
- $data = $new_data;
- }
+ $data = $self->callback_and_reg( object => $data );
foreach my $class ( @{ $self->class_callbacks } ) {
last unless blessed($data);
next unless $data->isa($class);
- my $new_data = $self->callback( $class => $data );
- unless ( $ignore ) {
- $self->_register_mapping( $data, $new_data );
- $data = $new_data;
- }
- }
+ $data = $self->callback_and_reg( $class => $data );
+ }
+
+ $data = $self->callback_and_reg( object_final => $data )
+ if blessed($data);
$data;
}
@@ -83,9 +82,8 @@
*{"visit_$reftype"} = eval '
sub {
my ( $self, $data ) = @_;
- my $new_data = $self->callback( '.$reftype.' => $data );
- $self->_register_mapping( $data, $new_data );
- if ( ref $data eq ref $new_data ) {
+ my $new_data = $self->callback_and_reg( '.$reftype.' => $data );
+ if ( "'.uc($reftype).'" eq ref $new_data ) {
return $self->_register_mapping( $data, $self->SUPER::visit_'.$reftype.'( $new_data ) );
} else {
return $self->_register_mapping( $data, $self->visit( $new_data ) );
@@ -96,14 +94,31 @@
}
sub callback {
- my ( $self, $name, $data ) = @_;
+ my ( $self, $name, $data, @args ) = @_;
if ( my $code = $self->callbacks->{$name} ) {
- my $ret = $self->$code( $data );
+ my $ret = $self->$code( $data, @args );
return $self->ignore_return_values ? $data : $ret ;
} else {
return $data;
}
+}
+
+sub callback_and_reg {
+ my ( $self, $name, $data, @args ) = @_;
+
+ my $new_data = $self->callback( $name, $data, @args );
+
+ unless ( $self->ignore_return_values ) {
+ return $self->_register_mapping( $data, $new_data );
+ } else {
+ return $data;
+ }
+}
+
+sub visit_tied {
+ my ( $self, $tied, @args ) = @_;
+ $self->SUPER::visit_tied( $self->callback_and_reg( tied => $tied, @args ) );
}
__PACKAGE__;
@@ -152,6 +167,13 @@
This is useful when you want to modify $_ directly
+=item tied_as_objects
+
+Whether ot not to visit the L<perlfunc/tied> of a tied structure instead of
+pretending the structure is just a normal one.
+
+See L<Data::Visitor/visit_tied>.
+
=back
=back
@@ -227,6 +249,11 @@
Called for scalar references.
+=item tied
+
+Called on the return value of C<tied> for all tied containers. Also passes in
+the variable as the second argument.
+
=back
=head1 AUTHOR
Added: branches/upstream/libdata-visitor-perl/current/t/magic.t
URL: http://svn.debian.org/wsvn/branches/upstream/libdata-visitor-perl/current/t/magic.t?rev=12587&op=file
==============================================================================
--- branches/upstream/libdata-visitor-perl/current/t/magic.t (added)
+++ branches/upstream/libdata-visitor-perl/current/t/magic.t Sat Jan 12 17:44:41 2008
@@ -1,0 +1,32 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More 'no_plan';
+
+use ok 'Data::Visitor::Callback';
+
+use Tie::RefHash;
+
+my $h = {
+ foo => {},
+};
+
+tie %{ $h->{foo} }, "Tie::RefHash";
+
+$h->{bar}{gorch} = $h->{foo};
+
+$h->{foo}{[1, 2, 3]} = "blart";
+
+my $v = Data::Visitor::Callback->new( tied_as_objects => 1 );
+
+my $copy = $v->visit($h);
+
+isnt( $copy, $h, "it's a copy" );
+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" );
+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