Class::InsideOut
package Class::InsideOut;
use strict;
use vars qw/$VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS/;
$VERSION = '1.10';
@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 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 { ref shift eq 'CODE' or 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__