File Coverage

blib/lib/Class/MethodVars.pm

Criterion	Covered	Total	%
statement	99	360	27.5
branch	18	202	8.9
condition	6	94	6.3
subroutine	20	25	80.0
pod	0	4	0.0
total	143	685	20.8

package Class::MethodVars;
use warnings;
use strict;

use NEXT;

our $VERSION = '1.'.qw $Rev: 133 $[1];

our %Configs; # Needs to be accessible to Class::Framework
my %OptionsMap = (
	'^args'=>'hatargs',
	'hatargs'=>'hatargs',
	'varargs'=>'varargs',
	'^fields'=>'hatfields',
	'hatfields'=>'hatfields',
	'varfields'=>'varfields',
	'^this'=>'hatthis',
	'hatthis'=>'hatthis',
	'varthis'=>'varthis',
	'subthis'=>'subthis',
	'^class'=>'hatclass',
	'hatclass'=>'hatclass',
	'varclass'=>'varclass',
	'subclass'=>'subclass',

	'debug'=>'debug',
);
my %DefaultOptions = (
	hatargs=>1,
	hatfields=>1,
	subthis=>1,
	subclass=>1,
	# No varthis and varclass because that causes an implicit use vars which is bad for a default.
);

sub __DefaultConfigs() {
	return {
		fieldhatprefix=>"",
		fieldvarprefix=>"",
		class=>"__CLASS__",
		this=>"this",
		fields=>[],
		rwfields=>[],
		rofields=>[],
		wofields=>[],
		hiddenfields=>[],
		options=>{ %DefaultOptions }
	};
}

sub import {
	shift; # You should NEVER be @ISA = "Class::MethodVars"
	my $package = caller;
	if ($Configs{$package}) {
		require Carp;
		Carp::croak "Double import into this package!";
	}
	my $Config = $Configs{$package}||=__DefaultConfigs;
	my $cpos = 0;
	while (@_) {
		my $cmd = shift;
		$cpos++;
		if ($cpos == 1 and ref($cmd)) {
			push(@{$Config->{rwfields}},@$cmd);
		} elsif ($cmd eq '-this') {
			$Config->{this} = shift;
		} elsif ($cmd eq '-class') {
			$Config->{class} = shift;
		} elsif ($cpos == 1 and not $cmd=~/^[\+-]/) {
			push(@{$Config->{rwfields}},$cmd);
			while (@_ and not $_[0]=~/^-/) {
				push(@{$Config->{rwfields}},shift);
			}
		} elsif ($cmd eq '-fields' or $cmd eq '-field') {
			if (@_ and ref($_[0])) {
				push(@{$Config->{rwfields}},@{shift()});
			} else {
				while (@_ and not $_[0]=~/^-/) {
					push(@{$Config->{rwfields}},shift);
				}
			}
		} elsif ($cmd =~ /^-(r[wo]|wo|hidden)fields?$/) {
			my $fieldtype = lc $1."fields";
			if (@_ and ref($_[0])) {
				push(@{$Config->{$fieldtype}},@{shift()});
			} else {
				while (@_ and not $_[0]=~/^-/) {
					push(@{$Config->{$fieldtype}},shift);
				}
			}
		} elsif ($cmd eq '-fieldvarprefix') {
			$Config->{fieldvarprefix} = shift;
		} elsif ($cmd eq '-fieldhatprefix') {
			$Config->{fieldhatprefix} = shift;
		} elsif ($cmd=~/^([+-])(.*)$/ and $OptionsMap{$2}) {
			my ($toggle,$option) = ($1,$2);
			if ($toggle eq '-' and @_ and $_[0]=~/^(?:[10]|ON|OFF|TRUE|FALSE)$/i) { # 'it's okay - you would have -fields if expecting field names...
				$toggle = shift;
			}
			$toggle = grep { lc($toggle) eq lc($_) } qw( - 1 ON TRUE );
			$Config->{options}->{$option} = $toggle;
		} else {
			require Carp;
			local $Carp::CarpLevel = 1;
			Carp::croak "I don't know what to do with \"$cmd\"";
		}
	}
	$Config->{fields} = [ Class::MethodVars::_Private::unique(@{$Config->{rwfields}},@{$Config->{rofields}},@{$Config->{wofields}},@{$Config->{hiddenfields}}) ];
	#FIXME: I should probably whine if people use the same field name for a -rofield as a -wofield (for example).
	my @bad_field_names = grep { not /\A\w+\z/ } @{$Config->{fields}};
	if (@bad_field_names) {
		require Carp;
		if (eval { require Lingua::EN::Inflect; 1 }) {
			Carp::croak Lingua::EN::Inflect::inflect("Invalid field PL(name,".@bad_field_names."): ").join(", ",@bad_field_names);
		} else {
			local $" = ", ";
			Carp::croak "Invalid field name(s): @bad_field_names";
		}
	}
	$Config->{allfields} = [ Class::MethodVars::_Private::findBaseFields($package) ]; # This will pull in self and base fields.
	$Config->{options}->{subthis} = 0 if $Config->{this}=~/^\$?_$/;
	$Config->{options}->{subclass} = 0 if $Config->{class}=~/^\$?_$/;
	eval 'unshift @'.$package.'::ISA,q('.__PACKAGE__.'::_ATTRS)';
	eval 'package '.$package.'; sub '.$Config->{this}.'();' if $Config->{options}->{subthis};
	eval 'package '.$package.'; sub '.$Config->{class}.'();' if $Config->{options}->{subclass};
	my @varnames;
	push(@varnames,$Config->{this}) if $Config->{options}->{varthis};
	push(@varnames,$Config->{class}) if $Config->{options}->{varclass};
	push(@varnames,map { $Config->{fieldvarprefix}.$_ } @{$Config->{fields}}) if $Config->{options}->{varfields};
	# Can't do varargs, because I don't know what the args will be in advance!
	eval 'package '.$package.'; use vars qw('.join(" ",map { s{^(?![\%\$\@])}{\$}; $_ } @varnames).');' if @varnames;
	1;
}

