r25985 - in /trunk/libdata-visitor-perl: Changes META.yml SIGNATURE debian/changelog debian/control lib/Data/Visitor.pm lib/Data/Visitor/Callback.pm t/base.t t/bugs.t t/magic.t
gwolf at users.alioth.debian.org
gwolf at users.alioth.debian.org
Sun Oct 12 19:32:42 UTC 2008
Author: gwolf
Date: Sun Oct 12 19:32:39 2008
New Revision: 25985
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=25985
Log:
New upstream version; declaring dependencies on a yet-to-be-uploaded
package (libmouse-perl)
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/debian/control
trunk/libdata-visitor-perl/lib/Data/Visitor.pm
trunk/libdata-visitor-perl/lib/Data/Visitor/Callback.pm
trunk/libdata-visitor-perl/t/base.t
trunk/libdata-visitor-perl/t/bugs.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=25985&op=diff
==============================================================================
--- trunk/libdata-visitor-perl/Changes (original)
+++ trunk/libdata-visitor-perl/Changes Sun Oct 12 19:32:39 2008
@@ -1,3 +1,9 @@
+0.21
+ - Fix a bug in Data::Visitor::Callback WRT returning non reference values
+ from callbacks (#38306).
+ - Refactor the visit_tied split
+ - Propagation of void context
+
0.20
- Split visit_tied into methods per each reftype, to make it possible to
return something that is an object but still doesn't get tied.
Modified: trunk/libdata-visitor-perl/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdata-visitor-perl/META.yml?rev=25985&op=diff
==============================================================================
--- trunk/libdata-visitor-perl/META.yml (original)
+++ trunk/libdata-visitor-perl/META.yml Sun Oct 12 19:32:39 2008
@@ -1,6 +1,6 @@
--- #YAML:1.0
name: Data-Visitor
-version: 0.20
+version: 0.21
abstract: ~
license: ~
author: ~
Modified: trunk/libdata-visitor-perl/SIGNATURE
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdata-visitor-perl/SIGNATURE?rev=25985&op=diff
==============================================================================
--- trunk/libdata-visitor-perl/SIGNATURE (original)
+++ trunk/libdata-visitor-perl/SIGNATURE Sun Oct 12 19:32:39 2008
@@ -14,26 +14,26 @@
-----BEGIN PGP SIGNED MESSAGE-----
Hash: SHA1
-SHA1 ceeb8fc9f7d76f98cefef5391b4c158962f4c806 Changes
+SHA1 540130e615abd56c3f3f8fe780f4239bda2e35a9 Changes
SHA1 106762d02554191b029a90b21c412fcdeb7a0db3 MANIFEST
SHA1 e8482690dad0ff3aaa335aa5b8b650851e504871 MANIFEST.SKIP
-SHA1 64f336386023c0e5d03bbd2ffc57ef5bb862d851 META.yml
+SHA1 ff8b6b589050387ba8ce949cfff8f42c81d39b24 META.yml
SHA1 77503aee33fccc87148e852ef51462bd6fcbe3ce Makefile.PL
SHA1 6cf45b4e947e1bb11fd188e9866d73eabc936ead TODO
-SHA1 d72bfffd684123e62862ab882f34c413f08a487f lib/Data/Visitor.pm
-SHA1 977e34f680aaf8acfafb415b02fb06c507ed55bd lib/Data/Visitor/Callback.pm
-SHA1 dfba09a3df7adaf6d0369a4745e6e336272c405d t/base.t
-SHA1 257c858e1bc12c1039e93cac62a0d37f2e0d804d t/bugs.t
+SHA1 8b70a4559b107f90d89808bfaf5859d4969019d0 lib/Data/Visitor.pm
+SHA1 844edf4f5a2cbdf77e96620c2812f875f99988ae lib/Data/Visitor/Callback.pm
+SHA1 5979c9ecf150b843cb7750f761c0a9c0c1211a41 t/base.t
+SHA1 85ffd870fe37f7fd4ce1fc783f366bc50c253a02 t/bugs.t
SHA1 e4b813021fa680c61cb4229a9ddeb0a22ec5bf82 t/callback.t
SHA1 3836b0eeb006cc4984e80dec1a537b808c3173d2 t/callback_aliasing.t
SHA1 ba502603afe759f9f22026c8c6527d1753fa6174 t/circular_refs.t
SHA1 54affd2088fa25d8eec562fb8d39e1abd0d123c7 t/globs.t
-SHA1 a3a3ead5cdb91a600fb6c7ae585bfe98fcf82bbf t/magic.t
+SHA1 8bd93450c072afbef10a423dd360e8f55cdacd40 t/magic.t
SHA1 66d201c2ce83481cee0a2838f118b5cce35c8bcc t/weak.t
-----BEGIN PGP SIGNATURE-----
Version: GnuPG v1.4.7 (Darwin)
-iD8DBQFIyo7zVCwRwOvSdBgRAte0AJ9P2zjzKAZ6LlYIwRLlwyquaebfZACgq3qw
-8rTPvZa9r0wmcbxcSPMU9pM=
-=wC46
+iD8DBQFIzrMEVCwRwOvSdBgRAhxuAJ4tz/nrKuUOWRz0geJm1/CD6WzBOwCgtrTP
+QRAGjEssTlCNGoUYWYyEa3Y=
+=HixG
-----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=25985&op=diff
==============================================================================
--- trunk/libdata-visitor-perl/debian/changelog (original)
+++ trunk/libdata-visitor-perl/debian/changelog Sun Oct 12 19:32:39 2008
@@ -1,13 +1,15 @@
-libdata-visitor-perl (0.20-1) UNRELEASED; urgency=low
+libdata-visitor-perl (0.21-1) UNRELEASED; urgency=low
TODO: tests failing trying to find Squirrel.pm, needs non-existent Squirrel
package now
(Squirrel.pm is part of the Mouse dist: http://search.cpan.org/dist/Mouse/)
Squirrel also depends on Class::Method::Modifiers
-
+ I'm currently building Mouse -Gunnar
+
+ [ Jose Luis Rivas ]
* New upstream release.
- -- Jose Luis Rivas <ghostbar38 at gmail.com> Tue, 22 Jul 2008 00:23:16 -0430
+ -- Gunnar Wolf <gwolf at debian.org> Sun, 12 Oct 2008 13:55:48 -0500
libdata-visitor-perl (0.17-1) unstable; urgency=low
Modified: trunk/libdata-visitor-perl/debian/control
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdata-visitor-perl/debian/control?rev=25985&op=diff
==============================================================================
--- trunk/libdata-visitor-perl/debian/control (original)
+++ trunk/libdata-visitor-perl/debian/control Sun Oct 12 19:32:39 2008
@@ -3,7 +3,8 @@
Priority: optional
Build-Depends: debhelper (>= 6)
Build-Depends-Indep: perl (>= 5.8.0-7), libtest-use-ok-perl,
- libtest-mockobject-perl (>= 1.05), libclass-accessor-perl, libtie-toobject-perl
+ libtest-mockobject-perl (>= 1.05), libclass-accessor-perl, libtie-toobject-perl,
+ libmouse-perl
Maintainer: Debian Perl Group <pkg-perl-maintainers at lists.alioth.debian.org>
Uploaders: Krzysztof Krzyzaniak (eloy) <eloy at debian.org>,
gregor herrmann <gregoa at debian.org>,
@@ -16,7 +17,8 @@
Package: libdata-visitor-perl
Architecture: all
Depends: ${perl:Depends}, ${misc:Depends}, libtest-use-ok-perl,
- libtest-mockobject-perl (>= 1.05), libclass-accessor-perl, libtie-toobject-perl
+ libtest-mockobject-perl (>= 1.05), libclass-accessor-perl, libtie-toobject-perl,
+ libmouse-perl
Description: A visitor for Perl data structures
Data::Visitor is a simple visitor implementation for Perl values.
.
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=25985&op=diff
==============================================================================
--- trunk/libdata-visitor-perl/lib/Data/Visitor.pm (original)
+++ trunk/libdata-visitor-perl/lib/Data/Visitor.pm Sun Oct 12 19:32:39 2008
@@ -14,7 +14,7 @@
# the double not 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};
-our $VERSION = "0.20";
+our $VERSION = "0.21";
has tied_as_objects => (
isa => "Bool",
@@ -69,7 +69,11 @@
}
}
- push @ret, $self->visit_no_rec_check( $data );
+ if ( defined wantarray ) {
+ push @ret, scalar($self->visit_no_rec_check($data));
+ } else {
+ $self->visit_no_rec_check($data);
+ }
}
return ( @_ == 1 ? $ret[0] : @ret );
@@ -144,48 +148,48 @@
local $self->{depth} = (($self->{depth}||0) + 1) if DEBUG;
- if ( not defined wantarray ) {
- $self->_register_mapping( $hash, $hash );
-
- if ( defined(tied(%$hash)) and $self->tied_as_objects ) {
- $self->visit_tied(tied(%$hash), $_[1]);
- } else {
- $self->visit_hash_entries($_[1]);
- }
-
- return;
- } else {
- if ( defined(tied(%$hash)) and $self->tied_as_objects ) {
- return $self->visit_tied_hash(tied(%$hash), $_[1]);
- } else {
- return $self->visit_normal_hash($_[1]);
- }
+ if ( defined(tied(%$hash)) and $self->tied_as_objects ) {
+ return $self->visit_tied_hash(tied(%$hash), $_[1]);
+ } else {
+ return $self->visit_normal_hash($_[1]);
}
}
sub visit_normal_hash {
my ( $self, $hash ) = @_;
- my $new_hash = {};
- $self->_register_mapping( $hash, $new_hash );
-
- %$new_hash = $self->visit_hash_entries($_[1]);
-
- return $self->retain_magic( $_[1], $new_hash );
+ if ( defined wantarray ) {
+ my $new_hash = {};
+ $self->_register_mapping( $hash, $new_hash );
+
+ %$new_hash = $self->visit_hash_entries($_[1]);
+
+ return $self->retain_magic( $_[1], $new_hash );
+ } else {
+ $self->_register_mapping($hash, $hash);
+ $self->visit_hash_entries($_[1]);
+ return;
+ }
}
sub visit_tied_hash {
my ( $self, $tied, $hash ) = @_;
- my $new_hash = {};
- $self->_register_mapping( $hash, $new_hash );
-
- if ( blessed(my $new_tied = $self->visit_tied(tied(%$hash), $_[2])) ) {
- $self->trace( data => tying => var => $new_hash, to => $new_tied ) if DEBUG;
- tie %$new_hash, 'Tie::ToObject', $new_tied;
- return $self->retain_magic($_[2], $new_hash);
- } else {
- return $self->visit_normal_hash($_[2]);
+ if ( defined wantarray ) {
+ my $new_hash = {};
+ $self->_register_mapping( $hash, $new_hash );
+
+ if ( blessed(my $new_tied = $self->visit_tied($_[1], $_[2])) ) {
+ $self->trace( data => tying => var => $new_hash, to => $new_tied ) if DEBUG;
+ tie %$new_hash, 'Tie::ToObject', $new_tied;
+ return $self->retain_magic($_[2], $new_hash);
+ } else {
+ return $self->visit_normal_hash($_[2]);
+ }
+ } else {
+ $self->_register_mapping($hash, $hash);
+ $self->visit_tied($_[1], $_[2]);
+ return;
}
}
@@ -228,48 +232,50 @@
sub visit_array {
my ( $self, $array ) = @_;
- if ( not defined wantarray ) {
- $self->_register_mapping( $array, $array );
-
- if ( defined(tied @$array) and $self->tied_as_objects ) {
- $self->visit_tied(tied(@$array), $_[1]);
- } else {
- $self->visit_array_entries($_[1]);
- }
-
- return;
- } else {
- if ( defined(tied(@$array)) and $self->tied_as_objects ) {
- return $self->visit_tied_array(tied(@$array), $_[1]);
- } else {
- return $self->visit_normal_array($_[1]);
- }
+ if ( defined(tied(@$array)) and $self->tied_as_objects ) {
+ return $self->visit_tied_array(tied(@$array), $_[1]);
+ } else {
+ return $self->visit_normal_array($_[1]);
}
}
sub visit_normal_array {
my ( $self, $array ) = @_;
- my $new_array = [];
- $self->_register_mapping( $array, $new_array );
-
- @$new_array = $self->visit_array_entries($_[1]);
-
- return $self->retain_magic( $_[1], $new_array );
+ if ( defined wantarray ) {
+ my $new_array = [];
+ $self->_register_mapping( $array, $new_array );
+
+ @$new_array = $self->visit_array_entries($_[1]);
+
+ return $self->retain_magic( $_[1], $new_array );
+ } else {
+ $self->_register_mapping( $array, $array );
+ $self->visit_array_entries($_[1]);
+
+ return;
+ }
}
sub visit_tied_array {
my ( $self, $tied, $array ) = @_;
- my $new_array = [];
- $self->_register_mapping( $array, $new_array );
-
- if ( blessed(my $new_tied = $self->visit_tied(tied(@$array), $_[2])) ) {
- $self->trace( data => tying => var => $new_array, to => $new_tied ) if DEBUG;
- tie @$new_array, 'Tie::ToObject', $new_tied;
- return $self->retain_magic($_[2], $new_array);
- } else {
- return $self->visit_normal_array($_[2]);
+ if ( defined wantarray ) {
+ my $new_array = [];
+ $self->_register_mapping( $array, $new_array );
+
+ if ( blessed(my $new_tied = $self->visit_tied($_[1], $_[2])) ) {
+ $self->trace( data => tying => var => $new_array, to => $new_tied ) if DEBUG;
+ tie @$new_array, 'Tie::ToObject', $new_tied;
+ return $self->retain_magic($_[2], $new_array);
+ } else {
+ return $self->visit_normal_array($_[2]);
+ }
+ } else {
+ $self->_register_mapping( $array, $array );
+ $self->visit_tied($_[1], $_[2]);
+
+ return;
}
}
@@ -291,51 +297,49 @@
sub visit_scalar {
my ( $self, $scalar ) = @_;
- if ( not defined wantarray ) {
- $self->_register_mapping( $scalar, $scalar );
-
- if ( defined(tied($$scalar)) and $self->tied_as_objects ) {
- $self->visit_tied(tied($$scalar), $_[1]);
- } else {
- $self->visit($$scalar);
- }
-
- return;
- } else {
+ if ( defined(tied($$scalar)) and $self->tied_as_objects ) {
+ return $self->visit_tied_scalar(tied($$scalar), $_[1]);
+ } else {
+ return $self->visit_normal_scalar($_[1]);
+ }
+}
+
+sub visit_normal_scalar {
+ my ( $self, $scalar ) = @_;
+
+ if ( defined wantarray ) {
my $new_scalar;
$self->_register_mapping( $scalar, \$new_scalar );
- if ( defined(tied($$scalar)) and $self->tied_as_objects ) {
- return $self->visit_tied_scalar(tied($$scalar), $_[1]);
- } else {
- return $self->visit_normal_scalar($_[1]);
- }
- }
-}
-
-sub visit_normal_scalar {
- my ( $self, $scalar ) = @_;
-
- my $new_scalar;
- $self->_register_mapping( $scalar, \$new_scalar );
-
- $new_scalar = $self->visit( $$scalar );
-
- return $self->retain_magic($_[1], \$new_scalar);
+ $new_scalar = $self->visit( $$scalar );
+
+ return $self->retain_magic($_[1], \$new_scalar);
+ } else {
+ $self->_register_mapping( $scalar, $scalar );
+ $self->visit( $$scalar );
+ return;
+ }
+
}
sub visit_tied_scalar {
my ( $self, $tied, $scalar ) = @_;
- my $new_scalar;
- $self->_register_mapping( $scalar, \$new_scalar );
-
- if ( blessed(my $new_tied = $self->visit_tied(tied($$scalar), $_[2])) ) {
- $self->trace( data => tying => var => $new_scalar, to => $new_tied ) if DEBUG;
- tie $new_scalar, 'Tie::ToObject', $new_tied;
- return $self->retain_magic($_[2], \$new_scalar);
- } else {
- return $self->visit_normal_array($_[2]);
+ if ( defined wantarray ) {
+ my $new_scalar;
+ $self->_register_mapping( $scalar, \$new_scalar );
+
+ if ( blessed(my $new_tied = $self->visit_tied($_[1], $_[2])) ) {
+ $self->trace( data => tying => var => $new_scalar, to => $new_tied ) if DEBUG;
+ tie $new_scalar, 'Tie::ToObject', $new_tied;
+ return $self->retain_magic($_[2], \$new_scalar);
+ } else {
+ return $self->visit_normal_scalar($_[2]);
+ }
+ } else {
+ $self->_register_mapping( $scalar, $scalar );
+ $self->visit_tied($_[1], $_[2]);
+ return;
}
}
@@ -347,49 +351,49 @@
sub visit_glob {
my ( $self, $glob ) = @_;
- if ( not defined wantarray ) {
- $self->_register_mapping( $glob, $glob );
-
- if ( defined(tied(*$glob)) and $self->tied_as_objects ) {
- $self->visit_tied(tied(*$glob), $_[1]);
- } else {
- $self->visit( *$glob{$_} || next ) for qw/SCALAR ARRAY HASH/;
- }
-
- return;
- } else {
- if ( defined(tied(*$glob)) and $self->tied_as_objects ) {
- return $self->visit_tied_glob(tied(*$glob), $_[1]);
- } else {
- return $self->visit_normal_glob($_[1]);
- }
+ if ( defined(tied(*$glob)) and $self->tied_as_objects ) {
+ return $self->visit_tied_glob(tied(*$glob), $_[1]);
+ } else {
+ return $self->visit_normal_glob($_[1]);
}
}
sub visit_normal_glob {
my ( $self, $glob ) = @_;
- my $new_glob = Symbol::gensym();
- $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/;
-
- return $self->retain_magic($_[1], $new_glob);
+ if ( defined wantarray ) {
+ my $new_glob = Symbol::gensym();
+ $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/;
+
+ return $self->retain_magic($_[1], $new_glob);
+ } else {
+ $self->_register_mapping( $glob, $glob );
+ $self->visit( *$glob{$_} || next ) for qw/SCALAR ARRAY HASH/;
+ return;
+ }
}
sub visit_tied_glob {
my ( $self, $tied, $glob ) = @_;
- my $new_glob = Symbol::gensym();
- $self->_register_mapping( $glob, \$new_glob );
-
- if ( blessed(my $new_tied = $self->visit_tied($tied, $_[2])) ) {
- $self->trace( data => tying => var => $new_glob, to => $new_tied ) if DEBUG;
- tie *$new_glob, 'Tie::ToObject', $new_tied;
- return $self->retain_magic($_[2], $new_glob);
- } else {
- return $self->visit_normal_glob($_[2]);
+ if ( defined wantarray ) {
+ my $new_glob = Symbol::gensym();
+ $self->_register_mapping( $glob, \$new_glob );
+
+ if ( blessed(my $new_tied = $self->visit_tied($_[1], $_[2])) ) {
+ $self->trace( data => tying => var => $new_glob, to => $new_tied ) if DEBUG;
+ tie *$new_glob, 'Tie::ToObject', $new_tied;
+ return $self->retain_magic($_[2], $new_glob);
+ } else {
+ return $self->visit_normal_glob($_[2]);
+ }
+ } else {
+ $self->_register_mapping( $glob, $glob );
+ $self->visit_tied($_[1], $_[2]);
+ return;
}
}
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=25985&op=diff
==============================================================================
--- trunk/libdata-visitor-perl/lib/Data/Visitor/Callback.pm (original)
+++ trunk/libdata-visitor-perl/lib/Data/Visitor/Callback.pm Sun Oct 12 19:32:39 2008
@@ -87,11 +87,17 @@
}
}
- my $ret = $self->SUPER::visit( $self->callback( visit => $data ) );
+ my $ret;
+
+ if ( defined wantarray ) {
+ $ret = $self->SUPER::visit( $self->callback( visit => $data ) );
+ } else {
+ $self->SUPER::visit( $self->callback( visit => $data ) );
+ }
$replaced_hash->{$refaddr} = $_ if $refaddr and ( not ref $_ or $refaddr ne refaddr($_) );
- push @ret, $ret;
+ push @ret, $ret if defined wantarray;
}
return ( @_ == 1 ? $ret[0] : @ret );
@@ -212,9 +218,13 @@
unless ( $self->ignore_return_values ) {
no warnings 'uninitialized';
- if ( refaddr($data) != refaddr($new_data) ) {
- return $self->_register_mapping( $data, $new_data );
+ if ( ref $data ) {
+ if ( refaddr($data) != refaddr($new_data) ) {
+ return $self->_register_mapping( $data, $new_data );
+ }
}
+
+ return $new_data;
}
return $data;
Modified: trunk/libdata-visitor-perl/t/base.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdata-visitor-perl/t/base.t?rev=25985&op=diff
==============================================================================
--- trunk/libdata-visitor-perl/t/base.t (original)
+++ trunk/libdata-visitor-perl/t/base.t Sun Oct 12 19:32:39 2008
@@ -3,7 +3,7 @@
use strict;
use warnings;
-use Test::More tests => 31;
+use Test::More tests => 32;
use Test::MockObject::Extends;
my $m;
@@ -14,7 +14,9 @@
can_ok( $o, "visit" );
-my @things = ( "foo", 1, undef, 0, {}, [], bless({}, "Some::Class") );
+my @things = ( "foo", 1, undef, 0, {}, [], do { my $x = "blah"; \$x }, bless({}, "Some::Class") );
+
+$o->visit($_) for @things; # no explosions in void context
is_deeply( $o->visit( $_ ), $_, "visit returns value unlatered" ) for @things;
Modified: trunk/libdata-visitor-perl/t/bugs.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdata-visitor-perl/t/bugs.t?rev=25985&op=diff
==============================================================================
--- trunk/libdata-visitor-perl/t/bugs.t (original)
+++ trunk/libdata-visitor-perl/t/bugs.t Sun Oct 12 19:32:39 2008
@@ -3,10 +3,28 @@
use strict;
use warnings;
-use Test::More tests => 2;
+use Test::More tests => 3;
use Data::Visitor::Callback;
sub newcb { Data::Visitor::Callback->new( @_ ) }
ok( !newcb()->ignore_return_values, "ignore_return_values defaults to false" );
is( newcb( ignore_return_values => 1 )->ignore_return_values, 1, "but can be set as initial param" );
+
+{
+ my $data = {
+ action => 'original'
+ };
+
+ my $callbacks = {
+ value => sub {
+ my( $visitor, $data ) = @_;
+# program gets to here and $data eq 'original'
+ return 'modified';
+ }
+ };
+
+ my $v = Data::Visitor::Callback->new( %$callbacks );
+
+ is_deeply( $v->visit($data), { modified => "modified" } );
+}
Modified: trunk/libdata-visitor-perl/t/magic.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdata-visitor-perl/t/magic.t?rev=25985&op=diff
==============================================================================
--- trunk/libdata-visitor-perl/t/magic.t (original)
+++ trunk/libdata-visitor-perl/t/magic.t Sun Oct 12 19:32:39 2008
@@ -32,3 +32,54 @@
ok( ref( ( keys %{ $copy->{foo} } )[0] ), "the key is a ref" );
is_deeply([ keys %{ $copy->{foo} } ], [ keys %{ $h->{foo} } ], "keys eq deeply" );
+my $v_no_tie = Data::Visitor::Callback->new( tied_as_objects => 0 );
+
+my $no_tie_copy = $v_no_tie->visit($h);
+
+ok( !tied(%{ $no_tie_copy->{foo} }), "not tied" );
+
+sub Foo::AUTOLOAD { fail("tie interface must not be called") }
+sub Foo::DESTROY {} # no fail
+
+{
+ foreach my $v (
+ Data::Visitor::Callback->new( tied_as_objects => 1 ),
+ Data::Visitor->new( tied_as_objects => 1 )
+ ) {
+ my $x = bless {}, "Foo";
+
+ use Tie::ToObject;
+
+ tie my @array, 'Tie::ToObject' => $x;
+ tie my %hash, 'Tie::ToObject' => $x;
+ tie *handle, 'Tie::ToObject' => $x;
+ tie my $scalar,'Tie::ToObject' => $x;
+
+ {
+ $v->visit(\@array);
+ my $copy = $v->visit(\@array);
+ is( ref($copy), "ARRAY", "tied array" );
+ ok( tied(@$copy), "copy is tied" );
+ }
+
+ {
+ $v->visit(\%hash);
+ my $copy = $v->visit(\%hash);
+ is( ref($copy), "HASH", "tied array" );
+ ok( tied(%$copy), "copy is tied" );
+ }
+
+ {
+ $v->visit(\$scalar);
+ my $copy = $v->visit(\$scalar);
+ is( ref($copy), "SCALAR", "tied array" );
+ ok( tied($$copy), "copy is tied" );
+ }
+ {
+ $v->visit(\*handle);
+ my $copy = $v->visit(\*handle);
+ is( ref($copy), "GLOB", "tied array" );
+ ok( tied(*$copy), "copy is tied" );
+ }
+ }
+}
More information about the Pkg-perl-cvs-commits
mailing list