File Coverage

lib/Class/STL/ClassMembers/DataMember.pm

Criterion	Covered	Total	%
statement	103	141	73.0
branch	26	48	54.1
condition	3	11	27.2
subroutine	18	25	72.0
pod	0	15	0.0
total	150	240	62.5

# vim:ts=4 sw=4
# ----------------------------------------------------------------------------------------------------
#  Name		: Class::STL::ClassMembers::DataMember.pm
#  Created	: 27 April 2006
#  Author	: Mario Gaffiero (gaffie)
#
# Copyright 2006-2007 Mario Gaffiero.
#
# This file is part of Class::STL::Containers(TM).
#
# Class::STL::Containers is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# Class::STL::Containers is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with Class::STL::Containers; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
# ----------------------------------------------------------------------------------------------------
# Modification History
# When          Version     Who     What
# ----------------------------------------------------------------------------------------------------
# TO DO:
# ----------------------------------------------------------------------------------------------------
require 5.005_62;
use strict;
use warnings;
use vars qw( $VERSION $BUILD );
$VERSION = '0.26';
$BUILD = 'Monday May 15 23:08:34 GMT 2006';
# ----------------------------------------------------------------------------------------------------
{
	package Class::STL::ClassMembers::DataMember;
	use Carp qw(confess);
	sub new
	{
		my $proto = shift;
		return $_[0]->clone() if (ref($_[0]) && $_[0]->isa(__PACKAGE__));
		my $class = ref($proto) || $proto;
		my $self = {};
		bless($self, $class);
		$self->members_init(_caller => (caller())[0], @_);
		return $self;
	}
	sub code_meminit
	{
		my $self = shift;
		my $n = $self->name();
		return defined($self->default())
			? "\$self->$n(exists(\$p{'$n'}) ? \$p{'$n'} : '@{[ $self->default() ]}');"
			: "\$self->$n(\$p{'$n'}) if (exists(\$p{'$n'}));";
	}
	sub code_memaccess
	{
		my $self = shift;
		my $member = shift;
		my $n = $self->name();
#<		my $c = $self->_caller_str();
		my $tab = ' ' x 4;
		my $code = "sub $n { # Data Member\n";
		$code .= "${tab}my \$self = shift;\n";
		$code .= "${tab}use Carp qw(confess);\n";
		$code .= "${tab}my \$v = shift;\n";
		$code .= "${tab}if (defined(\$v) && ref(\$v) eq 'ARRAY') {\n";
		$code .= "${tab}${tab}\$self->{@{[ uc($n) ]}} = [];\n";
		$code .= "${tab}${tab}foreach (\@{\$v}) {\n";
		if (defined($self->validate())) {
			$code .= "${tab}${tab}${tab}confess \"**Field '$n' value '\$_' failed validation ('\" . '@{[ $self->validate() ]}' . \"')\"\n";
			$code .= "${tab}${tab}${tab}${tab}unless (!defined(\$_) || \$_ =~ /@{[ $self->validate() ]}/);\n";
		}
		$code .= "${tab}${tab}${tab}push(\@{\$self->{@{[ uc($n) ]}}}, ref(\$_) && \$_->can('clone') ? \$_->clone() : \$_);\n";
		$code .= "${tab}${tab}}\n";
		$code .= "${tab}}\n";

		$code .= "${tab}else {\n";

		if (defined($self->validate())) {
			$code .= "${tab}${tab}confess \"**Field '$n' value '\$v' failed validation ('\" . '@{[ $self->validate() ]}' . \"')\"\n";
			$code .= "${tab}${tab}${tab}unless (!defined(\$v) || \$v =~ /@{[ $self->validate() ]}/);\n";
		}
		$code .= "${tab}${tab}\$self->{@{[ uc($n) ]}} = \$v if (defined(\$v));\n";
		$code .= "${tab}}\n";

		$code .= "${tab}return \$self->{@{[ uc($n) ]}};\n";
		$code .= "}\n";
		return $code;
	}
	sub code_memattr
	{
		my $self = shift;
		my $code = "@{[ $self->name() ]} => [ "
			. "'@{[ defined($self->default()) ? $self->default() : q## ]}', "
			. "'@{[ defined($self->validate()) ? $self->validate() : q## ]}',"
			. "'@{[ ref($self) ]}'"
			. " ]";
		return $code;
	}
	sub code_memdata
	{
		my $self = shift;
		return "@{[ $self->name() ]} => \$self->{@{[ uc($self->name()) ]}}";
	}
	sub _caller_str
	{
		my $self = shift;
		my $str = $self->_caller();
		$str =~ s/[:]+/_/g;
		return $str;
	}
	sub name {
		my $self = shift;
		$self->{NAME} = shift if (@_);
		return $self->{NAME};
	}
	sub default {
		my $self = shift;
		$self->{DEFAULT} = shift if (@_);
		return $self->{DEFAULT};
	}
	sub validate {
		my $self = shift;
		$self->{VALIDATE} = shift if (@_);
		return $self->{VALIDATE};
	}
	sub _caller {
		my $self = shift;
		$self->{_CALLER} = shift if (@_);
		return $self->{_CALLER};
	}
	sub members_init {
		my $self = shift;
		use vars qw(@ISA);
		if (int(@ISA) && (caller())[0] ne __PACKAGE__) {
			$self->SUPER::members_init(@_);
		}
		my @p;
		while (@_) { my $p=shift; push(@p, $p, shift) if (!ref($p)); }
		my %p = @p;
		$self->name($p{'name'}) if (exists($p{'name'}));
		$self->default($p{'default'}) if (exists($p{'default'}));
		$self->validate($p{'validate'}) if (exists($p{'validate'}));
		$self->_caller($p{'_caller'}) if (exists($p{'_caller'}));
	}
	sub member_print {
		my $self = shift;
		my $delim = shift || '|';
		return join("$delim",
			"name=@{[ defined($self->name()) ? $self->name() : 'NULL' ]}",
			"default=@{[ defined($self->default()) ? $self->default() : 'NULL' ]}",
			"validate=@{[ defined($self->validate()) ? $self->validate() : 'NULL' ]}",
			"_caller=@{[ defined($self->_caller()) ? $self->_caller() : 'NULL' ]}",
		);
	}
	sub members_local { # static function
		return {
			name=>[ ],
			default=>[ ],
			validate=>[ ],
			_caller=>[ ],
		};
	}
	sub members {
		my $self = shift;
		use vars qw(@ISA);
		my $super = (int(@ISA)) ? $self->SUPER::members() : {};
		return keys(%$super)
		? {
			%$super,
			name=>[ ],
			default=>[ ],
			validate=>[ ],
			_caller=>[ ],
		}
		: {
			name=>[ ],
			default=>[ ],
			validate=>[ ],
			_caller=>[ ],
		};
	}
	sub swap {
		my $self = shift;
		my $other = shift;
		use vars qw(@ISA);
		my $tmp = $self->clone();
		$self->SUPER::swap($other) if (int(@ISA));
		$self->name($other->name());
		$self->default($other->default());
		$self->validate($other->validate());
		$self->_caller($other->_caller());
		$other->name($tmp->name());
		$other->default($tmp->default());
		$other->validate($tmp->validate());
		$other->_caller($tmp->_caller());
	}
	sub clone {
		my $self = shift;
		use vars qw(@ISA);
		my $clone = int(@ISA) ? $self->SUPER::clone() : $self->new();
		$clone->name($self->name());
		$clone->default($self->default());
		$clone->validate($self->validate());
		$clone->_caller($self->_caller());
		return $clone;
	}
	sub undefine {
		my $self = shift;
		map($self->{"@{[ uc($_) ]}"} = undef, @_);
	}
}
1;