sub Method {
	my ($package, $symbol, $referent, $attr, $data, $stage) = @_;
	no warnings 'redefine';
	no strict 'refs';
	if (0 and defined($symbol) and *{$symbol}{NAME} eq 'ANON') {
	#   ^--- DISABLED!
		# Darn, need to find a better symbol. (Probably :Method is not on the first prototype...)
		#XXX: This doesn't work. Even $referent points to the wrong thing :(
		#	Can't figure out true name, can't figure out true reference = can't put Humpty Dumpty back together again :(
		($symbol) = eval 'grep { *{$_}{NAME} ne "ANON" } grep { *{$_}{CODE} and *{$_}{CODE} eq $referent } values %'.$package.'::';
	}
	if (not defined($symbol) or *{$symbol}{NAME} eq 'ANON') {
		require Carp;
		local $Carp::CarpLevel = 3;
		if ($^S) {
			Carp::croak "Unable to identify the name of subroutine at $referent. You appear to be calling this inside an eval. This is a known bug - please \"use\" this module at the start of your application.\n";
		} else {
			Carp::croak "Unable to identify the name of subroutine at $referent. Please ensure :Method is on the first prototype.\n";
		}
		# Don't try and apply the magic to a closure, this attribute is not set up for it.
	}
	my ($self,@args);
	my $Config = $Configs{$package}||__DefaultConfigs;
	$data = "." unless defined $data;
	if (ref $data) {
		($self,@args) = @$data;
	} else {
		($self,@args) = split(/[,\s]+/,$data);
	}
	$self = $Config->{this} if $self eq '.';
	$self=~s{^\$}{};
	if ($self eq "_") {
		$self = "";
		$self.= 'local $_ = (ref($_[0]) and UNIVERSAL::isa($_[0],q('.$package.')))?shift:$_; my $me = $_;' if $Config->{options}->{varthis};
		$self.= 'my $me = shift;' unless $Config->{options}->{varthis};
		$self.= 'local ${^__} = $me;' if $Config->{options}->{hatthis};
		$self.= 'local $_ = (ref($_[0]) and UNIVERSAL::isa($_[0],q('.$package.')))?shift:$_; my $me = $_;' unless $self;
	} else {
		my $selfname = $self;
		$self = 'my $me = shift;';
		$self.='local *'.$package.'::'.$selfname.' = sub { $me };' if $Config->{options}->{subthis};
		$self.='local ${^_'.$selfname.'} = $me;' if $Config->{options}->{hatthis};
		$self.='local *'.$package.'::'.$selfname.' = \$me;' if $Config->{options}->{varthis};
		#$self = 'my $me = $_[0]; local *'.$package.'::'.$self.' = sub { $me }; local ${^_'.$self.'} = $_[0]; local *'.$package.'::'.$self.' = \shift;'
	}
	if (0) { # This is all too late. Needed to do it in BEGIN if I was going to do it at all.
		my @varargs = @args;
		eval 'package '.$package.'; use vars qw('.join(" ",grep { $_ ne "_" } map { s{^(?![\%\$\@])}{\$}; $_ } @varargs).');' if @varargs;
	}
	for (@args) {
		my $aname = $_;
		if ($aname=~/^\@(\w+)$/ and $aname eq $args[-1]) {
			$aname = $1;
			$_ = ''; # This alters @args!
			$_.= 'local @{^_'.$aname.'} = @_;' if $Config->{options}->{hatargs};
			$_.= 'my @args = @_; local *'.$package.'::'.$aname.' = \@args;' if $Config->{options}->{varargs};
			next;
		}
		if ($aname=~/^\%(\w+)$/ and $aname eq $args[-1]) {
			$aname = $1;
			$_ = ''; # This alters @args!
			$_.= 'local %{^_'.$aname.'} = @_;' if $Config->{options}->{hatargs};
			$_.= 'my %args = @_; local *'.$package.'::'.$aname.' = \%args;' if $Config->{options}->{varargs};
			next;
		}
		$aname=~s{^\$}{}; # Allow, but ignore leading dollar sigal.
		unless ($aname=~/^\w+$/) {
			require Carp;
			local $Carp::CarpLevel = 1;
			Carp::croak "Bad argument name: $aname (@args)";
		}
		$_ = ''; # This alters @args!
		if ($aname eq '_') {
			$_.='local $_ = $_[0];';
		} else {
			$_.='local ${^_'.$aname.'} = $_[0];' if $Config->{options}->{hatargs};
			$_.='local *'.$package.'::'.$aname.' = \$_[0];' if $Config->{options}->{varargs};
		}
		$_.='shift;';
	}
	my @fields = @{$Config->{allfields}};
	for (@fields) {
		my $fname = $_;
		$_ = "";
		$_.='local *{^_'.$Config->{fieldhatprefix}.$fname.'} = \$me->{q('.$fname.')};' if $Config->{options}->{hatfields};
		$_.='local *'.$package.'::'.$Config->{fieldvarprefix}.$fname.' = \$me->{q('.$fname.')};' if $Config->{options}->{varfields};
	}
	my $proto = prototype $referent;
	if (defined $proto) {
		$proto = "($proto)";
	} else {
		$proto = "";
	}
	if ($Config->{options}->{debug}) {
		my $subdecl = "sub ".$package."::".(*{$symbol}{NAME}).$proto." {\n\t$self\n\t@fields\n\t@args\n\t\$referent->(\@_)\n};\n";
		$subdecl=~s{;(?!\n)\s*}{;\n\t}gs;
		warn $subdecl;
	}
	local $@;
	my $subdecl = "package $package; sub $proto {
		$self
		@fields
		@args
		\$referent->(\@_)
	};";
	#*{$symbol} = eval $subdecl;
	#die $@."\n$subdecl" if $@;
	my $subref = eval $subdecl;
	die "Failure to create sub: ".$@."\n$subdecl" if $@;
	my ($sympkg,$symname) = (*{$symbol}{PACKAGE},*{$symbol}{NAME});
