3 # This file is part of Stem.
4 # Copyright (C) 1999, 2000, 2001 Stem Systems, Inc.
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.
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.
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
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:
24 # Stem Systems, Inc. 781-643-7504
25 # 79 Everett St. info@stemsystems.com
35 # dispatch table for attribute 'type' checking and conversion
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,
56 my( $attr_spec, %args_in ) = @_ ;
58 my( $package ) = caller ;
60 #print "PACK $package\n" ;
62 my $obj = bless {}, $package ;
64 #print Dumper( $attr_spec ) ;
65 #print "class args ", Dumper( \%args_in ) ;
67 my( $cell_info_obj, $cell_info_name ) ;
69 my $reg_name = $args_in{ 'reg_name' } || '' ;
71 foreach my $field ( @{$attr_spec} ) {
73 my $field_name = $field->{'name'} or next ;
75 my $field_val = $args_in{ $field_name } ;
77 if ( my $class = $field->{'class'} ) {
79 # optinally force a sub-object build by passing a default empty list
81 # Stem::Cell is always built
83 if ( $field->{'always_create'} ||
84 $class eq 'Stem::Cell' ) {
91 if ( ref $field_val eq 'HASH' ) {
93 @class_args = %{$field_val} ;
95 elsif ( ref $field_val eq 'ARRAY' ) {
97 @class_args = @{$field_val} ;
103 my $class_args = $field->{'class_args'} ;
105 if ( $class_args && ref $class_args eq 'HASH' ) {
107 push( @class_args, %{$class_args} ) ;
109 elsif ( $class_args && ref $class_args eq 'ARRAY' ) {
111 push( @class_args, @{$class_args} ) ;
114 # Stem::Cell wants to know its owner's cell name
116 push( @class_args, 'reg_name' => $reg_name )
117 if $class eq 'Stem::Cell' ;
119 $field_val = $class->new( @class_args ) ;
121 return <<ERR unless $field_val ;
122 Missing attribute class object for '$field_name' for class $package
125 return $field_val unless ref $field_val ;
127 # track the field info for Stem::Cell for use later
129 if ( $class eq 'Stem::Cell' ) {
131 $cell_info_obj = $field_val ;
132 $cell_info_name = $field_name ;
136 # handle a callback type attribute. it does all the parsing and object stuffing
137 # the callback should return
139 if ( my $callback = $field->{'callback'} and $field_val ) {
142 my $cb_err = $callback->( $obj,
143 $field_name, $field_val ) ;
145 return $cb_err if $cb_err ;
150 if ( my $env_name = $field->{'env'} ) {
152 my @prefixes = ( $reg_name ) ?
153 ( "${reg_name}:", "${reg_name}_", '' ) :
156 foreach my $prefix ( @prefixes ) {
158 #print "ENV NAME [$prefix$env_name]\n" ;
161 $Stem::Vars::Env{"$prefix$env_name"} ;
163 next unless defined $env_val ;
165 $field_val = $env_val ;
166 #print "ENV field $field_name [$env_val]\n" ;
171 unless( defined $field_val ) {
173 if ( $field->{'required'} ) {
176 Missing required field '$field_name' for class $package
180 $field_val = $field->{'default'}
181 if exists $field->{'default'} ;
184 #print "field $field_name [$field_val]\n" ;
186 next unless defined $field_val ;
188 if ( my $type = $field->{'type'} ) {
190 my $type_code = $type_to_code{$type} ;
191 return "Unknown attribute type '$type'"
194 my $err = $type_code->(
195 \$field_val, $type, $field_name ) ;
196 #print "ERR $err\n" ;
197 return $err if $err ;
200 $obj->{$field_name} = $field_val ;
203 if ( $cell_info_obj ) {
205 return <<ERR unless $reg_name ;
206 Missing 'name' in configuration for class $package.
207 It is required for use by Stem::Cell
210 $cell_info_obj->cell_init( $obj,
216 #print "class obj ", Dumper( $obj ) ;
223 my ( $val_ref, $type ) = @_ ;
225 return if ${$val_ref} =~ s/^(?:|1|Y|Yes)$/1/i ||
226 ${$val_ref} =~ s/^(?:|0|N|No)$/0/i ;
228 return "Attribute value '${$val_ref}' is not boolean"
233 my ( $val_ref, $type ) = @_ ;
235 return if ref ${$val_ref} ;
237 return "Attribute value '${$val_ref}' is not an object"
242 my ( $val_ref, $type, $name ) = @_ ;
244 my( $to_hub, $cell_name, $target ) =
245 Stem::Msg::split_address( ${$val_ref} ) ;
247 return if $cell_name ;
249 return "Attribute $name: value '${$val_ref}' is not a valid Stem address"
254 my ( $val_ref, $type ) = @_ ;
256 return if defined fileno( ${$val_ref} ) ;
258 return "Attribute value '${$val_ref}' is not an open IO handle"
263 my ( $val_ref, $type ) = @_ ;
265 my $err = _convert_to_list( $val_ref ) ;
269 return "Attribute value '${$val_ref}' is not a list\n$err" ;
274 my ( $val_ref, $type ) = @_ ;
276 my $err = _convert_to_hash( $val_ref ) ;
280 return "Attribute value '${$val_ref}' is not a hash\n$err" ;
283 sub _type_list_of_list {
285 my ( $val_ref, $type ) = @_ ;
287 #print Dumper $val_ref ;
288 my $err = _convert_to_list( $val_ref ) ;
290 #print Dumper $val_ref ;
292 return $err if $err ;
294 foreach my $sub_val ( @{$$val_ref}) {
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" ;
302 #print Dumper $val_ref ;
307 sub _type_list_of_hash {
309 my ( $val_ref, $type ) = @_ ;
311 #print Dumper $val_ref ;
312 my $err = _convert_to_list( $val_ref ) ;
314 #print Dumper $val_ref ;
316 return $err if $err ;
318 foreach my $sub_val ( @{$$val_ref}) {
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" ;
326 #print Dumper $val_ref ;
332 sub _type_hash_of_list {
334 my ( $val_ref, $type ) = @_ ;
336 #print Dumper $val_ref ;
337 my $err = _convert_to_hash( $val_ref ) ;
339 #print Dumper $val_ref ;
341 return $err if $err ;
343 foreach my $val ( values %{$$val_ref}) {
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" ;
351 #print Dumper $val_ref ;
356 sub _type_hash_of_hash {
358 my ( $val_ref, $type ) = @_ ;
360 #print Dumper $val_ref ;
361 my $err = _convert_to_hash( $val_ref ) ;
363 #print Dumper $val_ref ;
365 return $err if $err ;
367 foreach my $val ( values %{$$val_ref}) {
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" ;
375 #print Dumper $val_ref ;
380 sub _convert_to_list {
382 my ( $val_ref ) = @_ ;
384 my $val_type = ref ${$val_ref} ;
386 return if $val_type eq 'ARRAY' ;
388 unless ( $val_type ) {
390 ${$val_ref} = [ ${$val_ref} ] ;
394 if ( $val_type eq 'HASH' ) {
396 ${$val_ref} = [ %{${$val_ref}} ] ;
400 return 'It must be a scalar or a reference to an array or hash' ;
403 sub _convert_to_hash {
405 my ( $val_ref ) = @_ ;
407 my $val_type = ref ${$val_ref} ;
409 return if $val_type eq 'HASH' ;
411 if ( $val_type eq 'ARRAY' ) {
413 ${$val_ref} = { @{${$val_ref}} } ;
417 return 'It must be a reference to an array or hash' ;