package Data::Rmap;
our $VERSION = 0.2;
=head1 AUTHOR

Brad Bowman E<lt>rmap@bereft.netE<gt>
Copyright (C) 2004 All rights reserved.

=cut
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_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 XXX can you 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 }
# ALL & !GLOB 
# Others like CODE, Regex, etc are ignored
    
my %type_bits = (
    HASH => HASH,
    ARRAY => ARRAY,
    SCALAR => SCALAR,
    REF => REF,
    GLOB => GLOB,
);  

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 rmap (&@) {
    __PACKAGE__->new(shift, VALUE, {})->_rmap(@_);
}


sub rmap_all (&@) {
    __PACKAGE__->new(shift, HASH|ARRAY|SCALAR|REF|VALUE|GLOB, {})->_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_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) {
            local ($@); # don't trample
            # call in array context.  pass block for reentrant
            my @got = eval { $self->call(); }; # XXX all reentrant
            if($@) {
                if(ref($@) && $@ == $cut) {
                    push @return, @$cut;
                    next; # they're cutting, don't recurse
                } else {
                    die $@;
                }
            }
            push @return, @got;
        }
        # 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($_) for $$_; # XXX for needed?
            push @return, $self->_rmap($$_); # XXX for needed?
        } 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;