File Coverage

blib/lib/Params/Coerce.pm

Criterion	Covered	Total	%
statement	79	88	89.7
branch	29	48	60.4
condition			n/a
subroutine	20	20	100.0
pod	2	2	100.0
total	130	158	82.2

package Params::Coerce; # git description: v0.14-9-g675637f
# ABSTRACT: Allows your classes to do coercion of parameters

#pod =pod
#pod
#pod =head1 NAME
#pod
#pod
#pod =head1 SYNOPSIS
#pod
#pod   # Coerce a object of class Foo to a Bar
#pod   my $bar = Params::Coerce::coerce('Bar', $Foo)
#pod
#pod   # Create a coercion param function
#pod   use Params::Coerce '_Bar' => 'Bar';
#pod   my $bar = _Bar($Foo);
#pod
#pod   # Usage when Bar has a 'from' method
#pod   my $bar = Bar->from($Foo);
#pod
#pod Real world example using L.
#pod
#pod   # My class needs a URI
#pod   package Web::Spider;
#pod
#pod   use URI;
#pod   use Params::Coerce 'coerce';
#pod
#pod   sub new {
#pod       my $class = shift;
#pod
#pod       # Where do we start spidering
#pod       my $start = coerce('URI', shift) or die "Wasn't passed a URI";
#pod
#pod       bless { root => $start }, $class;
#pod   }
#pod
#pod   #############################################
#pod   # Now we can do the following
#pod
#pod   # Pass a URI as normal
#pod   my $URI     = URI->new('http://ali.as/');
#pod   my $Spider1 = Web::Spider->new( $URI );
#pod
#pod   # We can also pass anything that can be coerced into being a URI
#pod   my $Website = HTML::Location->new( '/home/adam/public_html', 'http://ali.as' );
#pod   my $Spider2 = Web::Spider->new( $Website );
#pod
#pod =head1 DESCRIPTION
#pod
#pod A big part of good API design is that we should be able to be flexible in
#pod the ways that we take parameters.
#pod
#pod Params::Coerce attempts to encourage this, by making it easier to take a
#pod variety of different arguments, while adding negligible additional complexity
#pod to your code.
#pod
#pod =head2 What is Coercion
#pod
#pod "Coercion" in computing terms generally refers to "implicit type
#pod conversion". This is where data and object are converted from one type to
#pod another behind the scenes, and you just just magically get what you need.
#pod
#pod The L pragma, and its string overloading is the form of coercion
#pod you are most likely to have encountered in Perl programming. In this case,
#pod your object is automatically (within perl itself) coerced into a string.
#pod
#pod C is intended for higher-order coercion between various
#pod types of different objects, for use mainly in subroutine and (mostly)
#pod method parameters, particularly on external APIs.
#pod
#pod =head2 __as_Another_Class Methods
#pod
#pod At the heart of C is the ability to transform objects from
#pod one thing to another. This can be done by a variety of different
#pod mechanisms.
#pod
#pod The preferred mechanism for this is by creating a specially named method
#pod in a class that indicates it can be coerced into another type of object.
#pod
#pod As an example, L provides an object method that returns an
#pod equivalent L object.
#pod
#pod   # In the package HTML::Location
#pod
#pod   # Coerce to a URI
#pod   sub __as_URI {
#pod   	my $self = shift;
#pod  	return URI->new( $self->uri );
#pod   }
#pod
#pod =head2 __from_Another_Class Methods
#pod
#pod From version 0.04 of C, you may now also provide
#pod __from_Another_Class methods as well. In the above example, rather then
#pod having to define a method in L, you may instead define
#pod one in L. The following code has an identical effect.
#pod
#pod   # In the package URI
#pod
#pod   # Coerce from a HTML::Location
#pod   sub __from_HTML_Location {
#pod   	my $Location = shift;
#pod   	return URI->new( $Location->uri );
#pod   }
#pod
#pod C will only look for the __from method, if it does not
#pod find a __as method.
#pod
#pod =head2 Loading Classes
#pod
#pod One thing to note with the C<__as_Another_Class> methods is that you are
#pod B required to load the class you are converting to in the class you
#pod are converting from.
#pod
#pod In the above example, L does B have to load the URI
#pod class. The need to load the classes for every object we might some day need
#pod to be coerced to would result in highly excessive resource usage.
#pod
#pod Instead, C guarantees that the class you are converting to
#pod C be loaded before it calls the __as_Another_Class method. Of course,
#pod in most situations you will have already loaded it for another purpose in
#pod either the From or To classes and this won't be an issue.
#pod
#pod If you make use of some class B the class you are being coerced
#pod to in the __as_Another_Class method, you will need to make sure that is loaded
#pod in your code, but it is suggested that you do it at run-time with a
#pod C if you are not using it already elsewhere.
#pod
#pod =head2 Coercing a Parameter
#pod
#pod The most explicit way of accessing the coercion functionality is with the
#pod Params::Coerce::coerce function. It takes as its first argument the name
#pod of the class you wish to coerce B, followed by the parameter to which you
#pod wish to apply the coercion.
#pod
#pod   package My::Class;
#pod
#pod   use URI ();
#pod   use Params::Coerce '_URI' => 'URI';
#pod
#pod   sub new {
#pod   	my $class = shift;
#pod
#pod   	# Take a URI argument
#pod   	my $URI = Params::Coerce::coerce('URI', shift) or return;
#pod
#pod   	...
#pod   }
#pod
#pod For people doing procedural programming, you may also import this function.
#pod
#pod   # Import the coerce function
#pod   use Params::Coerce 'coerce';
#pod
#pod Please note that the C function is the B function
#pod that can be imported, and that the two argument pragma (or the passing of
#pod two or more arguments to ->import) means something different entirely.
#pod
#pod =head2 Importing Parameter Coercion Methods
#pod
#pod The second way of using Params::Coerce, and the more common one for
#pod Object-Oriented programming, is to create method specifically for taking
#pod parameters in a coercing manner.
#pod
#pod   package My::Class;
#pod
#pod   use URI ();
#pod   use Params::Coerce '_URI' => 'URI';
#pod
#pod   sub new {
#pod   	my $class = shift;
#pod
#pod 	# Take a URI as parameter
#pod   	my $URI1 = $class->_URI(shift) or return;
#pod   	my $URI2 = _URI(shift) or return;
#pod   	...
#pod   }
#pod
#pod =head2 The C Constructor
#pod
#pod From version C<0.11> of C, an additional mechanism is
#pod available with the importable C constructor.
#pod
#pod   package My::Class;
#pod
#pod   use Params::Coerce 'from';
#pod
#pod   package Other::Class;
#pod
#pod   sub method {
#pod   	my $self = shift;
#pod   	my $My   = My::Class->from(shift) or die "Bad param";
#pod   	...
#pod   }
#pod
#pod This is mainly a convenience. The above is equivalent to
#pod
#pod   package My::Class;
#pod
#pod   use Params::Coerce 'from' => 'Params::Coerce';
#pod
#pod In future versions, this C<-Efrom> syntax may also tweak the resolution
#pod order of the coercion.
#pod
#pod =head2 Chained Coercion
#pod
#pod While it is intended that Params::Coerce will eventually support coercion
#pod using multiple steps, like C<__as_HTML_Location->__as_URI>>,
#pod it is not currently capable of this. At this time only a single coercion
#pod step is supported.
#pod
#pod =head1 FUNCTIONS
#pod
#pod =cut

