File Coverage

blib/lib/Form/Base.pm

Criterion	Covered	Total	%
statement	15	57	26.3
branch	0	12	0.0
condition	0	6	0.0
subroutine	5	9	55.5
pod	1	1	100.0
total	21	85	24.7

package Form::Base;

use strict;
use warnings;
use UNIVERSAL::moniker;

=head1 NAME

Form::Base - Base class for other Form classes

=head1 SYNOPSIS

=head1 DESCRIPTION

This provides a base class for Form classes that need attributes that
can be set either as class or instance methods. This is really a
standalone CPAN module waiting to escape once we decide it's a sensible
approach to things.

=head1 METHODS

=head2 mk_attributes

	__PACKAGE__->mk_attributes(qw/ decorators fields name /);

Any subclass which wishes to have other attributes that follow this same
pattern (inheritiable class data which gets copied into instance data
when a form is created), can set them up using mk_attributes.

=cut

use base qw/Class::Data::Inheritable/;

sub mk_attributes {
	my ($class, @att) = @_;
	no strict 'refs';

	foreach my $att (@att) {
		my $inner = "_$att";
		my $add   = "add_$att";
		my $addalias   = "_add_$att";
        my $alias = "_att_$att";

		$class->mk_classdata($inner);

		*{"$class\::$alias"} = sub {
			my $proto = shift;
            if (ref $proto) {
                if (@_) { $proto->{$att} = shift }
                return $proto->{$att};
            } else {
                $proto->$inner(@_);
            }
		};

        *{"$class\::$att"} = \&{"$class\::$alias"}
            unless *{"$class\::$att"}{CODE};

		*{"$class\::$addalias"} = sub {
			my $proto = shift;
			$proto->$alias([ @{ $proto->$alias || [] }, @_ ]);
			return $proto;
		};
        *{"$class\::$add"} = \&{"$class\::$addalias"}
            unless *{"$class\::$add"}{CODE};
	}

	*{"$class\::new"} = sub {
		my ($class, $args) = @_;
		my $self = bless {}, ref $class || $class;

		# Copy class-data down into instance
		foreach my $att (@att) {
            my $att2 = "_att_$att";
			$self->$att2($class->$att2() || $class->moniker);
            # Why the moniker?
		}

		while (my ($att, $val) = each %$args) {
			if (ref($val) eq "ARRAY") {
				my $meth = "add_$att";
				$self->$meth(@$val);
			} else {
				$self->$att($val);
			}
		}
		return $self;
	};
}

1;