view release on metacpan or  search on metacpan

lib/Alter.pm  view on Meta::CPAN

    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__

=head1 NAME

Alter - Alter Ego Objects

=head2 Synopsis

  package MyClass;
  use Alter ego => {}; # Alter ego of type hash

  # Put data in it
  my $obj = \ do { my $o };
  ego( $obj)->{a} = 1;
  ego( $obj)->{b} = 2;

  # Retrieve it again
  print ego( $obj)->{ b}, "\n"; # prints 2

  package OtherClass;
  defined( ego $obj) or die; # dies, OtherClass hasn't set an alter ego

  # Direct access to the corona of alter egos
  my $crown = Alter::corona $obj;

=head2 Functions