File Coverage

blib/lib/Class/Simple.pm

Criterion	Covered	Total	%
statement	189	195	96.9
branch	61	74	82.4
condition	8	11	72.7
subroutine	34	35	97.1
pod	5	5	100.0
total	297	320	92.8

#$Id: Simple.pm,v 1.31 2008/02/01 00:38:06 sullivan Exp $
#
#	See the POD documentation starting towards the __END__ of this file.

package Class::Simple;

use 5.008;
use strict;
use warnings;

our $VERSION = '0.19';

use Scalar::Util qw(refaddr);
use Carp;
use Class::ISA;
use List::Util qw( first );

my %STORAGE;
my %PRIVATE;
my %READONLY;
my @internal_attributes = qw(CLASS);

our $AUTOLOAD;
our $No_serialized_code;

sub AUTOLOAD
{
my $self = $_[0]; # DO NOT use shift().  It causes problems with goto.

	no strict 'refs';

	$AUTOLOAD =~ /(.*)::((get|set|clear|raise|readonly|_)_)?(\w+)/;
	my $pkg = $1;
	my $prefix = $3 || '';
	my $attrib = $4;

	#
	#	$obj->set__foo and $obj->get__foo
	#
	my $store_as;
	if ($prefix eq '_')
	{
		$attrib = "_$attrib";
		$store_as = $attrib;
	}
	#
	#	$obj->_foo
	#
	elsif (($attrib =~ /^_/) && !$prefix)
	{
		$store_as = $attrib;
		$store_as =~ s/^_//;
	}
	else
	{
		$store_as = $attrib;
	}

	my $setter = "set_$attrib";
	my $getter = "get_$attrib";

	if (my $get_attributes = $self->can('ATTRIBUTES'))
	{
		my @attributes = &$get_attributes();
		push(@attributes, @internal_attributes);
		croak("$attrib is not a defined attribute in $pkg")
		  unless first(sub {$_ eq $attrib}, @attributes);
	}

	if (my $get_private = $pkg->can('PRIVATIZE'))
	{
		my @privates = &$get_private();
		if ( first(sub {$_ eq $attrib}, @privates)
		  && (_my_caller() ne $pkg) )
		{
			croak("$attrib is private to $pkg.");
		}
	}

	#
	#	Make sure that if you add more special prefixes here,
	#	you add them to the $AUTOLOAD regex above, too.
	#
	if ($prefix eq 'set')
	{
		*{$AUTOLOAD} = sub
		{
		my $self = shift;

			my $ref = refaddr($self);
			my $store_as = $self->_caller_class($store_as);
			croak("$attrib is readonly:  cannot set.")
			  if ($READONLY{$ref}->{$store_as});
			return ($STORAGE{$ref}->{$store_as} = shift(@_));
		};
	}
	elsif ($prefix eq 'get')
	{
		*{$AUTOLOAD} = sub
		{
		my $self = shift;

			my $ref = refaddr($self);
			my $store_as = $self->_caller_class($store_as,
			  $STORAGE{$ref});
			return ($STORAGE{$ref}->{$store_as});
		};
	}
#
#	Bug #7528 in Perl keeps this from working.
#	http://rt.perl.org/rt3/Public/Bug/Display.html?id=7528
#	I could make people declare methods they want to use lv_ with
#	but that goes against the philosophy of being ::Simple.
#
#	elsif ($prefix eq 'lv')
#	{
#		*{$AUTOLOAD} = sub : lvalue
#		{
#		my $self = shift;
#
#			my $ref = refaddr($self);
#			my $store_as = $self->_caller_class($store_as);
#			croak("$attrib is readonly:  cannot set.")
#			  if ($READONLY{$ref}->{$store_as});
#			return ($STORAGE{$ref}->{$store_as});
#		};
#	}
	elsif ($prefix eq 'clear')
	{
		*{$AUTOLOAD} = sub
		{
		my $self = shift;

			return ($self->$setter(undef));
		};
	}
	elsif ($prefix eq 'raise')
	{
		*{$AUTOLOAD} = sub
		{
		my $self = shift;

			return ($self->$setter(1));
		};
	}
	elsif ($prefix eq 'readonly')
	{
		*{$AUTOLOAD} = sub
		{
		my $self = shift;

			my $ret = $self->$setter(@_);
			my $ref = refaddr($self);
			my $store_as = $self->_caller_class($store_as);
			$READONLY{$ref}->{$store_as} = 1;
			return ($ret);
		};
	}
	#
	#	All methods starting with '_' can only be called from
	#	within their package.  Not inheritable, which makes
	#	the test easier than something privatized..
	#
	#	Note that we cannot just call get_ and set_ here
	#	because if someone writes their own get_foo and then
	#	_foo is called, _foo will call set_foo, which will
	#	probably store something with _foo, which will call
	#	set_foo, etc.  Sure wish we could somehow share
	#	code with get_ and set_, though.
	#
	elsif (!$prefix && ($attrib =~ /^_/))
	{
		if (my $method = $pkg->can($attrib))
		{
			goto &$method;
		}

		*{$AUTOLOAD} = sub
		{
		my $self = shift;

			croak("Cannot call $attrib:  Private method to $pkg.")
			  unless ($pkg->isa(Class::Simple::_my_caller()));
			my $ref = refaddr($self);
			if (scalar(@_))
			{
				my $store_as = $self->_caller_class($store_as);
				croak("$attrib is readonly:  cannot set.")
				  if ($READONLY{$ref}->{$store_as});
				return ($STORAGE{$ref}->{$store_as} =shift(@_));
			}
			else
			{
				my $store_as = $self->_caller_class($store_as,
				  $STORAGE{$ref});
				return ($STORAGE{$ref}->{$store_as});
			}
		};
	}
	else
	{
		*{$AUTOLOAD} = sub
		{
		my $self = shift;

			return (scalar(@_)
			  ? $self->$setter(@_)
			  : $self->$getter());
		};
	}
	goto &$AUTOLOAD;
}



