File Coverage

blib/lib/Class/InsideOut.pm

Criterion	Covered	Total	%
statement	286	302	94.7
branch	96	110	87.2
condition	27	31	87.1
subroutine	48	49	97.9
pod	7	7	100.0
total	464	499	92.9

package Class::InsideOut;
use strict;
# ABSTRACT: a safe, simple inside-out object construction kit
our $VERSION = '1.13'; # VERSION

use vars qw/@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS/;

@ISA         = qw ( Exporter );
@EXPORT      = qw ( ); # nothing by default
@EXPORT_OK   = qw ( new id options private property public readonly register );
%EXPORT_TAGS = (
    "std"       => [ qw( id private public readonly register ) ],
    "new"       => [ qw( new ) ],
    "all"       => [ @EXPORT_OK ],
    "singleton" => [], # just a flag for import()
);

use Carp;
use Exporter;
use Class::ISA;
use Scalar::Util 1.09 qw( refaddr reftype blessed );

# Check for XS Scalar::Util with weaken() or warn and fallback
# syntax of error changed in Scalar::Util so we check both versions
BEGIN {
    eval { Scalar::Util->import( "weaken" ) };
    if ( $@ =~ /\AWeak references|weaken is only available/ ) {
        warn "Scalar::Util::weaken unavailable: "
           . "Class::InsideOut will not be thread-safe and will leak memory\n";
        *weaken = sub { return @_ };
    }
}

#--------------------------------------------------------------------------#
# Class data
#--------------------------------------------------------------------------#

my %PROP_DATA_FOR;      # class => { prop_name => property hashrefs }
my %PUBLIC_PROPS_FOR;   # class => { prop_name => 1 }
my %CLASS_ISA;          # class => [ list of self and @ISA tree ]
my %OPTIONS;            # class => { default accessor options  }
my %OBJECT_REGISTRY;    # refaddr => weak object reference

#--------------------------------------------------------------------------#
# option validation parameters
#--------------------------------------------------------------------------#

# Private but global so related classes can define their own valid options
# if they need them.  Modify at your own risk.  Done this way so as to
# avoid creating class functions to do the same basic thing

use vars qw( %_OPTION_VALIDATION );

sub __coderef {
    return 1 if reftype($_[0])||"" eq 'CODE';

    # Avoid loading overload.pm unless we'd have to die otherwise
    require overload;
    return 1 if overload::Overloaded($_[0]) && overload::Method($_[0], q[&{}]);

    die "must be a code reference";
}

%_OPTION_VALIDATION = (
    privacy => sub {
        my $v = shift;
        $v =~ /public|private/ or die "'$v' is not a valid privacy setting"
    },
    set_hook =>  \&__coderef,
    get_hook =>  \&__coderef,
);

#--------------------------------------------------------------------------#
# public functions
#--------------------------------------------------------------------------#

sub import {
    no strict 'refs';
    my $caller = caller;
    *{ "$caller\::DESTROY" } = _gen_DESTROY( $caller );
    # check for ":singleton" and do export attach instead of thaw
    if ( grep { $_ eq ":singleton" } @_ ) {
        *{ "$caller\::STORABLE_freeze" } = _gen_STORABLE_freeze( $caller, 1 );
        *{ "$caller\::STORABLE_attach" } = _gen_STORABLE_attach( $caller );
        @_ = grep { $_ ne ':singleton' } @_; # strip it back out
    }
    else {
        *{ "$caller\::STORABLE_freeze" } = _gen_STORABLE_freeze( $caller, 0 );
        *{ "$caller\::STORABLE_thaw" } = _gen_STORABLE_thaw( $caller );
    }
    local $Exporter::ExportLevel = $Exporter::ExportLevel + 1;
    &Exporter::import;
}

BEGIN { *id = \&Scalar::Util::refaddr; }

sub options {
    my $opt = shift;
    my $caller = caller;
    _check_options( $opt ) if defined $opt;
    return %{ $OPTIONS{ $caller } = _merge_options( $caller, $opt ) };
}

