File Coverage

blib/lib/Devel/Walk/Unstorable.pm

Criterion	Covered	Total	%
statement	45	47	95.7
branch	12	14	85.7
condition	6	11	54.5
subroutine	11	11	100.0
pod	5	5	100.0
total	79	88	89.7

package Devel::Walk::Unstorable;

use strict;
use warnings;

use Devel::Walk ();

require Exporter;

our @ISA = qw(Exporter);
our %EXPORT_TAGS = ( 'all' => [ qw( unstorable ) ] );
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
our @EXPORT = qw( unstorable );
our $VERSION = '0.02';

###############################################
sub unstorable
{
    my( $obj, $name ) = @_;
    my $S = Devel::Walk::Unstorable->new;
    $S->walk( $obj, $name );
    return $S->list;
}

###############################################
sub new
{
    my $package = shift;
    return bless {@_}, $package;
}

sub walk
{
    my( $self, $obj, $name ) = @_;
    local $self->{LAST};
    $self->{list} ||= [];
    Devel::Walk::walk( $obj, sub { $self->__unstorable( @_ ); }, $name );
    push @{ $self->{list} }, $self->{LAST} if defined $self->{LAST} and @{ $self->{list} } and
                        $self->{list}[-1] ne $self->{LAST};
}

sub list { @{ $_[0]->{list} } }

sub __deepest
{
    my( $self, $old, $new ) = @_;
    return unless defined $old;
    my $ol = length( $old );
    # $old = '$something->{one}'
    # $new = '$something->{one}[0]'
    # $old is not deepest
    return if substr( $new, 0, $ol ) eq $old;

    # $old = '$something->{one}'
    # $new = '$${$something->{one}}{more}'
    # $old is not deepest
    return if $new =~ /^\$\$\{\Q$old\E\}/;
    # $old = '$something->{one}'
    # $new = '$something->{two}'
    # $old is deepest
    # warn "deepest='$old'";
    return 1;
}

sub __unstorable
{
    my( $self, $loc, $obj ) = @_;
    require 'Storable.pm';
    if( $self->__deepest( $self->{LAST}, $loc ) ) {
        # warn "deepest=$self->{LAST}";
        push @{ $self->{list} }, $self->{LAST};
        $self->{LAST} = undef;
    }

    if( $self->check( $loc, $obj ) ) {
        # warn "$loc is unstorable";
        $self->{LAST} = $loc;
        return 1;
    }
    else {
        # warn "$loc is storable";
    }
    return;
}

sub check
{
    my( $self, $loc, $obj ) = @_;
    return 1 if ref( $obj ) and not eval { $SIG{__DIE__} = 'DEFAULT'; Storable::freeze( $obj ); 1; };
    return;
}

1;

__END__