use 5.006;
use strict;
use Carp         ();
use Scalar::Util ();
use Params::Util '_IDENTIFIER',
                 '_INSTANCE',
                 '_CLASS';

# Load Overhead: 52k

our $VERSION = '0.15';

# The hint cache
my %hints = ();





#####################################################################
# Use as a Pragma

sub import {
	my $class = shift;
	my @param = @_ or return;
	Carp::croak("Too many parameters") if @param > 2; # Um, what?

	# We'll need to know who is calling us
	my $pkg = caller();

	# We export them the coerce function if they want it
	if ( @param == 1 ) {
		if ( $param[0] eq 'coerce' ) {
			no strict 'refs';
			*{"${pkg}::coerce"} = *coerce;
			return 1;
		} elsif ( $param[0] eq 'from' ) {
			# They want a from constructor
			no strict 'refs';
			*{"${pkg}::from"} = *from;
			return 1;
		} else {
			Carp::croak "Params::Coerce does not export '$_[0]'";
		}
	}

	# The two argument form is 'method' => 'class'
	# Check the values given to us.
	my $method = _IDENTIFIER($param[0]) or Carp::croak "Illegal method name '$param[0]'";
	my $want   = _CLASS($param[1])      or Carp::croak "Illegal class name '$param[1]'";
	_function_exists($pkg, $method)    and Carp::croak "Cannot create '${pkg}::$method'. It already exists";

	# Make sure the class is loaded
	unless ( _loaded($want) ) {
		eval "require $want";
		croak($@) if $@;
	}

	# Create the method in our caller
	eval "package $pkg;\nsub $method {\n\tParams::Coerce::_coerce('$want', \$_[-1])\n}";
	Carp::croak("Failed to create coercion method '$method' in $pkg': $@") if $@;

	1;
}

