File Coverage

lib/Class/STL/ClassMembers.pm

Criterion	Covered	Total	%
statement	1145	2055	55.7
branch	214	718	29.8
condition	84	327	25.6
subroutine	272	508	53.5
pod	0	40	0.0
total	1715	3648	47.0

# vim:ts=4 sw=4
# ----------------------------------------------------------------------------------------------------
#  Name		: Class::STL::ClassMembers.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;
	use UNIVERSAL qw(isa can);
	use Carp qw(confess);
	use Class::STL::Trace;
	sub import
	{
		my $proto = shift;
		my $class = ref($proto) || $proto;
		my $self = {};
		bless($self, $class);
		$self->_caller((caller())[0]);
		$self->_trace(Class::STL::Trace->new(debug_on => 0));
		$self->{MEMBERS} = { };
		$self->_members(grep(!ref($_) || (ref($_) && !$_->isa('Class::STL::ClassMembers::FunctionMember::Abstract')), @_));
		$self->_code([]);
		push(@{$self->_code()},
			map($_->code($self->_caller()),
				grep(ref($_) && $_->isa('Class::STL::ClassMembers::FunctionMember::Abstract'), @_)));
		$self->_prepare();
		return $self;
	}
	sub memlist
	{
		my $self = shift;
		return values(%{$self->_members()});
	}
	# ----------------------------------------------------------------------------------------------------
	# PRIVATE
	# ----------------------------------------------------------------------------------------------------
	sub _prepare
	{
		my $self = shift;
		$self->code_members_access();
		$self->code_members_init();
		$self->code_members_print();
		$self->code_members_local();
		$self->code_members_data();
		$self->code_members();
		$self->code_swap();
		$self->code_clone();
		$self->code_undefine();
#<		$self->code_factory();

		unshift(@{$self->_code()}, "{\npackage @{[ $self->_caller() ]};\n");
		push(@{$self->_code()}, "}\n");

		$self->_trace()->print($self->_caller(), join("", @{$self->_code()})) if ($self->_trace()->debug_on());
		eval(join("", @{$self->_code()}));
		confess "**Error in eval for @{[ $self->_caller() ]} ClassMembers functions creation:\n$@" if ($@);
	}
	sub _code
	{
		my $self = shift;
		$self->{CODE} = shift if (@_);
		return $self->{CODE};
	}
	sub _trace
	{
		my $self = shift;
		$self->{_TRACE} = shift if (@_);
		return $self->{_TRACE};
	}
	sub _caller
	{
		my $self = shift;
		$self->{CALLER} = shift if (@_);
		return $self->{CALLER};
	}
	sub _caller_str
	{
		my $self = shift;
		my $str = $self->_caller();
		$str =~ s/[:]+/_/g;
		return $str;
	}
	sub _members
	{
		my $self = shift;
		foreach (@_) {
			my $m = ref($_) ? $_
				: Class::STL::ClassMembers::DataMember->new(name => $_, _caller => $self->_caller());
			$self->{MEMBERS}->{$m->name()} = $m;
		}
		return $self->{MEMBERS};
	}
