[1980] | 1 | # ------------------------------------------------------------------------------ |
---|
| 2 | # NAME |
---|
| 3 | # Fcm::CfgFile |
---|
| 4 | # |
---|
| 5 | # DESCRIPTION |
---|
| 6 | # This class is used for reading and writing FCM config files. A FCM config |
---|
| 7 | # file is a line-based text file that provides information on how to perform |
---|
| 8 | # a particular task using the FCM system. |
---|
| 9 | # |
---|
| 10 | # COPYRIGHT |
---|
| 11 | # (C) Crown copyright Met Office. All rights reserved. |
---|
| 12 | # For further details please refer to the file COPYRIGHT.txt |
---|
| 13 | # which you should have received as part of this distribution. |
---|
| 14 | # ------------------------------------------------------------------------------ |
---|
| 15 | |
---|
| 16 | package Fcm::CfgFile; |
---|
| 17 | @ISA = qw(Fcm::Base); |
---|
| 18 | |
---|
| 19 | # Standard pragma |
---|
| 20 | use warnings; |
---|
| 21 | use strict; |
---|
| 22 | |
---|
| 23 | # Standard modules |
---|
| 24 | use Carp; |
---|
| 25 | use File::Basename; |
---|
| 26 | use File::Path; |
---|
| 27 | use File::Spec; |
---|
| 28 | |
---|
| 29 | # FCM component modules |
---|
| 30 | use Fcm::Base; |
---|
| 31 | use Fcm::CfgLine; |
---|
| 32 | use Fcm::Config; |
---|
| 33 | use Fcm::Keyword; |
---|
| 34 | use Fcm::Util; |
---|
| 35 | |
---|
| 36 | # List of property methods for this class |
---|
| 37 | my @scalar_properties = ( |
---|
| 38 | 'actual_src', # actual source of configuration file |
---|
| 39 | 'lines', # list of lines, Fcm::CfgLine objects |
---|
| 40 | 'pegrev', # peg revision of configuration file |
---|
| 41 | 'src', # source of configuration file |
---|
| 42 | 'type', # type of configuration file |
---|
| 43 | 'version', # version of configuration file |
---|
| 44 | ); |
---|
| 45 | |
---|
| 46 | # Local module variables |
---|
| 47 | my $expand_type = 'bld|ext'; # config file type that needs variable expansions |
---|
| 48 | |
---|
| 49 | # ------------------------------------------------------------------------------ |
---|
| 50 | # SYNOPSIS |
---|
| 51 | # $obj = Fcm::CfgFile->new (%args); |
---|
| 52 | # |
---|
| 53 | # DESCRIPTION |
---|
| 54 | # This method constructs a new instance of the Fcm::CfgFile class. See above |
---|
| 55 | # for allowed list of properties. (KEYS should be in uppercase.) |
---|
| 56 | # ------------------------------------------------------------------------------ |
---|
| 57 | |
---|
| 58 | sub new { |
---|
| 59 | my $this = shift; |
---|
| 60 | my %args = @_; |
---|
| 61 | my $class = ref $this || $this; |
---|
| 62 | |
---|
| 63 | my $self = Fcm::Base->new (%args); |
---|
| 64 | |
---|
| 65 | bless $self, $class; |
---|
| 66 | |
---|
| 67 | for (@scalar_properties) { |
---|
| 68 | $self->{$_} = exists $args{uc ($_)} ? $args{uc ($_)} : undef; |
---|
| 69 | } |
---|
| 70 | |
---|
| 71 | return $self; |
---|
| 72 | } |
---|
| 73 | |
---|
| 74 | # ------------------------------------------------------------------------------ |
---|
| 75 | # SYNOPSIS |
---|
| 76 | # $value = $obj->X; |
---|
| 77 | # $obj->X ($value); |
---|
| 78 | # |
---|
| 79 | # DESCRIPTION |
---|
| 80 | # Details of these properties are explained in @scalar_properties. |
---|
| 81 | # ------------------------------------------------------------------------------ |
---|
| 82 | |
---|
| 83 | for my $name (@scalar_properties) { |
---|
| 84 | no strict 'refs'; |
---|
| 85 | |
---|
| 86 | *$name = sub { |
---|
| 87 | my $self = shift; |
---|
| 88 | |
---|
| 89 | if (@_) { |
---|
| 90 | $self->{$name} = $_[0]; |
---|
| 91 | } |
---|
| 92 | |
---|
| 93 | if (not defined $self->{$name}) { |
---|
| 94 | if ($name eq 'lines') { |
---|
| 95 | $self->{$name} = []; |
---|
| 96 | } |
---|
| 97 | } |
---|
| 98 | |
---|
| 99 | return $self->{$name}; |
---|
| 100 | } |
---|
| 101 | } |
---|
| 102 | |
---|
| 103 | # ------------------------------------------------------------------------------ |
---|
| 104 | # SYNOPSIS |
---|
| 105 | # $mtime = $obj->mtime (); |
---|
| 106 | # |
---|
| 107 | # DESCRIPTION |
---|
| 108 | # This method returns the modified time of the configuration file source. |
---|
| 109 | # ------------------------------------------------------------------------------ |
---|
| 110 | |
---|
| 111 | sub mtime { |
---|
| 112 | my $self = shift; |
---|
| 113 | my $mtime = undef; |
---|
| 114 | |
---|
| 115 | if (-f $self->src) { |
---|
| 116 | $mtime = (stat $self->src)[9]; |
---|
| 117 | } |
---|
| 118 | |
---|
| 119 | return $mtime; |
---|
| 120 | } |
---|
| 121 | |
---|
| 122 | # ------------------------------------------------------------------------------ |
---|
| 123 | # SYNOPSIS |
---|
| 124 | # $read = $obj->read_cfg (); |
---|
| 125 | # |
---|
| 126 | # DESCRIPTION |
---|
| 127 | # This method reads the current configuration file. It returns the number of |
---|
| 128 | # lines read from the config file, or "undef" if it fails. The result is |
---|
| 129 | # placed in the LINES array of the current instance, and can be accessed via |
---|
| 130 | # the "lines" method. |
---|
| 131 | # ------------------------------------------------------------------------------ |
---|
| 132 | |
---|
| 133 | sub read_cfg { |
---|
| 134 | my $self = shift; |
---|
| 135 | |
---|
| 136 | my @lines = $self->_get_cfg_lines; |
---|
| 137 | |
---|
| 138 | # List of CFG types that need INC declarations expansion |
---|
| 139 | my %exp_inc = (); |
---|
| 140 | for (split (/$Fcm::Config::DELIMITER_LIST/, $self->setting ('CFG_EXP_INC'))) { |
---|
| 141 | $exp_inc{uc ($_)} = 1; |
---|
| 142 | } |
---|
| 143 | |
---|
| 144 | # List of CFG labels that are reserved keywords |
---|
| 145 | my %cfg_keywords = (); |
---|
| 146 | for (split (/$Fcm::Config::DELIMITER_LIST/, $self->setting ('CFG_KEYWORD'))) { |
---|
| 147 | $cfg_keywords{$self->cfglabel ($_)} = 1; |
---|
| 148 | } |
---|
| 149 | |
---|
| 150 | # Loop each line, to separate lines into label : value pairs |
---|
| 151 | my $cont = undef; |
---|
| 152 | my $here = undef; |
---|
| 153 | for my $line_num (1 .. @lines) { |
---|
| 154 | my $line = $lines[$line_num - 1]; |
---|
| 155 | chomp $line; |
---|
| 156 | |
---|
| 157 | my $label = ''; |
---|
| 158 | my $value = ''; |
---|
| 159 | my $comment = ''; |
---|
| 160 | |
---|
| 161 | # If this line is a continuation, set $start to point to the line that |
---|
| 162 | # starts this continuation. Otherwise, set $start to undef |
---|
| 163 | my $start = defined ($cont) ? $self->lines->[$cont] : undef; |
---|
| 164 | my $warning = undef; |
---|
| 165 | |
---|
| 166 | if ($line =~ /^(\s*#.*)$/) { # comment line |
---|
| 167 | $comment = $1; |
---|
| 168 | |
---|
| 169 | } elsif ($line =~ /\S/) { # non-blank line |
---|
| 170 | if (defined $cont) { |
---|
| 171 | # Previous line has a continuation mark |
---|
| 172 | $value = $line; |
---|
| 173 | |
---|
| 174 | # Separate value and comment |
---|
| 175 | if ($value =~ s/((?:\s+|^)#\s+.*)$//) { |
---|
| 176 | $comment = $1; |
---|
| 177 | } |
---|
| 178 | |
---|
| 179 | # Remove leading spaces |
---|
| 180 | $value =~ s/^\s*\\?//; |
---|
| 181 | |
---|
| 182 | # Expand environment variables |
---|
| 183 | my $warn; |
---|
| 184 | ($value, $warn) = $self->_expand_variable ($value, 1) if $value; |
---|
| 185 | $warning .= ($warning ? ', ' : '') . $warn if $warn; |
---|
| 186 | |
---|
| 187 | # Expand internal variables |
---|
| 188 | ($value, $warn) = $self->_expand_variable ($value, 0) if $value; |
---|
| 189 | $warning .= ($warning ? ', ' : '') . $warn if $warn; |
---|
| 190 | |
---|
| 191 | # Get "line" that begins the current continuation |
---|
| 192 | my $v = $start->value . $value; |
---|
| 193 | $v =~ s/\\$//; |
---|
| 194 | $start->value ($v); |
---|
| 195 | |
---|
| 196 | } else { |
---|
| 197 | # Previous line does not have a continuation mark |
---|
| 198 | if ($line =~ /^\s*(\S+)(?:\s+(.*))?$/) { |
---|
| 199 | # Check line contains a valid label:value pair |
---|
| 200 | $label = $1; |
---|
| 201 | $value = defined ($2) ? $2 : ''; |
---|
| 202 | |
---|
| 203 | # Separate value and comment |
---|
| 204 | if ($value =~ s/((?:\s+|^)#\s+.*)$//) { |
---|
| 205 | $comment = $1; |
---|
| 206 | } |
---|
| 207 | |
---|
| 208 | # Remove trailing spaces |
---|
| 209 | $value =~ s/\s+$//; |
---|
| 210 | |
---|
| 211 | # Value begins with $HERE? |
---|
| 212 | $here = ($value =~ /\$\{?HERE\}?(?:[^A-Z_]|$)/); |
---|
| 213 | |
---|
| 214 | # Expand environment variables |
---|
| 215 | my $warn; |
---|
| 216 | ($value, $warn) = $self->_expand_variable ($value, 1) if $value; |
---|
| 217 | $warning .= ($warning ? ', ' : '') . $warn if $warn; |
---|
| 218 | |
---|
| 219 | # Expand internal variables |
---|
| 220 | ($value, $warn) = $self->_expand_variable ($value, 0) if $value; |
---|
| 221 | $warning .= ($warning ? ', ' : '') . $warn if $warn; |
---|
| 222 | } |
---|
| 223 | } |
---|
| 224 | |
---|
| 225 | # Determine whether current line ends with a continuation mark |
---|
| 226 | if ($value =~ s/\\$//) { |
---|
| 227 | $cont = scalar (@{ $self->lines }) unless defined $cont; |
---|
| 228 | |
---|
| 229 | } else { |
---|
| 230 | $cont = undef; |
---|
| 231 | } |
---|
| 232 | } |
---|
| 233 | |
---|
| 234 | if (exists $exp_inc{uc ($self->type)} and |
---|
| 235 | uc ($start ? $start->label : $label) eq $self->cfglabel ('INC') and |
---|
| 236 | not defined $cont) { |
---|
| 237 | # Current configuration file requires expansion of INC declarations |
---|
| 238 | # The start/current line is an INC declaration |
---|
| 239 | # The current line is not a continuation or is the end of the continuation |
---|
| 240 | |
---|
| 241 | # Get lines from an "include" configuration file |
---|
| 242 | my $src = ($start ? $start->value : $value); |
---|
| 243 | $src .= '@' . $self->pegrev if $here and $self->pegrev; |
---|
| 244 | |
---|
| 245 | if ($src) { |
---|
| 246 | # Invoke a new instance to read the source |
---|
| 247 | my $cfg = Fcm::CfgFile->new ( |
---|
| 248 | SRC => expand_tilde ($src), TYPE => $self->type, |
---|
| 249 | ); |
---|
| 250 | |
---|
| 251 | $cfg->read_cfg; |
---|
| 252 | |
---|
| 253 | # Add lines to the lines array in the current configuration file |
---|
| 254 | $comment = 'INC ' . $src . ' '; |
---|
| 255 | push @{$self->lines}, Fcm::CfgLine->new ( |
---|
| 256 | comment => $comment . '# Start', |
---|
| 257 | number => ($start ? $start->number : $line_num), |
---|
| 258 | src => $self->actual_src, |
---|
| 259 | warning => $warning, |
---|
| 260 | ); |
---|
| 261 | push @{ $self->lines }, @{ $cfg->lines }; |
---|
| 262 | push @{$self->lines}, Fcm::CfgLine->new ( |
---|
| 263 | comment => $comment . '# End', |
---|
| 264 | src => $self->actual_src, |
---|
| 265 | ); |
---|
| 266 | |
---|
| 267 | } else { |
---|
| 268 | push @{$self->lines}, Fcm::CfgLine->new ( |
---|
| 269 | number => $line_num, |
---|
| 270 | src => $self->actual_src, |
---|
| 271 | warning => 'empty INC declaration.' |
---|
| 272 | ); |
---|
| 273 | } |
---|
| 274 | |
---|
| 275 | } else { |
---|
| 276 | # Push label:value pair into lines array |
---|
| 277 | push @{$self->lines}, Fcm::CfgLine->new ( |
---|
| 278 | label => $label, |
---|
| 279 | value => ($label ? $value : ''), |
---|
| 280 | comment => $comment, |
---|
| 281 | number => $line_num, |
---|
| 282 | src => $self->actual_src, |
---|
| 283 | warning => $warning, |
---|
| 284 | ); |
---|
| 285 | } |
---|
| 286 | |
---|
| 287 | next if defined $cont; # current line not a continuation |
---|
| 288 | |
---|
| 289 | my $slabel = ($start ? $start->label : $label); |
---|
| 290 | my $svalue = ($start ? $start->value : $value); |
---|
| 291 | next unless $slabel; |
---|
| 292 | |
---|
| 293 | # Check config file type and version |
---|
| 294 | if (index (uc ($slabel), $self->cfglabel ('CFGFILE')) == 0) { |
---|
| 295 | my @words = split /$Fcm::Config::DELIMITER_PATTERN/, $slabel; |
---|
| 296 | shift @words; |
---|
| 297 | |
---|
| 298 | my $name = @words ? lc ($words[0]) : 'type'; |
---|
| 299 | |
---|
| 300 | if ($self->can ($name)) { |
---|
| 301 | $self->$name ($svalue); |
---|
| 302 | } |
---|
| 303 | } |
---|
| 304 | |
---|
| 305 | # Set internal variable |
---|
| 306 | $slabel =~ s/^\%//; # Remove leading "%" from label |
---|
| 307 | |
---|
| 308 | $self->config->variable ($slabel, $svalue) |
---|
| 309 | unless exists $cfg_keywords{$slabel}; |
---|
| 310 | } |
---|
| 311 | |
---|
| 312 | # Report and reset warnings |
---|
| 313 | # ---------------------------------------------------------------------------- |
---|
| 314 | for my $line (@{ $self->lines }) { |
---|
| 315 | w_report $line->format_warning if $line->warning; |
---|
| 316 | $line->warning (undef); |
---|
| 317 | } |
---|
| 318 | |
---|
| 319 | return @{ $self->lines }; |
---|
| 320 | |
---|
| 321 | } |
---|
| 322 | |
---|
| 323 | # ------------------------------------------------------------------------------ |
---|
| 324 | # SYNOPSIS |
---|
| 325 | # $rc = $obj->print_cfg ($file, [$force]); |
---|
| 326 | # |
---|
| 327 | # DESCRIPTION |
---|
| 328 | # This method prints the content of current configuration file. If no |
---|
| 329 | # argument is specified, it prints output to the standard output. If $file is |
---|
| 330 | # specified, and is a writable file name, the output is sent to the file. If |
---|
| 331 | # the file already exists, its content is compared to the current output. |
---|
| 332 | # Nothing will be written if the content is unchanged unless $force is |
---|
| 333 | # specified. Otherwise, for typed configuration files, the existing file is |
---|
| 334 | # renamed using a prefix that contains its last modified time. The method |
---|
| 335 | # returns 1 if there is no error. |
---|
| 336 | # ------------------------------------------------------------------------------ |
---|
| 337 | |
---|
| 338 | sub print_cfg { |
---|
| 339 | my ($self, $file, $force) = @_; |
---|
| 340 | |
---|
| 341 | # Count maximum number of characters in the labels, (for pretty printing) |
---|
| 342 | my $max_label_len = 0; |
---|
| 343 | for my $line (@{ $self->lines }) { |
---|
| 344 | next unless $line->label; |
---|
| 345 | my $label_len = length $line->label; |
---|
| 346 | $max_label_len = $label_len if $label_len > $max_label_len; |
---|
| 347 | } |
---|
| 348 | |
---|
| 349 | # Output string |
---|
| 350 | my $out = ''; |
---|
| 351 | |
---|
| 352 | # Append each line of the config file to the output string |
---|
| 353 | for my $line (@{ $self->lines }) { |
---|
| 354 | $out .= $line->print_line ($max_label_len - length ($line->label) + 1); |
---|
| 355 | $out .= "\n"; |
---|
| 356 | } |
---|
| 357 | |
---|
| 358 | if ($out) { |
---|
| 359 | my $old_select = select; |
---|
| 360 | |
---|
| 361 | # Open file if necessary |
---|
| 362 | if ($file) { |
---|
| 363 | # Make sure the host directory exists and is writable |
---|
| 364 | my $dirname = dirname $file; |
---|
| 365 | if (not -d $dirname) { |
---|
| 366 | print 'Make directory: ', $dirname, "\n" if $self->verbose; |
---|
| 367 | mkpath $dirname; |
---|
| 368 | } |
---|
| 369 | croak $dirname, ': cannot write to config file directory, abort' |
---|
| 370 | unless -d $dirname and -w $dirname; |
---|
| 371 | |
---|
| 372 | if (-f $file and not $force) { |
---|
| 373 | if (-r $file) { |
---|
| 374 | # Read old config file to see if content has changed |
---|
| 375 | open IN, '<', $file or croak $file, ': cannot open (', $!, '), abort'; |
---|
| 376 | my $in_lines = ''; |
---|
| 377 | while (my $line = <IN>) { |
---|
| 378 | $in_lines .= $line; |
---|
| 379 | } |
---|
| 380 | close IN or croak $file, ': cannot close (', $!, '), abort'; |
---|
| 381 | |
---|
| 382 | # Return if content is up-to-date |
---|
| 383 | if ($in_lines eq $out) { |
---|
| 384 | print 'No change in ', lc ($self->type), ' cfg: ', $file, "\n" |
---|
| 385 | if $self->verbose > 1 and $self->type; |
---|
| 386 | return 1; |
---|
| 387 | } |
---|
| 388 | } |
---|
| 389 | |
---|
| 390 | # If config file already exists, make sure it is writable |
---|
| 391 | if (-w $file) { |
---|
| 392 | if ($self->type) { |
---|
| 393 | # Existing config file writable, rename it using its time stamp |
---|
| 394 | my $mtime = (stat $file)[9]; |
---|
| 395 | my ($sec, $min, $hour, $mday, $mon, $year) = (gmtime $mtime)[0 .. 5]; |
---|
| 396 | my $timestamp = sprintf '%4d%2.2d%2.2d_%2.2d%2.2d%2.2d_', |
---|
| 397 | $year + 1900, $mon + 1, $mday, $hour, $min, $sec; |
---|
| 398 | my $oldfile = File::Spec->catfile ( |
---|
| 399 | $dirname, $timestamp . basename ($file) |
---|
| 400 | ); |
---|
| 401 | rename $file, $oldfile; |
---|
| 402 | print 'Rename existing ', lc ($self->type), ' cfg: ', |
---|
| 403 | $oldfile, "\n" if $self->verbose > 1; |
---|
| 404 | } |
---|
| 405 | |
---|
| 406 | } else { |
---|
| 407 | # Existing config file not writable, throw an error |
---|
| 408 | croak $file, ': config file not writable, abort'; |
---|
| 409 | } |
---|
| 410 | } |
---|
| 411 | |
---|
| 412 | # Open file and select file handle |
---|
| 413 | open OUT, '>', $file |
---|
| 414 | or croak $file, ': cannot open config file (', $!, '), abort'; |
---|
| 415 | select OUT; |
---|
| 416 | } |
---|
| 417 | |
---|
| 418 | # Print output |
---|
| 419 | print $out; |
---|
| 420 | |
---|
| 421 | # Close file if necessary |
---|
| 422 | if ($file) { |
---|
| 423 | select $old_select; |
---|
| 424 | close OUT or croak $file, ': cannot close config file (', $!, '), abort'; |
---|
| 425 | |
---|
| 426 | if ($self->type and $self->verbose > 1) { |
---|
| 427 | print 'Generated ', lc ($self->type), ' cfg: ', $file, "\n"; |
---|
| 428 | |
---|
| 429 | } elsif ($self->verbose > 2) { |
---|
| 430 | print 'Generated cfg: ', $file, "\n"; |
---|
| 431 | } |
---|
| 432 | } |
---|
| 433 | |
---|
| 434 | } else { |
---|
| 435 | # Warn if nothing to print |
---|
| 436 | my $warning = 'Empty configuration'; |
---|
| 437 | $warning .= ' - nothing written to file: ' . $file if $file; |
---|
| 438 | carp $warning if $self->type; |
---|
| 439 | } |
---|
| 440 | |
---|
| 441 | return 1; |
---|
| 442 | } |
---|
| 443 | |
---|
| 444 | # ------------------------------------------------------------------------------ |
---|
| 445 | # SYNOPSIS |
---|
| 446 | # @lines = $self->_get_cfg_lines (); |
---|
| 447 | # |
---|
| 448 | # DESCRIPTION |
---|
| 449 | # This internal method reads from a configuration file residing in a |
---|
| 450 | # Subversion repository or in the normal file system. |
---|
| 451 | # ------------------------------------------------------------------------------ |
---|
| 452 | |
---|
| 453 | sub _get_cfg_lines { |
---|
| 454 | my $self = shift; |
---|
| 455 | my @lines = (); |
---|
| 456 | |
---|
| 457 | my $verbose = $self->verbose; |
---|
| 458 | |
---|
| 459 | my ($src) = $self->src(); |
---|
| 460 | if ($src =~ qr{\A([A-Za-z][\w\+-\.]*):}xms) { # is a URI |
---|
| 461 | $src = Fcm::Keyword::expand($src); |
---|
| 462 | # Config file resides in a SVN repository |
---|
| 463 | # -------------------------------------------------------------------------- |
---|
| 464 | # Set URL source and version |
---|
| 465 | my $rev = 'HEAD'; |
---|
| 466 | |
---|
| 467 | # Extract version from source if it exists |
---|
| 468 | if ($src =~ s{\@ ([^\@]+) \z}{}xms) { |
---|
| 469 | $rev = $1; |
---|
| 470 | } |
---|
| 471 | |
---|
| 472 | $src = Fcm::Util::tidy_url($src); |
---|
| 473 | |
---|
| 474 | # Check whether URL is a config file |
---|
| 475 | my $rc; |
---|
| 476 | my @cmd = (qw/svn cat/, $src . '@' . $rev); |
---|
| 477 | @lines = &run_command ( |
---|
| 478 | \@cmd, METHOD => 'qx', DEVNULL => 1, RC => \$rc, ERROR => 'ignore', |
---|
| 479 | ); |
---|
| 480 | |
---|
| 481 | # Error in "svn cat" command |
---|
| 482 | if ($rc) { |
---|
| 483 | # See whether specified config file is a known type |
---|
| 484 | my %cfgname = %{ $self->setting ('CFG_NAME') }; |
---|
| 485 | my $key = uc $self->type; |
---|
| 486 | my $file = exists $cfgname{$key} ? $cfgname{$key} : ''; |
---|
| 487 | |
---|
| 488 | # If config file is a known type, specified URL may be a directory |
---|
| 489 | if ($file) { |
---|
| 490 | # Check whether a config file with a default name exists in the URL |
---|
| 491 | my $path = $src . '/' . $file; |
---|
| 492 | my @cmd = (qw/svn cat/, $path . '@' . $rev); |
---|
| 493 | |
---|
| 494 | @lines = &run_command ( |
---|
| 495 | \@cmd, METHOD => 'qx', DEVNULL => 1, RC => \$rc, ERROR => 'ignore', |
---|
| 496 | ); |
---|
| 497 | |
---|
| 498 | # Check whether a config file with a default name exists under the "cfg" |
---|
| 499 | # sub-directory of the URL |
---|
| 500 | if ($rc) { |
---|
| 501 | my $cfgdir = $self->setting (qw/DIR CFG/); |
---|
| 502 | $path = $src . '/' . $cfgdir . '/' . $file; |
---|
| 503 | my @cmd = (qw/svn cat/, $path . '@' . $rev); |
---|
| 504 | |
---|
| 505 | @lines = &run_command ( |
---|
| 506 | \@cmd, METHOD => 'qx', DEVNULL => 1, RC => \$rc, ERROR => 'ignore', |
---|
| 507 | ); |
---|
| 508 | } |
---|
| 509 | |
---|
| 510 | $src = $path unless $rc; |
---|
| 511 | } |
---|
| 512 | } |
---|
| 513 | |
---|
| 514 | if ($rc) { |
---|
| 515 | # Error in "svn cat" |
---|
| 516 | croak 'Unable to locate config file from "', $self->src, '", abort'; |
---|
| 517 | |
---|
| 518 | } else { |
---|
| 519 | # Print diagnostic, if necessary |
---|
| 520 | if ($verbose and $self->type and $self->type =~ /$expand_type/) { |
---|
| 521 | print 'Config file (', $self->type, '): ', $src; |
---|
| 522 | print '@', $rev if $rev; |
---|
| 523 | print "\n"; |
---|
| 524 | } |
---|
| 525 | } |
---|
| 526 | |
---|
| 527 | # Record the actual source location |
---|
| 528 | $self->pegrev ($rev); |
---|
| 529 | $self->actual_src ($src); |
---|
| 530 | |
---|
| 531 | } else { |
---|
| 532 | # Config file resides in the normal file system |
---|
| 533 | # -------------------------------------------------------------------------- |
---|
| 534 | my $src = $self->src; |
---|
| 535 | |
---|
| 536 | if (-d $src) { # Source is a directory |
---|
| 537 | croak 'Config file "', $src, '" is a directory, abort' if not $self->type; |
---|
| 538 | |
---|
| 539 | # Get name of the config file by looking at the type |
---|
| 540 | my %cfgname = %{ $self->setting ('CFG_NAME') }; |
---|
| 541 | my $key = uc $self->type; |
---|
| 542 | my $file = exists $cfgname{$key} ? $cfgname{$key} : ''; |
---|
| 543 | |
---|
| 544 | if ($file) { |
---|
| 545 | my $cfgdir = $self->setting (qw/DIR CFG/); |
---|
| 546 | |
---|
| 547 | # Check whether a config file with a default name exists in the |
---|
| 548 | # specified path, then check whether a config file with a default name |
---|
| 549 | # exists under the "cfg" sub-directory of the specified path |
---|
| 550 | if (-f File::Spec->catfile ($self->src, $file)) { |
---|
| 551 | $src = File::Spec->catfile ($self->src, $file); |
---|
| 552 | |
---|
| 553 | } elsif (-f File::Spec->catfile ($self->src, $cfgdir, $file)) { |
---|
| 554 | $src = File::Spec->catfile ($self->src, $cfgdir, $file); |
---|
| 555 | |
---|
| 556 | } else { |
---|
| 557 | croak 'Unable to locate config file from "', $self->src, '", abort'; |
---|
| 558 | } |
---|
| 559 | |
---|
| 560 | } else { |
---|
| 561 | croak 'Unknown config file type "', $self->type, '", abort'; |
---|
| 562 | } |
---|
| 563 | } |
---|
| 564 | |
---|
| 565 | if (-r $src) { |
---|
| 566 | open FILE, '<', $src; |
---|
| 567 | print 'Config file (', $self->type, '): ', $src, "\n" |
---|
| 568 | if $verbose and $self->type and $self->type =~ /$expand_type/; |
---|
| 569 | |
---|
| 570 | @lines = readline 'FILE'; |
---|
| 571 | close FILE; |
---|
| 572 | |
---|
| 573 | } else { |
---|
| 574 | croak 'Unable to read config file "', $src, '", abort'; |
---|
| 575 | } |
---|
| 576 | |
---|
| 577 | # Record the actual source location |
---|
| 578 | $self->actual_src ($src); |
---|
| 579 | } |
---|
| 580 | |
---|
| 581 | return @lines; |
---|
| 582 | } |
---|
| 583 | |
---|
| 584 | # ------------------------------------------------------------------------------ |
---|
| 585 | # SYNOPSIS |
---|
| 586 | # $string = $self->_expand_variable ($string, $env[, \%recursive]); |
---|
| 587 | # |
---|
| 588 | # DESCRIPTION |
---|
| 589 | # This internal method expands variables in $string. If $env is true, it |
---|
| 590 | # expands environment variables. Otherwise, it expands local variables. If |
---|
| 591 | # %recursive is set, it indicates that this method is being called |
---|
| 592 | # recursively. In which case, it must not attempt to expand a variable that |
---|
| 593 | # exists in the keys of %recursive. |
---|
| 594 | # ------------------------------------------------------------------------------ |
---|
| 595 | |
---|
| 596 | sub _expand_variable { |
---|
| 597 | my ($self, $string, $env, $recursive) = @_; |
---|
| 598 | |
---|
| 599 | # Pattern for environment/local variable |
---|
| 600 | my @patterns = $env |
---|
| 601 | ? (qr#\$([A-Z][A-Z0-9_]+)#, qr#\$\{([A-Z][A-Z0-9_]+)\}#) |
---|
| 602 | : (qr#%(\w+(?:::[\w\.-]+)*)#, qr#%\{(\w+(?:(?:::|/)[\w\.-]+)*)\}#); |
---|
| 603 | |
---|
| 604 | my $ret = ''; |
---|
| 605 | my $warning = undef; |
---|
| 606 | while ($string) { |
---|
| 607 | # Find the first match in $string |
---|
| 608 | my ($prematch, $match, $postmatch, $var_label); |
---|
| 609 | for my $pattern (@patterns) { |
---|
| 610 | next unless $string =~ /$pattern/; |
---|
| 611 | if ((not defined $prematch) or length ($`) < length ($prematch)) { |
---|
| 612 | $prematch = $`; |
---|
| 613 | $match = $&; |
---|
| 614 | $var_label = $1; |
---|
| 615 | $postmatch = $'; |
---|
| 616 | } |
---|
| 617 | } |
---|
| 618 | |
---|
| 619 | if ($match) { |
---|
| 620 | $ret .= $prematch; |
---|
| 621 | $string = $postmatch; |
---|
| 622 | |
---|
| 623 | # Get variable value from environment or local configuration |
---|
| 624 | my $variable = $env |
---|
| 625 | ? (exists $ENV{$var_label} ? $ENV{$var_label} : undef) |
---|
| 626 | : $self->config->variable ($var_label); |
---|
| 627 | |
---|
| 628 | if ($env and $var_label eq 'HERE' and not defined $variable) { |
---|
| 629 | $variable = dirname ($self->actual_src); |
---|
| 630 | $variable = File::Spec->rel2abs ($variable) if not &is_url ($variable); |
---|
| 631 | } |
---|
| 632 | |
---|
| 633 | # Substitute match with value of variable |
---|
| 634 | if (defined $variable) { |
---|
| 635 | my $cyclic = 0; |
---|
| 636 | if ($recursive) { |
---|
| 637 | if (exists $recursive->{$var_label}) { |
---|
| 638 | $cyclic = 1; |
---|
| 639 | |
---|
| 640 | } else { |
---|
| 641 | $recursive->{$var_label} = 1; |
---|
| 642 | } |
---|
| 643 | |
---|
| 644 | } else { |
---|
| 645 | $recursive = {$var_label => 1}; |
---|
| 646 | } |
---|
| 647 | |
---|
| 648 | if ($cyclic) { |
---|
| 649 | $warning .= ', ' if $warning; |
---|
| 650 | $warning .= $match . ': cyclic dependency, variable not expanded'; |
---|
| 651 | $ret .= $variable; |
---|
| 652 | |
---|
| 653 | } else { |
---|
| 654 | my ($r, $w) = $self->_expand_variable ($variable, $env, $recursive); |
---|
| 655 | $ret .= $r; |
---|
| 656 | if ($w) { |
---|
| 657 | $warning .= ', ' if $warning; |
---|
| 658 | $warning .= $w; |
---|
| 659 | } |
---|
| 660 | } |
---|
| 661 | |
---|
| 662 | } else { |
---|
| 663 | $warning .= ', ' if $warning; |
---|
| 664 | $warning .= $match . ': variable not expanded'; |
---|
| 665 | $ret .= $match; |
---|
| 666 | } |
---|
| 667 | |
---|
| 668 | } else { |
---|
| 669 | $ret .= $string; |
---|
| 670 | $string = ""; |
---|
| 671 | } |
---|
| 672 | } |
---|
| 673 | |
---|
| 674 | return ($ret, $warning); |
---|
| 675 | } |
---|
| 676 | |
---|
| 677 | 1; |
---|
| 678 | |
---|
| 679 | __END__ |
---|