view release on metacpan or  search on metacpan

lib/Data/Rmap.pm  view on Meta::CPAN

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_code (&@) {
    __PACKAGE__->new(shift, CODE, {})->_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});
        defined *$_{CODE} and
            push @return, $self->_rmap(*$_{CODE});
        # Is it always: *f{GLOB} == \*f ?
        # Also PACKAGE NAME GLOB
    }
    return @return;
}

1;