#>	sub code_get_set
#>	{
#>		#TODO: get() -- returns array with mebers' values
#>		#		set(, , ...) -- sets member(s) value(s)
#>	}
	sub code_members_access
	{
		my $self = shift;
		map(push(@{$self->_code()}, $_->code_memaccess($_)), values(%{$self->_members()}));
		return;
	}
	sub code_members_init
	{
		my $self = shift;
		my $tab = ' ' x 4;
		my $code = "sub members_init {\n";	# --> BUILDALL
		$code .= "${tab}my \$self = shift;\n";
		$code .= "${tab}use vars qw(\@ISA);\n";
		$code .= "${tab}if (int(\@ISA) && (caller())[0] ne __PACKAGE__) {\n";
		$code .= "${tab}${tab}\$self->SUPER::members_init(\@_);\n";
		$code .= "${tab}}\n";
		if (keys(%{$self->_members()})) {
			$code .= "${tab}my \@p;\n";
			$code .= "${tab}while (\@_) { my \$p=shift; push(\@p, \$p, shift) if (!ref(\$p)); }\n";
			$code .= "${tab}my \%p = \@p;\n";
			$code .= "${tab}@{[ join(\"\n    \", map($_->code_meminit(), values( %{$self->_members()} ))) ]}\n";
		}
		$code .= "}\n";
		push(@{$self->_code()}, $code);
		return;
	}
	sub code_members_print
	{
		my $self = shift;
		my $tab = ' ' x 4;
		my $code = "sub members_print {\n";
		$code .= "${tab}my \$self = shift;\n";
		$code .= "${tab}my \$delim = shift || '|';\n";
		if (keys(%{$self->_members()})) {
			$code .= "${tab}return join(\"\$delim\",\n${tab}${tab}";
			$code .=
				join(qq/,\n$tab$tab/,
					map
					(
						qq/"$_=\@{[ defined(\$self->$_()) ? \$self->$_() : 'NULL' ]}"/,
						sort(keys(%{$self->_members()}))
					)
				);
			$code .= "\n${tab});\n";
		} else {
			$code .= "${tab}return '';\n";
		}
		$code .= "}\n";
		push(@{$self->_code()}, $code);
		return;
	}
	sub code_members_local
	{
		my $self = shift;
		my $tab = ' ' x 4;
		my $code = "sub members_local { # static function\n";
		if (keys(%{$self->_members()})) {
			$code .= "${tab}return {\n${tab}${tab}";
			$code .= join(",\n${tab}${tab}", map($_->code_memattr(), values(%{$self->_members()})));
			$code .= "\n${tab}};\n";
		} else {
			$code .= "${tab}return {};\n";
		}
		$code .= "}\n";
		push(@{$self->_code()}, $code);
		return;
	}
	sub code_members_data
	{
		my $self = shift;
		my $tab = ' ' x 4;
		my $code = "sub memdata {\n";
		$code .= "${tab}my \$self = shift;\n";
		$code .= "${tab}use vars qw(\@ISA);\n";
		$code .= "${tab}my \$super = (int(\@ISA))";
		$code .= " ? \$self->SUPER::memdata() : {};\n";
		if (keys(%{$self->_members()})) {
			$code .= "${tab}return {\n${tab}${tab}";
			$code .= "\%\$super,\n${tab}${tab}";
			$code .= join(",\n${tab}${tab}", map($_->code_memdata(), values(%{$self->_members()})));
			$code .= "\n${tab}};\n";
		} else {
			$code .= "${tab}return {\%\$super};\n";
		}
		$code .= "}\n";
		push(@{$self->_code()}, $code);
		return;
	}
	sub code_members
	{
		my $self = shift;
		my $tab = ' ' x 4;
		my $code = "sub members {\n";
		$code .= "${tab}my \$self = shift;\n";
		$code .= "${tab}use vars qw(\@ISA);\n";
		$code .= "${tab}my \$super = (int(\@ISA))";
		$code .= " ? \$self->SUPER::members() : {};\n";
    	$code .= "${tab}return keys(\%\$super)\n${tab}? {\n${tab}${tab}";
		$code .= "\%\$super,\n${tab}${tab}";
		$code .= join(",\n${tab}${tab}", map($_->code_memattr(), values(%{$self->_members()})));
		$code .= "\n${tab}}\n";
    	$code .= "${tab}: {\n${tab}${tab}";
		$code .= join(",\n${tab}${tab}", map($_->code_memattr(), values(%{$self->_members()})));
		$code .= "\n${tab}};\n";
		$code .= "}\n";
		push(@{$self->_code()}, $code);
		return;
	}
	sub code_swap
	{
		my $self = shift;
		my $tab = ' ' x 4;
		my $code = "sub swap {\n";
		$code .= "${tab}my \$self = shift;\n";
		$code .= "${tab}my \$other = shift;\n";
		$code .= "${tab}use vars qw(\@ISA);\n";
		$code .= "${tab}my \$tmp = \$self->clone();\n";
		$code .= "${tab}\$self->SUPER\::swap(\$other) if (int(\@ISA));\n";
		if (keys(%{$self->_members()})) {
			$code .= "${tab}@{[ join(qq#\n${tab}#,
				map(qq#\$self->$_(\$other->$_());#, keys( %{$self->_members()} ) )) ]}\n";
			$code .= "${tab}@{[ join(qq#\n${tab}#,
				map(qq#\$other->$_(\$tmp->$_());#, keys( %{$self->_members()} ) )) ]}\n";
		}
		$code .= "}\n";
		push(@{$self->_code()}, $code);
		return;
	}
	sub code_clone
	{
		my $self = shift;
		my $tab = ' ' x 4;
		my $code = "sub _clone {\n";
		$code .= "${tab}my \$self = shift;\n";
		$code .= "${tab}use vars qw(\@ISA);\n";
		$code .= "${tab}my \$clone = int(\@ISA) ? \$self->SUPER\::_clone() : \$self->_new();\n";
		if (keys(%{$self->_members()})) {
			$code .= "${tab}@{[ join(qq#\n${tab}#,
				map(qq#\$clone->$_(\$self->$_());#, keys( %{$self->_members()} ) )) ]}\n";
		}
		$code .= "${tab}return \$clone;\n";
		$code .= "}\n";
		$code .= "sub clone {\n";
		$code .= "${tab}my \$self = shift;\n";
		$code .= "${tab}use vars qw(\@ISA);\n";
		$code .= "${tab}my \$clone = int(\@ISA) ? \$self->SUPER\::clone() : \$self->new();\n";
		if (keys(%{$self->_members()})) {
			$code .= "${tab}@{[ join(qq#\n${tab}#,
				map(qq#\$clone->$_(\$self->$_());#, keys( %{$self->_members()} ) )) ]}\n";
		}
		$code .= "${tab}return \$clone;\n";
		$code .= "}\n";
		push(@{$self->_code()}, $code);
		return;
	}
	sub code_undefine
	{
		my $self = shift;
		my $tab = ' ' x 4;
#<		my $c = $self->_caller_str();
		my $code = "sub undefine {\n${tab}my \$self = shift;\n";
		$code .= "${tab}map(\$self->{\"\@{[ uc(\$_) ]}\"} = undef, \@_);\n";
		$code .= "}\n";
		push(@{$self->_code()}, $code);
		return;
	}
#?	sub code_factory
#?	{
#?		my $self = shift;
#?		return unless exists ${$self->_members()}{'element_type'};
#?		my $m = $self->_members()->{'element_type'};
#?		my $tab = ' ' x 4;
#?		my $code = "sub factory {\n";
#?		$code .= "${tab}my \$self = shift;\n";
#?		$code .= "${tab}return @{[ $m->default() ]}->new(\@_);\n";
#?		$code .= "}\n";
#?		push(@{$self->_code()}, $code);
#?		return;
#?	}
}
# ----------------------------------------------------------------------------------------------------
1;