#pod =pod
#pod
#pod =head2 coerce $class, $param
#pod
#pod The C function takes a class name and a single parameter and
#pod attempts to coerce the parameter into the intended class, or one of its
#pod subclasses.
#pod
#pod Please note that it is the responsibility of the consuming class to ensure
#pod that the class you wish to coerce to is loaded. C will check this
#pod and die is it is not loaded.
#pod
#pod Returns an instance of the class you specify, or one of its subclasses.
#pod Returns C if the parameter cannot be coerced into the class you wish.
#pod
#pod =cut

sub coerce($$) {
	# Check what they want properly first
	my $want = _CLASS($_[0]) or Carp::croak("Illegal class name '$_[0]'");
	_loaded($want)           or Carp::croak("Tried to coerce to unloaded class '$want'");

	# Now call the real function
	_coerce($want, $_[1]);
}

# The from method that is imported into the classes
sub from {
	@_ == 2 or Carp::croak("'->from must be called as a method with a single param");
	_coerce(@_);
}

# Internal version with less checks. Should ONLY be called once
# the first argument is FULLY validated.
sub _coerce {
	my $want = shift;
	my $have = Scalar::Util::blessed($_[0]) ? shift : return undef;

	# In the simplest case it is already what we need
	return $have if $have->isa($want);

	# Is there a coercion hint for this combination
	my $key = ref($have) . ',' . $want;
	my $hint = exists $hints{$key} ? $hints{$key}
		: _resolve($want, ref($have), $key)
		or return undef;

	# Call the coercion function
	my $type = substr($hint, 0, 1, '');
	if ( $type eq '>' ) {
		# Direct Push
		$have = $have->$hint();
	} elsif ( $type eq '<' ) {
		# Direct Pull
		$have = $want->$hint($have);
	} elsif ( $type eq '^' ) {
		# Third party
		my ($pkg, $function) = $hint =~ m/^(.*)::(.*)\z/s;
		require $pkg;
		no strict 'refs';
		$have = &{"${pkg}::${function}"}($have);
	} else {
		Carp::croak("Unknown coercion hint '$type$hint'");
	}

	# Did we get what we wanted?
	_INSTANCE($have, $want);
}

# Try to work out how to get from one class to the other class
sub _resolve {
	my ($want, $have, $key) = @_;

	# Look for a __as method
	my $method = "__as_$want";
	$method =~ s/::/_/g;
	return _hint($key, ">$method") if $have->can($method);

	# Look for a direct __from method
	$method = "__from_$have";
	$method =~ s/::/_/g;
	return _hint($key, "<$method") if $want->can($method);

	# Give up (and don't try again).
	# We use zero specifically so it will return false in boolean context
	_hint($key, '0');
}

# For now just save to the memory hash.
# Later, this may also involve saving to a database somewhere.
sub _hint {
	$hints{$_[0]} = $_[1];
}





#####################################################################
# Support Functions

# Is a class loaded.
sub _loaded {
	no strict 'refs';
	foreach ( keys %{"$_[0]::"} ) {
		return 1 unless substr($_, -2, 2) eq '::';
	}
	'';
}

# Does a function exist.
sub _function_exists {
	no strict 'refs';
	defined &{"$_[0]::$_[1]"};
}

1;

__END__