File Coverage

blib/lib/Class/Adapter/Builder.pm

Criterion	Covered	Total	%
statement	112	129	86.8
branch	39	52	75.0
condition	4	9	44.4
subroutine	25	26	96.1
pod	1	9	11.1
total	181	225	80.4

package Class::Adapter::Builder;
# ABSTRACT: Generate Class::Adapter classes

#pod =pod
#pod
#pod =head1 SYNOPSIS
#pod
#pod   package My::Adapter;
#pod
#pod   use strict;
#pod   use Class::Adapter::Builder
#pod       ISA     => 'Specific::API',
#pod       METHODS => [ qw{foo bar baz} ],
#pod       method  => 'different_method';
#pod
#pod   1;
#pod
#pod =head1 DESCRIPTION
#pod
#pod C is another mechanism for letting you create
#pod I classes of your own.
#pod
#pod It is intended to act as a toolkit for generating the guts of many varied
#pod and different types of I classes.
#pod
#pod For a simple base class you can inherit from and change a specific method,
#pod see L.
#pod
#pod =head2 The Pragma Interface
#pod
#pod The most common method for defining I classes, as shown in the
#pod synopsis, is the pragma interface.
#pod
#pod This consists of a set of key/value pairs provided when you load the module.
#pod
#pod   # The format for building Adapter classes
#pod   use Class::Adapter::Builder PARAM => VALUE, ...
#pod
#pod =over 4
#pod
#pod =item ISA
#pod
#pod The C param is provided as either a single value, or a reference
#pod to an C containing is list of classes.
#pod
#pod Normally this is just a straight list of classes. However, if the value
#pod for C is set to C<'_OBJECT_'> the object will identify itself as
#pod whatever is contained in it when the C<-Eisa> and C<-Ecan> method
#pod are called on it.
#pod
#pod =item NEW
#pod
#pod Normally, you need to create your C objects separately:
#pod
#pod   # Create the object
#pod   my $query = CGI->new( 'param1', 'param2' );
#pod
#pod   # Create the Decorator
#pod   my $object = My::Adapter->new( $query );
#pod
#pod If you provide a class name as the C param, the Decorator will
#pod do this for you, passing on any constructor arguments.
#pod
#pod   # Assume we provided the following
#pod   # NEW => 'CGI',
#pod
#pod   # We can now do the above in one step
#pod   my $object = My::Adapter->new( 'param1', 'param2' );
#pod
#pod =item AUTOLOAD
#pod
#pod By default, a C does not pass on any methods, with the
#pod methods to be passed on specified explicitly with the C<'METHODS'>
#pod param.
#pod
#pod By setting C to true, the C will be given the
#pod standard C function to to pass through all unspecified
#pod methods to the parent object.
#pod
#pod By default the AUTOLOAD will pass through any and all calls, including
#pod calls to private methods.
#pod
#pod If the AUTOLOAD is specifically set to 'PUBLIC', the AUTOLOAD setting
#pod will ONLY apply to public methods, and any private methods will not
#pod be passed through.
#pod
#pod =item METHODS
#pod
#pod The C param is provided as a reference to an array of all
#pod the methods that are to be passed through to the parent object as is.
#pod
#pod =back
#pod
#pod Any params other than the ones specified above are taken as translated
#pod methods.
#pod
#pod   # If you provide the following
#pod   # foo => bar
#pod
#pod   # It the following are equivalent
#pod   $decorator->foo;
#pod   $decorator->_OBJECT_->bar;
#pod
#pod This capability is provided primarily because in Perl one of the main
#pod situations in which you hit the limits of Perl's inheritance model is
#pod when your class needs to inherit from multiple different classes that
#pod containing clashing methods.
#pod
#pod For example:
#pod
#pod   # If your class is like this
#pod   package Foo;
#pod
#pod   use base 'This', 'That';
#pod
#pod   1;
#pod
#pod If both Cmethod> exists and Cmethod> exists,
#pod and both mean different things, then Cmethod> becomes
#pod ambiguous.
#pod
#pod A C could be used to wrap your C object, with
#pod the C becoming the C sub-class, and passing
#pod C<$decorator-Emethod> through to C<$object-Ethat_method>.
#pod
#pod =head1 METHODS
#pod
#pod Yes, C has public methods and later on you will
#pod be able to access them directly, but for now they are remaining
#pod undocumented, so that I can shuffle things around for another few
#pod versions.
#pod
#pod Just stick to the pragma interface for now.
#pod
#pod =cut

