File Coverage

blib/lib/Sub/NamedParams.pm

Criterion	Covered	Total	%
statement	58	59	98.3
branch	25	28	89.2
condition	2	3	66.6
subroutine	9	9	100.0
pod	1	1	100.0
total	95	100	95.0

package Sub::NamedParams;

use 5.005;
use strict;
use Carp qw/croak/;

require Exporter;
use vars     qw/ $VERSION @ISA @EXPORT_OK /;
$VERSION   = '1.02';
@ISA       = qw/ Exporter/;
@EXPORT_OK = qw/ wrap /;

# I don't like defining this outside the sub, but I want this lexically
# scoped (so programmers won't futz with it) and persistant.
{
	my %wrapped_sub;

	sub wrap {
		my %wrapper = @_;
		my $package = caller(0);

		foreach ( qw/ sub names / ) {
			if ( ! exists $wrapper{$_} ) {
				croak "You must supply '$_' in the argument list'";
			}
		}

		croak "'sub' value must not be a reference." unless !ref $wrapper{sub};

		my $sub = $wrapper{ sub };
		if ( $sub !~ /::/ ) {
			# if it's not fully qualified, append the package
			$sub = "${package}::$sub";
		}

		my $target = $sub;
		if ( exists $wrapper{ target } ) {
			$target = $wrapper{ target };
			if ( $target !~ /::/ ) {
				$target = "${package}::$target";
			}
		}
		if (my $error = _bad_target( $target, \%wrapper )) {
			croak $error;
		}

		$wrapped_sub{ $target } = 1;

		no strict 'refs';
		my $orig_sub = \&$sub;

		$wrapper{ hashref } = 1  if ! exists $wrapper{ hashref };
		$wrapper{ default } = {} if ! exists $wrapper{ default };

		local $^W; # suppress warnings about redefined sub
		*{$target} = sub {
			my %args = $wrapper{ hashref } ? %{$_[0]} : @_;
			my @orig_args;
			foreach my $arg_name ( @{$wrapper{ names }} ) {
				if ( exists $args{ $arg_name } ) {
					push @orig_args, $args{ $arg_name };
				} elsif ( exists $wrapper{ default }{ $arg_name } ) {
					push @orig_args, $wrapper{ default }{ $arg_name };
				} else {
					croak( "Cannot find value or default for '$arg_name'" );
				}
			}
			return $orig_sub->( @orig_args );
		}
	}

	sub _bad_target {
		my ( $target, $wrap ) = @_;
		my $error = '';
		if ( exists $wrapped_sub{ $target } ) {
			$error = "Cannot rewrap '$target'";
		} elsif (exists $wrap->{target} and $wrap->{sub} ne $wrap->{target}) {
			no strict 'refs';
			if ( defined &{$target} ) {
				$error = "Cannot target a pre-existing sub: '$target'";
			}
		}
		return $error;
	}
}
'Ovid';

__END__