File Coverage

blib/lib/generics.pm

Criterion	Covered	Total	%
statement	77	78	98.7
branch	28	28	100.0
condition	9	9	100.0
subroutine	12	13	92.3
pod	2	2	100.0
total	128	130	98.4

package generics;

use strict;
use warnings;

our $VERSION = '0.04';

sub import {
	my ($self) = shift;
	# return if they dont pass anything in (use generics;)
	return unless @_;
	# otherwise ...
	my ($class, @params) = @_;
	# turn off strict refs cause we are messing with stuff
	no strict 'refs';
	# turn off warnings, so we dont get
	# the function redefinition warning
	# or the prototype mismatch as well
	no warnings qw(redefine prototype once);
	# find out who called us
	my ($calling_package, $file, $line) = caller();
	# this is for:
	# 	use generics params => (*params*);
	# it just pre-initializes the sub routines
	# so they can be called like constants
	# if you do not then define those params
	# later on, the methods will just return undefined
	if ($class eq "params") {
		# create a hash for to hold the
		# valid parameters
		%{"${calling_package}::GENERIC_PARAMS"} = () unless %{"${calling_package}::GENERIC_PARAMS"};
		map {
			# check for duplicate parameters
			# basically just see if the param
			# already exists in the hash of
			# valid params
			(!exists(${"${calling_package}::GENERIC_PARAMS"}{$_})) ||  die "generics exception: attempted duplicate parameter creation in $calling_package in file: $file on line: $line.\n";
			# this creates a subroutine that returns undef.
			# this prevents Perl from thinking that this
			# subroutine doesnt exist, but allows you to
			# to catch it as an error.
			my $name = $_;
			*{"${calling_package}::$_"} = sub { die "generics exception: ${calling_package}::$name is an undefined parameter (and has no default)\n" };
			# add the latest param as a key in the valid
			# params hash, and increment it by one
			${"${calling_package}::GENERIC_PARAMS"}{$_}++;
			} @params;
		return;
	}
	elsif ($class eq "inherit") {
		# if you want to inherit generic params,
		# but still have your own, then you need
		# to do this:
		# 	use generics inherit => "My::Base::Class";
		# and it will allow one to inherit from
		# the base class. it can be called alone
		# or in conjunction with other calls to generics
		# which therby either create or overwrite the
		# generic params alreay inherited.
		# NOTE:
		# we create a function in the calling package which
		# returns the value of the function from the base
		# packages so that we are truely inheriting from it.
		# But keep in mind that this all happens at runtime,
		# so if the generic parameters are changed in
		# the calling package then it will override these
		# parameters, because that change will happen at
		# compile time and therefore override this function.
		# NOTE:
		# any changes made to the params of the base package
		# will be reflected in the calling package since the
		# inheritance is performed at runtime.
		my $base_package = $params[0];
		%{"${calling_package}::GENERIC_PARAMS"} = %{"${base_package}::GENERIC_PARAMS"};
		foreach my $param_key (keys %{"${base_package}::GENERIC_PARAMS"}) {
			*{"${calling_package}::${param_key}"} = sub { &{"${base_package}::${param_key}"}() };
		}
		return;
	}
	# before we go any further lets make sure
	# the parameters are even key value pairs
 	(@params && ($#params % 2) != 0) || die "generics exception: uneven parameter assigments of generics in $calling_package in file: $file on line: $line.\n";
	my %params = @params;
	# this is for:
	# 	use generics default_params => (*params and default values*);
	# it sets up the generic parameters and
	# fills them with a default value.
	# NOTE:
	# there is no need to check for
	# duplicate params here, because they
	# will get swallowed up by the hash
	# assignment.
	if ($class eq "default_params") {
		# create a hash for to hold the
		# valid parameters, unless we already
		# have one (meaning someone has done
		# and "inherit" somewhere.
		%{"${calling_package}::GENERIC_PARAMS"} = () unless %{"${calling_package}::GENERIC_PARAMS"};
		while (my ($key, $value) = each %params) {
			# add the latest param as a key in the valid
			# params hash, and increment it by one
			${"${calling_package}::GENERIC_PARAMS"}{$key}++;
			*{"${calling_package}::$key"} = $value if (ref($value) eq "CODE");
			*{"${calling_package}::$key"} = sub { $value } if (!ref($value) || (ref($value) ne "CODE"));
		}
	}
	# this is for:
	#	use generics *package* => (*params and values*);
	# this is when the module is loaded and
	# before you use it in any code. It populates
	# the generic parameters with the new
	# values that are passed.
	else {
		# get the hash of valid params
		my %valid_params = %{"${class}::GENERIC_PARAMS"};
		while (my ($key, $value) = each %params) {
			# before we assign anything, check
			# to see that the key we are assigning
			# is a valid param in the generic module
			(exists($valid_params{$key})) || die "generics exception: $key is not a valid generic parameter for $class in $calling_package in file: $file on line: $line.\n";
			# if we get past the exception, then all
			# is cool and we can assign the parameter
			*{"${class}::$key"} = $value if (ref($value) eq "CODE");
			*{"${class}::$key"} = sub () { $value } if (!ref($value) || (ref($value) ne "CODE"));
		}
	}
}

## NOTE:
# if ever you need to change the module configuration
# you will need to re-import the the configuration. Here
# is a way to do that (without having to say import which
# wouldnt make as much sense semanticaly).
# Keep in mind though that this will not restore the default
# values originally assigned in the class, it will just overwrite
# the current ones.
#
# this will be needed very rarely. If you find yourself using it
# you should question the reason first, and only use it as a last
# resort.
*change_params = \&import;

# to support module reloading

sub has_generic_params {
	my ($self, $package_name) = @_;
	no strict 'refs';
	return exists ${"${package_name}::"}{GENERIC_PARAMS} ? 1 : 0;
}

sub dump_params {
	my ($self, $package_name) = @_;
	no strict 'refs';
	return map {
			($_ => &{"${package_name}::$_"}())
			} keys %{"${package_name}::GENERIC_PARAMS"};
}

1;
__END__