use 5.005;
use strict;
use Carp           ();
use Class::Adapter ();

our $VERSION = '1.09';





#####################################################################
# Constructor

sub new {
	my $class = ref $_[0] || $_[0];
	return bless {
		target  => $_[1],
		isa     => [ 'Class::Adapter' ],
		modules => {},
		methods => {},
	}, $class;
}

sub import {
	my $class = shift;

	# Must have at least one param
	return 1 unless @_;

	# Create the Builder object
	my $target = caller;
	my $self   = $class->new( $target );
	unless ( $self ) {
		Carp::croak("Failed to create Class::Adapter::Builder object");
	}

	# Process the option pairs
	while ( @_ ) {
		my $key   = shift;
		my $value = shift;
		if ( $key eq 'NEW' ) {
			$self->set_NEW( $value );
		} elsif ( $key eq 'ISA' ) {
			$self->set_ISA( $value );
		} elsif ( $key eq 'AUTOLOAD' ) {
			$self->set_AUTOLOAD( $value );
		} elsif ( $key eq 'METHODS' ) {
			$self->set_METHODS( $value );
		} else {
			$self->set_method( $key, $value );
		}
	}

	# Generate the code
	my $code = $self->make_class or Carp::croak(
		"Failed to generate Class::Adapter::Builder class"
	);

	# Compile the combined code via a temp file so that debugging works
	#require File::Temp;
	#my ($fh, $filename) = File::Temp::tempfile();
	#$fh->print("$code");
	#close $fh;
	#require $filename;
	#print "Loaded '$filename'\n";

	eval "$code";
	$@ and Carp::croak(
		"Error while compiling Class::Adapter::Builder class '$target' ($@)"
	);

	$target;
}





#####################################################################
# Main Methods

sub set_NEW {
	my $self     = shift;
	$self->{new} = shift;

	# We always need Scalar::Util to pass through new
	$self->{modules}->{'Scalar::Util'} = 1;

	# Add a use for the module unless it is already loaded.
	# We test with the can call instead of just blindly require'ing in
	# case we want to NEW to something that doesn't have it's own
	# .pm file.
	unless ( $self->{new}->can('new') ) {
		$self->{modules}->{ $self->{new} } = 1;
	}

	return 1;
}

sub set_ISA {
	my $self  = shift;
	my $array = ref $_[0] eq 'ARRAY' ? shift : [ @_ ];
	$self->{isa} = $array;
	return 1;
}

sub set_AUTOLOAD {
	my $self = shift;
	if ( $_[0] ) {
		$self->{autoload} = 1;
		$self->{modules}->{Carp} = 1;
		if ( $_[0] eq 'PUBLIC' ) {
			$self->{autoload_public} = 1;
		}
	} else {
		delete $self->{autoload};
	}
	return 1;
}

sub set_METHODS {
	my $self  = shift;
	my $array = ref $_[0] eq 'ARRAY' ? shift : [ @_ ];
	foreach my $name ( @$array ) {
		$self->set_method( $name, $name ) or return undef;
	}
	return 1;
}

sub set_method {
	my $self = shift;
	if ( @_ == 1 ) {
		$self->{methods}->{$_[0]} = $_[0];
	} elsif ( @_ == 2 ) {
		$self->{methods}->{$_[0]} = $_[1];
	} else {
		return undef;
	}
	return 1;
}





#####################################################################
# Code Generation Functions

