File Coverage

blib/lib/Data/Decycle.pm

Criterion	Covered	Total	%
statement	63	88	71.5
branch	26	48	54.1
condition	2	12	16.6
subroutine	19	22	86.3
pod	7	7	100.0
total	117	177	66.1

#
# $Id: Decycle.pm,v 0.2 2010/08/23 09:11:03 dankogai Exp dankogai $
#
package Data::Decycle;
use 5.008001;
use warnings;
use strict;
use Carp;
use Scalar::Util qw/refaddr weaken isweak/;

our $VERSION = sprintf "%d.%02d", q$Revision: 0.2 $ =~ /(\d+)/g;
our $DEBUG = 0;

use base 'Exporter';
our @EXPORT    = ();
our @EXPORT_OK = qw(recsub $CALLEE
  may_leak has_cyclic_ref decycle_deeply weaken_deeply
);
our %EXPORT_TAGS = ( all => [ @EXPORT, @EXPORT_OK ], );

BEGIN {
    require constant;
    constant->import(
        HAS_PADWALKER => eval {
            require PadWalker;
            $PadWalker::VERSION >= 1.0;
        }
    );
}

sub new {
    my $class = shift;
    my $self = bless [], $class;
    $self->add(@_);
}

sub add {
    my $self = shift;
    for (@_){
	croak "$_ is not a reference" unless ref $_;
	push @{$self}, $_;
    }
    $self;
}

sub DESTROY {
    my $self = shift;
    if ($DEBUG > 1){
	require Data::Dumper and Data::Dumper->import;
	print Dumper($self);
    }
    for (@{$self}){
	next unless ref $_;
	carp "decyling ($_)" if $DEBUG;
	decycle_deeply($_);
    }
}

our $CALLEE;

sub recsub(&) {
    my $code = shift;
    sub {
        local *CALLEE = \$code;
        $code->(@_);
    }
}

sub _mkfinder(&) {
    my $cb = shift;
    return recsub {
        return unless ref $_[0];
        no warnings 'uninitialized';
        return $cb->( $_[0] ) if $_[1]->{ refaddr $_[0] }++;
        if ( UNIVERSAL::isa( $_[0], 'HASH' ) ) {
            for ( values %{ $_[0] } ) {
                next unless ref $_;
                return 1 if $CALLEE->( $_, $_[1] );
            }
        }
        elsif ( UNIVERSAL::isa( $_[0], 'ARRAY' ) ) {
            for ( @{ $_[0] } ) {
                next unless ref $_;
                return 1 if $CALLEE->( $_, $_[1] );
            }
        }
        elsif (UNIVERSAL::isa( $_[0], 'SCALAR' )
            || UNIVERSAL::isa( $_[0], 'REF' ) )
        {
            return $CALLEE->( ${ $_[0] }, $_[1] );
        }
        elsif ( HAS_PADWALKER && UNIVERSAL::isa( $_[0], 'CODE' ) ) {
            my $r = PadWalker::closed_over( $_[0] );
            return unless keys %$r;
            $CALLEE->( $r, $_[1] ) && return 1;
        }
        return;
    }
}

*_has_cyclic_ref = _mkfinder { 1 };
sub has_cyclic_ref($){ _has_cyclic_ref($_[0], {}) }

*_may_leak = _mkfinder { !isweak($_[0]) };
sub may_leak($){ _may_leak($_[0], {}) }

sub _mkwalker(&){
    my $cb = shift;
    return recsub {
        return unless ref $_[0];
        no warnings 'uninitialized';
        return $cb->( $_[0] ) if $_[1]->{ refaddr $_[0] }++;
        if ( UNIVERSAL::isa( $_[0], 'HASH' ) ) {
            $CALLEE->( $_, $_[1] ) for values %{ $_[0] };
        }
        elsif ( UNIVERSAL::isa( $_[0], 'ARRAY' ) ) {
            $CALLEE->( $_, $_[1] ) for @{ $_[0] };
        }
        elsif (UNIVERSAL::isa( $_[0], 'SCALAR' )
            || UNIVERSAL::isa( $_[0], 'REF' ) )
        {
            $CALLEE->( ${ $_[0] }, $_[1] );
        }
        elsif ( HAS_PADWALKER && UNIVERSAL::isa( $_[0], 'CODE' ) ) {
            my $r = PadWalker::closed_over( $_[0] );
            return unless keys %$r;
            $CALLEE->( $r, $_[1] );
        }
        return;
    };
}

*_decycle_deeply = _mkwalker { undef $_[0] };
sub decycle_deeply($) { _decycle_deeply( $_[0], {} ) }

*_weaken_deeply = _mkwalker {
    weaken $_[0] unless UNIVERSAL::isa( $_[0], 'CODE' )
};
sub weaken_deeply($) { _weaken_deeply( $_[0], {} ) }

1; # End of Data::Decycle

__END__