Commit | Line | Data |
4536f655 |
1 | # File: Stem/Class.pm |
2 | |
3 | # This file is part of Stem. |
4 | # Copyright (C) 1999, 2000, 2001 Stem Systems, Inc. |
5 | |
6 | # Stem is free software; you can redistribute it and/or modify |
7 | # it under the terms of the GNU General Public License as published by |
8 | # the Free Software Foundation; either version 2 of the License, or |
9 | # (at your option) any later version. |
10 | |
11 | # Stem is distributed in the hope that it will be useful, |
12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of |
13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
14 | # GNU General Public License for more details. |
15 | |
16 | # You should have received a copy of the GNU General Public License |
17 | # along with Stem; if not, write to the Free Software |
18 | # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA |
19 | |
20 | # For a license to use the Stem under conditions other than those |
21 | # described here, to purchase support for this software, or to purchase a |
22 | # commercial warranty contract, please contact Stem Systems at: |
23 | |
24 | # Stem Systems, Inc. 781-643-7504 |
25 | # 79 Everett St. info@stemsystems.com |
26 | # Arlington, MA 02474 |
27 | # USA |
28 | |
29 | package Stem::Class ; |
30 | |
31 | use strict ; |
32 | |
33 | #use Data::Dumper ; |
34 | |
35 | # dispatch table for attribute 'type' checking and conversion |
36 | |
37 | my %type_to_code = ( |
38 | |
39 | 'boolean' => \&_type_boolean, |
40 | 'hash' => \&_type_hash, |
41 | 'list' => \&_type_list, |
42 | 'HoL' => \&_type_hash_of_list, |
43 | 'LoL' => \&_type_list_of_list, |
44 | 'HoH' => \&_type_hash_of_hash, |
45 | 'LoH' => \&_type_list_of_hash, |
46 | 'addr' => \&_type_address, |
47 | 'address' => \&_type_address, |
48 | 'obj' => \&_type_object, |
49 | 'object' => \&_type_object, |
50 | 'cb_object' => \&_type_object, |
51 | 'handle' => \&_type_handle, |
52 | ) ; |
53 | |
54 | sub parse_args { |
55 | |
56 | my( $attr_spec, %args_in ) = @_ ; |
57 | |
58 | my( $package ) = caller ; |
59 | |
60 | #print "PACK $package\n" ; |
61 | |
62 | my $obj = bless {}, $package ; |
63 | |
64 | #print Dumper( $attr_spec ) ; |
65 | #print "class args ", Dumper( \%args_in ) ; |
66 | |
67 | my( $cell_info_obj, $cell_info_name ) ; |
68 | |
69 | my $reg_name = $args_in{ 'reg_name' } || '' ; |
70 | |
71 | foreach my $field ( @{$attr_spec} ) { |
72 | |
73 | my $field_name = $field->{'name'} or next ; |
74 | |
75 | my $field_val = $args_in{ $field_name } ; |
76 | |
77 | if ( my $class = $field->{'class'} ) { |
78 | |
79 | # optinally force a sub-object build by passing a default empty list |
80 | # for its value |
81 | # Stem::Cell is always built |
82 | |
83 | if ( $field->{'always_create'} || |
84 | $class eq 'Stem::Cell' ) { |
85 | |
86 | $field_val ||= [] ; |
87 | } |
88 | |
89 | my @class_args ; |
90 | |
91 | if ( ref $field_val eq 'HASH' ) { |
92 | |
93 | @class_args = %{$field_val} ; |
94 | } |
95 | elsif ( ref $field_val eq 'ARRAY' ) { |
96 | |
97 | @class_args = @{$field_val} ; |
98 | } |
99 | else { |
100 | next ; |
101 | } |
102 | |
103 | my $class_args = $field->{'class_args'} ; |
104 | |
105 | if ( $class_args && ref $class_args eq 'HASH' ) { |
106 | |
107 | push( @class_args, %{$class_args} ) ; |
108 | } |
109 | elsif ( $class_args && ref $class_args eq 'ARRAY' ) { |
110 | |
111 | push( @class_args, @{$class_args} ) ; |
112 | } |
113 | |
114 | # Stem::Cell wants to know its owner's cell name |
115 | |
116 | push( @class_args, 'reg_name' => $reg_name ) |
117 | if $class eq 'Stem::Cell' ; |
118 | |
119 | $field_val = $class->new( @class_args ) ; |
120 | |
121 | return <<ERR unless $field_val ; |
122 | Missing attribute class object for '$field_name' for class $package |
123 | ERR |
124 | |
125 | return $field_val unless ref $field_val ; |
126 | |
127 | # track the field info for Stem::Cell for use later |
128 | |
129 | if ( $class eq 'Stem::Cell' ) { |
130 | |
131 | $cell_info_obj = $field_val ; |
132 | $cell_info_name = $field_name ; |
133 | } |
134 | } |
135 | |
136 | # handle a callback type attribute. it does all the parsing and object stuffing |
137 | # the callback should return |
138 | |
139 | if ( my $callback = $field->{'callback'} and $field_val ) { |
140 | |
141 | |
142 | my $cb_err = $callback->( $obj, |
143 | $field_name, $field_val ) ; |
144 | |
145 | return $cb_err if $cb_err ; |
146 | |
147 | next ; |
148 | } |
149 | |
150 | if ( my $env_name = $field->{'env'} ) { |
151 | |
152 | my @prefixes = ( $reg_name ) ? |
153 | ( "${reg_name}:", "${reg_name}_", '' ) : |
154 | ( '' ) ; |
155 | |
156 | foreach my $prefix ( @prefixes ) { |
157 | |
158 | #print "ENV NAME [$prefix$env_name]\n" ; |
159 | |
160 | my $env_val = |
161 | $Stem::Vars::Env{"$prefix$env_name"} ; |
162 | |
163 | next unless defined $env_val ; |
164 | |
165 | $field_val = $env_val ; |
166 | #print "ENV field $field_name [$env_val]\n" ; |
167 | last ; |
168 | } |
169 | } |
170 | |
171 | unless( defined $field_val ) { |
172 | |
173 | if ( $field->{'required'} ) { |
174 | |
175 | return <<ERR ; |
176 | Missing required field '$field_name' for class $package |
177 | ERR |
178 | } |
179 | |
180 | $field_val = $field->{'default'} |
181 | if exists $field->{'default'} ; |
182 | } |
183 | |
184 | #print "field $field_name [$field_val]\n" ; |
185 | |
186 | next unless defined $field_val ; |
187 | |
188 | if ( my $type = $field->{'type'} ) { |
189 | |
190 | my $type_code = $type_to_code{$type} ; |
191 | return "Unknown attribute type '$type'" |
192 | unless $type_code ; |
193 | |
194 | my $err = $type_code->( |
195 | \$field_val, $type, $field_name ) ; |
196 | #print "ERR $err\n" ; |
197 | return $err if $err ; |
198 | } |
199 | |
200 | $obj->{$field_name} = $field_val ; |
201 | } |
202 | |
203 | if ( $cell_info_obj ) { |
204 | |
205 | return <<ERR unless $reg_name ; |
206 | Missing 'name' in configuration for class $package. |
207 | It is required for use by Stem::Cell |
208 | ERR |
209 | |
210 | $cell_info_obj->cell_init( $obj, |
211 | $reg_name, |
212 | $cell_info_name |
213 | ) ; |
214 | } |
215 | |
216 | #print "class obj ", Dumper( $obj ) ; |
217 | |
218 | return $obj ; |
219 | } |
220 | |
221 | sub _type_boolean { |
222 | |
223 | my ( $val_ref, $type ) = @_ ; |
224 | |
225 | return if ${$val_ref} =~ s/^(?:|1|Y|Yes)$/1/i || |
226 | ${$val_ref} =~ s/^(?:|0|N|No)$/0/i ; |
227 | |
228 | return "Attribute value '${$val_ref}' is not boolean" |
229 | } |
230 | |
231 | sub _type_object { |
232 | |
233 | my ( $val_ref, $type ) = @_ ; |
234 | |
235 | return if ref ${$val_ref} ; |
236 | |
237 | return "Attribute value '${$val_ref}' is not an object" |
238 | } |
239 | |
240 | sub _type_address { |
241 | |
242 | my ( $val_ref, $type, $name ) = @_ ; |
243 | |
244 | my( $to_hub, $cell_name, $target ) = |
245 | Stem::Msg::split_address( ${$val_ref} ) ; |
246 | |
247 | return if $cell_name ; |
248 | |
249 | return "Attribute $name: value '${$val_ref}' is not a valid Stem address" |
250 | } |
251 | |
252 | sub _type_handle { |
253 | |
254 | my ( $val_ref, $type ) = @_ ; |
255 | |
256 | return if defined fileno( ${$val_ref} ) ; |
257 | |
258 | return "Attribute value '${$val_ref}' is not an open IO handle" |
259 | } |
260 | |
261 | sub _type_list { |
262 | |
263 | my ( $val_ref, $type ) = @_ ; |
264 | |
265 | my $err = _convert_to_list( $val_ref ) ; |
266 | |
267 | return unless $err ; |
268 | |
269 | return "Attribute value '${$val_ref}' is not a list\n$err" ; |
270 | } |
271 | |
272 | sub _type_hash { |
273 | |
274 | my ( $val_ref, $type ) = @_ ; |
275 | |
276 | my $err = _convert_to_hash( $val_ref ) ; |
277 | |
278 | return unless $err ; |
279 | |
280 | return "Attribute value '${$val_ref}' is not a hash\n$err" ; |
281 | } |
282 | |
283 | sub _type_list_of_list { |
284 | |
285 | my ( $val_ref, $type ) = @_ ; |
286 | |
287 | #print Dumper $val_ref ; |
288 | my $err = _convert_to_list( $val_ref ) ; |
289 | |
290 | #print Dumper $val_ref ; |
291 | |
292 | return $err if $err ; |
293 | |
294 | foreach my $sub_val ( @{$$val_ref}) { |
295 | |
296 | $err = _convert_to_list( \$sub_val ) ; |
297 | return <<ERR if $err ; |
298 | Attribute's secondary value '$sub_val' can't be converted to a list\n$err" ; |
299 | ERR |
300 | } |
301 | |
302 | #print Dumper $val_ref ; |
303 | |
304 | return ; |
305 | } |
306 | |
307 | sub _type_list_of_hash { |
308 | |
309 | my ( $val_ref, $type ) = @_ ; |
310 | |
311 | #print Dumper $val_ref ; |
312 | my $err = _convert_to_list( $val_ref ) ; |
313 | |
314 | #print Dumper $val_ref ; |
315 | |
316 | return $err if $err ; |
317 | |
318 | foreach my $sub_val ( @{$$val_ref}) { |
319 | |
320 | $err = _convert_to_hash( \$sub_val ) ; |
321 | return <<ERR if $err ; |
322 | Attribute's secondary value '$sub_val' can't be converted to a hash\n$err" ; |
323 | ERR |
324 | } |
325 | |
326 | #print Dumper $val_ref ; |
327 | |
328 | return ; |
329 | } |
330 | |
331 | |
332 | sub _type_hash_of_list { |
333 | |
334 | my ( $val_ref, $type ) = @_ ; |
335 | |
336 | #print Dumper $val_ref ; |
337 | my $err = _convert_to_hash( $val_ref ) ; |
338 | |
339 | #print Dumper $val_ref ; |
340 | |
341 | return $err if $err ; |
342 | |
343 | foreach my $val ( values %{$$val_ref}) { |
344 | |
345 | $err = _convert_to_list( \$val ) ; |
346 | return <<ERR if $err ; |
347 | Attribute's secondary value '$val' can't be converted to a list\n$err" ; |
348 | ERR |
349 | } |
350 | |
351 | #print Dumper $val_ref ; |
352 | |
353 | return ; |
354 | } |
355 | |
356 | sub _type_hash_of_hash { |
357 | |
358 | my ( $val_ref, $type ) = @_ ; |
359 | |
360 | #print Dumper $val_ref ; |
361 | my $err = _convert_to_hash( $val_ref ) ; |
362 | |
363 | #print Dumper $val_ref ; |
364 | |
365 | return $err if $err ; |
366 | |
367 | foreach my $val ( values %{$$val_ref}) { |
368 | |
369 | $err = _convert_to_hash( \$val ) ; |
370 | return <<ERR if $err ; |
371 | Attribute's secondary value '$val' can't be converted to a hash\n$err" ; |
372 | ERR |
373 | } |
374 | |
375 | #print Dumper $val_ref ; |
376 | |
377 | return ; |
378 | } |
379 | |
380 | sub _convert_to_list { |
381 | |
382 | my ( $val_ref ) = @_ ; |
383 | |
384 | my $val_type = ref ${$val_ref} ; |
385 | |
386 | return if $val_type eq 'ARRAY' ; |
387 | |
388 | unless ( $val_type ) { |
389 | |
390 | ${$val_ref} = [ ${$val_ref} ] ; |
391 | return ; |
392 | } |
393 | |
394 | if ( $val_type eq 'HASH' ) { |
395 | |
396 | ${$val_ref} = [ %{${$val_ref}} ] ; |
397 | return ; |
398 | } |
399 | |
400 | return 'It must be a scalar or a reference to an array or hash' ; |
401 | } |
402 | |
403 | sub _convert_to_hash { |
404 | |
405 | my ( $val_ref ) = @_ ; |
406 | |
407 | my $val_type = ref ${$val_ref} ; |
408 | |
409 | return if $val_type eq 'HASH' ; |
410 | |
411 | if ( $val_type eq 'ARRAY' ) { |
412 | |
413 | ${$val_ref} = { @{${$val_ref}} } ; |
414 | return ; |
415 | } |
416 | |
417 | return 'It must be a reference to an array or hash' ; |
418 | } |
419 | |
420 | 1 ; |