#	eval '*{$symbol} = $subref; 1' or warn "Assigning symbol: $@"; # I don't know why this doesn't work any more.
	eval '$'.$sympkg.'::{$symname} = $subref' or die "Failed to assign symbol *{$symbol}{PACKAGE}::*{$symbol}{NAME}: $@";
}

sub ClassMethod {
	my ($package, $symbol, $referent, $attr, $data, $stage) = @_;
	no warnings 'redefine';
	no strict 'refs';
	if (0 and defined($symbol) and *{$symbol}{NAME} eq 'ANON') {
	#   ^--- DISABLED!
		# Darn, need to find a better symbol. (Probably :Method is not on the first prototype...)
		#XXX: This doesn't work. Even $referent points to the wrong thing :(
		#	Can't figure out true name, can't figure out true reference = can't put Humpty Dumpty back together again :(
		($symbol) = eval 'grep { *{$_}{NAME} ne "ANON" } grep { *{$_}{CODE} and *{$_}{CODE} eq $referent } values %'.$package.'::';
	}
	if (not defined($symbol) or *{$symbol}{NAME} eq 'ANON') {
		require Carp;
		local $Carp::CarpLevel = 3;
		if ($^S) {
			Carp::croak "Unable to identify the name of subroutine at $referent. You appear to be calling this inside an eval. This is a known bug - please \"use\" this module at the start of your application.\n";
		} else {
			Carp::croak "Unable to identify the name of subroutine at $referent. Please ensure :Method is on the first prototype.\n";
		}
		# Don't try and apply the magic to a closure, this attribute is not set up for it.
	}
	my ($class,@args);
	my $Config = $Configs{$package}||__DefaultConfigs;
	$data = "." unless defined $data;
	if (ref $data) {
		($class,@args) = @$data;
	} else {
		($class,@args) = split(/[,\s]+/,$data);
	}
	$class = $Config->{class} if $class eq '.';
	my $self = $Config->{this};
	$class=~s{^\$}{};
	$self=~s{^\$}{};
	if ($self eq "_") {
		$self = "";
		$self.= 'local $_ = (ref($_[0]) and UNIVERSAL::isa($_[0],q('.$package.')))?shift:$_; my $me = $_;' if $Config->{options}->{varthis};
		$self.= 'my $me = shift;' unless $Config->{options}->{varthis};
		$self.= 'local ${^__} = $me;' if $Config->{options}->{hatthis};
		$self.= 'local $_ = (ref($_[0]) and UNIVERSAL::isa($_[0],q('.$package.')))?shift:$_; my $me = $_;' unless $self;
	} else {
		my $selfname = $self;
		$self = 'my $me = shift;';
		$self.='local *'.$package.'::'.$selfname.' = sub { $me };' if $Config->{options}->{subthis};
		$self.='local ${^_'.$selfname.'} = $me;' if $Config->{options}->{hatthis};
		$self.='local *'.$package.'::'.$selfname.' = \$me;' if $Config->{options}->{varthis};
		#$self = 'my $me = $_[0]; local *'.$package.'::'.$self.' = sub { $me }; local ${^_'.$self.'} = $_[0]; local *'.$package.'::'.$self.' = \shift;'
	}
	if ($class eq "_") {
		$class = "";
		$class.= 'local $_ = ref($me)||$me;' if $Config->{options}->{varthis};
		$class.= 'local ${^__} = $me;' if $Config->{options}->{hatthis};
		$class.= 'local $_ = ref($me)||$me;' unless $class;
	} else {
		my $classname = $class;
		$class = 'my $class = ref($me)||$me;';
		$class.='local *'.$package.'::'.$classname.' = sub { $class };' if $Config->{options}->{subclass};
		$class.='local ${^_'.$classname.'} = $class;' if $Config->{options}->{hatclass};
		$class.='local *'.$package.'::'.$classname.' = \$class;' if $Config->{options}->{varclass};
	}
	for (@args) {
		my $aname = $_;
		if ($aname=~/^\@(\w+)$/ and $aname eq $args[-1]) {
			$aname = $1;
			$_ = '';
			$_.= 'local @{^_'.$aname.'} = @_;' if $Config->{options}->{hatargs};
			$_.= 'my @args = @_; local *'.$package.'::'.$aname.' = \@args;' if $Config->{options}->{varargs};
			next;
		}
		if ($aname=~/^\%(\w+)$/ and $aname eq $args[-1]) {
			$aname = $1;
			$_ = '';
			$_.= 'local %{^_'.$aname.'} = @_;' if $Config->{options}->{hatargs};
			$_.= 'my %args = @_; local *'.$package.'::'.$aname.' = \%args;' if $Config->{options}->{varargs};
			next;
		}
		$aname=~s{^\$}{}; # Allow, but ignore leading dollar sigal.
		unless ($aname=~/^\w+$/) {
			require Carp;
			local $Carp::CarpLevel = 1;
			Carp::croak "Bad argument name: $aname (@args)";
		}
		$_ = ''; # This alters @args!
		if ($aname eq '_') {
			$_.='local $_ = $_[0];';
		} else {
			$_.='local ${^_'.$aname.'} = $_[0];' if $Config->{options}->{hatargs};
			$_.='local *'.$package.'::'.$aname.' = \$_[0];' if $Config->{options}->{varargs};
		}
		$_.='shift;';
	}
#	Class methods don't get fields (you have the {this} variable).
#	my @fields = @{$Config->{fields}};
#	for (@fields) {
#		my $fname = $_;
#		$_ = "";
#		$_.='local ${^_'.$fname.'} = $me->{q('.$fname.')};' if $Config->{options}->{hatfields};
#		$_.='local *'.$package.'::'.$fname.' = \$me->{q('.$fname.')};' if $Config->{options}->{varfields};
#	}
	my $proto = prototype $referent;
	if (defined $proto) {
		$proto = "($proto)";
	} else {
		$proto = "";
	}
	if ($Config->{options}->{debug}) {
		my $subdecl = "sub ".$package."::".(*{$symbol}{NAME}).$proto." {\n\t$self\n\t$class\n\t@args\n\t\$referent->(\@_)\n};\n";
		$subdecl=~s{;(?!\n)\s*}{;\n\t}gs;
		warn $subdecl;
	}
	local $@;
	my $subdecl = "package $package; sub $proto {
		$self
		$class
		@args
		\$referent->(\@_)
	};";
	my $subref = eval $subdecl;
	die "Failure to create sub: ".$@."\n$subdecl" if $@;
	my ($sympkg,$symname) = (*{$symbol}{PACKAGE},*{$symbol}{NAME});