sub make_class {
	my $self  = shift;

	# Generate derived lists
	my %seen  = ();
	$self->{load} = [
		grep { $_ !~ /^Class::Adapter(?:::Builder)?$/ }
		sort grep { ! $seen{$_}++ }
		keys %{$self->{modules}}
	];
	$self->{fake} = [
		grep { ! $seen{$_} } grep { $_ ne '_OBJECT_' } @{$self->{isa}}
	];

	# Build up the parts of the class
	my @parts = (
		"package $self->{target};\n\n"
		. "# Generated by Class::Abstract::Builder\n"
	);

	if ( keys %{$self->{modules}} ) {
		push @parts, $self->_make_modules;
	}

	if ( $self->{new} ) {
		push @parts, $self->_make_new( $self->{new} );
	}

	my $methods = $self->{methods};
	foreach my $name ( keys %$methods ) {
		push @parts, $self->_make_method( $name, $methods->{$name} );
	}

	if ( @{$self->{isa}} == 1 ) {
		if ( $self->{isa}->[0] eq '_OBJECT_' ) {
			push @parts, $self->_make_OBJECT;
		} else {
			push @parts, $self->_make_ISA( @{$self->{isa}} );
		}
	}

	if ( $self->{autoload} ) {
		push @parts, $self->_make_AUTOLOAD( $self->{target}, $self->{autoload_public} );
	}

	return join( "\n", @parts, "1;\n" );
}

sub _make_modules {
	my $self  = shift;
	my $pkg   = $self->{target};
	my $load  = join '',
		map { "\nuse $_ ();" }
		@{$self->{load}};

	# Foo->isa('Foo') returns false if the namespace does not exist
	# Use the package command in a scope to create namespaces where needed.
	my $namespaces = join '',
		map { "\n\t$_->isa('$_') or do { package $_ };" }
		@{$self->{fake}};

	return <<"END_MODULES";
use strict;${load}
use Class::Adapter ();

BEGIN {
	\@${pkg}::ISA = 'Class::Adapter';${namespaces}
}
END_MODULES
}

sub _make_new { <<"END_NEW" }
sub new {
	my \$class  = ref \$_[0] ? ref shift : shift;
	my \$object = $_[1]\->new(\@_);
	Scalar::Util::blessed(\$object) or return undef;
	\$class->SUPER::new(\$object);
}
END_NEW



sub _make_method { <<"END_METHOD" }
sub $_[1] { shift->_OBJECT_->$_[2](\@_) }
END_METHOD



sub _make_OBJECT { <<"END_OBJECT" }
sub isa {
	ref(\$_[0])
	? shift->_OBJECT_->isa(\@_)
	: shift->isa(\@_);
}

sub can {
	ref(\$_[0])
	? shift->_OBJECT_->can(\@_)
	: shift->can(\@_);
}
END_OBJECT

sub _make_ISA {
	my $self = shift;
	my @lines = (
		"sub isa {\n",
		( map { "\treturn 1 if \$_[1]->isa('$_');\n" } @_ ),
		"\treturn undef;\n",
		"}\n",
		"\n",
		"sub can {\n",
		# If we are pretending to be a fake ISA, and we get a can call,
		# we should try to require the module (even if it doesn't exist)
		# so that we can provide an accurate answer in the case where
		# we are faking a module that exists.
		( map { "\trequire $_ unless $_->isa('UNIVERSAL');\n" } @{$self->{fake}} ),
		"\treturn 1 if \$_[0]->SUPER::can(\$_[1]);\n",
		( map { "\treturn 1 if $_->can(\$_[1]);\n" } @_ ),
		"\treturn undef;\n",
		"}\n",
	);
	return join '', @lines;
}



sub _make_AUTOLOAD { my $pub = $_[2] ? 'and substr($method, 0, 1) ne "_"' : ''; return <<"END_AUTOLOAD" }
sub AUTOLOAD {
	my \$self     = shift;
	my (\$method) = \$$_[1]::AUTOLOAD =~ m/^.*::(.*)\\z/s;
	unless ( ref(\$self) $pub) {
		Carp::croak(
			  qq{Can't locate object method "\$method" via package "\$self" }
			. qq{(perhaps you forgot to load "\$self")}
		);
	}
	\$self->_OBJECT_->\$method(\@_);
}

sub DESTROY {
	if ( defined \$_[0]->{OBJECT} and \$_[0]->{OBJECT}->can('DESTROY') ) {
		undef \$_[0]->{OBJECT};
	}
}
END_AUTOLOAD

1;

__END__