File Coverage

blib/lib/Class/Framework.pm

Criterion	Covered	Total	%
statement	24	66	36.3
branch	0	28	0.0
condition	0	15	0.0
subroutine	8	12	66.6
pod	0	2	0.0
total	32	123	26.0

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]}) {
			add_base($package,@{$_[$i+1]});
			splice(@_,$i,2);
			last;
		} elsif ( (not ref($_[$i+1])) and $_[$i+1]=~/\A\w+(?:::\w+)*\z/ ) {
			add_base($package,$_[$i+1]);
			splice(@_,$i,2);
			last;
		}
	}
	insert_base $package,"Class::Accessor";
	insert_base $package,"Class::Framework::New";
	eval "package $package; Class::MethodVars->import(\@_); 1" or die $@; # And this is where the rest of @_ is used...
	my @fields = @{$Class::MethodVars::Configs{$package}->{fields}};
	my @rwfields = @{$Class::MethodVars::Configs{$package}->{rwfields}};
	my @rofields = @{$Class::MethodVars::Configs{$package}->{rofields}};
	my @wofields = @{$Class::MethodVars::Configs{$package}->{wofields}};
	# There are also "hiddenfields" which don't get accessors...
	eval "package $package; use fields \@fields; 1" or die $@;
	$package->mk_accessors(@rwfields) if @rwfields;
	$package->mk_accessors(@rofields) if @rofields;
	$package->mk_accessors(@wofields) if @wofields;

}

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

use Class::MethodVars; # Defaults - I only need __CLASS__ anyway.

sub new :ClassMethod {
	my $fields;
	if (@_ == 1 and ref($_[0]) and $_[0]->isa("HASH")) {
		$fields = shift;
	} elsif ((@_ % 2) == 0) {
		$fields = {@_};
	}
	my $me = fields::new(__CLASS__); # Note that __CLASS__ could be different to __PACKAGE__!
	%$me = %$fields if $fields;
	if ($me->can("_INIT")) {
		$me->_INIT(@_);
	}
	return $me;
}

1;
__END__