lib/Stem/Class.pm

   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 ;