#	eval '*{$symbol} = $subref; 1' or warn "Assigning symbol: $@"; # I don't know why this doesn't work any more.
	eval '$'.$sympkg.'::{$symname} = $subref' or die "Failed to assign symbol *{$symbol}{PACKAGE}::*{$symbol}{NAME}: $@";
#	*{$symbol} = eval "package $package; sub $proto {
#		$self
#		$class
#		@args
#		\$referent->(\@_)
#	};";
}

our %Methods;
our %ClassMethods;
our %symcache;

sub findsym($$) {
	my ($pkg,$ref) = @_;
	return $symcache{$pkg,$ref} if $symcache{$pkg,$ref} and *{$symcache{$pkg,$ref}}{CODE} eq $ref;
	no strict 'refs';
	for (values %{$pkg."::"}) {
		return $symcache{$pkg,$ref} = $_ if *{$_}{CODE} and *{$_}{CODE} eq $ref;
	}
	return undef; # Don't cache incase there is a better way to get it later.
}

sub make_methods($);
sub make_methods($) {
	my $pkg = shift;
	# My call line looks like this to maintain Attribute::Handlers compatibility.
	# unfortunately I cannot use Attribute::Handlers because it fails to trigger
	# if you do "eval 'use mypkg;'" and it can't find the symbols.
	#my ($package, $symbol, $referent, $attr, $data, $stage);
	my @oa = $pkg->NEXT::ELSEWHERE::ancestors;
	1 while @oa and shift(@oa) ne $pkg;
	1 while @oa and shift(@oa) ne "Class::MethodVars::_ATTRS";
	my $next;
	if (@oa) {
		make_methods(shift(@oa));
	}
	for my $data (@{$ClassMethods{$pkg}||[]}) {
		my ($package,$ref,$args) = @$data;
		my $sym = findsym($package,$ref);
		ClassMethod($package,$sym,$ref,"ClassMethod",$args,"import");
	}
	for my $data (@{$Methods{$pkg}||[]}) {
		my ($package,$ref,$args) = @$data;
		my $sym = findsym($package,$ref);
		Method($package,$sym,$ref,"ClassMethod",$args,"import");
	}
	delete $ClassMethods{$pkg};
	delete $Methods{$pkg};
}

