File Coverage

blib/lib/Class/Method/Auto.pm

Criterion	Covered	Total	%
statement	66	69	95.6
branch	15	22	68.1
condition			n/a
subroutine	10	10	100.0
pod	0	1	0.0
total	91	102	89.2

package Class::Method::Auto;

use strict;
use warnings;

our $VERSION = "1.00";

use attributes 'get';

sub my_croak($$) {
	my ($package, $method) = @_;
	require Carp;
	Carp::croak "Undefined subroutine &${package}::$method called";
}

sub import {
	shift;
	my $target = caller;
	my ($regexp, $check_attributes, @methods);
	for (@_) {
		if (ref($_) eq 'Regexp') {
			$regexp = $_;
		} elsif ($_ eq '-attributes') {
			$check_attributes = 1;
		} else {
			push(@methods, $_);
		}
	}
	if (@methods) { # install for every method in @_
		for my $method(@methods) {
			my $autosub = sub {
				my $package = caller;
				unshift(@_, $package);
				my @isa;
				{
					no strict 'refs';
					@isa = @{$package.'::ISA'};
				}
				for (@isa) {
					my $sub = $_->can($method);
					goto &{$sub} if defined $sub;
				}
				my_croak($package, $method);
			};
			{
				no strict 'refs';
				*{"${target}::$method"} = $autosub unless defined *{"${target}::$method"}{'CODE'};
			}
		}
	} else { # install globally;
		my $autoload = sub {
			my $method = our $AUTOLOAD;
			$method =~ s/.*:://;
			my $package = caller;
			if ($regexp) {
				my_croak($package, $method) unless ($method =~ $regexp);
			}
			unshift(@_, $package);
			my $sub = $package->can($method);
			my_croak($package, $method) unless defined $sub;
			if ($check_attributes) {
				my %attr;
				@attr{get($sub)} = undef;
				my_croak($package, $method) unless exists $attr{'method'};
			}
			goto &{$sub};
		};
		{
			no strict 'refs';
			if (defined *{"${target}::AUTOLOAD"}{'CODE'}) {
				require Carp;
				Carp::croak "There already seems to be a routine named AUTOLOAD in $target";
			} else {
				*{"${target}::AUTOLOAD"} = $autoload;
			}
		}
	}
}


1;
__END__