File Coverage

blib/lib/Class/Std/Fast/Storable.pm

Criterion	Covered	Total	%
statement	74	74	100.0
branch	27	34	79.4
condition	3	6	50.0
subroutine	12	12	100.0
pod	2	2	100.0
total	118	128	92.1

package Class::Std::Fast::Storable;

use version; $VERSION = qv('0.0.8');
use strict;
use warnings;
use Carp;
use Storable;

BEGIN {
    require Class::Std::Fast;
}

my $attributes_of_ref = {};
my @exported_subs = qw(
    Class::Std::Fast::ident
    Class::Std::Fast::DESTROY
    Class::Std::Fast::MODIFY_CODE_ATTRIBUTES
    Class::Std::Fast::AUTOLOAD
    Class::Std::Fast::_DUMP
    STORABLE_freeze
    STORABLE_thaw
    MODIFY_HASH_ATTRIBUTES
);

sub import {
    my $caller_package = caller;

    my %flags = (@_>=3)
            ? @_[1..$#_]
            : (@_==2) && $_[1] >=2
                ? ( constructor =>  'basic', cache => 0 )
                : ( constructor => 'normal', cache => 0);
    $flags{cache} = 0 if not defined $flags{cache};
    $flags{constructor} = 'normal' if not defined $flags{constructor};

    Class::Std::Fast::_init_import(
        $caller_package, %flags
    );

    no strict qw(refs);
    for my $name ( @exported_subs ) {
        my ($sub_name) = $name =~ m{(\w+)\z}xms;
        *{ $caller_package . '::' . $sub_name } = \&{$name};
    }
}

sub MODIFY_HASH_ATTRIBUTES {
    my $caller_package = $_[0];
    my @unhandled      = Class::Std::Fast::MODIFY_HASH_ATTRIBUTES(@_);
    my $i              = 0;
    $attributes_of_ref->{$caller_package} = {
        map {
            $_->{name} eq '????' ? '????_' . $i++ : $_->{name}
                => $_->{ref};
        } @{Class::Std::Fast::_get_internal_attributes($caller_package) || []}
    };
    return @unhandled;
}

# It's a constant - so there's no use creating it in each freeze again
my $FROZEN_ANON_SCALAR = Storable::freeze(\(my $anon_scalar));

sub STORABLE_freeze {
    # TODO do we really need to unpack @_? We're getting called for
    # Zillions of objects...
    my($self, $cloning) = @_;
    Class::Std::Fast::real_can($self, 'STORABLE_freeze_pre')
        && $self->STORABLE_freeze_pre($cloning);

    my %frozen_attr; #to be constructed
    my $id           = ${$self};
    my @package_list = ref $self;
    my %package_seen = ( $package_list[0]  => 1 ); # ignore diamond/looped base classes :-)

    no strict qw(refs);

    PACKAGE:
    while( my $package = shift @package_list) {
        #make sure we add any base classes to the list of
        #packages to examine for attributes.

        # Original line:
        # push @package_list, grep { ! $package_seen{$_}++; } @{"${package}::ISA"};
        # This one's faster...
        push @package_list, grep { ! exists $package_seen{$_} && do { $package_seen{$_} = undef; 1; } } @{"${package}::ISA"};

        #look for any attributes of this object for this package
        my $attr_ref = $attributes_of_ref->{$package} or next PACKAGE;

        # TODO replace inner my variable by $_ - faster...
        ATTR:              # examine attributes from known packages only
        for ( keys %{$attr_ref} ) {
            #nothing to do if attr not set for this object
            exists $attr_ref->{$_}{$id}
                and $frozen_attr{$package}{ $_ } = $attr_ref->{$_}{$id}; # save the attr by name into the package hash
        }
    }
    Class::Std::Fast::real_can($self, 'STORABLE_freeze_post')
        && $self->STORABLE_freeze_post($cloning, \%frozen_attr);

    return ($FROZEN_ANON_SCALAR, \%frozen_attr);
}

sub STORABLE_thaw {
    # croak "must be called from Storable" unless caller eq 'Storable';
    # unfortunately, Storable never appears on the call stack.

    # TODO do we really need to unpack @_? We're getting called for
    # zillions of objects...
    my $self = shift;
    my $cloning = shift;
    my $frozen_attr_ref = $_[1]; # $_[0] is the frozen anon scalar.

    Class::Std::Fast::real_can($self, 'STORABLE_thaw_pre')
        && $self->STORABLE_thaw_pre($cloning, $frozen_attr_ref);

    my $id = ${$self} ||= Class::Std::Fast::ID();

    PACKAGE:
    while( my ($package, $pkg_attr_ref) = each %{$frozen_attr_ref} ) {
        # TODO This test is quite expensive. Is there a better one?
        $self->isa($package)
            or croak "unknown base class '$package' seen while thawing "
                   . ref $self;
        ATTR:
        for ( keys  %{$attributes_of_ref->{$package}} ) {
            # for known attrs...
            # nothing to do if frozen attr doesn't exist
            exists $pkg_attr_ref->{$_} or next ATTR;

            # block attempts to meddle with existing objects
            exists $attributes_of_ref->{$package}->{$_}->{$id}
                and croak "trying to modify existing attributes for $package";

            # ok, set the attribute
            $attributes_of_ref->{$package}->{$_}->{$id}
                = delete $pkg_attr_ref->{$_};
        }
        # this is probably serious enough to throw an exception.
        # however, TODO: it would be nice if the class could somehow
        # indicate to ignore this problem.
        %$pkg_attr_ref
        and croak "unknown attribute(s) seen while thawing class $package:"
                     . join q{, }, keys %$pkg_attr_ref;
    }

    Class::Std::Fast::real_can($self, 'STORABLE_thaw_post')
        && $self->STORABLE_thaw_post($cloning);
}

1;

__END__