File Coverage

blib/lib/Class/Frame.pm

Criterion	Covered	Total	%
statement	98	122	80.3
branch	2	4	50.0
condition			n/a
subroutine	12	14	85.7
pod	0	1	0.0
total	112	141	79.4

package Class::Frame;

use 5.006;
use strict;
no strict 'refs';
no strict 'subs';
use warnings;

our $VERSION = '1.0';
our ( @ISA, @EXPORT );

use Exporter;

@ISA = qw( Exporter );
@EXPORT = qw( DEFINE_FIELDS );

sub DEFINE_FIELDS {
	my $pkg = (caller())[0];
	my %args = @_;

	*{$pkg.'::_FIELDS'} = sub {return {%args}};

	# Inject constructor
	my $constructor =<<'CONSTRUCTOR';
	sub {
		my $pkg = shift;
		my %args = @_;

		my $self = {};
		bless $self, $pkg;

		# Set-up class fields with default values
		my $fields = $self->_FIELDS;
		$self->_setter(name => $_, val => $fields->{$_})
			for (keys %$fields);

		# Update class fields with new values
		$self->_setter(name => $_, val => $args{$_}) for (keys %args);

		return $self;
	}
CONSTRUCTOR

	*{$pkg.'::new'} = eval($constructor);

	# Inject accessors/mutators
	foreach my $arg (keys %args) {

		*{$pkg.'::set_'.$arg} =
			eval('sub { my $self = shift; $self->_setter(name => "'.$arg.'", val => shift);}');

		*{$pkg.'::get_'.$arg} =
			eval('sub { my $self = shift; return $self->_getter(name => "'.$arg.'");}');

		*{$pkg.'::get_'.$arg.'_default'} =
			eval('sub { my $self = shift; return $self->_FIELDS->{'.$arg.'};}');

		*{$pkg.'::'.$arg} = *{$pkg.'::get_'.$arg};
	}
}

sub _setter {
	my $self = shift;
	my %args = @_;
	my $name = $args{name} or die "name argument is missing";
	$self->{$name} = $args{val};
}

sub _getter {
	my $self = shift;
	my %args = @_;
	my $name = $args{name} or die "name argument is missing";
	return $self->{$name};
}

1;

__END__