1# vim:ts=4 sw=4
2# ----------------------------------------------------------------------------------------------------
3#  Name		: Class::STL::ClassMembers::DataMember.pm
4#  Created	: 27 April 2006
5#  Author	: Mario Gaffiero (gaffie)
6#
7# Copyright 2006-2007 Mario Gaffiero.
8#
9# This file is part of Class::STL::Containers(TM).
10#
11# Class::STL::Containers is free software; you can redistribute it and/or modify
12# it under the terms of the GNU General Public License as published by
13# the Free Software Foundation; version 2 of the License.
14#
15# Class::STL::Containers is distributed in the hope that it will be useful,
16# but WITHOUT ANY WARRANTY; without even the implied warranty of
17# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18# GNU General Public License for more details.
19#
20# You should have received a copy of the GNU General Public License
21# along with Class::STL::Containers; if not, write to the Free Software
22# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
23# ----------------------------------------------------------------------------------------------------
24# Modification History
25# When          Version     Who     What
26# ----------------------------------------------------------------------------------------------------
27# TO DO:
28# ----------------------------------------------------------------------------------------------------
29require 5.005_62;
30use strict;
31use warnings;
32use vars qw( $VERSION $BUILD );
33$VERSION = '0.26';
34$BUILD = 'Monday May 15 23:08:34 GMT 2006';
35# ----------------------------------------------------------------------------------------------------
36{
37	package Class::STL::ClassMembers::DataMember;
38	use Carp qw(confess);
39	sub new
40	{
41		my $proto = shift;
42		return $_[0]->clone() if (ref($_[0]) && $_[0]->isa(__PACKAGE__));
43		my $class = ref($proto) || $proto;
44		my $self = {};
45		bless($self, $class);
46		$self->members_init(_caller => (caller())[0], @_);
47		return $self;
48	}
49	sub code_meminit
50	{
51		my $self = shift;
52		my $n = $self->name();
53		return defined($self->default())
54			? "\$self->$n(exists(\$p{'$n'}) ? \$p{'$n'} : '@{[ $self->default() ]}');"
55			: "\$self->$n(\$p{'$n'}) if (exists(\$p{'$n'}));";
56	}
57	sub code_memaccess
58	{
59		my $self = shift;
60		my $member = shift;
61		my $n = $self->name();
62#<		my $c = $self->_caller_str();
63		my $tab = ' ' x 4;
64		my $code = "sub $n { # Data Member\n";
65		$code .= "${tab}my \$self = shift;\n";
66		$code .= "${tab}use Carp qw(confess);\n";
67		$code .= "${tab}my \$v = shift;\n";
68		$code .= "${tab}if (defined(\$v) && ref(\$v) eq 'ARRAY') {\n";
69		$code .= "${tab}${tab}\$self->{@{[ uc($n) ]}} = [];\n";
70		$code .= "${tab}${tab}foreach (\@{\$v}) {\n";
71		if (defined($self->validate())) {
72			$code .= "${tab}${tab}${tab}confess \"**Field '$n' value '\$_' failed validation ('\" . '@{[ $self->validate() ]}' . \"')\"\n";
73			$code .= "${tab}${tab}${tab}${tab}unless (!defined(\$_) || \$_ =~ /@{[ $self->validate() ]}/);\n";
74		}
75		$code .= "${tab}${tab}${tab}push(\@{\$self->{@{[ uc($n) ]}}}, ref(\$_) && \$_->can('clone') ? \$_->clone() : \$_);\n";
76		$code .= "${tab}${tab}}\n";
77		$code .= "${tab}}\n";
78
79		$code .= "${tab}else {\n";
80
81		if (defined($self->validate())) {
82			$code .= "${tab}${tab}confess \"**Field '$n' value '\$v' failed validation ('\" . '@{[ $self->validate() ]}' . \"')\"\n";
83			$code .= "${tab}${tab}${tab}unless (!defined(\$v) || \$v =~ /@{[ $self->validate() ]}/);\n";
84		}
85		$code .= "${tab}${tab}\$self->{@{[ uc($n) ]}} = \$v if (defined(\$v));\n";
86		$code .= "${tab}}\n";
87
88		$code .= "${tab}return \$self->{@{[ uc($n) ]}};\n";
89		$code .= "}\n";
90		return $code;
91	}
92	sub code_memattr
93	{
94		my $self = shift;
95		my $code = "@{[ $self->name() ]} => [ "
96			. "'@{[ defined($self->default()) ? $self->default() : q## ]}', "
97			. "'@{[ defined($self->validate()) ? $self->validate() : q## ]}',"
98			. "'@{[ ref($self) ]}'"
99			. " ]";
100		return $code;
101	}
102	sub code_memdata
103	{
104		my $self = shift;
105		return "@{[ $self->name() ]} => \$self->{@{[ uc($self->name()) ]}}";
106	}
107	sub _caller_str
108	{
109		my $self = shift;
110		my $str = $self->_caller();
111		$str =~ s/[:]+/_/g;
112		return $str;
113	}
114	sub name {
115		my $self = shift;
116		$self->{NAME} = shift if (@_);
117		return $self->{NAME};
118	}
119	sub default {
120		my $self = shift;
121		$self->{DEFAULT} = shift if (@_);
122		return $self->{DEFAULT};
123	}
124	sub validate {
125		my $self = shift;
126		$self->{VALIDATE} = shift if (@_);
127		return $self->{VALIDATE};
128	}
129	sub _caller {
130		my $self = shift;
131		$self->{_CALLER} = shift if (@_);
132		return $self->{_CALLER};
133	}
134	sub members_init {
135		my $self = shift;
136		use vars qw(@ISA);
137		if (int(@ISA) && (caller())[0] ne __PACKAGE__) {
138			$self->SUPER::members_init(@_);
139		}
140		my @p;
141		while (@_) { my $p=shift; push(@p, $p, shift) if (!ref($p)); }
142		my %p = @p;
143		$self->name($p{'name'}) if (exists($p{'name'}));
144		$self->default($p{'default'}) if (exists($p{'default'}));
145		$self->validate($p{'validate'}) if (exists($p{'validate'}));
146		$self->_caller($p{'_caller'}) if (exists($p{'_caller'}));
147	}
148	sub member_print {
149		my $self = shift;
150		my $delim = shift || '|';
151		return join("$delim",
152			"name=@{[ defined($self->name()) ? $self->name() : 'NULL' ]}",
153			"default=@{[ defined($self->default()) ? $self->default() : 'NULL' ]}",
154			"validate=@{[ defined($self->validate()) ? $self->validate() : 'NULL' ]}",
155			"_caller=@{[ defined($self->_caller()) ? $self->_caller() : 'NULL' ]}",
156		);
157	}
158	sub members_local { # static function
159		return {
160			name=>[ ],
161			default=>[ ],
162			validate=>[ ],
163			_caller=>[ ],
164		};
165	}
166	sub members {
167		my $self = shift;
168		use vars qw(@ISA);
169		my $super = (int(@ISA)) ? $self->SUPER::members() : {};
170		return keys(%$super)
171		? {
172			%$super,
173			name=>[ ],
174			default=>[ ],
175			validate=>[ ],
176			_caller=>[ ],
177		}
178		: {
179			name=>[ ],
180			default=>[ ],
181			validate=>[ ],
182			_caller=>[ ],
183		};
184	}
185	sub swap {
186		my $self = shift;
187		my $other = shift;
188		use vars qw(@ISA);
189		my $tmp = $self->clone();
190		$self->SUPER::swap($other) if (int(@ISA));
191		$self->name($other->name());
192		$self->default($other->default());
193		$self->validate($other->validate());
194		$self->_caller($other->_caller());
195		$other->name($tmp->name());
196		$other->default($tmp->default());
197		$other->validate($tmp->validate());
198		$other->_caller($tmp->_caller());
199	}
200	sub clone {
201		my $self = shift;
202		use vars qw(@ISA);
203		my $clone = int(@ISA) ? $self->SUPER::clone() : $self->new();
204		$clone->name($self->name());
205		$clone->default($self->default());
206		$clone->validate($self->validate());
207		$clone->_caller($self->_caller());
208		return $clone;
209	}
210	sub undefine {
211		my $self = shift;
212		map($self->{"@{[ uc($_) ]}"} = undef, @_);
213	}
214}
2151;
216