package traverse;

use strict;

require Exporter;
use Carp;

sub traverse(&$);

use constant { TR_ARRAY      => 1,
	       TR_HASH       => 2,
	       TR_OBJECT     => 3,
	       TR_KEY        => 4,
	       TR_KEY_END    => 5,
	       TR_SCALAR     => 6,
	       TR_ARRAY_END  => 7,
	       TR_HASH_END   => 8,
	       TR_CODE       => 9 };

our @ISA = ('Exporter');

our @EXPORT = ('&traverse');
our @EXPORT_OK = ('TR_ARRAY', 
		  'TR_HASH', 
		  'TR_OBJECT', 
		  'TR_KEY',
		  'TR_KEY_END', 
		  'TR_SCALAR', 

		  'TR_ARRAY_END', 
		  'TR_HASH_END', 
		  'TR_CODE', 
		  '&traverse');
our %EXPORT_TAGS = ( constants => 
		     [ 'TR_ARRAY', 
		       'TR_HASH', 
		       'TR_OBJECT', 
		       'TR_KEY',
		       'TR_KEY_END', 
		       'TR_SCALAR', 
		       'TR_ARRAY_END', 
		       'TR_HASH_END', 
		       'TR_CODE', 
		       '&traverse' ] );


# wrap this around _do_it to hide return array
sub traverse(&$) { 
    my ($code, $root) = @_;

    my $ret = _do_it($code, $root, [ ] );

    return wantarray ? @$ret : $ret;
}

sub _do_it { 
    my ($code, $root, $ret) = @_;

    my $type = ref $root;

    if( $type eq 'ARRAY' ) { 
        _run(TR_ARRAY, $code, $root, $ret);
        foreach my $node ( @$root ) { 
            _do_it( $code, $node, $ret ); 
        }
        _run(TR_ARRAY_END, $code, $root, $ret);
    } elsif ( $type eq 'HASH' ) { 
        _run(TR_HASH, $code, $root, $ret);
        foreach my $key ( keys %$root ) { 
            _run(TR_KEY, $code, $key, $ret);
            _do_it( $code, $root->{$key}, $ret );
            _run(TR_KEY_END, $code, $key, $ret);
        }
        _run(TR_HASH_END, $code, $root, $ret);
    } elsif ( $type eq 'CODE' ) { 
        _run(TR_CODE, $code, $root, $ret);
    } elsif ( $type =~ /=/ ) { 
        _run(TR_OBJECT, $code, $root, $ret);
    } elsif ( !$type ) { 
        _run(TR_SCALAR, $code, $root, $ret);
    } else {
        croak "Unsupported type $type in traverse.";
    }

    return $ret;

}


sub _run { 
    my ( $const, $code, $item, $ret ) = @_;

    $_ = $item;
    if( my @rets = $code->($const) ) { 
	push @$ret, @rets;
    }

}

1;