NAME
    traverse - Provides a generic pre-order traversal algorithm with
    user-supplied callbacks.

SYNOPSIS
      use traverse qw(:constants);

      # Call a method on a complex structure of objects
      traverse { $_[0] == TR_OBJECT && $_->some_method } $struct;

      # Produce some Data::Dumper-like output
      my $d = 0;
      traverse { $_[0] == TR_ARRAY 
                   && print ' ' x ( $d+=2 ), "[\n";
                 $_[0] == TR_HASH 
                   && print ' ' x ( $d+=2 ), "{\n";
                 $_[0] == TR_SCALAR
                   && print ' ' x $d, "'$_',\n";
                 $_[0] == TR_KEY
                   && print ' ' x $d, "$_ => ";
                 $_[0] == TR_ARRAY_END   
                   && print ' ' x ( $d-=2 ), "],\n"; 
                 $_[0] == TR_HASH_END    
                   && print ' ' x ( $d-=2 ), "},\n";
           } $struct;

      # Turn a structure into XML
      my $d = 0;
      my $xml = "<data>\n";
      $xml .= join "\n", 
        traverse { $_[0] == TR_ARRAY
                     && ' ' x ( $d += 2 ) . '<array>';
                   $_[0] == TR_HASH 
                     && ' ' x ( $d += 2 ) . '<hash>'; 
                   $_[0] == TR_SCALAR 
                     && ' ' x $d . "  <item>$_</item>";
                   $_[0] == TR_KEY          
                     && ' ' x $d . "<key name=\"$_\">";
                   $_[0] == TR_KEY_END      
                     && ' ' x $d . '</key>';
                   $_[0] == TR_HASH_END 
                     && ' ' x ( $d -= 2 ) . '</hash>';
                   $_[0] == TR_ARRAY_END 
                     && ' ' x ( $d -= 2 ) . '</array>';           
              } $struct;
      $xml .= "\n</data>";
      print $xml;

DESCRIPTION
    traverse.pm exports a single subroutine, "traverse", 
    and a number of constants. "traverse" takes a BLOCK 
    or CODE reference and a reference to an arbitrarily   
    complex data structure (such as a hash of hashes arrays
    or an array of arrays of hashes of arrays of objects) 
    and traverses the structure in pre-order. Each item is 
    available in the BLOCK or subroutine in $_, and the 
    first argument is a constant which tells you
    what kind of thing the item is. In list context, 
    "traverse" returns a list of whatever was returned by 
    the BLOCK or subroutine. In scalar
    context, it returns an ARRAY reference to the same list.

CONSTANTS
    TR_ARRAY - The item in $_ is an ARRAY reference.
    TR_HASH - The item in $_ is a HASH reference.
    TR_OBJECT - The item in $_ is an object.
    TR_KEY - The item in $_ is a hash key
    TR_KEY_END - Passed after a hash key. $_ is the same as 
      before.
    TR_SCALAR - The item in $_ is a hash or array scalar 
      element.
    TR_ARRAY_END - Passed after an array is completed. $_ is 
      the same ARRAY reference as when it started.
    TR_HASH_END - Passed after a hash is completed. $_ is 
      the same HASH reference as when it started.
    TR_CODE - The item in $_ is a CODE reference.
[download]

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;
[download]