view release on metacpan or  search on metacpan

lib/Data/Visitor.pm  view on Meta::CPAN

package Data::Visitor; # git description: v0.31-4-g7498abb
use Moose;
# ABSTRACT: Visitor style traversal of Perl data structures

our $VERSION = '0.32';
use Scalar::Util qw/blessed refaddr reftype weaken isweak/;
use overload ();
use Symbol ();

use Tie::ToObject;

no warnings 'recursion';

use namespace::clean -except => 'meta';

# 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};

use constant HAS_DATA_ALIAS => eval { +require Data::Alias; 1 };

has tied_as_objects => (
	isa => "Bool",
	is  => "rw",
);

# currently broken
has weaken => (
	isa => "Bool",
	is  => "rw",
	default => 0,
);

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";
}

sub visit {
	my $self = shift;

	local $self->{depth} = (($self->{depth}||0) + 1) if DEBUG;
	my $seen_hash = local $self->{_seen} = ($self->{_seen} || {}); # delete it after we're done with the whole visit

	my @ret;

	foreach my $data ( @_ ) {
		$self->trace( flow => visit => $data ) if DEBUG;

		if ( my $refaddr = ref($data) && refaddr($data) ) { # only references need recursion checks
			$seen_hash->{weak} ||= isweak($data) if $self->weaken;

			if ( exists $seen_hash->{$refaddr} ) {
				$self->trace( mapping => found_mapping => from => $data, to => $seen_hash->{$refaddr} ) if DEBUG;
				push @ret, $self->visit_seen( $data, $seen_hash->{$refaddr} );
				next;
			} else {
				$self->trace( mapping => no_mapping => $data ) if DEBUG;
			}
		}

		if ( defined wantarray ) {
			push @ret, scalar($self->visit_no_rec_check($data));
		} else {
			$self->visit_no_rec_check($data);
		}
	}

	return ( @_ == 1 ? $ret[0] : @ret );
}

sub visit_seen {
	my ( $self, $data, $result ) = @_;
	return $result;
}

sub _get_mapping {
	my ( $self, $data ) = @_;
	$self->{_seen}{ refaddr($data) };
}

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;
}

sub visit_no_rec_check {
	my ( $self, $data ) = @_;

	if ( blessed($data) ) {
		return $self->visit_object($_[1]);
	} elsif ( ref $data ) {
		return $self->visit_ref($_[1]);
	}

	return $self->visit_value($_[1]);
}

sub visit_object {
	my ( $self, $object ) = @_;
	$self->trace( flow => visit_object => $object ) if DEBUG;

	if ( not defined wantarray ) {
		$self->_register_mapping( $object, $object );
		$self->visit_value($_[1]);
		return;
	} else {
		return $self->_register_mapping( $object, $self->visit_value($_[1]) );
	}

lib/Data/Visitor.pm  view on Meta::CPAN

		$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 ) = @_;

	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;
	}
}

sub retain_magic {
	my ( $self, $proto, $new ) = @_;

	if ( blessed($proto) and !blessed($new) ) {
		$self->trace( data => blessing => $new, ref $proto ) if DEBUG;
		bless $new, ref $proto;
	}

	my $seen_hash = $self->{_seen};
	if ( $seen_hash->{weak} ) {
		#if ("$]" >= '5.022') {
		#  TODO: Data::Alias does not work on recent perls, but there is built-in aliasing support now.
		#  e.g. see what Var::Pairs 0.003004 did.
		#}
		if (HAS_DATA_ALIAS) {
			my @weak_refs;
			foreach my $value ( Data::Alias::deref($proto) ) {
				if ( ref $value and isweak($value) ) {
					push @weak_refs, refaddr $value;
				}
			}

			if ( @weak_refs ) {
				my %targets = map { refaddr($_) => 1 } @{ $self->{_seen} }{@weak_refs};
				foreach my $value ( Data::Alias::deref($new) ) {
					if ( ref $value and $targets{refaddr($value)}) {
						push @{ $seen_hash->{weakened} ||= [] }, $value; # keep a ref around
						weaken($value);
					}
				}
			}
		}
		else {
			die "Found a weak reference, but Data::Alias is not installed. You must install Data::Alias in order for this to work.";
		}
	}

	# FIXME real magic, too

	return $new;
}

sub visit_tied {
	my ( $self, $tied, $var ) = @_;
	$self->trace( flow => visit_tied => $tied ) if DEBUG;
	$self->visit($_[1]); # as an object eventually
}

__PACKAGE__->meta->make_immutable if __PACKAGE__->meta->can("make_immutable");

__PACKAGE__;

__END__

=pod

=encoding UTF-8

=head1 NAME

Data::Visitor - Visitor style traversal of Perl data structures

=head1 VERSION

version 0.32

=head1 SYNOPSIS

	# NOTE
	# You probably want to use Data::Visitor::Callback for trivial things

	package FooCounter;
	use Moose;

	extends qw(Data::Visitor);

	has number_of_foos => (
		isa => "Int",
		is  => "rw",
		default => 0,
	);

	sub visit_value {
		my ( $self, $data ) = @_;

		if ( defined $data and $data eq "foo" ) {
			$self->number_of_foos( $self->number_of_foos + 1 );
		}