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