sub new {
    my $class = shift;
    croak "new() must be called as a class method"
        if ref $class;
    my $self = register( $class );
    return $self unless @_;

    # initialization
    croak "Arguments to new must be a hash or hash reference"
        if ( @_ == 1 && ! ( ref $_[0] && reftype($_[0]) eq 'HASH' ) )
        || ( @_ > 1 && @_ % 2 );

    my %args = (@_ == 1) ? %{$_[0]} : @_;

    for my $prop ( keys %args ) {
        for my $c ( _class_tree( $class ) ) {
            my $properties = $PROP_DATA_FOR{ $c };
            next unless $properties;
            if ( exists $properties->{$prop} ) {
                $properties->{$prop}{ refaddr $self } = $args{$prop};
            }
        }
    }

    return $self;
}

sub private($\%;$) { ## no critic -- prototype
    &_check_property;
    $_[2] ||= {};
    $_[2] = { %{$_[2]}, privacy => 'private' };
    goto &_install_property;
}

sub property($\%;$) { ## no critic -- prototype
    &_check_property;
    goto &_install_property;
}

sub public($\%;$) { ## no critic -- prototype
    &_check_property;
    $_[2] ||= {};
    $_[2] = { %{$_[2]}, privacy => 'public' };
    goto &_install_property;
}

sub readonly($\%;$) { ## no critic -- prototype
    &_check_property;
    $_[2] ||= {};
    $_[2] = {
        %{$_[2]},
        privacy => 'public',
        set_hook => sub { die "is read-only\n" }
    };
    goto &_install_property;
}

sub register {
    my ($obj);
    if    ( @_ == 0 ) {
        # register()
        croak "Invalid call to register(): empty argument list"
    }
    elsif ( @_ == 1 ) {
        # register( OBJECT | CLASSNAME )
        if    ( blessed $_[0] ) {
            $obj = shift;
        }
        elsif ( ref \$_[0] eq 'SCALAR' ) {
            $obj = \(my $scalar);
            bless $obj, shift;
        }
        else {
            croak "Invalid argument '$_[0]' to register(): " .
                  "must be an object or class name"
        }
    }
    else {
        # register( REFERENCE/OBJECT, CLASSNAME )
        $obj = shift;
        bless $obj, shift; # ok to rebless
    }

    weaken( $OBJECT_REGISTRY{ refaddr $obj } = $obj );
    return $obj;
}

#--------------------------------------------------------------------------#
# private functions for implementation
#--------------------------------------------------------------------------#

# Registering is global to avoid having to register objects for each class.
# CLONE is not exported but CLONE in Class::InsideOut updates all registered
# objects for all properties across all classes

sub CLONE {
    my $class = shift;

    # assemble references to all properties for all classes
    my @properties = map { values %$_ } values %PROP_DATA_FOR;

    for my $old_id ( keys %OBJECT_REGISTRY ) {

        # retrieve the new object and id
        my $object = $OBJECT_REGISTRY{ $old_id };
        my $new_id = refaddr $object;

        # for all properties, relocate data to the new id if
        # the property has data under the old id
        for my $prop ( @properties ) {
            next unless exists $prop->{ $old_id };
            $prop->{ $new_id } = $prop->{ $old_id };
            delete $prop->{ $old_id };
        }

        # update the registry to the new, cloned object
        weaken ( $OBJECT_REGISTRY{ $new_id } = $object );
        _deregister( $old_id );
    }
}

sub _check_options{
    my ($opt) = @_;
    local $Carp::CarpLevel = $Carp::CarpLevel + 1;

    croak "Invalid options argument '$opt': must be a hash reference"
        if ref $opt ne 'HASH';

    my @valid_keys = keys %_OPTION_VALIDATION;
    for my $key ( keys %$opt ) {
        croak "Invalid option '$key': unknown option"
            if ! grep { $_ eq $key } @valid_keys;
        eval { $_OPTION_VALIDATION{$key}->( $opt->{$key} ) };
        croak "Invalid option '$key': $@" if $@;
    }

    return;
}

sub _check_property {
    my ($label, $hash, $opt) = @_;
    local $Carp::CarpLevel = $Carp::CarpLevel + 1;
    croak "Invalid property name '$label': must be a perl identifier"
        if $label !~ /\A[a-z_]\w*\z/i;
    croak "Duplicate property name '$label'"
        if grep { $_ eq $label } keys %{ $PROP_DATA_FOR{ caller(1) } };
    _check_options( $opt ) if defined $opt;
    return;
}

