[libdata-rmap-perl] 01/01: initial import of Data::Rmap 0.62 from CPAN
Florian Schlichting
fsfs at moszumanska.debian.org
Thu Apr 30 21:19:07 UTC 2015
This is an automated email from the git hooks/post-receive script.
fsfs pushed a commit to tag 0.62
in repository libdata-rmap-perl.
commit 359dd872c1a5185dd9ed7918b0252d929c6d926c
Author: Brad Bowman <perl-cpan at bereft.net>
Date: Wed Jul 7 12:49:34 2010 +1000
initial import of Data::Rmap 0.62 from CPAN
git-cpan-module: Data::Rmap
git-cpan-version: 0.62
git-cpan-authorid: BOWMANBS
---
Build.PL | 34 ++++
Changes | 14 ++
INSTALL | 14 ++
MANIFEST | 9 +
META.yml | 12 ++
Makefile.PL | 14 ++
README | 320 ++++++++++++++++++++++++++++++++
lib/Data/Rmap.pm | 546 +++++++++++++++++++++++++++++++++++++++++++++++++++++++
test.pl | 191 +++++++++++++++++++
9 files changed, 1154 insertions(+)
diff --git a/Build.PL b/Build.PL
new file mode 100644
index 0000000..47284a5
--- /dev/null
+++ b/Build.PL
@@ -0,0 +1,34 @@
+#!/usr/bin/perl -w
+use strict;
+use Module::Build;
+
+my $class = Module::Build->subclass(
+ code => q{
+ sub ACTION_deb {
+ use strict;
+ my $self = shift;
+ $self->dispatch('distdir');
+ my $distdir = $self->dist_name .'-'. $self->dist_version;
+ my $lc_distdir = lc($distdir);
+
+ # do_system echos
+ $self->do_system("rm","-rf", $lc_distdir) or die $!;
+ $self->do_system("mv", $distdir, $lc_distdir) or die $!;
+ $self->do_system("cp","-r", "debian", $lc_distdir) or die $!;
+ $self->add_to_cleanup($lc_distdir);
+
+ $self->do_system("cd $lc_distdir && debuild -us -uc") or die $!;
+ }
+ },
+);
+
+$class->new(
+ module_name => 'Data::Rmap',
+ license => 'perl',
+ requires => {
+ 'Scalar::Util' => 0,
+ 'Test::Exception' => 0,
+ },
+ create_makefile_pl => 'traditional',
+)->create_build_script;
+
diff --git a/Changes b/Changes
new file mode 100644
index 0000000..d8a7cec
--- /dev/null
+++ b/Changes
@@ -0,0 +1,14 @@
+Mon Sep 22 21:26:27 EST 2008
+0.62 - Clarified LICENSE terms in pod, user request
+
+Mon Aug 15 11:19:02 EST 2005
+0.61 - Added Test::Exception prereq
+ - Debian packaging support
+
+Mon Dec 20 15:53:16 EST 2004
+0.6 - Allowed for "REF" in tests for 5.8
+ - Changed Module::Build usage
+
+Tue May 11 17:00:06 EST 2004
+0.5 - added README Changes
+ - trim long lines in docs
diff --git a/INSTALL b/INSTALL
new file mode 100644
index 0000000..b2e4248
--- /dev/null
+++ b/INSTALL
@@ -0,0 +1,14 @@
+INSTALL INSTRUCTIONS FOR Data::Rmap
+
+perl Makefile.PL;
+make;
+make test;
+make install;
+
+OR
+
+perl Build.PL;
+./Build;
+./Build test;
+./Build install;
+
diff --git a/MANIFEST b/MANIFEST
new file mode 100644
index 0000000..aa65cce
--- /dev/null
+++ b/MANIFEST
@@ -0,0 +1,9 @@
+MANIFEST This list of files
+Build.PL
+Makefile.PL
+lib/Data/Rmap.pm
+test.pl
+META.yml
+Changes
+README
+INSTALL
diff --git a/META.yml b/META.yml
new file mode 100644
index 0000000..47a445d
--- /dev/null
+++ b/META.yml
@@ -0,0 +1,12 @@
+# http://module-build.sourceforge.net/META-spec.html
+#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
+name: Data-Rmap
+version: 0.62
+version_from: lib/Data/Rmap.pm
+installdirs: site
+requires:
+ Scalar::Util: 0
+ Test::Exception: 0
+
+distribution_type: module
+generated_by: ExtUtils::MakeMaker version 6.30_01
diff --git a/Makefile.PL b/Makefile.PL
new file mode 100644
index 0000000..19345d3
--- /dev/null
+++ b/Makefile.PL
@@ -0,0 +1,14 @@
+# Note: this file was auto-generated by Module::Build::Compat version 0.03
+use ExtUtils::MakeMaker;
+WriteMakefile
+(
+ 'NAME' => 'Data::Rmap',
+ 'VERSION_FROM' => 'lib/Data/Rmap.pm',
+ 'PREREQ_PM' => {
+ 'Scalar::Util' => '0',
+ 'Test::Exception' => '0'
+ },
+ 'INSTALLDIRS' => 'site',
+ 'PL_FILES' => {}
+ )
+;
diff --git a/README b/README
new file mode 100644
index 0000000..22b856d
--- /dev/null
+++ b/README
@@ -0,0 +1,320 @@
+NAME
+ Data::Rmap - recursive map, apply a block to a data structure
+
+SYNOPSIS
+ $ perl -MData::Rmap -e 'print rmap { $_ } 1, [2,3], \\4, "\n"'
+ 1234
+
+ $ perl -MData::Rmap=:all
+ rmap_all { print (ref($_) || "?") ,"\n" } \@array, \%hash, \*glob;
+
+ # OUTPUT (Note: a GLOB always has a SCALAR, hence the last two items)
+ # ARRAY
+ # HASH
+ # GLOB
+ # SCALAR
+ # ?
+
+ # Upper-case your leaves in-place
+ $array = [ "a", "b", "c" ];
+ $hash = { key => "a value" };
+ rmap { $_ = uc $_; } $array, $hash;
+
+ use Data::Dumper; $Data::Dumper::Terse=1; $Data::Dumper::Indent=0;
+ print Dumper($array), " ", Dumper($hash), "\n";
+
+ # OUTPUT
+ # ['A','B','C'] {'key' => 'A VALUE'}
+
+ # Simple array dumper.
+ # Uses $self->recurse method to alter traversal order
+ ($dump) = rmap_to {
+
+ return "'$_'" unless ref($_); # scalars are quoted and returned
+
+ my $self = shift;
+ # use $self->recurse to grab results and wrap them
+ return '[ ' . join(', ', $self->recurse() ) . ' ]';
+
+ } ARRAY|VALUE, [ 1, [ 2, [ [ 3 ], 4 ] ], 5 ];
+
+ print "$dump\n";
+ # OUTPUT
+ # [ '1', [ '2', [ [ '3' ], '4' ] ], '5' ]
+
+DESCRIPTION
+ rmap BLOCK LIST
+
+ Recursively evaluate a BLOCK over a list of data structures (locally
+ setting $_ to each element) and return the list composed of the results
+ of such evaluations. $_ can be used to modify the elements.
+
+ Data::Rmap currently traverses HASH, ARRAY, SCALAR and GLOB reference
+ types and ignores others. Depending on which rmap_* wrapper is used, the
+ BLOCK is called for only scalar values, arrays, hashes, references, all
+ elements or a customizable combination.
+
+ The list of data structures is traversed pre-order in a depth-first
+ fashion. That is, the BLOCK is called for the container reference before
+ is it called for it's elements (although see "recurse" below for
+ post-order). The values of a hash are traversed in the usual "values"
+ order which may affect some applications.
+
+ If the "cut" subroutine is called in the BLOCK then the traversal stops
+ for that branch, say if you "cut" an array then the code is never called
+ for it's elements (or their sub-elements). To simultaneously return
+ values and cut, simply pass the return list to cut:
+ "cut('add','to','returned');"
+
+ The first parameter to the BLOCK is an object which maintains the state
+ of the traversal. Methods available on this object are described in
+ "State Object" below.
+
+EXPORTS
+ By default:
+
+ rmap, rmap_all, cut
+
+ Optionally:
+
+ rmap_scalar rmap_hash rmap_array rmap_ref rmap_to
+ :types => [ qw(NONE VALUE HASH ARRAY SCALAR REF OBJECT ALL) ],
+ :all => ... # everything
+
+Functions
+ The various names are just wrappers which select when to call the code
+ BLOCK. rmap_all always calls it, the others are more selective while
+ rmap_to takes an extra parameter permitting you to provide selection
+ criteria. Furthermore, you can always just rmap_all and skip nodes which
+ are not of interest.
+
+ rmap_to { ... } $want, @data_structures;
+ Most general first.
+
+ Recurse the @data_structures and apply the BLOCK to elements
+ selected by $want. The $want parameter is the bitwise "or" of
+ whatever types you choose (imported with :types):
+
+ VALUE - non-reference scalar, eg. 1
+ HASH - hash reference
+ ARRAY - array reference
+ SCALAR - scalar refernce, eg. \1
+ REF - higher-level reference, eg. \\1, \\{}
+ B<NOT> any reference type, see <Scalar::Util>'s reftype:
+ perl -MScalar::Util=reftype -le 'print map reftype($_), \1, \\1'
+ GLOB - glob reference, eg. \*x
+ (scalar, hash and array recursed)
+ ALL - all of the above
+ NONE - none of the above
+
+ So to call the block for arrays and scalar values do:
+
+ use Data::Rmap ':all'; # or qw(:types rmap_to)
+ rmap { ... } ARRAY|VALUE, @data_structures;
+
+ (ALL & !GLOB) might also be handy.
+
+ The remainder of the wrappers are given in terms of the $want for
+ rmap_to.
+
+ rmap { ... } @list;
+ Recurse and call the BLOCK on non-reference scalar values. $want =
+ VALUE
+
+ rmap_all BLOCK LIST
+ Recurse and call the BLOCK on everything. $want = ALL
+
+ rmap_scalar { ... } @list
+ Recurse and call the BLOCK on non-collection scalars. $want =
+ VALUE|SCALAR|REF
+
+ rmap_hash
+ Recurse and call the BLOCK on hash refs. $want = HASH
+
+ rmap_array
+ Recurse and call the BLOCK on array refs. $want = ARRAY
+
+ rmap_ref
+ Recurse and call the BLOCK on all references (not GLOBS). $want =
+ HASH|ARRAY|SCALAR|REF
+
+ Note: rmap_ref isn't the same as rmap_to {} REF
+
+ cut(@list)
+ Don't traverse sub-elements and return the @list immediately. For
+ example, if $_ is an ARRAY reference, then the array's elements are
+ not traversed.
+
+ If there's two paths to an element, both will need to be cut.
+
+State Object
+ The first parameter to the BLOCK is an object which maintains most of
+ the traversal state (except current node, which is $_). *You will ignore
+ it most of the time*. The "recurse" method may be useful. Other methods
+ should only be used in throw away tools, see TODO
+
+ Methods:
+
+ recurse
+ Process child nodes of $_ now and return the result.
+
+ This makes it easier to perform post-order and in-order processing
+ of a structure. Note that since the same "seen list" is used, the
+ child nodes aren't reprocessed.
+
+ code
+ The code reference of the BLOCK itself. Possible useful in some
+ situations.
+
+ seen
+ (Warning: I'm undecided whether this method should be public)
+
+ Reference to the HASH used to track where we have visited. You may
+ want to modify it in some situations (though I haven't yet). Beware
+ circular references. The (current) convention used for the key is in
+ the source.
+
+ want
+ (Warning: I'm undecided whether this method should be public)
+
+ The $want state described in rmap_to.
+
+EXAMPLES
+ # command-line play
+ $ perl -MData::Rmap -le 'print join ":", rmap { $_ } 1,2,[3..5],\\6'
+ 1:2:3:4:5:6
+
+ # Linearly number questions on a set of pages
+ my $qnum = 1;
+ rmap_hash {
+ $_->{qnum} = $qnum++ if($_->{qn});
+ } @pages;
+
+ # Grep recursively, finding ALL objects
+ use Scalar::Util qw(blessed);
+ my @objects = rmap_ref {
+ blessed($_) ? $_ : ();
+ } $data_structure;
+
+ # Grep recursively, finding public objects (note the cut)
+ use Scalar::Util qw(blessed);
+ my @objects = rmap_ref {
+ blessed($_) ? cut($_) : ();
+ } $data_structure;
+
+ # Return a modified structure
+ # (result flattening means we must cheat by cloning then modifying)
+ use Storable qw(dclone);
+ use Lingua::EN::Numbers::Easy;
+
+ $words = [ 1, \2, { key => 3 } ];
+ $nums = dclone $words;
+ rmap { $_ = $N{$_} || $_ } $nums;
+
+ # Make an assertion about a structure
+ use Data::Dump;
+ rmap_ref {
+ blessed($_) && $_->isa('Question') && defined($_->name)
+ or die "Question doesn't have a name:", dump($_);
+ } @pages;
+
+ # Traverse a tree using localize state
+ $tree = [
+ one =>
+ two =>
+ [
+ three_one =>
+ three_two =>
+ [
+ three_three_one =>
+ ],
+ three_four =>
+ ],
+ four =>
+ [
+ [
+ five_one_one =>
+ ],
+ ],
+ ];
+
+ @path = ('q');
+ rmap_to {
+ if(ref $_) {
+ local(@path) = (@path, 1); # ARRAY adds a new level to the path
+ $_[0]->recurse(); # does stuff within local(@path)'s scope
+ } else {
+ print join('.', @path), " = $_ \n"; # show the scalar's path
+ }
+ $path[-1]++; # bump last element (even when it was an aref)
+ } ARRAY|VALUE, $tree;
+
+ # OUTPUT
+ # q.1 = one
+ # q.2 = two
+ # q.3.1 = three_one
+ # q.3.2 = three_two
+ # q.3.3.1 = three_three_one
+ # q.3.4 = three_four
+ # q.4 = four
+ # q.5.1.1 = five_one_one
+
+Troubleshooting
+ Beware comma after block:
+
+ rmap { print }, 1..3;
+ ^-------- bad news, you get and empty list:
+ rmap(sub { print $_; }), 1..3;
+
+ If you don't import a function, perl's confusion may produce:
+
+ $ perl -MData::Rmap -le 'rmap_scalar { print } 1'
+ Can't call method "rmap_scalar" without a package or object reference...
+
+ $ perl -MData::Rmap -le 'rmap_scalar { $_++ } 1'
+ Can't call method "rmap_scalar" without a package or object reference...
+
+ If there's two paths to an element, both will need to be cut.
+
+ If there's two paths to an element, one will be taken randomly when
+ there is an intervening hash.
+
+TODO
+ put for @_ iin wrapper to allow parameters in a different wrapper, solve
+ localizing problem.
+
+ Note that the package/class name of the "State Object" is subject to
+ change.
+
+ The want and seen accessors may change or become useful dynamic
+ mutators.
+
+ Store custom localized data about the traversal. Seems too difficult and
+ ugly when compare to doing it at the call site. Should support multiple
+ reentrancy so avoid the symbol table.
+
+ "rmap_args { } $data_structure, @args" form to pass parameters. Could
+ potentially help localizing needs. (Maybe only recurse last item)
+
+ Benchmark. Use array based object and/or direct access internally.
+
+ rmap_objects shortcut for Scalar::Utils::blessed (Let me know of other
+ useful rmap_??? wrappers)
+
+ Think about permitting different callback for different types. The
+ prototype syntax is a bit too flaky....
+
+ Ensure that no memory leaks are possible, leaking the closure.
+
+ Read http://www.cs.vu.nl/boilerplate/
+
+SEE ALSO
+ map, grep, Storable's dclone, Scalar::Util's reftype and blessed
+
+ Faint traces of treemap:
+
+ http://www.perlmonks.org/index.pl?node_id=60829
+
+AUTHOR
+ Brad Bowman <rmap at bereft.net> Copyright (C) 2004 All rights reserved.
+
diff --git a/lib/Data/Rmap.pm b/lib/Data/Rmap.pm
new file mode 100644
index 0000000..72cf43d
--- /dev/null
+++ b/lib/Data/Rmap.pm
@@ -0,0 +1,546 @@
+package Data::Rmap;
+our $VERSION = 0.62;
+
+=head1 NAME
+
+Data::Rmap - recursive map, apply a block to a data structure
+
+=head1 SYNOPSIS
+
+ $ perl -MData::Rmap -e 'print rmap { $_ } 1, [2,3], \\4, "\n"'
+ 1234
+
+ $ perl -MData::Rmap=:all
+ rmap_all { print (ref($_) || "?") ,"\n" } \@array, \%hash, \*glob;
+
+ # OUTPUT (Note: a GLOB always has a SCALAR, hence the last two items)
+ # ARRAY
+ # HASH
+ # GLOB
+ # SCALAR
+ # ?
+
+
+ # Upper-case your leaves in-place
+ $array = [ "a", "b", "c" ];
+ $hash = { key => "a value" };
+ rmap { $_ = uc $_; } $array, $hash;
+
+ use Data::Dumper; $Data::Dumper::Terse=1; $Data::Dumper::Indent=0;
+ print Dumper($array), " ", Dumper($hash), "\n";
+
+ # OUTPUT
+ # ['A','B','C'] {'key' => 'A VALUE'}
+
+
+ # Simple array dumper.
+ # Uses $self->recurse method to alter traversal order
+ ($dump) = rmap_to {
+
+ return "'$_'" unless ref($_); # scalars are quoted and returned
+
+ my $self = shift;
+ # use $self->recurse to grab results and wrap them
+ return '[ ' . join(', ', $self->recurse() ) . ' ]';
+
+ } ARRAY|VALUE, [ 1, [ 2, [ [ 3 ], 4 ] ], 5 ];
+
+ print "$dump\n";
+ # OUTPUT
+ # [ '1', [ '2', [ [ '3' ], '4' ] ], '5' ]
+
+
+=head1 DESCRIPTION
+
+ rmap BLOCK LIST
+
+Recursively evaluate a BLOCK over a list of data structures
+(locally setting $_ to each element) and return the list composed
+of the results of such evaluations. $_ can be used to modify
+the elements.
+
+Data::Rmap currently traverses HASH, ARRAY, SCALAR and GLOB reference
+types and ignores others. Depending on which rmap_* wrapper is used,
+the BLOCK is called for only scalar values, arrays, hashes, references,
+all elements or a customizable combination.
+
+The list of data structures is traversed pre-order in a depth-first fashion.
+That is, the BLOCK is called for the container reference before is it called
+for it's elements (although see "recurse" below for post-order).
+The values of a hash are traversed in the usual "values" order which
+may affect some applications.
+
+If the "cut" subroutine is called in the BLOCK then the traversal
+stops for that branch, say if you "cut" an array then the code is
+never called for it's elements (or their sub-elements).
+To simultaneously return values and cut, simply pass the return list
+to cut: C<cut('add','to','returned');>
+
+The first parameter to the BLOCK is an object which maintains the
+state of the traversal. Methods available on this object are
+described in L<State Object> below.
+
+=head1 EXPORTS
+
+By default:
+
+ rmap, rmap_all, cut
+
+Optionally:
+
+ rmap_scalar rmap_hash rmap_array rmap_ref rmap_to
+ :types => [ qw(NONE VALUE HASH ARRAY SCALAR REF OBJECT ALL) ],
+ :all => ... # everything
+
+=head1 Functions
+
+The various names are just wrappers which select when to call
+the code BLOCK. rmap_all always calls it, the others are more
+selective while rmap_to takes an extra parameter permitting you
+to provide selection criteria. Furthermore, you can always
+just rmap_all and skip nodes which are not of interest.
+
+=over 4
+
+=item rmap_to { ... } $want, @data_structures;
+
+Most general first.
+
+Recurse the @data_structures and apply the BLOCK to
+elements selected by $want. The $want parameter is the
+bitwise "or" of whatever types you choose (imported with :types):
+
+ VALUE - non-reference scalar, eg. 1
+ HASH - hash reference
+ ARRAY - array reference
+ SCALAR - scalar refernce, eg. \1
+ REF - higher-level reference, eg. \\1, \\{}
+ B<NOT> any reference type, see <Scalar::Util>'s reftype:
+ perl -MScalar::Util=reftype -le 'print map reftype($_), \1, \\1'
+ GLOB - glob reference, eg. \*x
+ (scalar, hash and array recursed)
+ ALL - all of the above
+ NONE - none of the above
+
+So to call the block for arrays and scalar values do:
+
+ use Data::Rmap ':all'; # or qw(:types rmap_to)
+ rmap { ... } ARRAY|VALUE, @data_structures;
+
+(ALL & !GLOB) might also be handy.
+
+The remainder of the wrappers are given in terms of the $want for rmap_to.
+
+=item rmap { ... } @list;
+
+Recurse and call the BLOCK on non-reference scalar values. $want = VALUE
+
+=item rmap_all BLOCK LIST
+
+Recurse and call the BLOCK on everything. $want = ALL
+
+=item rmap_scalar { ... } @list
+
+Recurse and call the BLOCK on non-collection scalars.
+$want = VALUE|SCALAR|REF
+
+=item rmap_hash
+
+Recurse and call the BLOCK on hash refs. $want = HASH
+
+=item rmap_array
+
+Recurse and call the BLOCK on array refs. $want = ARRAY
+
+=item rmap_ref
+
+Recurse and call the BLOCK on all references (not GLOBS).
+$want = HASH|ARRAY|SCALAR|REF
+
+Note: rmap_ref isn't the same as rmap_to {} REF
+
+=item cut(@list)
+
+Don't traverse sub-elements and return the @list immediately.
+For example, if $_ is an ARRAY reference, then the array's elements
+are not traversed.
+
+If there's two paths to an element, both will need to be cut.
+
+=back
+
+=head1 State Object
+
+The first parameter to the BLOCK is an object which maintains
+most of the traversal state (except current node, which is $_).
+I<You will ignore it most of the time>.
+The "recurse" method may be useful.
+Other methods should only be used in throw away tools, see L<TODO>
+
+Methods:
+
+=over 4
+
+=item recurse
+
+Process child nodes of $_ now and return the result.
+
+This makes it easier to perform post-order and in-order
+processing of a structure. Note that since the same "seen list"
+is used, the child nodes aren't reprocessed.
+
+=item code
+
+The code reference of the BLOCK itself. Possible useful in
+some situations.
+
+=item seen
+
+(Warning: I'm undecided whether this method should be public)
+
+Reference to the HASH used to track where we have visited.
+You may want to modify it in some situations (though I haven't yet).
+Beware circular references. The (current) convention used for the key
+is in the source.
+
+=item want
+
+(Warning: I'm undecided whether this method should be public)
+
+The $want state described in L<rmap_to>.
+
+=back
+
+=head1 EXAMPLES
+
+ # command-line play
+ $ perl -MData::Rmap -le 'print join ":", rmap { $_ } 1,2,[3..5],\\6'
+ 1:2:3:4:5:6
+
+
+ # Linearly number questions on a set of pages
+ my $qnum = 1;
+ rmap_hash {
+ $_->{qnum} = $qnum++ if($_->{qn});
+ } @pages;
+
+
+ # Grep recursively, finding ALL objects
+ use Scalar::Util qw(blessed);
+ my @objects = rmap_ref {
+ blessed($_) ? $_ : ();
+ } $data_structure;
+
+
+ # Grep recursively, finding public objects (note the cut)
+ use Scalar::Util qw(blessed);
+ my @objects = rmap_ref {
+ blessed($_) ? cut($_) : ();
+ } $data_structure;
+
+
+ # Return a modified structure
+ # (result flattening means we must cheat by cloning then modifying)
+ use Storable qw(dclone);
+ use Lingua::EN::Numbers::Easy;
+
+ $words = [ 1, \2, { key => 3 } ];
+ $nums = dclone $words;
+ rmap { $_ = $N{$_} || $_ } $nums;
+
+
+ # Make an assertion about a structure
+ use Data::Dump;
+ rmap_ref {
+ blessed($_) && $_->isa('Question') && defined($_->name)
+ or die "Question doesn't have a name:", dump($_);
+ } @pages;
+
+
+ # Traverse a tree using localize state
+ $tree = [
+ one =>
+ two =>
+ [
+ three_one =>
+ three_two =>
+ [
+ three_three_one =>
+ ],
+ three_four =>
+ ],
+ four =>
+ [
+ [
+ five_one_one =>
+ ],
+ ],
+ ];
+
+ @path = ('q');
+ rmap_to {
+ if(ref $_) {
+ local(@path) = (@path, 1); # ARRAY adds a new level to the path
+ $_[0]->recurse(); # does stuff within local(@path)'s scope
+ } else {
+ print join('.', @path), " = $_ \n"; # show the scalar's path
+ }
+ $path[-1]++; # bump last element (even when it was an aref)
+ } ARRAY|VALUE, $tree;
+
+ # OUTPUT
+ # q.1 = one
+ # q.2 = two
+ # q.3.1 = three_one
+ # q.3.2 = three_two
+ # q.3.3.1 = three_three_one
+ # q.3.4 = three_four
+ # q.4 = four
+ # q.5.1.1 = five_one_one
+
+=head1 Troubleshooting
+
+Beware comma after block:
+
+ rmap { print }, 1..3;
+ ^-------- bad news, you get and empty list:
+ rmap(sub { print $_; }), 1..3;
+
+If you don't import a function, perl's confusion may produce:
+
+ $ perl -MData::Rmap -le 'rmap_scalar { print } 1'
+ Can't call method "rmap_scalar" without a package or object reference...
+
+ $ perl -MData::Rmap -le 'rmap_scalar { $_++ } 1'
+ Can't call method "rmap_scalar" without a package or object reference...
+
+If there's two paths to an element, both will need to be cut.
+
+If there's two paths to an element, one will be taken randomly when
+there is an intervening hash.
+
+Autovivification can lead to "Deep recursion" warnings if you test
+C<exists $_->{this}{that}> instead of
+C<exists $_->{this} && exists $_->{this}{that}>
+as you may follow a long chain of "this"s
+
+
+=head1 TODO
+
+put for @_ iin wrapper to allow parameters in a different wrapper,
+solve localizing problem.
+
+Note that the package/class name of the L<State Object>
+is subject to change.
+
+The want and seen accessors may change or become useful
+dynamic mutators.
+
+Store custom localized data about the traversal.
+Seems too difficult and ugly when compare to doing it at the call site.
+Should support multiple reentrancy so avoid the symbol table.
+
+C<rmap_args { } $data_structure, @args> form to pass parameters.
+Could potentially help localizing needs. (Maybe only recurse last item)
+
+Benchmark. Use array based object and/or direct access internally.
+
+rmap_objects shortcut for Scalar::Utils::blessed
+(Let me know of other useful rmap_??? wrappers)
+
+Think about permitting different callback for different types.
+The prototype syntax is a bit too flaky....
+
+Ensure that no memory leaks are possible, leaking the closure.
+
+Read http://www.cs.vu.nl/boilerplate/
+
+=head1 SEE ALSO
+
+map, grep, L<Storable>'s dclone, L<Scalar::Util>'s reftype and blessed
+
+Faint traces of treemap:
+
+ http://www.perlmonks.org/index.pl?node_id=60829
+
+=head1 AUTHOR
+
+Brad Bowman E<lt>rmap at bereft.netE<gt>
+
+=head1 LICENCE AND COPYRIGHT
+
+Copyright (c) 2004-2008 Brad Bowman (E<lt>rmap at bereft.netE<gt>).
+All rights reserved.
+
+This module is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+See L<perlartistic> and L<perlgpl>.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+=cut
+
+# Early design discussion:
+# http://www.perlmonks.org/index.pl?node_id=295642
+# wantarray
+# http://www.class-dbi.com/cgi-bin/wiki/index.cgi?AtomicUpdates
+
+use warnings;
+use strict;
+use Carp qw(croak);
+use Scalar::Util qw(blessed refaddr reftype);
+
+require Exporter;
+our @ISA = qw(Exporter);
+our @EXPORT = qw(rmap rmap_all cut);
+our %EXPORT_TAGS = (
+ types => [ qw(NONE VALUE HASH ARRAY SCALAR REF GLOB ALL) ],
+);
+our @EXPORT_OK = ( qw(rmap_scalar rmap_hash rmap_array rmap_ref rmap_to),
+ @{ $EXPORT_TAGS{types} } );
+
+$EXPORT_TAGS{all} = [ @EXPORT, @EXPORT_OK ];
+
+
+# Uses stringifying instead of S::U::ref* b/c it's under control
+my $cut = \do { my $thing }; # my = out of symbol table
+sub cut {
+ die $cut = [@_]; # cut can return
+}
+
+sub NONE() { 0 }
+sub VALUE() { 1 }
+sub HASH() { 2 }
+sub ARRAY() { 4 }
+sub SCALAR() { 8 }
+sub REF() { 16 }
+sub GLOB() { 32 }
+sub ALL() { VALUE|HASH|ARRAY|SCALAR|REF|GLOB }
+# Others like CODE, Regex, etc are ignored
+
+my %type_bits = (
+ HASH => HASH,
+ ARRAY => ARRAY,
+ SCALAR => SCALAR,
+ REF => REF,
+ GLOB => GLOB,
+ # reftype actually returns undef for:
+ VALUE => VALUE,
+);
+
+sub new {
+ bless { code => $_[1], want => $_[2], seen => $_[3] }, $_[0];
+}
+sub code { $_[0]->{code} }
+sub want { $_[0]->{want} }
+sub seen { $_[0]->{seen} }
+sub call { $_[0]->{code}->($_[0]) }
+
+sub recurse {
+ # needs to deref $_ and *then* run the code, enter _recurse directly
+ $_[0]->_recurse(); # cut not needed as seen remembers
+}
+
+sub rmap (&@) {
+ __PACKAGE__->new(shift, VALUE, {})->_rmap(@_);
+}
+
+sub rmap_all (&@) {
+ __PACKAGE__->new(shift, ALL, {})->_rmap(@_);
+}
+
+sub rmap_scalar (&@) {
+ __PACKAGE__->new(shift, VALUE|SCALAR|REF, {})->_rmap(@_);
+}
+
+sub rmap_hash (&@) {
+ __PACKAGE__->new(shift, HASH, {})->_rmap(@_);
+}
+
+sub rmap_array (&@) {
+ __PACKAGE__->new(shift, ARRAY, {})->_rmap(@_);
+}
+
+sub rmap_ref (&@) {
+ __PACKAGE__->new(shift, HASH|ARRAY|SCALAR|REF, {})->_rmap(@_);
+}
+
+sub rmap_to (&@) {
+ __PACKAGE__->new(shift, shift, {})->_rmap(@_);
+}
+
+sub _rmap {
+ my $self = shift;
+ my @return;
+
+ for (@_) { # just one after the wrapper call
+ my ($key, $type);
+
+ if($type = reftype($_)) {
+ $key = refaddr $_;
+ $type = $type_bits{$type} or next;
+ } else {
+ $key = "V:".refaddr(\$_); # prefix to distinguish from \$_
+ $type = VALUE;
+ }
+
+ next if ( exists $self->seen->{$key} );
+ $self->seen->{$key} = undef;
+
+ # Call the $code
+ if($self->want & $type) {
+ my $e; # local($@) and rethrow caused problems
+ my @got;
+ {
+ local ($@); # don't trample, cut impl. should be transparent
+ # call in array context. pass block for reentrancy
+ @got = eval { $self->call() };
+ $e = $@;
+ }
+
+ if($e) {
+ if(ref($e) && $e == $cut) {
+ push @return, @$cut; # cut can add to return list
+ next; # they're cutting, don't recurse
+ } else {
+ die $e;
+ }
+ }
+ push @return, @got;
+ }
+
+ push @return, $self->_recurse(); # process $_ node
+ }
+ return @return;
+}
+
+sub _recurse {
+ my $self = shift;
+ my $type = $type_bits{reftype($_) || 'VALUE'} or return;
+ my @return;
+
+ # Recurse appropriately, keeping $_ alias
+ if ($type & HASH) {
+ push @return, $self->_rmap($_) for values %$_;
+ } elsif ($type & ARRAY) {
+ # Does this change cut behaviour? No, cut is one scalar ref
+ #push @return, _rmap($code, $want, $seen, $_) for @$_;
+ push @return, $self->_rmap(@$_);
+ } elsif ($type & (SCALAR|REF) ) {
+ push @return, $self->_rmap($$_);
+ } elsif ($type & GLOB) {
+ # SCALAR is always there, undef may be unused or set to undef
+ push @return, $self->_rmap(*$_{SCALAR});
+ defined *$_{ARRAY} and
+ push @return, $self->_rmap(*$_{ARRAY});
+ defined *$_{HASH} and
+ push @return, $self->_rmap(*$_{HASH});
+ # Is it always: *f{GLOB} == \*f ?
+ # Also CODE PACKAGE NAME GLOB
+ }
+ return @return;
+}
+
+1;
diff --git a/test.pl b/test.pl
new file mode 100644
index 0000000..993f3fa
--- /dev/null
+++ b/test.pl
@@ -0,0 +1,191 @@
+#!/usr/bin/perl -w
+use strict;
+use Test::More 'no_plan'; # tests =>$n
+use Test::Exception;
+
+BEGIN { use_ok( 'Data::Rmap' ); }
+use Data::Dumper;
+$Data::Dumper::Purity=1;
+
+our $data = {
+ 'arrays' => [[ 'shared', 'not_shared' ]],
+ 'num' => 2,
+ 'ref' => \do { my $a = 'ref' },
+ 'hash' => {
+ 'a' => 'vala',
+ 'b' => 'valb',
+ 'c' => { qn=> 'this' },
+ },
+ 'ref_to_hash' => \{ qn=> 'that' },
+ };
+
+# shared value
+$data->{share_ref} = \$data->{arrays}[0][0];
+$data->{another_obj} = \do{ my $o = ${$data->{ref_to_hash}}};
+
+my $orig_dump = Dumper($data);
+
+# do nothing slowly
+rmap { } $data;
+rmap_all { } $data;
+
+# test importing imlicitly
+use Data::Rmap qw(rmap_scalar);
+rmap_scalar { } $data;
+use Data::Rmap qw(:types rmap_to);
+rmap_to { } HASH|ARRAY|SCALAR|REF|VALUE|GLOB, $data;
+use Data::Rmap qw(:all);
+rmap_hash { } $data;
+rmap_array { } $data;
+
+# check nothign changed
+ok(Dumper($data) eq $orig_dump, 'nothing changed');
+
+rmap { $_ = "#$_#"; } $data; # all the leaves
+
+ok($data->{num} eq '#2#', "num #2#");
+ok($data->{arrays}[0][0] eq '#shared#', "done once #shared#");
+ok(${$data->{ref}} eq '#ref#', "${$data->{ref}} eq '#ref#'");
+ok($data->{hash}{a} eq '#vala#', "nested hashes done #vala#");
+ok(${$data->{ref_to_hash}}->{qn} eq '#that#', "ref_to_hash done #that#");
+
+my $count = 1;
+rmap_all {
+ cut if ref($_) eq 'ARRAY';
+ $_ = "=\U$_=" if !ref($_); # leaves
+ $_->{qnum} = $count++ if ref($_) eq 'HASH' && exists $_->{qn};
+} $data;
+#diag(Dumper $data);
+
+ok($data->{arrays}[0][1] eq '#not_shared#', 'ARRAY cut');
+ok($data->{arrays}[0][0] eq '=#SHARED#=', 'cut one path only');
+ok($data->{hash}{a} eq '=#VALA#=', 'HASH not cut');
+like(${$data->{ref_to_hash}}->{qnum}, qr/^=\d+=$/, 'qnum added to qn');
+
+# action only done once
+$data = [];
+$data->[0] = "string";
+$data->[1] = \$data->[0];
+$data->[2] = \\do{ my $s = "last" };
+
+rmap { $_ = "!$_" } $data;
+ok($data->[0] eq '!string', "done once");
+ok(${$data->[1]} eq '!string', "access via both paths");
+ok(\$data->[0] == \${$data->[1]}, "still same ref");
+ok($${$data->[2]} eq '!last', "got '!last'");
+
+# test aliasing with write only: ref => \'ref'
+my $ro_err = qr/^Modification of a read-only value attempted/;
+throws_ok { rmap { $_++ } 1 } $ro_err, 'read-only scalar';
+throws_ok { rmap { $_++ } \1 } $ro_err, 'read-only scalar ref';
+throws_ok { rmap { $_++ } [\1] } $ro_err, 'read-only scalar ref in array';
+throws_ok { rmap { $_++ } {1,\1} } $ro_err, 'read-only scalar ref in hash';
+*ro = \1;
+throws_ok { rmap { $_++ } *ro } $ro_err, 'read-only scalar ref in glob';
+
+# test returns
+is_deeply([ rmap { ++$_ } [1,2] ], [2,3], 'return altered pre-inc');
+is_deeply([ rmap { $_++ } [1,2] ], [1,2], 'return not altered post-inc');
+is( scalar(rmap { ++$_ } [2..4]), 3, 'scalar context num items');
+our $rw = 2;
+is_deeply([ rmap { ++$_ } [\do{my $a = 1}, \*rw] ], [2,3], 'flattens return');
+is_deeply([ rmap { ++$_ } [1,[2]] ], [2,3], 'flattens 2');
+
+# test cut
+# take first element of each array reference found
+is_deeply([ rmap_array { cut($_->[0]) } [1,0],[2,0,[0]],[[3],0], {0,\[4]} ],
+ [ 1, 2, [3], 4 ],
+ 'cut limits recursion');
+
+is_deeply([ rmap { cut(++$_) } [1,2] ], [2,3], 'cut return altered pre-inc');
+is_deeply([ rmap { ++$_; cut() } [1,2] ], [], 'cut can return nothing');
+
+# test $_[0]->recurse
+my ($array_dump) = rmap_to {
+ return $_ unless ref($_);
+ '[ ' . join(', ', $_[0]->recurse() ) . ' ]';
+} ARRAY|VALUE, [ 1, [ 2, [ [ 3 ], 4 ] ], 5 ];
+is($array_dump, '[ 1, [ 2, [ [ 3 ], 4 ] ], 5 ]', 'dumper dumps');
+
+my $tree = [
+ one =>
+ two =>
+ [
+ three_one =>
+ three_two =>
+ [
+ three_three_one =>
+ ],
+ three_four =>
+ ],
+ four =>
+ [
+ [
+ five_one_one =>
+ ],
+ ],
+];
+
+my $got = '';
+our @path = ('q');
+rmap_to {
+ if(ref $_) {
+ local(@path) = (@path, 1); # ARRAY adds a new level to the path
+ $_[0]->recurse(); # does stuff within local(@path)'s scope
+ } else {
+ $got .= join('.', @path) . ' ';
+ }
+ $path[-1]++; # bump last element (even when it was an aref)
+} ARRAY|VALUE, $tree;
+
+is($got, 'q.1 q.2 q.3.1 q.3.2 q.3.3.1 q.3.4 q.4 q.5.1.1 ',
+ 'tree numbering w/ recurse');
+
+
+# test each name works as expected
+our $x = 3;
+my @types = (1, [], {}, \\2, \*x);
+#$_ = join(' ', rmap_all { $_ } @types); s/\(.*?\)/\\S+/g; diag($_);
+like(join(' ',
+ rmap { $_ } @types),
+ qr/^1 2 3$/,
+ 'rmap types'
+);
+
+like(join(' ',
+ rmap_all { $_ } @types),
+ qr/^1 ARRAY\S+ HASH\S+ (REF|SCALAR)\S+ SCALAR\S+ 2 GLOB\S+ SCALAR\S+ 3$/,
+ 'rmap_all types'
+);
+
+like(join(' ',
+ rmap_scalar { $_ } @types),
+ qr/^1 (REF|SCALAR)\S+ SCALAR\S+ 2 SCALAR\S+ 3$/,
+ 'rmap_scalar types'
+);
+
+like(join(' ',
+ rmap_hash { $_ } @types),
+ qr/^HASH\S+$/,
+ 'rmap_hash types'
+);
+
+like(join(' ',
+ rmap_array { $_ } @types),
+ qr/^ARRAY\S+$/,
+ 'rmap_array types'
+);
+
+like(join(' ',
+ rmap_ref { $_ } @types),
+ qr/^ARRAY\S+ HASH\S+ (REF|SCALAR)\S+ SCALAR\S+ SCALAR\S+$/,
+ 'rmap_ref types'
+);
+
+
+like(join(' ',
+ rmap_to { $_ } GLOB|HASH, @types),
+ qr/^HASH\S+ GLOB\S+$/,
+ 'rmap_to GLOB|HASH types'
+);
+
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libdata-rmap-perl.git
More information about the Pkg-perl-cvs-commits
mailing list