File Coverage

blib/lib/Class/LazyObject.pm

Criterion	Covered	Total	%
statement	95	96	98.9
branch	18	22	81.8
condition	12	21	57.1
subroutine	19	19	100.0
pod			n/a
total	144	158	91.1

package Class::LazyObject;
use strict;
use warnings;

use Carp qw();

BEGIN {
	use vars '$VERSION';
	$VERSION     = '0.10_1';
}

use vars '$AUTOLOAD';

#We want to inflate calls to methods defined in UNIVERSAL, but we implicitly inherit from UNIVERSAL.
#As long as we predeclare the methods here, they will override those in UNIVERSAL, but since they are never defined, AUTOLOAD will be called:
use subs grep {defined UNIVERSAL::can(__PACKAGE__, $_)} keys %UNIVERSAL::;

sub AUTOLOAD
{
	my $self = $_[0]; #don't shift it, since we will need to access this directly later.

	$AUTOLOAD =~ /.*::(\w+)/;
	my $method = $1;

	my $class_method = (ref($self) || $self).'::Methods';#call all class methods on this.

	unless (UNIVERSAL::can($class_method, 'inherit')) {#If a class inherits from a class that inherits from Class::LazyObject, it may not have called inherit and therefore won't have ::Methods installed.
		#One approach might be to call inherit for it, but we're just going to search for an ancestor with a ::Methods that can inherit.
		my @parent_classes = (Class::ISA::super_path( ref($self)||$self ), 'UNIVERSAL');
		foreach my $parent_class (@parent_classes){ #We probably want the equivalent of first from Scalar::MoreUtil but this is good for now
			$class_method = $parent_class.'::Methods';
			last if UNIVERSAL::can($class_method, 'inherit');
		}
	}

	if (($method eq 'new') && !ref($self))
	{
		#new was called on a class, rather than an object, so we should actually construct ourselves, rather than passing this to whatever we're proxying.
		return $class_method->new(@_);
	}

	ref($self) or return $class_method->$method(@_[ 1 .. $#_ ]); #If this was called as a class method, pass it on to ::Methods but don't pass OUR package name.

	print "Lazy...\n" if $class_method->get_classdata('debug');

	my $object; #this is the object we will eventually replace ourselves with.

	if ( ref($$self) && UNIVERSAL::isa($$self, $class_method->get_classdata('class')) )
	{
		$object = $$self;
	}
	else
	{
		$object = $class_method->get_classdata('inflate')->($class_method->get_classdata('class'), $$self);
		$$self = $object; #don't create this again.
	}

	$_[0] = $object; #replace ourselves with the object.

	goto (
		 	UNIVERSAL::can($_[0], $method) ||
		 	$class_method->_prepareAUTOLOADRef($_[0], ref($_[0]).'::'.$method) || #UNIVERSAL::can can't detect if a method is AUTOLOADed, so we have to.
		 	Carp::croak(sprintf qq{Can\'t locate object method "%s" via package "%s" }, $method, ref $_[0] )#Error message stolen from Class::WhiteHole
		 );
}

sub DESTROY #You won't AUTOLOAD this! Muahahaha!
{
	undef; #This is here because certain perl versions can't handle completely emtpy subs.
}


#class method to see whether something is lazy?
#class methods for original isa and can

#---------
package Class::LazyObject::Methods;
#stick all of our class methods here so we don't pollute Class::LazyObject's namespace.
#everything in this class should be called as class methods, NOT object methods.

use Carp::Clan '^Class::LazyObject(::|$)';
use Class::Data::TIN  qw(get_classdata);
use Class::ISA;

sub _findAUTOLOADPackage
{
	#Takes 1 argument, either an object or the name of a package.
	#Returns the name of the package containing the sub AUTOLOAD that would be called when $first_arg->AUTOLOAD was called
	#In other words, it traverses the inheritance hierarchy the same way Perl does until it finds an AUTOLOAD, and returns the name of the package containing the AUTOLOAD.
	#Returns undef if AUTOLOAD is not in the inheritance hierarchy.

	shift;#Don't care about our package name.

	my $object_or_package = shift;
	my $orig_class = ref($object_or_package) || $object_or_package;

	return undef unless UNIVERSAL::can($orig_class, 'AUTOLOAD');

	my @classes = (Class::ISA::self_and_super_path($orig_class), 'UNIVERSAL');

	my $package;
	foreach my $class (@classes)
	{
		no strict 'refs';#Symbol table munging ahead
		$package = $class;
		last if defined(*{$package.'::AUTOLOAD';}{CODE});
	}

	return $package;
}

sub _prepareAUTOLOADRef
{
	#Takes 2 arguments:
	#	either an object or the name of a package
	#	the fully qualified method name to make AUTOLOAD think it was called as a result of
	#Sets the appropriate package's $AUTOLOAD so that when the AUTOLOAD method is called on the first argument, it will think it was called as a result of a call to the method specified by the second argument.
	#Returns the result of (UNIVERSAL::can($first_arg, 'AUTOLOAD'));

	my $class = shift;

	my ($object, $method) = @_;

	if (UNIVERSAL::can($object, 'AUTOLOAD'))#no point in doing any of this if it can't AUTOLOAD.
	{
		my $package = $class->_findAUTOLOADPackage($object);

		{
			no strict 'refs';
			*{$package.'::AUTOLOAD'} = \$method;
		}
	}

	return UNIVERSAL::can($object, 'AUTOLOAD');
}

#defaults, these are overridable when someone calls ->inherit
Class::Data::TIN->new(__PACKAGE__,
	inflate => sub {return $_[0]->new_inflate($_[1]);},
	debug   => 0,
	);

sub inherit
{
	#calls to Class::LazyObject->inherit are forwarded here.

	my $class = shift; #don't care about our own package name.
	my %params = @_;

	my @required_params = qw(inflated_class deflated_class);

	foreach my $param (@required_params)
	{
		croak "You did not pass '$param', which is a required parameter." unless exists $params{$param};
	}

	my %param_map = ( #keys are key names in the parameters passed to this function. Values are corrisponding class data names.
		inflated_class => 'class'
		);

	my %class_data = %params;
	delete @class_data{keys %param_map, 'deflated_class'};#we'll stick these in with their appropriate names:
	@class_data{values %param_map} = @params{keys %param_map};#pass the parameters whose names have changed


	my $method_package = $params{deflated_class}.'::Methods';

	{
		no strict 'refs'; #more symbol table munging
		push(@{$method_package.'::ISA'}, $class); #Create a package to hold all the methods, that inherits from THIS class, or add this class to its inheritance if it does exist.  #Should this be $class instead of __PACKAGE__
		#^Push is used instead of unshift so that someone can override their ::Methods package with its own inheritence hierarchy, and methods will be called here only AFTER Perl finds they don't exist in the overridden ISA.
	}

	Class::Data::TIN->new($method_package, %class_data);
}

sub new
{
	my ($own_package, $class, $id) = @_;#first argument is this method's, class, not the lazy object's

	if (ref($id) && UNIVERSAL::isa($id, $own_package->get_classdata('class')))
	{
		croak "A Lazy Object's ID cannot be a an object of same class (or of a class inherited from the one) it is proxying!";
	}

	return bless \$id, $class;
}

1;

#LAUNDRY LIST:
 #LAZYNESS, impatience, hubris
 #should we document the $AUTOLOAD persistence thingy as a caveat?
 #CALLING AUTOLOAD on inflate
 #CAVEAT: can't distinguish between no id and an id of undef.
 #  -solve by storing a Class::LazyObject::NoID object instead of undef?
 #Does goto propogate scalar/list context?
 #Lvalue subs?
 #PROBLEM: Can't inherit from a lazy object (that has already called inherit) it right now without calling inherit because the corrisponding ::Methods class hasn't been created yet. Instead of being completely nonpolluting, can we create a method with a long convoluted name like __________Class_____LazyObject______Find____Methods and use the NEXT module to make redispatch any calls of it that are object method calls instead of static class calls?
 #Does ORL's can work correctly for classes that inherit from an unrealized class?


__END__