sub _class_tree {
    my $class = shift;
    $CLASS_ISA{ $class } ||= [ Class::ISA::self_and_super_path( $class ) ];
    return @{ $CLASS_ISA{ $class } };
}

# take either object or object id
sub _deregister {
    my ($arg) = @_;
    my $obj_id = ref $arg ? refaddr $arg : $arg;
    delete $OBJECT_REGISTRY{ $obj_id };
    return;
}

# turn object into hash -- see _revert()
sub _evert {
    my ( $obj ) = @_;

    # Extract properties to save
    my %property_vals;
    for my $c ( _class_tree( ref $obj) ) {
        next unless exists $PROP_DATA_FOR{ $c };
        my $properties = $PROP_DATA_FOR{ $c };
        for my $prop ( keys %$properties ) {
            my $value = exists $properties->{$prop}{ refaddr $obj }
                      ? $properties->{$prop}{ refaddr $obj }
                      : undef ;
            $property_vals{$c}{$prop} = $value;
        }
    }

    # extract object reference contents (by type)
    my $type = reftype $obj;
    my $contents = $type eq 'SCALAR' ? \do{ my $s = $$obj }
                 : $type eq 'ARRAY'  ? [ @$obj ]
                 : $type eq 'HASH'   ? { %$obj }
                 : undef    # other types not supported
                 ;

    # assemble reference to hand back
    return {
        class => ref $obj,
        type => $type,
        contents => $contents,
        properties => \%property_vals
    };
}

sub _gen_accessor {
    my ($ref) = @_;
    return sub {
        my $obj = shift;
        my $obj_id = refaddr $obj;
        $ref->{ $obj_id } = shift if (@_);
        return $ref->{ $obj_id };
    };
}

sub _gen_hook_accessor {
    my ($ref, $name, $get_hook, $set_hook) = @_;
    return sub {
        my ($obj,@args) = @_;
        my $obj_id = refaddr $obj;
        if (@args) {
            local *_ = \($args[0]);
            if ($set_hook) {
                eval { $set_hook->(@args) };
                if ( $@ ) { chomp $@; croak "$name() $@" }
                $ref->{ $obj_id } = shift @args;
            }
            else {
                $ref->{ $obj_id } = shift @args;
            }
        }
        elsif ($get_hook) {
            local $_ = $ref->{ $obj_id };
            my ( $value, @value );
            if ( wantarray ) {
                @value = eval { $get_hook->() };
            }
            else {
                $value = eval { $get_hook->() };
            }
            if ( $@ ) { chomp $@; croak "$name() $@" }
            return wantarray ? @value : $value;
        }
        else {
            return $ref->{ $obj_id };
        }
    };
}

sub _gen_DESTROY {
    my $class = shift;
    return sub {
        my $obj = shift;
        my $obj_id = refaddr $obj; # cache for later property deletes

        # Call a custom DEMOLISH hook if one exists.
        my $demolish;
        {
            no strict 'refs';
            $demolish = *{ "$class\::DEMOLISH" }{CODE};
        }
        $demolish->($obj) if defined $demolish;

        # Clean up properties in all Class::InsideOut parents
        for my $c ( _class_tree( $class ) ) {
            next unless exists $PROP_DATA_FOR{ $c };
            delete $_->{ $obj_id } for values %{ $PROP_DATA_FOR{ $c } };
        }

        # XXX this global registry could be deleted repeatedly
        # in superclasses -- SUPER::DESTROY shouldn't be called by DEMOLISH
        # it should only call SUPER::DEMOLISH if need be; still,
        # rest of the destructor doesn't need the registry, so early deletion
        # by a subclass should be safe
        _deregister( $obj );

        return;
    };
}

sub _gen_STORABLE_attach {
    my $class = shift;
    return sub {
        my ( $class, $cloning, $serialized ) = @_;
        require Storable;
        my $data = Storable::thaw( $serialized );

        # find a user attach hook
        my $hook;
        {
            no strict 'refs';
            $hook = *{ "$class\::ATTACH" }{CODE};
        }

        # try user hook to recreate, otherwise new(), otherwise give up
        if ( defined $hook ) {
            return $hook->($class, $cloning, $data);
        }
        elsif ( $class->can( "new" ) ) {
            return $class->new();
        }
        else {
            warn "Error attaching to $class:\n" .
                  "Couldn't find STORABLE_attach_hook() or new() in $class\n";
            return;
        }
    };
}