#
#	Call all the DEMOLISH()es and then delete from %STORAGE.
#
sub DESTROY
{
my $self = shift;

	$self->_travel_isa('DESTROY', 'DEMOLISH');
	my $ref = refaddr($self);
	delete($STORAGE{$ref}) if exists($STORAGE{$ref});
	delete($READONLY{$ref}) if exists($READONLY{$ref});
}



#
#	Travel up the class's @ISA and run $func, if we can.
#	To keep from running a sub more than once we flag
#	$storage in %STORAGE.
#
sub _travel_isa
{
my $self = shift;
my $storage = shift;
my $func = shift;

	my $ref = refaddr($self);
	$STORAGE{$ref}->{$storage}= {} unless exists($STORAGE{$ref}->{$storage});
	my @path = reverse(Class::ISA::super_path($self->CLASS));
	foreach my $c (@path)
	{
		next if ($c eq __PACKAGE__);
		next if $STORAGE{$ref}->{$storage}->{$c}++;

		my $cn = "${c}::can";
		if (my $in = $c->can($func))
		{
			$self->$in(@_);
		}
	}
	$self->$func(@_) if $self->can($func);
}



#
#	Figures out the class of the caller, going up the class hierarchy
#	starting at the current class and going up until we find something
#	stored.  Confusing, eh?  We're trying to properly handle the following:
#
#	package Foo;
#	use base qw(Bar);
#	...
#	$self->set_a(1);
#	...
#	package Bar;
#	use base qw(Class::Simple);
#	...
#	$self->set_a(2);
#
#	The set_a in Bar should not affect the set_a in Foo and neither should
#	affect an Foo object that has done its own set_a.
#
sub _caller_class
{
my $self = shift;
my $store_as = shift;
my $storage = shift;

	#
	#	There is a problem with multiple-inheritance.  Until I
	#	can figure out a solution, just return $store_as to
	#	disable this feature.
	#
	return $store_as;
#	for (my $i = 0; my $c = scalar(caller($i)); ++$i)
#	{
#		next if ($c eq __PACKAGE__);
#		my $sa = "${c}::${store_as}";
#		if ($storage)
#		{
#			next unless $self->isa($c);
#			my @path = reverse(Class::ISA::super_path($c));
#			foreach my $p ($c, @path)
#			{
#				my $sa = "${p}::${store_as}";
#				return ($sa) if exists($storage->{$sa});
#			}
#		}
#		else
#		{
#			return ($sa) if $self->isa($c);
#		}
#	}
#	my $sa = ref($self) . "::${store_as}";
#	return ($sa); # Shouldn't get here but just in case
}



#
#	Make a scalar.  Bless it.  Call init.
#
sub new
{
my $class = shift;

	#
	#	Support for NONEW.
	#
	{
		no strict 'refs';
		my $classy = "${class}::";
		croak("Cannot call new() in $class.")
		  if exists(${$classy}{'NONEW'});
	}

	#
	#	This is how you get an anonymous scalar.
	#
	my $self = \do{my $anon_scalar};
	bless($self, $class);
	$self->readonly_CLASS($class);

	$self->init(@_);
	return ($self);
}