{
	no warnings 'void'; # "Too late to run INIT block"
	INIT {
		make_methods($_) for keys %ClassMethods;
		make_methods($_) for keys %Methods;
	};
}

package Class::MethodVars::_ATTRS;
use warnings;
use strict;

use NEXT; # Need this incase they used to inherit from someone else.

sub import {
	my ($spkg,@args) = @_;
	my $tpkg = caller;
	if ($spkg eq __PACKAGE__) {
		require Carp;
		Carp::croak "Don't do that.";
	}
	Class::MethodVars::make_methods($spkg);
	my @oa = $_[0]->NEXT::ELSEWHERE::ancestors;
	1 while @oa and shift(@oa) ne $tpkg;
	1 while @oa and shift(@oa) ne __PACKAGE__;
	my $next;
	if (@oa and $next = $oa[0]->can("import")) {
		goto &$next;
	}
}

sub MODIFY_CODE_ATTRIBUTES {
	my ($pkg,$ref,@attrs) = @_;

# I want to write this:
#	my @oldattrs = @attrs;
#	unless (eval q{ @attrs = $pkg->NEXT::DISTINCT::ACTUAL::MODIFY_CODE_ATTRIBUTES($ref,@attrs); 1 }) {
#		@attrs = @oldattrs;
#	}
# But "(eval)" can't call NEXT...MODIFY_CODE_ATTRIBUTES! So:
	my @oa = $_[0]->NEXT::ELSEWHERE::ancestors;
	1 while @oa and shift(@oa) ne caller;
	1 while @oa and shift(@oa) ne __PACKAGE__;
	my $next;
	if (@oa and $next = $oa[0]->can("import")) {
		@attrs = $pkg->$next($ref,@attrs);
	}
# End whinge

	my @bad_attrs;
	my @good_attrs;
	for (@attrs) {
		if (/\A(?:Class)?Method(?:\(.*)?\z/) {
			push(@good_attrs,$_);
		} else {
			push(@bad_attrs,$_);
		}
	}
	if (@good_attrs > 1) {
		require Carp;
		Carp::croak q{Please only use one of :Method or :ClassMethod for each method};
	} elsif (@good_attrs) {
		my $args;
		$args = [split(/[\s,]/,$1)] if $good_attrs[0]=~/\((.*)\)\s*\z/;
		if ($good_attrs[0]=~/\AClassMethod/) {
			$ClassMethods{$pkg}||=[];
			push(@{$ClassMethods{$pkg}},[ $pkg,$ref,$args ]);
		} else {
			$Methods{$pkg}||=[];
			push(@{$Methods{$pkg}},[ $pkg,$ref,$args ]);
		}
	}
	return @bad_attrs;
}

package Class::MethodVars::_Private;
use warnings;
use strict;

sub unique(@) {
	my %u = map { $_=>$_ } @_;
	return values %u;
}

sub retrFields($) {
	my $pkg = shift;
	return () unless $Class::MethodVars::Configs{$pkg};
	return () unless $Class::MethodVars::Configs{$pkg}->{fields};
	return @{$Class::MethodVars::Configs{$pkg}->{fields}};
}

sub findBaseFields($);
sub findBaseFields($) {
	my $pkg = shift;
	my @isa = eval '@'.$pkg.'::ISA';
	my @fields;
	for my $bpkg (@isa) {
		push(@fields,findBaseFields($bpkg));
	}
	return unique @fields,retrFields $pkg;
}

1;

__END__