File Coverage

blib/lib/Data/Traverse.pm

Criterion	Covered	Total	%
statement	48	48	100.0
branch	11	12	91.6
condition			n/a
subroutine	10	10	100.0
pod	0	3	0.0
total	69	73	94.5

package Data::Traverse;

use strict;
use warnings;

use Exporter;
use Carp qw(croak);
use Scalar::Util qw(reftype);

our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.
our @EXPORT_OK = ('&traverse');


our $VERSION = '0.03';

my $IGNORE_BAD_REFS = 0;

sub ignore_unsupported_refs {
    my $class = shift;
    $IGNORE_BAD_REFS = shift;
}

# Preloaded methods go here.

# Use this sub to do the prototype only. The real fun
# happens in real_traverse.
sub traverse(&$) {
    my ( $callback, $ref ) = @_;
    my $type = reftype $ref or
	croak "Second argument to traverse must be a reference";

    real_traverse( $callback, $ref, $type, caller );
}


sub real_traverse {
    my ( $callback, $ref, $type, $caller ) = @_;

    no strict 'refs';
    local(*{$caller."::a"}) = \my $a;
    local(*{$caller."::b"}) = \my $b;
    use strict 'refs';

    if ( $type eq 'ARRAY' ) {
	foreach my $item( @$ref ) {
	    $_ = $type;
	    my $st = reftype( $item );
	    if( $st ) {
		real_traverse( $callback, $item, $st, $caller );
	    } else {
		$a = $item;
		$callback->();
	    }
	}
    } elsif ( $type eq 'HASH' ) {
	while( my ( $key, $val ) = each %$ref ) {
	    $_ = $type;
	    my $st = reftype( $val );
	    if( $st ) {
		real_traverse( $callback, $val, $st, $caller );
	    } else {
		$a = $key;
		$b = $val;
		$callback->();
	    }
	}
    } else {
	croak "Encountered unsupported type $type in traverse"
          unless $IGNORE_BAD_REFS;
    }
}


1;
__END__