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


line stmt bran cond sub pod time code
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             # ----------------------------------------------------------------------------------------------------
29             require 5.005_62;
30 7     7   38 use strict;
  7         14  
  7         172  
31 7     7   33 use warnings;
  7         16  
  7         192  
32 7     7   40 use vars qw( $VERSION $BUILD );
  7         22  
  7         427  
33             $VERSION = '0.26';
34             $BUILD = 'Monday May 15 23:08:34 GMT 2006';
35             # ----------------------------------------------------------------------------------------------------
36             {
37             package Class::STL::ClassMembers::DataMember;
38 7     7   41 use Carp qw(confess);
  7         14  
  7         6837  
39             sub new
40             {
41 220     220 0 1647 my $proto = shift;
42 220 50 33     1792 return $_[0]->clone() if (ref($_[0]) && $_[0]->isa(__PACKAGE__));
43 220   33     675 my $class = ref($proto) || $proto;
44 220         391 my $self = {};
45 220         385 bless($self, $class);
46 220         970 $self->members_init(_caller => (caller())[0], @_);
47 220         643 return $self;
48             }
49             sub code_meminit
50             {
51 218     218 0 333 my $self = shift;
52 218         379 my $n = $self->name();
53 218 100       470 return defined($self->default())
54 53         98 ? "\$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 218     218 0 346 my $self = shift;
60 218         288 my $member = shift;
61 218         387 my $n = $self->name();
62             #< my $c = $self->_caller_str();
63 218         366 my $tab = ' ' x 4;
64 218         440 my $code = "sub $n { # Data Member\n";
65 218         476 $code .= "${tab}my \$self = shift;\n";
66 218         375 $code .= "${tab}use Carp qw(confess);\n";
67 218         369 $code .= "${tab}my \$v = shift;\n";
68 218         401 $code .= "${tab}if (defined(\$v) && ref(\$v) eq 'ARRAY') {\n";
69 218         359 $code .= "${tab}${tab}\$self->{@{[ uc($n) ]}} = [];\n";
  218         662  
70 218         505 $code .= "${tab}${tab}foreach (\@{\$v}) {\n";
71 218 100       423 if (defined($self->validate())) {
72 13         38 $code .= "${tab}${tab}${tab}confess \"**Field '$n' value '\$_' failed validation ('\" . '@{[ $self->validate() ]}' . \"')\"\n";
  13         48  
73 13         97 $code .= "${tab}${tab}${tab}${tab}unless (!defined(\$_) || \$_ =~ /@{[ $self->validate() ]}/);\n";
  13         29  
74             }
75 218         418 $code .= "${tab}${tab}${tab}push(\@{\$self->{@{[ uc($n) ]}}}, ref(\$_) && \$_->can('clone') ? \$_->clone() : \$_);\n";
  218         585  
76 218         499 $code .= "${tab}${tab}}\n";
77 218         336 $code .= "${tab}}\n";
78            
79 218         318 $code .= "${tab}else {\n";
80            
81 218 100       384 if (defined($self->validate())) {
82 13         31 $code .= "${tab}${tab}confess \"**Field '$n' value '\$v' failed validation ('\" . '@{[ $self->validate() ]}' . \"')\"\n";
  13         26  
83 13         31 $code .= "${tab}${tab}${tab}unless (!defined(\$v) || \$v =~ /@{[ $self->validate() ]}/);\n";
  13         23  
84             }
85 218         412 $code .= "${tab}${tab}\$self->{@{[ uc($n) ]}} = \$v if (defined(\$v));\n";
  218         532  
86 218         417 $code .= "${tab}}\n";
87            
88 218         328 $code .= "${tab}return \$self->{@{[ uc($n) ]}};\n";
  218         557  
89 218         372 $code .= "}\n";
90 218         699 return $code;
91             }
92             sub code_memattr
93             {
94 654     654 0 973 my $self = shift;
95 654         843 my $code = "@{[ $self->name() ]} => [ "
  654         1049  
96 654 100       1164 . "'@{[ defined($self->default()) ? $self->default() : q## ]}', "
97 654 100       1215 . "'@{[ defined($self->validate()) ? $self->validate() : q## ]}',"
98 654         1781 . "'@{[ ref($self) ]}'"
99             . " ]";
100 654         2185 return $code;
101             }
102             sub code_memdata
103             {
104 218     218 0 337 my $self = shift;
105 218         301 return "@{[ $self->name() ]} => \$self->{@{[ uc($self->name()) ]}}";
  218         355  
  218         395  
106             }
107             sub _caller_str
108             {
109 0     0   0 my $self = shift;
110 0         0 my $str = $self->_caller();
111 0         0 $str =~ s/[:]+/_/g;
112 0         0 return $str;
113             }
114             sub name {
115 1966     1966 0 2513 my $self = shift;
116 1966 100       3469 $self->{NAME} = shift if (@_);
117 1966         5072 return $self->{NAME};
118             }
119             sub default {
120 1137     1137 0 1522 my $self = shift;
121 1137 100       1889 $self->{DEFAULT} = shift if (@_);
122 1137         4082 return $self->{DEFAULT};
123             }
124             sub validate {
125 1194     1194 0 1604 my $self = shift;
126 1194 100       1988 $self->{VALIDATE} = shift if (@_);
127 1194         2959 return $self->{VALIDATE};
128             }
129             sub _caller {
130 220     220   296 my $self = shift;
131 220 50       521 $self->{_CALLER} = shift if (@_);
132 220         526 return $self->{_CALLER};
133             }
134             sub members_init {
135 220     220 0 339 my $self = shift;
136 7     7   48 use vars qw(@ISA);
  7         19  
  7         2449  
137 220 50 33     517 if (int(@ISA) && (caller())[0] ne __PACKAGE__) {
138 0         0 $self->SUPER::members_init(@_);
139             }
140 220         393 my @p;
141 220 50       430 while (@_) { my $p=shift; push(@p, $p, shift) if (!ref($p)); }
  670         896  
  670         1621  
142 220         726 my %p = @p;
143 220 50       799 $self->name($p{'name'}) if (exists($p{'name'}));
144 220 100       512 $self->default($p{'default'}) if (exists($p{'default'}));
145 220 100       433 $self->validate($p{'validate'}) if (exists($p{'validate'}));
146 220 50       560 $self->_caller($p{'_caller'}) if (exists($p{'_caller'}));
147             }
148             sub member_print {
149 0     0 0   my $self = shift;
150 0   0       my $delim = shift || '|';
151 0           return join("$delim",
152 0 0         "name=@{[ defined($self->name()) ? $self->name() : 'NULL' ]}",
153 0 0         "default=@{[ defined($self->default()) ? $self->default() : 'NULL' ]}",
154 0 0         "validate=@{[ defined($self->validate()) ? $self->validate() : 'NULL' ]}",
155 0 0         "_caller=@{[ defined($self->_caller()) ? $self->_caller() : 'NULL' ]}",
156             );
157             }
158             sub members_local { # static function
159             return {
160 0     0 0   name=>[ ],
161             default=>[ ],
162             validate=>[ ],
163             _caller=>[ ],
164             };
165             }
166             sub members {
167 0     0 0   my $self = shift;
168 7     7   52 use vars qw(@ISA);
  7         19  
  7         1047  
169 0 0         my $super = (int(@ISA)) ? $self->SUPER::members() : {};
170 0 0         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 0     0 0   my $self = shift;
187 0           my $other = shift;
188 7     7   41 use vars qw(@ISA);
  7         14  
  7         796  
189 0           my $tmp = $self->clone();
190 0 0         $self->SUPER::swap($other) if (int(@ISA));
191 0           $self->name($other->name());
192 0           $self->default($other->default());
193 0           $self->validate($other->validate());
194 0           $self->_caller($other->_caller());
195 0           $other->name($tmp->name());
196 0           $other->default($tmp->default());
197 0           $other->validate($tmp->validate());
198 0           $other->_caller($tmp->_caller());
199             }
200             sub clone {
201 0     0 0   my $self = shift;
202 7     7   37 use vars qw(@ISA);
  7         19  
  7         973  
203 0 0         my $clone = int(@ISA) ? $self->SUPER::clone() : $self->new();
204 0           $clone->name($self->name());
205 0           $clone->default($self->default());
206 0           $clone->validate($self->validate());
207 0           $clone->_caller($self->_caller());
208 0           return $clone;
209             }
210             sub undefine {
211 0     0 0   my $self = shift;
212 0           map($self->{"@{[ uc($_) ]}"} = undef, @_);
  0            
213             }
214             }
215             1;