r2313 - in packages: . libdata-visitor-perl
libdata-visitor-perl/branches libdata-visitor-perl/branches/upstream
libdata-visitor-perl/branches/upstream/current
libdata-visitor-perl/branches/upstream/current/lib
libdata-visitor-perl/branches/upstream/current/lib/Data
libdata-visitor-perl/branches/upstream/current/lib/Data/Visitor
libdata-visitor-perl/branches/upstream/current/t
Krzysztof Krzyzaniak
eloy at costa.debian.org
Sat Mar 11 16:24:11 UTC 2006
Author: eloy
Date: 2006-03-11 16:24:09 +0000 (Sat, 11 Mar 2006)
New Revision: 2313
Added:
packages/libdata-visitor-perl/
packages/libdata-visitor-perl/branches/
packages/libdata-visitor-perl/branches/upstream/
packages/libdata-visitor-perl/branches/upstream/current/
packages/libdata-visitor-perl/branches/upstream/current/Build.PL
packages/libdata-visitor-perl/branches/upstream/current/Changes
packages/libdata-visitor-perl/branches/upstream/current/MANIFEST
packages/libdata-visitor-perl/branches/upstream/current/META.yml
packages/libdata-visitor-perl/branches/upstream/current/Makefile.PL
packages/libdata-visitor-perl/branches/upstream/current/SIGNATURE
packages/libdata-visitor-perl/branches/upstream/current/lib/
packages/libdata-visitor-perl/branches/upstream/current/lib/Data/
packages/libdata-visitor-perl/branches/upstream/current/lib/Data/Visitor.pm
packages/libdata-visitor-perl/branches/upstream/current/lib/Data/Visitor/
packages/libdata-visitor-perl/branches/upstream/current/lib/Data/Visitor/Callback.pm
packages/libdata-visitor-perl/branches/upstream/current/t/
packages/libdata-visitor-perl/branches/upstream/current/t/base.t
packages/libdata-visitor-perl/branches/upstream/current/t/callback.t
packages/libdata-visitor-perl/branches/upstream/current/t/callback_aliasing.t
packages/libdata-visitor-perl/branches/upstream/current/t/circular_refs.t
packages/libdata-visitor-perl/branches/upstream/current/t/globs.t
packages/libdata-visitor-perl/tags/
Log:
[svn-inject] Installing original source of libdata-visitor-perl
Added: packages/libdata-visitor-perl/branches/upstream/current/Build.PL
===================================================================
--- packages/libdata-visitor-perl/branches/upstream/current/Build.PL 2006-03-11 13:54:31 UTC (rev 2312)
+++ packages/libdata-visitor-perl/branches/upstream/current/Build.PL 2006-03-11 16:24:09 UTC (rev 2313)
@@ -0,0 +1,21 @@
+#!/usr/bin/perl -w
+
+use strict;
+
+use Module::Build;
+
+Module::Build->new(
+ module_name => 'Data::Visitor',
+ license => 'perl',
+ requires => {
+ 'perl' => '>= 5.008',
+ },
+ build_requires => {
+ 'Test::More' => 0,
+ 'Test::use::ok' => 0,
+ 'Test::MockObject::Extends' => 0,
+ },
+ create_makefile_pl => 'traditional',
+ sign => 1,
+)->create_build_script;
+
Added: packages/libdata-visitor-perl/branches/upstream/current/Changes
===================================================================
--- packages/libdata-visitor-perl/branches/upstream/current/Changes 2006-03-11 13:54:31 UTC (rev 2312)
+++ packages/libdata-visitor-perl/branches/upstream/current/Changes 2006-03-11 16:24:09 UTC (rev 2313)
@@ -0,0 +1,8 @@
+0.02
+ - Added GLOB recursion support
+ - Added support for circular references
+ _ Added aliasing to $_ to Data::Validator::Callback
+ - Added ignore_return_values to Data::Validator::Callback
+
+0.01
+ - Initial release
Added: packages/libdata-visitor-perl/branches/upstream/current/MANIFEST
===================================================================
--- packages/libdata-visitor-perl/branches/upstream/current/MANIFEST 2006-03-11 13:54:31 UTC (rev 2312)
+++ packages/libdata-visitor-perl/branches/upstream/current/MANIFEST 2006-03-11 16:24:09 UTC (rev 2313)
@@ -0,0 +1,13 @@
+Build.PL
+Changes
+lib/Data/Visitor.pm
+lib/Data/Visitor/Callback.pm
+Makefile.PL
+MANIFEST This list of files
+META.yml
+t/base.t
+t/callback.t
+t/callback_aliasing.t
+t/circular_refs.t
+t/globs.t
+SIGNATURE Added here by Module::Build
Added: packages/libdata-visitor-perl/branches/upstream/current/META.yml
===================================================================
--- packages/libdata-visitor-perl/branches/upstream/current/META.yml 2006-03-11 13:54:31 UTC (rev 2312)
+++ packages/libdata-visitor-perl/branches/upstream/current/META.yml 2006-03-11 16:24:09 UTC (rev 2313)
@@ -0,0 +1,20 @@
+---
+name: Data-Visitor
+version: 0.02
+author:
+ - Yuval Kogman <nothingmuch at woobling.org>
+abstract: A visitor for Perl data structures
+license: perl
+requires:
+ perl: >= 5.008
+build_requires:
+ Test::MockObject::Extends: 0
+ Test::More: 0
+ Test::use::ok: 0
+provides:
+ Data::Visitor:
+ file: lib/Data/Visitor.pm
+ version: 0.02
+ Data::Visitor::Callback:
+ file: lib/Data/Visitor/Callback.pm
+generated_by: Module::Build version 0.2611
Added: packages/libdata-visitor-perl/branches/upstream/current/Makefile.PL
===================================================================
--- packages/libdata-visitor-perl/branches/upstream/current/Makefile.PL 2006-03-11 13:54:31 UTC (rev 2312)
+++ packages/libdata-visitor-perl/branches/upstream/current/Makefile.PL 2006-03-11 16:24:09 UTC (rev 2313)
@@ -0,0 +1,15 @@
+# Note: this file was auto-generated by Module::Build::Compat version 0.03
+use ExtUtils::MakeMaker;
+WriteMakefile
+(
+ 'NAME' => 'Data::Visitor',
+ 'VERSION_FROM' => 'lib/Data/Visitor.pm',
+ 'PREREQ_PM' => {
+ 'Test::MockObject::Extends' => '0',
+ 'Test::More' => '0',
+ 'Test::use::ok' => '0'
+ },
+ 'INSTALLDIRS' => 'site',
+ 'PL_FILES' => {}
+ )
+;
Added: packages/libdata-visitor-perl/branches/upstream/current/SIGNATURE
===================================================================
--- packages/libdata-visitor-perl/branches/upstream/current/SIGNATURE 2006-03-11 13:54:31 UTC (rev 2312)
+++ packages/libdata-visitor-perl/branches/upstream/current/SIGNATURE 2006-03-11 16:24:09 UTC (rev 2313)
@@ -0,0 +1,35 @@
+This file contains message digests of all files listed in MANIFEST,
+signed via the Module::Signature module, version 0.52.
+
+To verify the content in this distribution, first make sure you have
+Module::Signature installed, then type:
+
+ % cpansign -v
+
+It will check each file's integrity, as well as the signature's
+validity. If "==> Signature verified OK! <==" is not displayed,
+the distribution may already have been compromised, and you should
+not run its Makefile.PL or Build.PL.
+
+-----BEGIN PGP SIGNED MESSAGE-----
+Hash: SHA1
+
+SHA1 509a2daff64fcfa5a4a109578346ff9f79ecc99a Build.PL
+SHA1 d5d114531fb520cbdb372878b633e02f255b9110 Changes
+SHA1 d33439f719d6ad2cdb0499da44fc467ff9f27e5e MANIFEST
+SHA1 c04f14de3bb1aaa12d7f0ad297f0da80da89b000 META.yml
+SHA1 fcb5f51df9e299fd51478dff38d67a4dd65bf906 Makefile.PL
+SHA1 7a8f0e6022a67be17480e88b0fd5be54b7c5fba1 lib/Data/Visitor.pm
+SHA1 b84b6142f70c62b81efe4af2712f11256994c7f0 lib/Data/Visitor/Callback.pm
+SHA1 3180f412df2834d1f1c9290e9b8726d0b374afc2 t/base.t
+SHA1 915e0a329acabb60b35f61ffef7d97a8bee57da0 t/callback.t
+SHA1 7e59409671d0147236beef17a6dfdc0997d6a97a t/callback_aliasing.t
+SHA1 ae984fed9ab572d06d3cdc86f61aa4f1594d2447 t/circular_refs.t
+SHA1 54affd2088fa25d8eec562fb8d39e1abd0d123c7 t/globs.t
+-----BEGIN PGP SIGNATURE-----
+Version: GnuPG v1.4.1 (Darwin)
+
+iD8DBQFD6hXnVCwRwOvSdBgRAiasAJwIV3Jxh+j2IFEKM2+knGEExVRVYwCfSBRM
+1eGOoQAoLt93LbJIbKqG+6A=
+=tdR5
+-----END PGP SIGNATURE-----
Added: packages/libdata-visitor-perl/branches/upstream/current/lib/Data/Visitor/Callback.pm
===================================================================
--- packages/libdata-visitor-perl/branches/upstream/current/lib/Data/Visitor/Callback.pm 2006-03-11 13:54:31 UTC (rev 2312)
+++ packages/libdata-visitor-perl/branches/upstream/current/lib/Data/Visitor/Callback.pm 2006-03-11 16:24:09 UTC (rev 2313)
@@ -0,0 +1,183 @@
+#!/usr/bin/perl
+
+package Data::Visitor::Callback;
+use base qw/Data::Visitor/;
+
+use strict;
+use warnings;
+
+__PACKAGE__->mk_accessors( qw/callbacks ignore_return_values/ );
+
+sub new {
+ my ( $class, %callbacks ) = @_;
+
+ my $ignore_ret = 0;
+ if ( exists $callbacks{ignore_return_values} ) {
+ $ignore_ret = delete $callbacks{ignore_return_values};
+ }
+
+ my $self = $class->SUPER::new();
+
+ $self->callbacks( \%callbacks );
+
+ $self;
+}
+
+sub visit {
+ my ( $self, $data ) = @_;
+ local *_ = \$_[1]; # alias $_
+ $self->SUPER::visit( $self->callback( visit => $data ) );
+}
+
+sub visit_value {
+ my ( $self, $data ) = @_;
+
+ $self->callback( value => $data );
+ $self->callback( ( ref($data) ? "ref_value" : "plain_value" ) => $data );
+}
+
+sub visit_object {
+ my ( $self, $data ) = @_;
+ $self->callback( object => $data );
+}
+
+BEGIN {
+ foreach my $reftype ( qw/array hash glob scalar/ ) {
+ no strict 'refs';
+ *{"visit_$reftype"} = eval '
+ sub {
+ my ( $self, $data ) = @_;
+ my $new_data = $self->callback( '.$reftype.' => $data );
+ if ( ref $data eq ref $new_data ) {
+ $self->SUPER::visit_'.$reftype.'( $new_data );
+ } else {
+ $self->SUPER::visit( $new_data );
+ }
+ }
+ ' || die $@;
+ }
+}
+
+sub callback {
+ my ( $self, $name, $data ) = @_;
+
+ if ( my $code = $self->callbacks->{$name} ) {
+ my $ret = $code->( $self, $data );
+ return $self->ignore_return_values ? $data : $ret ;
+ } else {
+ return $data;
+ }
+}
+
+__PACKAGE__;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Data::Visitor::Callback - A Data::Visitor with callbacks.
+
+=head1 SYNOPSIS
+
+ use Data::Visitor::Callback;
+
+ my $v = Data::Visitor::Callback->new(
+ value => sub { ... },
+ array => sub { ... },
+ );
+
+ $v->visit( $some_perl_value );
+
+=head1 DESCRIPTION
+
+This is a L<Data::Visitor> subclass that lets you invoke callbacks instead of
+needing to subclass yourself.
+
+=head1 METHODS
+
+=over 4
+
+=item new %opts, %callbacks
+
+Construct a new visitor.
+
+The options supported are:
+
+=over 4
+
+=item ignore_return_values
+
+When this is true (off by default) the return values from the callbacks are
+ignored, thus disabling the fmapping behavior as documented in
+L<Data::Validator>.
+
+This is useful when you want to modify $_ directly
+
+=back
+
+=back
+
+=head1 CALLBACKS
+
+Use these keys for the corresponding callbacks.
+
+The callback is in the form:
+
+ sub {
+ my ( $visitor, $data ) = @_;
+
+ # or you can use $_, it's aliased
+
+ return $data; # or modified data
+ }
+
+Within the callback $_ is aliased to the data, and this is also passed in the
+parameter list.
+
+=over 4
+
+=item visit
+
+Called for all values
+
+=item value
+
+Called for non objects, non aggregate (hash, array) values.
+
+=item ref_value
+
+Called after C<value>, for references to regexes, globs and code.
+
+=item plain_value
+
+Called after C<value> for non references.
+
+=item object
+
+Called for blessed objects.
+
+=item array
+
+Called for array references.
+
+=item hash
+
+Called for hash references.
+
+=back
+
+=head1 AUTHOR
+
+Yuval Kogman <nothingmuch at woobling.org>
+
+=head1 COPYRIGHT & LICENSE
+
+ Copyright (c) 2006 Yuval Kogman. All rights reserved
+ This program is free software; you can redistribute
+ it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+
Added: packages/libdata-visitor-perl/branches/upstream/current/lib/Data/Visitor.pm
===================================================================
--- packages/libdata-visitor-perl/branches/upstream/current/lib/Data/Visitor.pm 2006-03-11 13:54:31 UTC (rev 2312)
+++ packages/libdata-visitor-perl/branches/upstream/current/lib/Data/Visitor.pm 2006-03-11 16:24:09 UTC (rev 2313)
@@ -0,0 +1,177 @@
+#!/usr/bin/perl
+
+package Data::Visitor;
+use base qw/Class::Accessor/;
+
+use strict;
+use warnings;
+
+use Scalar::Util ();
+use overload ();
+use Symbol ();
+
+our $VERSION = "0.02";
+
+sub visit {
+ my ( $self, $data ) = @_;
+
+ local $self->{_seen} = ($self->{_seen} || {});
+ return $data if ref $data and $self->{_seen}{ overload::StrVal( $data ) }++;
+
+ if ( Scalar::Util::blessed( $data ) ) {
+ return $self->visit_object( $data );
+ } elsif ( my $reftype = ref $data ) {
+ if ( $reftype eq "HASH" or $reftype eq "ARRAY" or $reftype eq "GLOB" or $reftype eq "SCALAR") {
+ my $method = lc "visit_$reftype";
+ return $self->$method( $data );
+ }
+ }
+
+ return $self->visit_value( $data );
+}
+
+sub visit_object {
+ my ( $self, $object ) = @_;
+
+ return $self->visit_value( $object );
+}
+
+sub visit_value {
+ my ( $self, $value ) = @_;
+
+ return $value;
+}
+
+sub visit_hash {
+ my ( $self, $hash ) = @_;
+
+ if ( not defined wantarray ) {
+ $self->visit( $_ ) for ( values %$hash );
+ } else {
+ return { map { $_ => $self->visit( $hash->{$_} ) } keys %$hash }
+ }
+}
+
+sub visit_array {
+ my ( $self, $array ) = @_;
+
+ if ( not defined wantarray ) {
+ $self->visit( $_ ) for @$array;
+ } else {
+ return [ map { $self->visit( $_ ) } @$array ];
+ }
+}
+
+sub visit_scalar {
+ my ( $self, $scalar ) = @_;
+ return \$self->visit( $$scalar );
+}
+
+sub visit_glob {
+ my ( $self, $glob ) = @_;
+
+ my $new_glob = Symbol::gensym();
+
+ no warnings 'misc'; # Undefined value assigned to typeglob
+ *$new_glob = $self->visit( *$glob{$_} || next ) for qw/SCALAR ARRAY HASH/;
+
+ return $new_glob;
+}
+
+__PACKAGE__;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Data::Visitor - A visitor for Perl data structures
+
+=head1 SYNOPSIS
+
+ use base qw/Data::Visitor/;
+
+ sub visit_value {
+ my ( $self, $data ) = @_;
+
+ return $whatever;
+ }
+
+ sub visit_array {
+ my ( $self, $data ) = @_;
+
+ # ...
+
+ return $self->SUPER::visit_array( $whatever );
+ }
+
+=head1 DESCRIPTION
+
+This module is a simple visitor implementation for Perl values.
+
+It has a main dispatcher method, C<visit>, which takes a single perl value and
+then calls the methods appropriate for that value.
+
+The visitor pattern is
+
+=head1 METHODS
+
+=over 4
+
+=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.
+
+=item visit_object $object
+
+If the value is a blessed object, C<visit> calls this method. The base
+implementation will just forward to C<visit_value>.
+
+=item visit_array $array_ref
+
+This method is called when the value is an array reference.
+
+=item visit_value $value
+
+If the value is anything else, this method is called. The base implementation
+will return $value.
+
+=back
+
+=head1 RETURN VALUE
+
+This object can be used as an C<fmap> of sorts - providing an ad-hoc functor
+interface for Perl data structures.
+
+In void context this functionality is ignored, but in any other context the
+default methods will all try to return a value of similar structure, with it's
+children also fmapped.
+
+=head1 SUBCLASSING
+
+Create instance data using the L<Class::Accessor> interface. L<Data::Validator>
+inherits L<Class::Accessor> to get a sane C<new>.
+
+Then override the callback methods in any way you like. To retain visitor
+behavior, make sure to retain the functionality of C<visit_array> and
+C<visit_hash>.
+
+=head1 SEE ALSO
+
+L<Tree::Simple::VisitorFactory>, L<Data::Traverse>
+
+=head1 AUTHOR
+
+Yuval Kogman <nothingmuch at woobling.org>
+
+=head1 COPYRIGHT & LICENSE
+
+ Copyright (c) 2006 Yuval Kogman. All rights reserved
+ This program is free software; you can redistribute
+ it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+
Added: packages/libdata-visitor-perl/branches/upstream/current/t/base.t
===================================================================
--- packages/libdata-visitor-perl/branches/upstream/current/t/base.t 2006-03-11 13:54:31 UTC (rev 2312)
+++ packages/libdata-visitor-perl/branches/upstream/current/t/base.t 2006-03-11 16:24:09 UTC (rev 2313)
@@ -0,0 +1,77 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 31;
+use Test::MockObject::Extends;
+
+my $m;
+use ok $m = "Data::Visitor";
+
+can_ok($m, "new");
+isa_ok(my $o = $m->new, $m);
+
+can_ok( $o, "visit" );
+
+my @things = ( "foo", 1, undef, 0, {}, [], bless({}, "Some::Class") );
+
+is_deeply( $o->visit( $_ ), $_, "visit returns value unlatered" ) for @things;
+
+can_ok( $o, "visit_value" );
+can_ok( $o, "visit_object" );
+can_ok( $o, "visit_hash" );
+can_ok( $o, "visit_array" );
+
+
+my $mock = Test::MockObject::Extends->new( $o );
+
+# cause logging
+$mock->set_always( $_ => "magic" ) for qw/visit_value visit_object/;
+$mock->mock( visit_hash => sub { shift->Data::Visitor::visit_hash( @_ ) } );
+$mock->mock( visit_array => sub { shift->Data::Visitor::visit_array( @_ ) } );
+
+$mock->clear;
+$mock->visit( "foo" );
+$mock->called_ok( "visit_value" );
+
+$mock->clear;
+$mock->visit( 1 );
+$mock->called_ok( "visit_value" );
+
+$mock->clear;
+$mock->visit( undef );
+$mock->called_ok( "visit_value" );
+
+$mock->clear;
+$mock->visit( [ ] );
+$mock->called_ok( "visit_array" );
+ok( !$mock->called( "visit_value" ), "visit_value not called" );
+
+$mock->clear;
+$mock->visit( [ "foo" ] );
+$mock->called_ok( "visit_array" );
+$mock->called_ok( "visit_value" );
+
+$mock->clear;
+$mock->visit( "foo" );
+$mock->called_ok( "visit_value" );
+
+$mock->clear;
+$mock->visit( {} );
+$mock->called_ok( "visit_hash" );
+ok( !$mock->called( "visit_value" ), "visit_value not called" );
+
+$mock->clear;
+$mock->visit( { foo => "bar" } );
+$mock->called_ok( "visit_hash" );
+$mock->called_ok( "visit_value" );
+
+$mock->clear;
+$mock->visit( bless {}, "Foo" );
+$mock->called_ok( "visit_object" );
+
+is_deeply( $mock->visit( undef ), "magic", "fmap behavior on value" );
+is_deeply( $mock->visit( { foo => "bar" } ), { foo => "magic" }, "fmap behavior on hash" );
+is_deeply( $mock->visit( [qw/la di da/]), [qw/magic magic magic/], "fmap behavior on array" );
+
Added: packages/libdata-visitor-perl/branches/upstream/current/t/callback.t
===================================================================
--- packages/libdata-visitor-perl/branches/upstream/current/t/callback.t 2006-03-11 13:54:31 UTC (rev 2312)
+++ packages/libdata-visitor-perl/branches/upstream/current/t/callback.t 2006-03-11 16:24:09 UTC (rev 2313)
@@ -0,0 +1,92 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 11;
+
+
+my $m; use ok $m = "Data::Visitor::Callback";
+
+can_ok($m, "new");
+
+my $counters;
+my %callbacks = (
+ map {
+ my $name = $_;
+ $name => sub { $counters->{$name}++; $_[1] }
+ } qw(
+ visit
+ value
+ ref_value
+ plain_value
+ object
+ array
+ hash
+ glob
+ scalar
+ ),
+);
+
+isa_ok(my $o = $m->new( %callbacks ), $m);
+
+counters_are( "foo", "string", {
+ visit => 1,
+ value => 1,
+ plain_value => 1,
+});
+
+counters_are( undef, "undef", {
+ visit => 1,
+ value => 1,
+ plain_value => 1,
+});
+
+counters_are( [], "array", {
+ visit => 1,
+ array => 1,
+});
+
+counters_are( {}, "hash", {
+ visit => 1,
+ hash => 1,
+});
+
+counters_are( [ "foo" ], "deep array", {
+ visit => 2,
+ array => 1,
+ value => 1,
+ plain_value => 1,
+});
+
+counters_are( bless({}, "Moose"), "objecct", {
+ visit => 1,
+ object => 1,
+});
+
+counters_are( \10, "scalar_ref", {
+ visit => 2,
+ 'scalar' => 1,
+ value => 1,
+ plain_value => 1,
+});
+
+our $FOO = 1;
+our %FOO = ( "foo" => undef );
+
+counters_are( \*FOO, "glob", {
+ visit => 5,
+ 'scalar' => 1,
+ hash => 1,
+ value => 2,
+ plain_value => 2,
+ 'glob' => 1,
+});
+
+sub counters_are {
+ my ( $data, $desc, $expected_counters ) = @_;
+ $counters = {};
+ $o->visit( $data );
+ local $Test::Builder::Level = 2;
+ is_deeply( $counters, $expected_counters, $desc );
+}
Added: packages/libdata-visitor-perl/branches/upstream/current/t/callback_aliasing.t
===================================================================
--- packages/libdata-visitor-perl/branches/upstream/current/t/callback_aliasing.t 2006-03-11 13:54:31 UTC (rev 2312)
+++ packages/libdata-visitor-perl/branches/upstream/current/t/callback_aliasing.t 2006-03-11 16:24:09 UTC (rev 2313)
@@ -0,0 +1,36 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 4;
+
+
+my $m; use ok $m = "Data::Visitor::Callback";
+
+my $structure = {
+ foo => "bar",
+ gorch => [ "baz", 1 ],
+};
+
+my $o = $m->new(
+ ignore_return_values => 0,
+ plain_value => sub { s/b/m/g; "laaa" },
+ array => sub { $_ = 42; undef},
+);
+
+$o->visit( $structure );
+
+$_ = "original";
+
+is_deeply( $structure, {
+ foo => "mar",
+ gorch => 42,
+}, "values were modified" );
+
+is( $_, "original", '$_ unchanged in outer scope');
+
+$o->callbacks->{hash} = sub { $_ = "value" };
+$o->visit( $structure );
+is( $structure, "value", "entire structure can also be changed");
+
Added: packages/libdata-visitor-perl/branches/upstream/current/t/circular_refs.t
===================================================================
--- packages/libdata-visitor-perl/branches/upstream/current/t/circular_refs.t 2006-03-11 13:54:31 UTC (rev 2312)
+++ packages/libdata-visitor-perl/branches/upstream/current/t/circular_refs.t 2006-03-11 16:24:09 UTC (rev 2313)
@@ -0,0 +1,29 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 3;
+
+
+my $m; use ok $m = "Data::Visitor";
+
+my $structure = {
+ foo => {
+ bar => undef,
+ },
+};
+
+$structure->{foo}{bar} = $structure;
+
+my $o = $m->new;
+
+{
+ alarm 1;
+ $o->visit( $structure );
+ alarm 0;
+ pass( "circular structures don't cause an endless loop" );
+}
+
+is_deeply( $o->visit( $structure ), $structure, "Structure recreated" );
+
Added: packages/libdata-visitor-perl/branches/upstream/current/t/globs.t
===================================================================
--- packages/libdata-visitor-perl/branches/upstream/current/t/globs.t 2006-03-11 13:54:31 UTC (rev 2312)
+++ packages/libdata-visitor-perl/branches/upstream/current/t/globs.t 2006-03-11 16:24:09 UTC (rev 2313)
@@ -0,0 +1,35 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 10;
+use Test::MockObject::Extends;
+
+use ok "Data::Visitor";
+
+our ( $FOO, %FOO );
+
+my $glob = \*FOO;
+
+$FOO = 3;
+%FOO = ( foo => "bar" );
+is( ${ *$glob{SCALAR} }, 3, "scalar glob created correctly" );
+is_deeply( *$glob{HASH}, { foo => "bar" }, "hash glob created correctly" );
+
+my $structure = [ $glob ];
+
+my $mock = Test::MockObject::Extends->new( "Data::Visitor" );
+$mock->mock( "visit_$_" => eval 'sub { shift->Data::Visitor::visit_' . $_ . '( @_ ) }' ) for qw/hash glob value array/;
+
+my $mapped = $mock->visit( $structure );
+
+# structure sanity
+is( ref $mapped, "ARRAY", "container" );
+is( ref ( $mapped->[0] ), "GLOB", "glob ref" );
+is( ${ *{$mapped->[0]}{SCALAR} }, 3, "value in glob's scalar slot");
+
+$mock->called_ok( "visit_array" );
+$mock->called_ok( "visit_glob" );
+$mock->called_ok( "visit_value" );
+$mock->called_ok( "visit_hash" );
More information about the Pkg-perl-cvs-commits
mailing list