File Coverage

blib/lib/Class/Rebless.pm

Criterion	Covered	Total	%
statement	54	54	100.0
branch	32	34	94.1
condition	5	8	62.5
subroutine	9	9	100.0
pod	1	2	50.0
total	101	107	94.3

package Class::Rebless;

require 5.005;
use strict;
use Carp;
use Scalar::Util;

use vars qw($VERSION $RE_BUILTIN $MAX_RECURSE);

$VERSION = '0.10';
$MAX_RECURSE = 1_000;


# MODULE INITIALIZATION

my %subs = (
    rebless => sub {
        my($opts) = @_;
        $opts->{editor} = sub {
            my ($obj, $class) = @_;
            bless $obj, $class;
        };
    },
    rebase  => sub {
        my($opts) = @_;
        $opts->{editor} = sub {
            my ($obj, $class) = @_;
            bless $obj, $class . '::' . ref $obj;
        };
    },
    custom  => sub {
        my($opts) = @_;
        $opts->{editor} or confess "custom reblesser requires an editor";
    },
);

while (my($name, $add_editor_to_opts) = each %subs) {
    no strict 'refs';
    *{__PACKAGE__ . "::$name"} = sub {
        my ($proto, $obj, $namespace, $opts) = @_;

        my $class = ref($proto) || $proto;

        $opts ||= {};
        $add_editor_to_opts->($opts);

        my $state = {
          level => 0,
          stack => { },
          seen  => { },
        };

        $class->_recurse($obj, $namespace, $opts, $state);
    };
}

{
    my $prune;
    sub prune {
        $prune = $_[1] if defined $_[1];
        $prune;
    }
    sub need_prune {
        return if not defined $prune;
        return $_[1] eq $prune;
    }
}

sub _recurse {
    my ($class, $obj, $namespace, $opts, $state) = @_;

    # If MAX_RECURSE is 10, we should be allowed to recurse ten times before
    # throwing an exception.  That means we only throw an exception at #11.
    die "maximum recursion level exceeded" if $state->{level} > $MAX_RECURSE;

    my $refaddr = Scalar::Util::refaddr($obj);
    if (defined $refaddr) {
      return $obj if $state->{seen}{$refaddr}++ and ! $opts->{revisit};
      return $obj if $state->{stack}{$refaddr};
    }

    local $state->{level} = $state->{level} + 1;
    local $state->{stack}{ defined $refaddr ? $refaddr : '' } = 1;

    # rebless this node, possibly pruning (skipping recursion
    # over its children)
    if (Scalar::Util::blessed $obj) {
        my $res = $opts->{editor}->($obj, $namespace); # re{bless,base} ref
        return $obj if $class->need_prune($res);
    }

    my $type = Scalar::Util::reftype $obj;
    return $obj unless defined $type;

    if      ($type eq 'SCALAR') {
        $class->_recurse($$obj, $namespace, $opts, $state);
    } elsif ($type eq 'ARRAY') {
        for my $elem (@$obj) {
            $class->_recurse($elem, $namespace, $opts, $state);
        }
    } elsif ($type eq 'HASH') {
        for my $val (values %$obj) {
            $class->_recurse($val, $namespace, $opts, $state);
        }
    } elsif ($type eq 'GLOB') {
        # Filehandles are GLOBs, but they don't have ARRAY slots!
        # Be paranoid, then, and recurse only on defined slots.

        my $slot;

        if (defined ($slot = *$obj{SCALAR})) {   # a glob has a scalar...
            $class->_recurse($$slot, $namespace, $opts, $state);
        }
        if (defined ($slot = *$obj{ARRAY})) {
            for my $elem (@$slot) {              # and an array...
              $class->_recurse($elem, $namespace, $opts, $state);
            }
        }
        if (defined ($slot = *$obj{HASH})) {
            for my $val (values %$slot) {        # ... and a hash.
                $class->_recurse($val, $namespace, $opts, $state);
            }
        }
    }
    return $obj;
}

1;


__END__