#
#	Flag the given method(s) as being private to the class
#	(and its children unless overridden).
#
sub privatize
{
my $class = shift;

	foreach my $method (@_)
	{
		no strict 'refs';

		#
		#	Can't privatize something that is already private
		#	from an ancestor.
		#
		foreach my $private_class (keys(%PRIVATE))
		{
			next unless $PRIVATE{$private_class}->{$method};
			croak("Cannot privatize ${class}::$method:  already private in $private_class.")
			  unless $private_class->isa($class);
		}

		#
		#	Can't retroactively make privatize something.
		#
		my $called_by = _my_caller();
		croak("Attempt to privatize ${class}::$method from $called_by.  Can only privatize in your own class.")
		  if ($class ne $called_by);
		$PRIVATE{$class}->{$method} = 1;

		#
		#	Although it is duplication of code (which I hope
		#	to come up with a clever way to avoid at some point),
		#	it is a better solution to have privatize() create
		#	these subs now.  Otherwise, having the private test
		#	done in AUTOLOAD gets to be fairly convoluted.
		#	Defining them here makes the tests a lot simpler.
		#
		my $getter = "${class}::get_$method";
		my $setter = "${class}::set_$method";
		my $generic = "${class}::$method";

		*{$getter} = sub
		{
		my $self = shift;

			no strict 'refs';
			croak("Cannot call $getter:  Private method to $class.")
			  unless $class->isa(Class::Simple::_my_caller());
			my $ref = refaddr($self);
			my $store_as = $self->_caller_class($method);
			return ($STORAGE{$ref}->{$store_as});
		};
		*$setter = sub
		{
		my $self = shift;

			no strict 'refs';
			croak("Cannot call $setter:  Private method to $class.")
			  unless $class->isa(Class::Simple::_my_caller());
			my $ref = refaddr($self);
			my $store_as = $self->_caller_class($method);
			croak("$method is readonly:  cannot set.")
			  if ($READONLY{$ref}->{$store_as});
			return ($STORAGE{$ref}->{$store_as} = shift(@_));
		};
		*$generic = sub
		{
		my $self = shift;

			no strict 'refs';
			croak("Cannot call $generic:  Private method to $class.")
			  unless $class->isa(Class::Simple::_my_caller());
			my $ref = refaddr($self);
			return (scalar(@_)
			  ? $self->$setter(@_)
			  : $self->$getter());
		};
		my $ugen = "_${generic}";
		*$ugen = *$generic;
	}
}



#
#	Bubble up the caller() stack until we leave this package.
#
sub _my_caller
{
	for (my $i = 0; my $c = caller($i); ++$i)
	{
		return ($c) unless $c eq __PACKAGE__;
	}
	return (__PACKAGE__); # Shouldn't get here but just in case
}



#
#	This will not be called if the child classes have
#	their own.  In case they don't (and they really shouldn't
#	because they should be using BUILD() instead), this is the default.
#
sub init
{
my $self = shift;

	$self->_travel_isa('init', 'BUILD', @_);
	return ($self);
}



##
##	toJson() and fromJson() are DUMP and SLURP equivalents for JSON.
##	I'm not sure if they're all that useful yet so they're silently
##	lurking here for now.
##
#sub toJson
#{
#my $self = shift;
#
#	croak("Cannot use toJson(): module JSON::XS not found.\n")
#	  unless (eval 'require JSON::XS; 1');
#
#	my $ref = refaddr($self);
#	my $json = JSON::XS->new();
#	return $json->encode($STORAGE{$ref});
#}
#
#
#
#sub fromJson
#{
#my $self = shift;
#my $str = shift;
#
#	return $self unless $str;
#
#	croak("Cannot use fromJson(): module JSON::XS not found.\n")
#	  unless (eval 'require JSON::XS; 1');
#
#	my $json = JSON::XS->new();
#	my $obj = $json->decode($str);
#	my $ref = refaddr($self);
#	$STORAGE{$ref} = $obj;
#
#	return ($self);
#}



#
#	Callback for Storable to serialize objects.
#
sub STORABLE_freeze
{
my $self = shift;
my $cloning = shift;

	croak("Cannot use STORABLE_freeze(): module Storable not found.\n")
	  unless (eval 'require Storable; 1');

	$Storable::Deparse = !$No_serialized_code;
	my $ref = refaddr($self);
	return Storable::freeze($STORAGE{$ref});
}



#
#	Callback for Storable to reconstitute serialized objects.
#
sub STORABLE_thaw
{
my $self = shift;
my $cloning = shift;
my $serialized = shift;

	croak("Cannot use STORABLE_thaw(): module Storable not found.\n")
	  unless (eval 'require Storable; 1');

	$Storable::Eval = !$No_serialized_code;
	my $ref = refaddr($self);
	$STORAGE{$ref} = Storable::thaw($serialized);
}

1;
__END__