lib/tool/scm/config_file_subs.pm

   1 # {{{ include statements
   2 start include statements
   3 use ext::Config::Tiny;
   4 use debug;
   5 end include statements
   6 # }}}
   7
   8 # {{{ new
   9
  10 start new
  11     {
  12       unless( defined $this -> {'file'} ){
  13         'debug' -> die( message => 'You must give a "file" argument to config_file -> new' );
  14       }
  15       my %valid_scalar_options;
  16       my %valid_array_options;
  17       my %valid_hash_options;
  18       my %valid_code_options;
  19       # Get the types of the possible options.
  20       foreach my $key ( keys %{$this} ){
  21         if( ref( $this -> {$key} ) eq 'SCALAR' ) {
  22 #         print "Found a valid scalar option: $key\n";
  23           if( ${$this -> {$key}} ne '' ){
  24             $valid_scalar_options{$key} = $this -> {$key};
  25           } else {
  26             $valid_scalar_options{$key} = 1;
  27           }
  28           $this -> {$key} = undef;
  29         } elsif( ref( $this -> {$key} ) eq 'ARRAY' ) {
  30 #         print "Found a valid array option $key\n";
  31           $valid_array_options{$key} = 1;
  32           $this -> {$key} = undef;
  33         } elsif( ref( $this -> {$key} ) eq 'HASH' ) {
  34 #         print "Found a valid hash option $key\n";
  35           if( keys %{ $this -> {$key} } > 0 ){
  36             my @list = keys %{ $this -> {$key} };
  37             if( $list[0] eq 'ARRAY' ){
  38               $valid_hash_options{$key} = 'ARRAY';
  39             } else {
  40               'debug' -> warn ( level => 2,message => "Type specification of $key is wierd\n" );
  41             }
  42           } else {
  43             $valid_hash_options{$key} = 'SCALAR';
  44           }
  45           $this -> {$key} = undef;
  46         } elsif( ref( $this -> {$key} ) eq 'CODE' ){
  47           $valid_code_options{$key} = 1;
  48           $this -> {$key} = undef;
  49         }
  50       }
  51       $this -> {'valid_scalar_options'} = \%valid_scalar_options;
  52       $this -> {'valid_array_options'} = \%valid_array_options;
  53       $this -> {'valid_hash_options'} = \%valid_hash_options;
  54       $this -> {'valid_code_options'} = \%valid_code_options;
  55
  56       my $string;
  57       open( FILE, $this -> file -> full_name );
  58       while( <FILE> ){
  59         s/\s*\\\s*$/\\/;
  60         s/[\t\r\f]*//g;
  61         s/^\s*//;
  62         $string .= $_ ;
  63       }
  64       close( FILE );
  65
  66       my $config_tiny = ext::Config::Tiny -> read_string( $string );
  67
  68       unless( defined $config_tiny ){
  69         'debug' -> die( message => "In configuration file [ " . $this -> file -> name . " ]: " . $ext::Config::Tiny::errstr );
  70       }
  71
  72       # Force config_tiny to lowercase
  73       foreach my $section ( keys %{$config_tiny} ){
  74         my %new_section = %{$config_tiny -> {$section}};
  75         if( $section eq '_' ){
  76           foreach my $option ( keys %{$config_tiny -> {$section}} ) {
  77             my $value = $config_tiny -> { $section } -> { $option };
  78             $new_section{ lc($option) } = $value;
  79           }
  80         }
  81         delete $config_tiny -> { $section };
  82         $config_tiny -> { lc( $section ) } = \%new_section ;
  83       }
  84
  85       # Check for the three main section.
  86       foreach my $section( 'test_relations' ){
  87         unless( defined $config_tiny -> {$section} ){
  88           'debug' -> die( message => "scm::config_file -> new: No [$section] section found." );
  89         } else {
  90           unless( scalar( keys( %{$config_tiny -> {$section}} ) ) > 0 ){
  91             'debug' -> die( message => "scm::config_file -> new: Section [$section] found empty" );
  92           }
  93         }
  94       }
  95
  96       $this -> parse_config( config_tiny => $config_tiny );
  97     }
  98 end new
  99
 100 # }}}
 101
 102 # {{{ parse_config
 103
 104 start parse_config
 105     {
 106       foreach my $section ( keys %{$config_tiny} ) {
 107
 108         if( $self -> {'valid_hash_options'}{$section} eq 'ARRAY' ){
 109
 110           foreach my $left_side( keys %{$config_tiny -> {$section}} ){
 111             my $right_side = $config_tiny -> {$section} -> {$left_side};
 112
 113             if( $section eq 'code' ){
 114               $right_side =~ s/\\/\n/g;
 115             } else {
 116               $right_side =~ s/\\//g;
 117             }
 118
 119             my @right_side_list;
 120             @right_side_list = split( /,/ , $right_side );
 121
 122             my @left_side_list;
 123             @left_side_list = split( /,/ , $left_side );
 124
 125             foreach my $left ( @left_side_list ){
 126               push(@{$self -> {$section} -> {$left}},@right_side_list);
 127             }
 128           }
 129
 130         } elsif ( $self -> {'valid_hash_options'}{$section} eq 'SCALAR' ) {
 131
 132           foreach my $left_side( keys %{$config_tiny -> {$section}} ){
 133             my $right_side = $config_tiny -> {$section} -> {$left_side};
 134
 135             $right_side =~ s/\\//g;
 136
 137             my @left_side_list;
 138             @left_side_list = split( /,/ , $left_side );
 139
 140             foreach my $left ( @left_side_list ){
 141               $self -> {$section} -> {$left} = $right_side;
 142             }
 143           }
 144
 145         } elsif( $section eq '_' ){
 146
 147           foreach my $option ( keys %{$config_tiny -> { $section }} ){
 148             if( $self -> {'valid_scalar_options'}{$option} ){
 149
 150               my $value = $config_tiny -> { $section } -> {$option};
 151               if( $self -> {'valid_scalar_options'}{$option} != 1 ){
 152                 my $success = 0;
 153                 foreach my $valid_values( split( /,/, ${$self -> {'valid_scalar_options'}{$option}} ) ){
 154                   if( $valid_values eq $value ){
 155                     $success = 1;
 156                     last;
 157                   }
 158                 }
 159                 unless( $success ){
 160                   'debug' -> die( message => "Invalid value for option $option: \"$value\". Valid values of $option is one of: " . ${$self -> {'valid_scalar_options'}{$option}} );
 161                 }
 162               }
 163
 164               $self -> { $option } = $config_tiny -> {$section} -> {$option};
 165
 166             } elsif( $self -> {'valid_array_options'}{$option} ) {
 167               my $value = $config_tiny -> { $section } -> {$option};
 168               $value =~ s/\s*//g;
 169               @{$self -> {$option}} = split( /,/ , $value );
 170             } elsif( $self -> {'valid_code_options'}{$option} ){
 171               $self -> {$option} = eval $config_tiny -> {$section} -> {$option};
 172             } else {
 173               'debug' -> die( message => "Found invalid option: $option\n" );
 174             }
 175           }
 176
 177         } else {
 178           'debug' -> die( message => "Found invalid section: $section" );
 179         }
 180       }
 181
 182       $self -> _check_included_relations;
 183       $self -> _check_various( header => 'upper_bounds', master => 'bounds', slave => 'upper' );
 184       $self -> _check_various( header => 'lower_bounds', master => 'bounds', slave => 'lower' );
 185       $self -> _check_various( header => 'code', master => 'code' );
 186       $self -> _check_various( header => 'inits', master => 'inits' );
 187
 188     }
 189 end parse_config
 190
 191 # }}}
 192
 193
 194 # {{{ _check_included_relations
 195 start _check_included_relations
 196 {
 197   if( defined $self -> {'included_relations'} ){
 198     foreach my $parameter ( keys %{$self -> {'included_relations'}} ){
 199       my $new_parameter_hash;
 200       foreach(my $i; $i < scalar @{$self -> {'included_relations'} -> {$parameter}}; $i++ ){
 201         my $cov_state = @{$self -> {'included_relations'} -> {$parameter}}[$i];
 202         if( $cov_state =~ /^\s*(\w+)-(\d+)\s*$/ ){
 203 #         unless( $2 >= 1 and $2 <=3 ){
 204 #           'debug' -> die( message => "Invalid state for parameter-covariate relation: \"$parameter-$1\". State is either 1,2 or 3." );
 205 #         }
 206           $new_parameter_hash -> {$1} -> {'state'} = $2;
 207         } else {
 208           # Default state value is 2. ( Linearly included )
 209           $new_parameter_hash -> {$cov_state} -> {'state'} = 2;
 210         }
 211       }
 212       delete $self -> {'included_relations'} -> {$parameter};
 213       %{$self -> {'included_relations'} -> {$parameter}} = %{$new_parameter_hash};
 214     }
 215   }
 216 }
 217 end _check_included_relations
 218 # }}}
 219
 220 # {{{ _check_various
 221 start _check_various
 222 {
 223   if( defined $self -> {$header} ){
 224     # If header is specified.
 225     foreach my $parmcov ( keys %{$self -> {$header }} ){
 226       # Loop over parmcov settings.
 227       if( $parmcov =~ /^\s*(\*|\w+):(\*|\w+)-(\d+)\s*$/ ){
 228         # If left side has correct form. With state spec.
 229         my @bounds = @{$self -> {$header } -> {$parmcov}};
 230         my $parm = $1;
 231         my $cov = $2;
 232         my $state = $3;
 233         my @parms;
 234         my @covs;
 235
 236         if( $parm eq '*' ){
 237           if( $cov eq '*' ){
 238             if( defined $self -> {'test_relations' } ){
 239               @parms = keys %{$self -> {'test_relations'}};
 240             }
 241           } else {
 242
 243             foreach my $parameter( keys %{$self -> {'test_relations'}} ){
 244               if( defined $self -> {'test_relations'} -> {$parameter} ){
 245                 foreach my $covariate( @{$self -> {'test_relations'} -> {$parameter}} ){
 246                   if( $cov eq $covariate ){
 247                     push( @parms, $parameter );
 248                   }
 249                 }
 250               }
 251             }
 252
 253           }
 254         } else {
 255           @parms = ($parm);
 256         }
 257
 258         if( $cov eq '*' ){
 259           foreach my $parameter( @parms ){
 260             if( defined $self -> {'test_relations'} -> {$parameter} ){
 261               push(@covs, @{$self -> {'test_relations'} -> {$parameter}});
 262             }
 263           }
 264         } else {
 265           @covs = ($cov);
 266         }
 267         foreach my $parameter( @parms ){
 268           foreach my $covariate( @covs ){
 269             if( ($parm eq '*' or $cov eq '*') ) {
 270
 271               if( length( $slave ) > 0 ){
 272                 unless( exists $self -> {'relations'} -> {$parameter} and
 273                         exists $self -> {'relations'} -> {$parameter} -> {$covariate} and
 274                         exists $self -> {'relations'} -> {$parameter} -> {$covariate} -> {$master} and
 275                         exists $self -> {'relations'} -> {$parameter} -> {$covariate} -> {$master} -> {$state} and
 276                         exists $self -> {'relations'} -> {$parameter} -> {$covariate} -> {$master} -> {$state} -> {$slave} ){
 277                   @{$self -> {'relations'} -> {$parameter} -> {$covariate} -> {$master} -> {$state} -> {$slave}} = @bounds;
 278                 }
 279               } else {
 280                 unless( exists $self -> {'relations'} -> {$parameter} and
 281                         exists $self -> {'relations'} -> {$parameter} -> {$covariate} and
 282                         exists $self -> {'relations'} -> {$parameter} -> {$covariate} -> {$master} and
 283                         exists $self -> {'relations'} -> {$parameter} -> {$covariate} -> {$master} -> {$state} ){
 284                   @{$self -> {'relations'} -> {$parameter} -> {$covariate} -> {$master} -> {$state}} = @bounds;
 285                 }
 286               }
 287             } else {
 288               if( length( $slave ) > 0 ){
 289                 @{$self -> {'relations'} -> {$parameter} -> {$covariate} -> {$master} -> {$state} -> {$slave}} = @bounds;
 290               } else {
 291                 @{$self -> {'relations'} -> {$parameter} -> {$covariate} -> {$master} -> {$state}} = @bounds;
 292               }
 293             }
 294
 295             # This is a hack to smack a linefeed at the end of code.
 296             if( $master eq 'code' ){
 297               if( defined $self -> {'relations'} -> {$parameter} -> {$covariate} -> {$master} -> {$state} ){
 298                 my $code = @{$self -> {'relations'} -> {$parameter} -> {$covariate} -> {$master} -> {$state}}[0];
 299                 #print $code;
 300                 @{$self -> {'relations'} -> {$parameter} -> {$covariate} -> {$master} -> {$state}} = split( /\n/, $code );
 301               }
 302             }
 303           }
 304         }
 305
 306       } else {
 307         # If left side has wrong form. Die with help full message
 308         'debug' -> die( message => "Invalid left side: $parmcov . Format is PARAMETER:COV-STATE\n" );
 309       }
 310     }
 311   }
 312 }
 313 end _check_various
 314 # }}}
 315
 316
 317 # {{{ parameters
 318 start parameters
 319     {
 320       @parameters = keys %{$self -> {'test_relations'}};
 321     }
 322 end parameters
 323 # }}}