sub _gen_STORABLE_freeze {
    my ($class, $singleton) = @_;
    return sub {
        my ( $obj, $cloning ) = @_;

        # Call STORABLE_freeze_hooks in each class if they exists
        for my $c ( _class_tree( ref $obj ) ) {
            my $hook;
            {
                no strict 'refs';
                $hook = *{ "$c\::FREEZE" }{CODE};
            }
            $hook->($obj) if defined $hook;
        }

        # Extract properties to save
        my $data = _evert( $obj );

        if ( $singleton ) {
            # can't return refs, so freeze data as string and return
            require Storable;
            return Storable::freeze( $data );
        }
        else {
            # return $serialized, @refs
            # serialized string doesn't matter -- all data has been moved into
            # the additional ref
            return 'BOGUS', $data;
        }
    };
}

sub _gen_STORABLE_thaw {
    my $class = shift;
    return sub {
        my ( $obj, $cloning, $serialized, $data ) = @_;

        _revert( $data, $obj );

        # Call STORABLE_thaw_hooks in each class if they exists
        for my $c ( _class_tree( ref $obj ) ) {
            my $hook;
            {
                no strict 'refs';
                $hook = *{ "$c\::THAW" }{CODE};
            }
            $hook->($obj) if defined $hook;
        }

        return;
    };
}

sub _install_property{
    my ($label, $hash, $opt) = @_;

    my $caller = caller(0); # we get here via "goto", so caller(0) is right
    $PROP_DATA_FOR{ $caller }{$label} = $hash;
    my $options = _merge_options( $caller, $opt );
    if ( exists $options->{privacy} && $options->{privacy} eq 'public' ) {
        no strict 'refs';
        *{ "$caller\::$label" } =
            ($options->{set_hook} || $options->{get_hook})
                ? _gen_hook_accessor( $hash, $label, $options->{get_hook},
                                                 $options->{set_hook} )
                : _gen_accessor( $hash ) ;
        $PUBLIC_PROPS_FOR{ $caller }{ $label } = 1;
    }
    return;
}

sub _merge_options {
    my ($class, $new_options) = @_;
    my @merged;
    push @merged, %{ $OPTIONS{ $class } } if defined $OPTIONS{ $class };
    push @merged, %$new_options if defined $new_options;
    return { @merged };
}

sub _revert {
    my ( $data, $obj ) = @_;

    my $contents = $data->{contents};
    if ( defined $obj ) {
        # restore contents to the pregenerated object
        for ( reftype $obj ) {
            /SCALAR/    ? do { $$obj = $$contents } :
            /ARRAY/     ? do { @$obj = @$contents } :
            /HASH/      ? do { %$obj = %$contents } :
                          do {} ;
        }
    }
    else {
        # just use the contents as the reference
        # and bless it back into an object
        $obj = $contents;
    }

    bless $obj, $data->{class};

    # restore properties
    for my $c ( _class_tree( ref $obj ) ) {
        my $properties = $PROP_DATA_FOR{ $c };
        next unless $properties;
        for my $prop ( keys %$properties ) {
            my $value = $data->{properties}{ $c }{ $prop };
            $properties->{$prop}{ refaddr $obj } = $value;
        }
    }

    # register object
    register( $obj );
    return $obj;
}

#--------------------------------------------------------------------------#
# private functions for use in testing
#--------------------------------------------------------------------------#

sub _object_count {
    return scalar( keys %OBJECT_REGISTRY );
}

sub _properties {
    my $class = shift;
    my %properties;
    for my $c ( _class_tree( $class ) ) {
        next if not exists $PROP_DATA_FOR{ $c };
        for my $p ( keys %{ $PROP_DATA_FOR{ $c } } ) {
            $properties{$c}{$p} = exists $PUBLIC_PROPS_FOR{$c}{$p}
                                ? "public" : "private";
        }
    }
    return \%properties;
}

sub _leaking_memory {
    my %leaks;

    for my $class ( keys %PROP_DATA_FOR ) {
        for my $prop ( values %{ $PROP_DATA_FOR{ $class } } ) {
            for my $obj_id ( keys %$prop ) {
                $leaks{ $class }++
                    if not exists $OBJECT_REGISTRY{ $obj_id };
            }
        }
    }

    return keys %leaks;
}

1; # modules must return true

__END__