#!/usr/bin/perl -w
=pod

do_rec BLOCK LIST
do_rec CODEREF LIST

=head1 SYNOPSIS

 # upper case your leaves
 do_rec { $_ = uc $_; } $data, $structures;

 # upper case your leaves (except children of arrays)
 do_rec sub (*) { 
    $_ = uc $_; 
    cut if ref($_) eq 'ARRAY';
 } $hashref;

=head1 DESCRIPTION

...

=head1 NOTES

Originally stolen from treemap:

 http://www.perlmonks.org/index.pl?node_id=60829&displaytype=displayco
+de

Two paths to the same thing will be taken randomly
if there's an intervening hash

If there's two paths to a thing, both must be cut.

=cut
use strict;
use Carp ();

our $cut = \'cut magic cookie';
sub cut() { $cut }

sub VALUE()  { 1 }
sub HASH()   { 2 }
sub ARRAY()  { 4 }
sub SCALAR() { 8 }
sub REF()    { 16 }
sub OBJECT() { 32 }

#$ @ % * & ; \@ \% \$ 
my %proto_map = ( 
    ';'  => VALUE,
    '$'  => SCALAR,
    '\\' => REF,
    '%'  => HASH,
    '@'  => ARRAY,
    '*'  => HASH|ARRAY|SCALAR|REF|VALUE,
    '&'  => OBJECT,

    # The proto isn't used anyway, these compile for me...
    'V'  => VALUE,
    'S'  => SCALAR,
    'R'  => REF,
    'H'  => HASH,
    'A'  => ARRAY,
    'O'  => OBJECT,
);

sub do_rec (&@) {
    my $code = shift;
    my $want;

    if(my $proto = prototype $code) {
        $want = 0;
        $proto =~ s{([;$%@*&\\VSRHAO])}
                   { $want |= $proto_map{ uc $1 }; '' }gei;

        Carp::croak "Unknown prototype: ",prototype $code  if $proto;
    } else {
        $want = VALUE;
    }

    _do_rec($code, $want, my $seen = {}, @_);
}
sub _do_rec {
    my ($code, $want, $seen) = (shift, shift, shift);

    for (@_) { # just one after the first;

        next if (exists $seen->{$_});

        my ($key, $type);

        if(ref($_)) {
            $key = $_; # gets stringified
            # ref can only be blessed into one thing at a time (so it'
+s ok)

            if (UNIVERSAL::isa($_,'HASH')) { # isa to ignore blessing
                $type = HASH;
            } elsif (UNIVERSAL::isa($_,'ARRAY')) {
                $type = ARRAY;
            } elsif (UNIVERSAL::isa($_,'SCALAR')) {
                $type = SCALAR;
            } elsif (UNIVERSAL::isa($_,'REF')) {
                $type = REF;
            }

            # if they want an OBJECT, OR it in
            if($want & OBJECT && m/=/) {
                $type |= OBJECT;
            }
        } else {
            $key = \$_; # reference to where value is stored
            $type = VALUE;
        }

        $seen->{$key} = undef;
        # Call the $code
        if($want & $type) {
            my $ret = $code->(); # pass type/ref?
            next if(ref($ret) && $ret == $cut); # return cut cookie ->
+ next
        }

        # Recurse appropriately
        if ($type & HASH) {
            _do_rec($code, $want, $seen, $_) for values %$_;
            # keys? do in higher level
        }
        elsif ($type & ARRAY) {
            # could hoist nonrefs like reply on pm: (need to mark seen
+)
            _do_rec($code, $want, $seen, $_) for @$_;
        }
        elsif ($type & (SCALAR|REF) ) {
            _do_rec($code, $want, $seen, $_) for $$_;
        }
    }
}
####################### EXAMPLE #############################

our $data = {
          'arrays' => [[ 'shared', 'not_shared' ]],
          'num' => 2,
          #'blahs'  => \'blah blah', # mod of ro var
          'blahs'  => \do { my $a = 'blah blah' },
          'hash' => { 
                      'a' => 'vala',
                      'b' => 'valb',
                      'c' => bless({ qn=> 'no_qnum' },'Obj'),
                    },
          'blessed' => bless(\{ qn=> 'that' },'Obj::Ref'),
        };

# shared value 
$data->{arrays} = bless(\$data->{arrays}[0][0],"Not::Scalar");

# ref to the same hash via 2 scalar refs with different blessing
$data->{another_obj} = bless(\do{ my $o = ${$data->{blessed}}},"Not::O
+bj");


use Data::Dumper;
$Data::Dumper::Purity=1;

# objects:
do_rec sub (&) { print ref($_)," " } => $data;
print "\n\n";

# all the leaves
do_rec { $_ = "#$_#"; } $data;

# (*) = everything
my $count = 1;
do_rec sub (*) {
    return cut if ref($_) eq 'ARRAY';
    return $_ = "=\U$_=" if !ref($_); # leaves
    $_->{qnum} = $count++ if ref($_) eq 'HASH' && exists $_->{qn};
} => $data;

print Dumper $data;
print "-----------------------------------------\n\n";

# Another example
$data = [ \do{ my $s = "string"} ];
$data->[1] = \$data->[0];
$data->[2] = \do{ my $s = "last" };
do_rec { $_ = uc $_; } $data;
print Dumper $data;
print "-----------------------------------------\n\n";
do_rec sub (Obj) { print ref($_),"\n" } => $data;

__END__
[download]