File Coverage

blib/lib/Alter.pm

Criterion	Covered	Total	%
statement	87	87	100.0
branch	29	34	85.2
condition	9	14	64.2
subroutine	19	19	100.0
pod	0	2	0.0
total	144	156	92.3

package Alter;
use 5.008000;
use strict; use warnings;

our $VERSION = '0.07';

our %EXPORT_TAGS = (
    all => [ qw(
        alter ego
        STORABLE_freeze STORABLE_attach STORABLE_thaw
        Dumper
    ) ],
);
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

# for re-exportation
*STORABLE_freeze = \ &Alter::Storable::STORABLE_freeze;
*STORABLE_thaw = \ &Alter::Storable::STORABLE_thaw;
*STORABLE_attach = \ &Alter::Storable::STORABLE_attach;
*Dumper= \ &Alter::Dumper::Dumper;

eval {
    die "Pure Perl requested" if $ENV{ PERL_ALTER_NO_XS}; # fake load failure
    no warnings 'redefine';
    require XSLoader;
    XSLoader::load('Alter', $VERSION);
    *is_xs = sub { 1 };
};
if ( $@ ) {
    # Fallback to pure perl implementation
    no warnings 'redefine';
    require Alter::AlterXS_in_perl if $@;
    *is_xs = sub { 0 };
}

### Import/Export

# Types supported for autovivification
use Scalar::Util qw( reftype);
my %ref_tab = (
    NOAUTO => 'NOAUTO',
    map +( reftype( $_) => $_) => (
        \ do { my $o }, # scalar
        [],             # array
        {},             # hash
    ),
);

sub import {
    require Exporter;
    my $class = shift;
    my $client = caller;
    my $storable = my $dumper = my $destroy = 1;
    for ( 1 .. @_ ) {
        my $arg = shift;
        $storable = 0, next if $arg eq '-storable';
        $dumper = 0, next if $arg eq '-dumper';
        $destroy = 0, next if $arg eq '-destroy';
        $storable = 0 if $arg =~ /^STORABLE_/;
        $dumper = 0 if $arg eq 'Dumper';
        my $type = ref( $arg) ? $arg : $ref_tab{ $arg};
        if ( $type && ref( $type) && $ref_tab{ reftype $type} ) {
            _set_class_type( $client, $type);
            next;
        } elsif ( $type and $type eq 'NOAUTO' ) {
            _set_class_type( $client, undef); # delete entry
            next;
        }
        push @_, $arg; # hand down to Exporter::import()
    }
    _add_base( $client, 'Alter::Storable')   if $storable;
    _add_base( $client, 'Alter::Dumper')     if $dumper;
    _add_base( $client, 'Alter::Destructor') if !is_xs() && $destroy;
    unshift @_, $class;
    goto Exporter->can( 'import') || die "Exporter can't import???";
}

sub _add_base {
    my ( $client, $base) = @_;
    return if $client->isa( $base);
    no strict 'refs';
    push @{ join '::' => $client, 'ISA' }, $base;
}

### Serialization support: ->image and ->reify

# Key to use for object body in image (different from any class name)
use constant BODY => '(body)';

# create a hash image of an object that contains the body and
# corona data
sub image {
    my $obj = shift;
    +{
        BODY() => $obj,
        %{ corona( $obj) }, # shallow copy
    };
}

# recreate the original object from an image.  When called as a
# class method, take the object from the "(body)" entry in image
# (the class is ignored).  Called as an object method, re-model
# the given object (whose data is lost) to match the image.  In
# this case, the types of the given object and the "(body)" entry
# must match, or else...  Also, the ref type must be supported
# ("CODE" isn't).
sub reify {
    my $obj = shift;
    my $im = shift;
    if ( ref $obj ) {
        my $orig = delete $im->{ BODY()};
        _transfer_content( $orig, $obj);
    } else {
        $obj = delete $im->{ BODY()};
    }
    %{ corona( $obj)} = %$im;
    $obj;
}

my %trans_tab = (
    SCALAR => sub { ${ $_[ 1] } = ${ $_[ 0] } },
    ARRAY  => sub { @{ $_[ 1] } = @{ $_[ 0] } },
    HASH   => sub { %{ $_[ 1] } = %{ $_[ 0] } },
    GLOB   => sub { *{ $_[ 1] } = *{ $_[ 0] } },
);

use Carp;
sub _transfer_content {
    my ( $from, $to) = @_;
    my $type = reftype $from;
    croak "Incompatible types in STORABLE_thaw" unless
        $type eq reftype $to;
    croak "Unsupported type '$type' in STORABLE_thaw" unless
        my $trans = $trans_tab{ $type};
    $trans->( $_[ 0], $_[ 1]); # may change $_[ 1] ($to)
    $_[ 1];
}

### Data::Dumper support (for viewing only)
{
    package Alter::Dumper;

    # return a viewable string containing the object information
    sub Dumper {
        my $obj = shift;
        require Data::Dumper;
        local $Data::Dumper::Purity = 1;
        Data::Dumper::Dumper( $obj->Alter::image);
    }
}

### Storable support
{
    package Alter::Storable;

    my $running; # indicate if the call is (indirectly) from ourselves
    sub STORABLE_freeze {
        my ( $obj, $cloning) = @_;
        return if $cloning;
        return unless $running = !$running; # return if $running was true
        # $running now true, preventing recursion
        Storable::freeze( $obj->Alter::image);
    }

    # recognized (and preferred) by Storable 2.15+, (Perl v5.8.8)
    # ignored by earlier versions
    sub STORABLE_attach {
        my ( $class, $cloning, $ser) = @_;
        ++ our $attaching; # used by t/*.t, not needed for anything else
        $class->Alter::reify( Storable::thaw( $ser));
    }

    # recognized by all versions of Storable
    # incidentally, the code is equivalent to STORABLE_attach
    sub STORABLE_thaw {
        my ( $obj, $cloning, $ser) = @_;
        ++ our $thawing; # used by t/*.t, not needed for anything else
        $obj->Alter::reify( Storable::thaw( $ser));
    }
}

1;
__END__