| 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 ( defined($self->type()) |
|---|
| 235 | && exists($exp_inc{uc($self->type())}) |
|---|
| 236 | && uc($start ? $start->label() : $label) eq $self->cfglabel('INC') |
|---|
| 237 | && !defined($cont) |
|---|
| 238 | ) { |
|---|
| 239 | # Current configuration file requires expansion of INC declarations |
|---|
| 240 | # The start/current line is an INC declaration |
|---|
| 241 | # The current line is not a continuation or is the end of the continuation |
|---|
| 242 | |
|---|
| 243 | # Get lines from an "include" configuration file |
|---|
| 244 | my $src = ($start ? $start->value : $value); |
|---|
| 245 | $src .= '@' . $self->pegrev if $here and $self->pegrev; |
|---|
| 246 | |
|---|
| 247 | if ($src) { |
|---|
| 248 | # Invoke a new instance to read the source |
|---|
| 249 | my $cfg = Fcm::CfgFile->new ( |
|---|
| 250 | SRC => expand_tilde ($src), TYPE => $self->type, |
|---|
| 251 | ); |
|---|
| 252 | |
|---|
| 253 | $cfg->read_cfg; |
|---|
| 254 | |
|---|
| 255 | # Add lines to the lines array in the current configuration file |
|---|
| 256 | $comment = 'INC ' . $src . ' '; |
|---|
| 257 | push @{$self->lines}, Fcm::CfgLine->new ( |
|---|
| 258 | comment => $comment . '# Start', |
|---|
| 259 | number => ($start ? $start->number : $line_num), |
|---|
| 260 | src => $self->actual_src, |
|---|
| 261 | warning => $warning, |
|---|
| 262 | ); |
|---|
| 263 | push @{ $self->lines }, @{ $cfg->lines }; |
|---|
| 264 | push @{$self->lines}, Fcm::CfgLine->new ( |
|---|
| 265 | comment => $comment . '# End', |
|---|
| 266 | src => $self->actual_src, |
|---|
| 267 | ); |
|---|
| 268 | |
|---|
| 269 | } else { |
|---|
| 270 | push @{$self->lines}, Fcm::CfgLine->new ( |
|---|
| 271 | number => $line_num, |
|---|
| 272 | src => $self->actual_src, |
|---|
| 273 | warning => 'empty INC declaration.' |
|---|
| 274 | ); |
|---|
| 275 | } |
|---|
| 276 | |
|---|
| 277 | } else { |
|---|
| 278 | # Push label:value pair into lines array |
|---|
| 279 | push @{$self->lines}, Fcm::CfgLine->new ( |
|---|
| 280 | label => $label, |
|---|
| 281 | value => ($label ? $value : ''), |
|---|
| 282 | comment => $comment, |
|---|
| 283 | number => $line_num, |
|---|
| 284 | src => $self->actual_src, |
|---|
| 285 | warning => $warning, |
|---|
| 286 | ); |
|---|
| 287 | } |
|---|
| 288 | |
|---|
| 289 | next if defined $cont; # current line not a continuation |
|---|
| 290 | |
|---|
| 291 | my $slabel = ($start ? $start->label : $label); |
|---|
| 292 | my $svalue = ($start ? $start->value : $value); |
|---|
| 293 | next unless $slabel; |
|---|
| 294 | |
|---|
| 295 | # Check config file type and version |
|---|
| 296 | if (index (uc ($slabel), $self->cfglabel ('CFGFILE')) == 0) { |
|---|
| 297 | my @words = split /$Fcm::Config::DELIMITER_PATTERN/, $slabel; |
|---|
| 298 | shift @words; |
|---|
| 299 | |
|---|
| 300 | my $name = @words ? lc ($words[0]) : 'type'; |
|---|
| 301 | |
|---|
| 302 | if ($self->can ($name)) { |
|---|
| 303 | $self->$name ($svalue); |
|---|
| 304 | } |
|---|
| 305 | } |
|---|
| 306 | |
|---|
| 307 | # Set internal variable |
|---|
| 308 | $slabel =~ s/^\%//; # Remove leading "%" from label |
|---|
| 309 | |
|---|
| 310 | $self->config->variable ($slabel, $svalue) |
|---|
| 311 | unless exists $cfg_keywords{$slabel}; |
|---|
| 312 | } |
|---|
| 313 | |
|---|
| 314 | # Report and reset warnings |
|---|
| 315 | # ---------------------------------------------------------------------------- |
|---|
| 316 | for my $line (@{ $self->lines }) { |
|---|
| 317 | w_report $line->format_warning if $line->warning; |
|---|
| 318 | $line->warning (undef); |
|---|
| 319 | } |
|---|
| 320 | |
|---|
| 321 | return @{ $self->lines }; |
|---|
| 322 | |
|---|
| 323 | } |
|---|
| 324 | |
|---|
| 325 | # ------------------------------------------------------------------------------ |
|---|
| 326 | # SYNOPSIS |
|---|
| 327 | # $rc = $obj->print_cfg ($file, [$force]); |
|---|
| 328 | # |
|---|
| 329 | # DESCRIPTION |
|---|
| 330 | # This method prints the content of current configuration file. If no |
|---|
| 331 | # argument is specified, it prints output to the standard output. If $file is |
|---|
| 332 | # specified, and is a writable file name, the output is sent to the file. If |
|---|
| 333 | # the file already exists, its content is compared to the current output. |
|---|
| 334 | # Nothing will be written if the content is unchanged unless $force is |
|---|
| 335 | # specified. Otherwise, for typed configuration files, the existing file is |
|---|
| 336 | # renamed using a prefix that contains its last modified time. The method |
|---|
| 337 | # returns 1 if there is no error. |
|---|
| 338 | # ------------------------------------------------------------------------------ |
|---|
| 339 | |
|---|
| 340 | sub print_cfg { |
|---|
| 341 | my ($self, $file, $force) = @_; |
|---|
| 342 | |
|---|
| 343 | # Count maximum number of characters in the labels, (for pretty printing) |
|---|
| 344 | my $max_label_len = 0; |
|---|
| 345 | for my $line (@{ $self->lines }) { |
|---|
| 346 | next unless $line->label; |
|---|
| 347 | my $label_len = length $line->label; |
|---|
| 348 | $max_label_len = $label_len if $label_len > $max_label_len; |
|---|
| 349 | } |
|---|
| 350 | |
|---|
| 351 | # Output string |
|---|
| 352 | my $out = ''; |
|---|
| 353 | |
|---|
| 354 | # Append each line of the config file to the output string |
|---|
| 355 | for my $line (@{ $self->lines }) { |
|---|
| 356 | $out .= $line->print_line ($max_label_len - length ($line->label) + 1); |
|---|
| 357 | $out .= "\n"; |
|---|
| 358 | } |
|---|
| 359 | |
|---|
| 360 | if ($out) { |
|---|
| 361 | my $old_select = select; |
|---|
| 362 | |
|---|
| 363 | # Open file if necessary |
|---|
| 364 | if ($file) { |
|---|
| 365 | # Make sure the host directory exists and is writable |
|---|
| 366 | my $dirname = dirname $file; |
|---|
| 367 | if (not -d $dirname) { |
|---|
| 368 | print 'Make directory: ', $dirname, "\n" if $self->verbose; |
|---|
| 369 | mkpath $dirname; |
|---|
| 370 | } |
|---|
| 371 | croak $dirname, ': cannot write to config file directory, abort' |
|---|
| 372 | unless -d $dirname and -w $dirname; |
|---|
| 373 | |
|---|
| 374 | if (-f $file and not $force) { |
|---|
| 375 | if (-r $file) { |
|---|
| 376 | # Read old config file to see if content has changed |
|---|
| 377 | open IN, '<', $file or croak $file, ': cannot open (', $!, '), abort'; |
|---|
| 378 | my $in_lines = ''; |
|---|
| 379 | while (my $line = <IN>) { |
|---|
| 380 | $in_lines .= $line; |
|---|
| 381 | } |
|---|
| 382 | close IN or croak $file, ': cannot close (', $!, '), abort'; |
|---|
| 383 | |
|---|
| 384 | # Return if content is up-to-date |
|---|
| 385 | if ($in_lines eq $out) { |
|---|
| 386 | print 'No change in ', lc ($self->type), ' cfg: ', $file, "\n" |
|---|
| 387 | if $self->verbose > 1 and $self->type; |
|---|
| 388 | return 1; |
|---|
| 389 | } |
|---|
| 390 | } |
|---|
| 391 | |
|---|
| 392 | # If config file already exists, make sure it is writable |
|---|
| 393 | if (-w $file) { |
|---|
| 394 | if ($self->type) { |
|---|
| 395 | # Existing config file writable, rename it using its time stamp |
|---|
| 396 | my $mtime = (stat $file)[9]; |
|---|
| 397 | my ($sec, $min, $hour, $mday, $mon, $year) = (gmtime $mtime)[0 .. 5]; |
|---|
| 398 | my $timestamp = sprintf '%4d%2.2d%2.2d_%2.2d%2.2d%2.2d_', |
|---|
| 399 | $year + 1900, $mon + 1, $mday, $hour, $min, $sec; |
|---|
| 400 | my $oldfile = File::Spec->catfile ( |
|---|
| 401 | $dirname, $timestamp . basename ($file) |
|---|
| 402 | ); |
|---|
| 403 | rename $file, $oldfile; |
|---|
| 404 | print 'Rename existing ', lc ($self->type), ' cfg: ', |
|---|
| 405 | $oldfile, "\n" if $self->verbose > 1; |
|---|
| 406 | } |
|---|
| 407 | |
|---|
| 408 | } else { |
|---|
| 409 | # Existing config file not writable, throw an error |
|---|
| 410 | croak $file, ': config file not writable, abort'; |
|---|
| 411 | } |
|---|
| 412 | } |
|---|
| 413 | |
|---|
| 414 | # Open file and select file handle |
|---|
| 415 | open OUT, '>', $file |
|---|
| 416 | or croak $file, ': cannot open config file (', $!, '), abort'; |
|---|
| 417 | select OUT; |
|---|
| 418 | } |
|---|
| 419 | |
|---|
| 420 | # Print output |
|---|
| 421 | print $out; |
|---|
| 422 | |
|---|
| 423 | # Close file if necessary |
|---|
| 424 | if ($file) { |
|---|
| 425 | select $old_select; |
|---|
| 426 | close OUT or croak $file, ': cannot close config file (', $!, '), abort'; |
|---|
| 427 | |
|---|
| 428 | if ($self->type and $self->verbose > 1) { |
|---|
| 429 | print 'Generated ', lc ($self->type), ' cfg: ', $file, "\n"; |
|---|
| 430 | |
|---|
| 431 | } elsif ($self->verbose > 2) { |
|---|
| 432 | print 'Generated cfg: ', $file, "\n"; |
|---|
| 433 | } |
|---|
| 434 | } |
|---|
| 435 | |
|---|
| 436 | } else { |
|---|
| 437 | # Warn if nothing to print |
|---|
| 438 | my $warning = 'Empty configuration'; |
|---|
| 439 | $warning .= ' - nothing written to file: ' . $file if $file; |
|---|
| 440 | carp $warning if $self->type; |
|---|
| 441 | } |
|---|
| 442 | |
|---|
| 443 | return 1; |
|---|
| 444 | } |
|---|
| 445 | |
|---|
| 446 | # ------------------------------------------------------------------------------ |
|---|
| 447 | # SYNOPSIS |
|---|
| 448 | # @lines = $self->_get_cfg_lines (); |
|---|
| 449 | # |
|---|
| 450 | # DESCRIPTION |
|---|
| 451 | # This internal method reads from a configuration file residing in a |
|---|
| 452 | # Subversion repository or in the normal file system. |
|---|
| 453 | # ------------------------------------------------------------------------------ |
|---|
| 454 | |
|---|
| 455 | sub _get_cfg_lines { |
|---|
| 456 | my $self = shift; |
|---|
| 457 | my @lines = (); |
|---|
| 458 | |
|---|
| 459 | my $verbose = $self->verbose; |
|---|
| 460 | |
|---|
| 461 | my ($src) = $self->src(); |
|---|
| 462 | if ($src =~ qr{\A([A-Za-z][\w\+-\.]*):}xms) { # is a URI |
|---|
| 463 | $src = Fcm::Keyword::expand($src); |
|---|
| 464 | # Config file resides in a SVN repository |
|---|
| 465 | # -------------------------------------------------------------------------- |
|---|
| 466 | # Set URL source and version |
|---|
| 467 | my $rev = 'HEAD'; |
|---|
| 468 | |
|---|
| 469 | # Extract version from source if it exists |
|---|
| 470 | if ($src =~ s{\@ ([^\@]+) \z}{}xms) { |
|---|
| 471 | $rev = $1; |
|---|
| 472 | } |
|---|
| 473 | |
|---|
| 474 | $src = Fcm::Util::tidy_url($src); |
|---|
| 475 | |
|---|
| 476 | # Check whether URL is a config file |
|---|
| 477 | my $rc; |
|---|
| 478 | my @cmd = (qw/svn cat/, $src . '@' . $rev); |
|---|
| 479 | @lines = &run_command ( |
|---|
| 480 | \@cmd, METHOD => 'qx', DEVNULL => 1, RC => \$rc, ERROR => 'ignore', |
|---|
| 481 | ); |
|---|
| 482 | |
|---|
| 483 | # Error in "svn cat" command |
|---|
| 484 | if ($rc) { |
|---|
| 485 | # See whether specified config file is a known type |
|---|
| 486 | my %cfgname = %{ $self->setting ('CFG_NAME') }; |
|---|
| 487 | my $key = uc $self->type; |
|---|
| 488 | my $file = exists $cfgname{$key} ? $cfgname{$key} : ''; |
|---|
| 489 | |
|---|
| 490 | # If config file is a known type, specified URL may be a directory |
|---|
| 491 | if ($file) { |
|---|
| 492 | # Check whether a config file with a default name exists in the URL |
|---|
| 493 | my $path = $src . '/' . $file; |
|---|
| 494 | my @cmd = (qw/svn cat/, $path . '@' . $rev); |
|---|
| 495 | |
|---|
| 496 | @lines = &run_command ( |
|---|
| 497 | \@cmd, METHOD => 'qx', DEVNULL => 1, RC => \$rc, ERROR => 'ignore', |
|---|
| 498 | ); |
|---|
| 499 | |
|---|
| 500 | # Check whether a config file with a default name exists under the "cfg" |
|---|
| 501 | # sub-directory of the URL |
|---|
| 502 | if ($rc) { |
|---|
| 503 | my $cfgdir = $self->setting (qw/DIR CFG/); |
|---|
| 504 | $path = $src . '/' . $cfgdir . '/' . $file; |
|---|
| 505 | my @cmd = (qw/svn cat/, $path . '@' . $rev); |
|---|
| 506 | |
|---|
| 507 | @lines = &run_command ( |
|---|
| 508 | \@cmd, METHOD => 'qx', DEVNULL => 1, RC => \$rc, ERROR => 'ignore', |
|---|
| 509 | ); |
|---|
| 510 | } |
|---|
| 511 | |
|---|
| 512 | $src = $path unless $rc; |
|---|
| 513 | } |
|---|
| 514 | } |
|---|
| 515 | |
|---|
| 516 | if ($rc) { |
|---|
| 517 | # Error in "svn cat" |
|---|
| 518 | croak 'Unable to locate config file from "', $self->src, '", abort'; |
|---|
| 519 | |
|---|
| 520 | } else { |
|---|
| 521 | # Print diagnostic, if necessary |
|---|
| 522 | if ($verbose and $self->type and $self->type =~ /$expand_type/) { |
|---|
| 523 | print 'Config file (', $self->type, '): ', $src; |
|---|
| 524 | print '@', $rev if $rev; |
|---|
| 525 | print "\n"; |
|---|
| 526 | } |
|---|
| 527 | } |
|---|
| 528 | |
|---|
| 529 | # Record the actual source location |
|---|
| 530 | $self->pegrev ($rev); |
|---|
| 531 | $self->actual_src ($src); |
|---|
| 532 | |
|---|
| 533 | } else { |
|---|
| 534 | # Config file resides in the normal file system |
|---|
| 535 | # -------------------------------------------------------------------------- |
|---|
| 536 | my $src = $self->src; |
|---|
| 537 | |
|---|
| 538 | if (-d $src) { # Source is a directory |
|---|
| 539 | croak 'Config file "', $src, '" is a directory, abort' if not $self->type; |
|---|
| 540 | |
|---|
| 541 | # Get name of the config file by looking at the type |
|---|
| 542 | my %cfgname = %{ $self->setting ('CFG_NAME') }; |
|---|
| 543 | my $key = uc $self->type; |
|---|
| 544 | my $file = exists $cfgname{$key} ? $cfgname{$key} : ''; |
|---|
| 545 | |
|---|
| 546 | if ($file) { |
|---|
| 547 | my $cfgdir = $self->setting (qw/DIR CFG/); |
|---|
| 548 | |
|---|
| 549 | # Check whether a config file with a default name exists in the |
|---|
| 550 | # specified path, then check whether a config file with a default name |
|---|
| 551 | # exists under the "cfg" sub-directory of the specified path |
|---|
| 552 | if (-f File::Spec->catfile ($self->src, $file)) { |
|---|
| 553 | $src = File::Spec->catfile ($self->src, $file); |
|---|
| 554 | |
|---|
| 555 | } elsif (-f File::Spec->catfile ($self->src, $cfgdir, $file)) { |
|---|
| 556 | $src = File::Spec->catfile ($self->src, $cfgdir, $file); |
|---|
| 557 | |
|---|
| 558 | } else { |
|---|
| 559 | croak 'Unable to locate config file from "', $self->src, '", abort'; |
|---|
| 560 | } |
|---|
| 561 | |
|---|
| 562 | } else { |
|---|
| 563 | croak 'Unknown config file type "', $self->type, '", abort'; |
|---|
| 564 | } |
|---|
| 565 | } |
|---|
| 566 | |
|---|
| 567 | if (-r $src) { |
|---|
| 568 | open FILE, '<', $src; |
|---|
| 569 | print 'Config file (', $self->type, '): ', $src, "\n" |
|---|
| 570 | if $verbose and $self->type and $self->type =~ /$expand_type/; |
|---|
| 571 | |
|---|
| 572 | @lines = readline 'FILE'; |
|---|
| 573 | close FILE; |
|---|
| 574 | |
|---|
| 575 | } else { |
|---|
| 576 | croak 'Unable to read config file "', $src, '", abort'; |
|---|
| 577 | } |
|---|
| 578 | |
|---|
| 579 | # Record the actual source location |
|---|
| 580 | $self->actual_src ($src); |
|---|
| 581 | } |
|---|
| 582 | |
|---|
| 583 | return @lines; |
|---|
| 584 | } |
|---|
| 585 | |
|---|
| 586 | # ------------------------------------------------------------------------------ |
|---|
| 587 | # SYNOPSIS |
|---|
| 588 | # $string = $self->_expand_variable ($string, $env[, \%recursive]); |
|---|
| 589 | # |
|---|
| 590 | # DESCRIPTION |
|---|
| 591 | # This internal method expands variables in $string. If $env is true, it |
|---|
| 592 | # expands environment variables. Otherwise, it expands local variables. If |
|---|
| 593 | # %recursive is set, it indicates that this method is being called |
|---|
| 594 | # recursively. In which case, it must not attempt to expand a variable that |
|---|
| 595 | # exists in the keys of %recursive. |
|---|
| 596 | # ------------------------------------------------------------------------------ |
|---|
| 597 | |
|---|
| 598 | sub _expand_variable { |
|---|
| 599 | my ($self, $string, $env, $recursive) = @_; |
|---|
| 600 | |
|---|
| 601 | # Pattern for environment/local variable |
|---|
| 602 | my @patterns = $env |
|---|
| 603 | ? (qr#\$([A-Z][A-Z0-9_]+)#, qr#\$\{([A-Z][A-Z0-9_]+)\}#) |
|---|
| 604 | : (qr#%(\w+(?:::[\w\.-]+)*)#, qr#%\{(\w+(?:(?:::|/)[\w\.-]+)*)\}#); |
|---|
| 605 | |
|---|
| 606 | my $ret = ''; |
|---|
| 607 | my $warning = undef; |
|---|
| 608 | while ($string) { |
|---|
| 609 | # Find the first match in $string |
|---|
| 610 | my ($prematch, $match, $postmatch, $var_label); |
|---|
| 611 | for my $pattern (@patterns) { |
|---|
| 612 | next unless $string =~ /$pattern/; |
|---|
| 613 | if ((not defined $prematch) or length ($`) < length ($prematch)) { |
|---|
| 614 | $prematch = $`; |
|---|
| 615 | $match = $&; |
|---|
| 616 | $var_label = $1; |
|---|
| 617 | $postmatch = $'; |
|---|
| 618 | } |
|---|
| 619 | } |
|---|
| 620 | |
|---|
| 621 | if ($match) { |
|---|
| 622 | $ret .= $prematch; |
|---|
| 623 | $string = $postmatch; |
|---|
| 624 | |
|---|
| 625 | # Get variable value from environment or local configuration |
|---|
| 626 | my $variable = $env |
|---|
| 627 | ? (exists $ENV{$var_label} ? $ENV{$var_label} : undef) |
|---|
| 628 | : $self->config->variable ($var_label); |
|---|
| 629 | |
|---|
| 630 | if ($env and $var_label eq 'HERE' and not defined $variable) { |
|---|
| 631 | $variable = dirname ($self->actual_src); |
|---|
| 632 | $variable = File::Spec->rel2abs ($variable) if not &is_url ($variable); |
|---|
| 633 | } |
|---|
| 634 | |
|---|
| 635 | # Substitute match with value of variable |
|---|
| 636 | if (defined $variable) { |
|---|
| 637 | my $cyclic = 0; |
|---|
| 638 | if ($recursive) { |
|---|
| 639 | if (exists $recursive->{$var_label}) { |
|---|
| 640 | $cyclic = 1; |
|---|
| 641 | |
|---|
| 642 | } else { |
|---|
| 643 | $recursive->{$var_label} = 1; |
|---|
| 644 | } |
|---|
| 645 | |
|---|
| 646 | } else { |
|---|
| 647 | $recursive = {$var_label => 1}; |
|---|
| 648 | } |
|---|
| 649 | |
|---|
| 650 | if ($cyclic) { |
|---|
| 651 | $warning .= ', ' if $warning; |
|---|
| 652 | $warning .= $match . ': cyclic dependency, variable not expanded'; |
|---|
| 653 | $ret .= $variable; |
|---|
| 654 | |
|---|
| 655 | } else { |
|---|
| 656 | my ($r, $w) = $self->_expand_variable ($variable, $env, $recursive); |
|---|
| 657 | $ret .= $r; |
|---|
| 658 | if ($w) { |
|---|
| 659 | $warning .= ', ' if $warning; |
|---|
| 660 | $warning .= $w; |
|---|
| 661 | } |
|---|
| 662 | } |
|---|
| 663 | |
|---|
| 664 | } else { |
|---|
| 665 | $warning .= ', ' if $warning; |
|---|
| 666 | $warning .= $match . ': variable not expanded'; |
|---|
| 667 | $ret .= $match; |
|---|
| 668 | } |
|---|
| 669 | |
|---|
| 670 | } else { |
|---|
| 671 | $ret .= $string; |
|---|
| 672 | $string = ""; |
|---|
| 673 | } |
|---|
| 674 | } |
|---|
| 675 | |
|---|
| 676 | return ($ret, $warning); |
|---|
| 677 | } |
|---|
| 678 | |
|---|
| 679 | 1; |
|---|
| 680 | |
|---|
| 681 | __END__ |
|---|
