bsb has asked for the wisdom of the Perl Monks concerning the following question:
I've changed treemap around and called it do_rec.
It now recurses data structures composed of hashes, arrays, scalars and their references, executing a block/coderef with $_ aliased appropriately so that changing $_ modifies the element.
By default, the block is only executed for leaves.
If you pass in a prototyped subroutine the prototype
is (mis)used to decide when to run your code
eg. do_rec sub(%;) {...} $data; # is run for values & HASHes
Blessing is ignored, objects are scanned (unless you "cut")
I have some biggish questions about my implementation:
Is this (ab)use of prototypes as out-of-band info evil?
Would attributes be better?
Does $seen->{ ref($_) ? $_ : \$_} = undef; really mark a value as seen? (demerphq?)
I use special "cut" return value to signal that this thing should not be recursed. I'm trying to make it impossible to accidently return it..?
Is there an easier way to keep the $_ aliasing?
I'd also like local-ized variables, for example to build up a "1.3.4" type path, but it needs more thought...
The code as I go home:
#!/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__
|
|---|
| Replies are listed 'Best First'. | |
|---|---|
|
Re: Recursive map Design Questions
by Abigail-II (Bishop) on Oct 01, 2003 at 14:53 UTC | |
by BrowserUk (Patriarch) on Oct 02, 2003 at 09:53 UTC | |
by demerphq (Chancellor) on Oct 03, 2003 at 16:31 UTC | |
by tye (Sage) on Oct 03, 2003 at 16:52 UTC | |
by demerphq (Chancellor) on Oct 03, 2003 at 23:45 UTC | |
| |
by BrowserUk (Patriarch) on Oct 03, 2003 at 16:49 UTC | |
by demerphq (Chancellor) on Oct 03, 2003 at 23:27 UTC | |
| |
by Abigail-II (Bishop) on Oct 05, 2003 at 17:47 UTC | |
by BrowserUk (Patriarch) on Oct 05, 2003 at 19:08 UTC | |
by bsb (Priest) on Oct 02, 2003 at 08:20 UTC | |
by Abigail-II (Bishop) on Oct 05, 2003 at 17:49 UTC | |
|
Re: Recursive map Design Questions
by simonm (Vicar) on Oct 01, 2003 at 18:10 UTC | |
|
Re: Recursive map Design Questions
by demerphq (Chancellor) on Oct 03, 2003 at 16:12 UTC | |
by bsb (Priest) on Oct 04, 2003 at 01:08 UTC | |
by demerphq (Chancellor) on Oct 04, 2003 at 10:01 UTC |