Class-Framework

 view release on metacpan or  search on metacpan

lib/Class/Framework.pm  view on Meta::CPAN

package Class::Framework;
use warnings;
use strict;

use Class::Accessor ();
use Class::MethodVars ();

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

sub insert_base($$) {
	my ($package,$base) = @_;
	eval "unshift(\@${package}::ISA,q($base))" unless $package->isa($base);
}

sub add_base($@) {
	my ($package,@base) = @_;
	eval "package $package; use base qw( @base ); 1" or die $@;
}

sub import {
	shift; # I don't care about what package this is. You should never be @ISA = "Class::Framework".
	my $package = caller;
	for (my $i = 0; $i < @_; $i++) {
		next unless $_[$i] eq '-base';
		if (ref($_[$i+1]) and ref($_[$i+1]) eq 'ARRAY' and not grep { not /\A\w+(?:::\w+)*\z/ } @{$_[$i+1]}) {

lib/Class/MethodVars.pm  view on Meta::CPAN

	'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=>[],

lib/Class/MethodVars.pm  view on Meta::CPAN

#		$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) {

lib/Class/MethodVars.pm  view on Meta::CPAN

			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;

t/PTest2.pm  view on Meta::CPAN

use warnings;
use strict;

# either {
use base qw( PTest );
use Class::Framework -field=>"x",-debug=>($ENV{debug}?1:0);
# } or {
#use Class::Framework -base=>"PTest",-field=>"x",-debug=>($ENV{debug}?1:0);
# }

sub meth2($) :Method(. thearg) {
	this->mymeth(${^_thearg});
# The next line would correctly have compliation errors becase the $this_* variables are not defined.
#	print "varfields: a=>$this_a,b=>$this_b,cde=>$this_cde,x=>$this_x";
	local $\ = "\n";
	print "hatfields: a=>${^_a},b=>${^_b},cde=>${^_cde},x=>${^_x}";
	print "objfields: ".join(",",map { "$_=>".this->{$_} } qw( a b cde x ));
	print "objaccess: ".join(",",map { "$_=>".this->$_() } qw( a b cde x ));
}

1;