| 1 | # ------------------------------------------------------------------------------ |
|---|
| 2 | # Copyright (C) 2006-2021 British Crown (Met Office) & Contributors. |
|---|
| 3 | # |
|---|
| 4 | # This file is part of FCM, tools for managing and building source code. |
|---|
| 5 | # |
|---|
| 6 | # FCM 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 3 of the License, or |
|---|
| 9 | # (at your option) any later version. |
|---|
| 10 | # |
|---|
| 11 | # FCM 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 FCM. If not, see <http://www.gnu.org/licenses/>. |
|---|
| 18 | # ------------------------------------------------------------------------------ |
|---|
| 19 | # NAME |
|---|
| 20 | # FCM1::ConfigSystem |
|---|
| 21 | # |
|---|
| 22 | # DESCRIPTION |
|---|
| 23 | # This is the base class for FCM systems that are based on inherited |
|---|
| 24 | # configuration files, e.g. the extract and the build systems. |
|---|
| 25 | # |
|---|
| 26 | # ------------------------------------------------------------------------------ |
|---|
| 27 | |
|---|
| 28 | package FCM1::ConfigSystem; |
|---|
| 29 | use base qw{FCM1::Base}; |
|---|
| 30 | |
|---|
| 31 | use strict; |
|---|
| 32 | use warnings; |
|---|
| 33 | |
|---|
| 34 | use FCM1::CfgFile; |
|---|
| 35 | use FCM1::CfgLine; |
|---|
| 36 | use FCM1::Dest; |
|---|
| 37 | use FCM1::Util qw{expand_tilde e_report w_report}; |
|---|
| 38 | use Sys::Hostname qw{hostname}; |
|---|
| 39 | |
|---|
| 40 | # List of property methods for this class |
|---|
| 41 | my @scalar_properties = ( |
|---|
| 42 | 'cfg', # configuration file |
|---|
| 43 | 'cfg_methods', # list of sub-methods for parse_cfg |
|---|
| 44 | 'cfg_prefix', # optional prefix in configuration declaration |
|---|
| 45 | 'dest', # destination for output |
|---|
| 46 | 'inherit', # list of inherited configurations |
|---|
| 47 | 'inherited', # list of inheritance hierarchy |
|---|
| 48 | 'type', # system type |
|---|
| 49 | ); |
|---|
| 50 | |
|---|
| 51 | # ------------------------------------------------------------------------------ |
|---|
| 52 | # SYNOPSIS |
|---|
| 53 | # $obj = FCM1::ConfigSystem->new; |
|---|
| 54 | # |
|---|
| 55 | # DESCRIPTION |
|---|
| 56 | # This method constructs a new instance of the FCM1::ConfigSystem class. |
|---|
| 57 | # ------------------------------------------------------------------------------ |
|---|
| 58 | |
|---|
| 59 | sub new { |
|---|
| 60 | my $this = shift; |
|---|
| 61 | my %args = @_; |
|---|
| 62 | my $class = ref $this || $this; |
|---|
| 63 | |
|---|
| 64 | my $self = FCM1::Base->new (%args); |
|---|
| 65 | |
|---|
| 66 | $self->{$_} = undef for (@scalar_properties); |
|---|
| 67 | |
|---|
| 68 | bless $self, $class; |
|---|
| 69 | |
|---|
| 70 | # List of sub-methods for parse_cfg |
|---|
| 71 | $self->cfg_methods ([qw/header inherit dest/]); |
|---|
| 72 | |
|---|
| 73 | return $self; |
|---|
| 74 | } |
|---|
| 75 | |
|---|
| 76 | # ------------------------------------------------------------------------------ |
|---|
| 77 | # SYNOPSIS |
|---|
| 78 | # $value = $obj->X; |
|---|
| 79 | # $obj->X ($value); |
|---|
| 80 | # |
|---|
| 81 | # DESCRIPTION |
|---|
| 82 | # Details of these properties are explained in @scalar_properties. |
|---|
| 83 | # ------------------------------------------------------------------------------ |
|---|
| 84 | |
|---|
| 85 | for my $name (@scalar_properties) { |
|---|
| 86 | no strict 'refs'; |
|---|
| 87 | |
|---|
| 88 | *$name = sub { |
|---|
| 89 | my $self = shift; |
|---|
| 90 | |
|---|
| 91 | # Argument specified, set property to specified argument |
|---|
| 92 | if (@_) { |
|---|
| 93 | $self->{$name} = $_[0]; |
|---|
| 94 | } |
|---|
| 95 | |
|---|
| 96 | # Default value for property |
|---|
| 97 | if (not defined $self->{$name}) { |
|---|
| 98 | if ($name eq 'cfg') { |
|---|
| 99 | # New configuration file |
|---|
| 100 | $self->{$name} = FCM1::CfgFile->new (TYPE => $self->type); |
|---|
| 101 | |
|---|
| 102 | } elsif ($name =~ /^(?:cfg_methods|inherit|inherited)$/) { |
|---|
| 103 | # Reference to an array |
|---|
| 104 | $self->{$name} = []; |
|---|
| 105 | |
|---|
| 106 | } elsif ($name eq 'cfg_prefix' or $name eq 'type') { |
|---|
| 107 | # Reference to an array |
|---|
| 108 | $self->{$name} = ''; |
|---|
| 109 | |
|---|
| 110 | } elsif ($name eq 'dest') { |
|---|
| 111 | # New destination |
|---|
| 112 | $self->{$name} = FCM1::Dest->new (TYPE => $self->type); |
|---|
| 113 | } |
|---|
| 114 | } |
|---|
| 115 | |
|---|
| 116 | return $self->{$name}; |
|---|
| 117 | } |
|---|
| 118 | } |
|---|
| 119 | |
|---|
| 120 | # ------------------------------------------------------------------------------ |
|---|
| 121 | # SYNOPSIS |
|---|
| 122 | # ($rc, $out_of_date) = $obj->check_cache (); |
|---|
| 123 | # |
|---|
| 124 | # DESCRIPTION |
|---|
| 125 | # This method returns $rc = 1 on success or undef on failure. It returns |
|---|
| 126 | # $out_of_date = 1 if current cache file is out of date relative to those in |
|---|
| 127 | # inherited runs or 0 otherwise. |
|---|
| 128 | # ------------------------------------------------------------------------------ |
|---|
| 129 | |
|---|
| 130 | sub check_cache { |
|---|
| 131 | my $self = shift; |
|---|
| 132 | |
|---|
| 133 | my $rc = 1; |
|---|
| 134 | my $out_of_date = 0; |
|---|
| 135 | |
|---|
| 136 | if (@{ $self->inherit } and -f $self->dest->cache) { |
|---|
| 137 | # Get modification time of current cache file |
|---|
| 138 | my $cur_mtime = (stat ($self->dest->cache))[9]; |
|---|
| 139 | |
|---|
| 140 | # Compare with modification times of inherited cache files |
|---|
| 141 | for my $use (@{ $self->inherit }) { |
|---|
| 142 | next unless -f $use->dest->cache; |
|---|
| 143 | my $use_mtime = (stat ($use->dest->cache))[9]; |
|---|
| 144 | $out_of_date = 1 if $use_mtime > $cur_mtime; |
|---|
| 145 | } |
|---|
| 146 | } |
|---|
| 147 | |
|---|
| 148 | return ($rc, $out_of_date); |
|---|
| 149 | } |
|---|
| 150 | |
|---|
| 151 | # ------------------------------------------------------------------------------ |
|---|
| 152 | # SYNOPSIS |
|---|
| 153 | # $rc = $obj->check_lock (); |
|---|
| 154 | # |
|---|
| 155 | # DESCRIPTION |
|---|
| 156 | # This method returns true if no lock is found in the destination or if the |
|---|
| 157 | # locks found are allowed. |
|---|
| 158 | # ------------------------------------------------------------------------------ |
|---|
| 159 | |
|---|
| 160 | sub check_lock { |
|---|
| 161 | my $self = shift; |
|---|
| 162 | |
|---|
| 163 | # Check all types of locks |
|---|
| 164 | for my $method (@FCM1::Dest::lockfiles) { |
|---|
| 165 | my $lock = $self->dest->$method; |
|---|
| 166 | |
|---|
| 167 | # Check whether lock exists |
|---|
| 168 | next unless -e $lock; |
|---|
| 169 | |
|---|
| 170 | # Check whether this lock is allowed |
|---|
| 171 | next if $self->check_lock_is_allowed ($lock); |
|---|
| 172 | |
|---|
| 173 | # Throw error if a lock exists |
|---|
| 174 | w_report 'ERROR: ', $lock, ': lock file exists,'; |
|---|
| 175 | w_report ' ', $self->dest->rootdir, ': destination is busy.'; |
|---|
| 176 | return; |
|---|
| 177 | } |
|---|
| 178 | |
|---|
| 179 | return 1; |
|---|
| 180 | } |
|---|
| 181 | |
|---|
| 182 | # ------------------------------------------------------------------------------ |
|---|
| 183 | # SYNOPSIS |
|---|
| 184 | # $rc = $self->check_lock_is_allowed ($lock); |
|---|
| 185 | # |
|---|
| 186 | # DESCRIPTION |
|---|
| 187 | # This method returns true if it is OK for $lock to exist in the destination. |
|---|
| 188 | # ------------------------------------------------------------------------------ |
|---|
| 189 | |
|---|
| 190 | sub check_lock_is_allowed { |
|---|
| 191 | my ($self, $lock) = @_; |
|---|
| 192 | |
|---|
| 193 | # Disallow all types of locks by default |
|---|
| 194 | return 0; |
|---|
| 195 | } |
|---|
| 196 | |
|---|
| 197 | # ------------------------------------------------------------------------------ |
|---|
| 198 | # SYNOPSIS |
|---|
| 199 | # $rc = $self->compare_setting ( |
|---|
| 200 | # METHOD_LIST => \@method_list, |
|---|
| 201 | # [METHOD_ARGS => \@method_args,] |
|---|
| 202 | # [CACHEBASE => $cachebase,] |
|---|
| 203 | # ); |
|---|
| 204 | # |
|---|
| 205 | # DESCRIPTION |
|---|
| 206 | # This method gets settings from the previous cache and updates the current. |
|---|
| 207 | # |
|---|
| 208 | # METHOD |
|---|
| 209 | # The method returns true on success. @method_list must be a list of method |
|---|
| 210 | # names for processing the cached lines in the previous run. If an existing |
|---|
| 211 | # cache exists, its content is read into $old_lines, which is a list of |
|---|
| 212 | # FCM1::CfgLine objects. Otherwise, $old_lines is set to undef. If $cachebase |
|---|
| 213 | # is set, it is used for as the cache basename. Otherwise, the default for |
|---|
| 214 | # the current system is used. It calls each method in the @method_list using |
|---|
| 215 | # $self->$method ($old_lines, @method_args), which should return a |
|---|
| 216 | # two-element list. The first element should be a return code (1 for out of |
|---|
| 217 | # date, 0 for up to date and undef for failure). The second element should be |
|---|
| 218 | # a reference to a list of FCM1::CfgLine objects for the output. |
|---|
| 219 | # ------------------------------------------------------------------------------ |
|---|
| 220 | |
|---|
| 221 | sub compare_setting { |
|---|
| 222 | my ($self, %args) = @_; |
|---|
| 223 | |
|---|
| 224 | my @method_list = exists ($args{METHOD_LIST}) ? @{ $args{METHOD_LIST} } : (); |
|---|
| 225 | my @method_args = exists ($args{METHOD_ARGS}) ? @{ $args{METHOD_ARGS} } : (); |
|---|
| 226 | my $cachebase = exists ($args{CACHEBASE}) ? $args{CACHEBASE} : undef; |
|---|
| 227 | |
|---|
| 228 | my $rc = 1; |
|---|
| 229 | |
|---|
| 230 | # Read cache if the file exists |
|---|
| 231 | # ---------------------------------------------------------------------------- |
|---|
| 232 | my $cache = $cachebase |
|---|
| 233 | ? File::Spec->catfile ($self->dest->cachedir, $cachebase) |
|---|
| 234 | : $self->dest->cache; |
|---|
| 235 | my @in_caches = (); |
|---|
| 236 | if (-f $cache) { |
|---|
| 237 | push @in_caches, $cache; |
|---|
| 238 | |
|---|
| 239 | } else { |
|---|
| 240 | for my $use (@{ $self->inherit }) { |
|---|
| 241 | my $use_cache = $cachebase |
|---|
| 242 | ? File::Spec->catfile ($use->dest->cachedir, $cachebase) |
|---|
| 243 | : $use->dest->cache; |
|---|
| 244 | push @in_caches, $use_cache if -f $use_cache; |
|---|
| 245 | } |
|---|
| 246 | } |
|---|
| 247 | |
|---|
| 248 | my $old_lines = undef; |
|---|
| 249 | for my $in_cache (@in_caches) { |
|---|
| 250 | next unless -f $in_cache; |
|---|
| 251 | my $cfg = FCM1::CfgFile->new (SRC => $in_cache); |
|---|
| 252 | |
|---|
| 253 | if ($cfg->read_cfg) { |
|---|
| 254 | $old_lines = [] if not defined $old_lines; |
|---|
| 255 | push @$old_lines, @{ $cfg->lines }; |
|---|
| 256 | } |
|---|
| 257 | } |
|---|
| 258 | |
|---|
| 259 | # Call methods in @method_list to see if cache is out of date |
|---|
| 260 | # ---------------------------------------------------------------------------- |
|---|
| 261 | my @new_lines = (); |
|---|
| 262 | my $out_of_date = 0; |
|---|
| 263 | for my $method (@method_list) { |
|---|
| 264 | my ($return, $lines); |
|---|
| 265 | ($return, $lines) = $self->$method ($old_lines, @method_args) if $rc; |
|---|
| 266 | |
|---|
| 267 | if (defined $return) { |
|---|
| 268 | # Method succeeded |
|---|
| 269 | push @new_lines, @$lines; |
|---|
| 270 | $out_of_date = 1 if $return; |
|---|
| 271 | |
|---|
| 272 | } else { |
|---|
| 273 | # Method failed |
|---|
| 274 | $rc = $return; |
|---|
| 275 | last; |
|---|
| 276 | } |
|---|
| 277 | } |
|---|
| 278 | |
|---|
| 279 | # Update the cache in the current run |
|---|
| 280 | # ---------------------------------------------------------------------------- |
|---|
| 281 | if ($rc) { |
|---|
| 282 | if (@{ $self->inherited } and $out_of_date) { |
|---|
| 283 | # If this is an inherited configuration, the cache must not be changed |
|---|
| 284 | w_report 'ERROR: ', $self->cfg->src, |
|---|
| 285 | ': inherited configuration does not match with its cache.'; |
|---|
| 286 | $rc = undef; |
|---|
| 287 | |
|---|
| 288 | } elsif ((not -f $cache) or $out_of_date) { |
|---|
| 289 | my $cfg = FCM1::CfgFile->new; |
|---|
| 290 | $cfg->lines ([sort {$a->label cmp $b->label} @new_lines]); |
|---|
| 291 | $rc = $cfg->print_cfg ($cache, 1); |
|---|
| 292 | } |
|---|
| 293 | } |
|---|
| 294 | |
|---|
| 295 | return $rc; |
|---|
| 296 | } |
|---|
| 297 | |
|---|
| 298 | # ------------------------------------------------------------------------------ |
|---|
| 299 | # SYNOPSIS |
|---|
| 300 | # ($changed_hash_ref, $new_lines_array_ref) = |
|---|
| 301 | # $self->compare_setting_in_config($prefix, \@old_lines); |
|---|
| 302 | # |
|---|
| 303 | # DESCRIPTION |
|---|
| 304 | # This method compares old and current settings for a specified item. |
|---|
| 305 | # |
|---|
| 306 | # METHOD |
|---|
| 307 | # This method does two things. |
|---|
| 308 | # |
|---|
| 309 | # It uses the current configuration for the $prefix item to generate a list of |
|---|
| 310 | # new FCM1::CfgLine objects (which is returned as a reference in the second |
|---|
| 311 | # element of the returned list). |
|---|
| 312 | # |
|---|
| 313 | # The values of the old lines are then compared with those of the new lines. |
|---|
| 314 | # Any settings that are changed are stored in a hash, which is returned as a |
|---|
| 315 | # reference in the first element of the returned list. The key of the hash is |
|---|
| 316 | # the name of the changed setting, and the value is the value of the new |
|---|
| 317 | # setting or undef if the setting no longer exists. |
|---|
| 318 | # |
|---|
| 319 | # ARGUMENTS |
|---|
| 320 | # $prefix - the name of an item in FCM1::Config to be compared |
|---|
| 321 | # @old_lines - a list of FCM1::CfgLine objects containing the old settings |
|---|
| 322 | # ------------------------------------------------------------------------------ |
|---|
| 323 | |
|---|
| 324 | sub compare_setting_in_config { |
|---|
| 325 | my ($self, $prefix, $old_lines_ref) = @_; |
|---|
| 326 | |
|---|
| 327 | my %changed = %{$self->setting($prefix)}; |
|---|
| 328 | my (@new_lines, %new_val_of); |
|---|
| 329 | while (my ($key, $val) = each(%changed)) { |
|---|
| 330 | $new_val_of{$key} = (ref($val) eq 'ARRAY' ? join(q{ }, sort(@{$val})) : $val); |
|---|
| 331 | push(@new_lines, FCM1::CfgLine->new( |
|---|
| 332 | LABEL => $prefix . $FCM1::Config::DELIMITER . $key, |
|---|
| 333 | VALUE => $new_val_of{$key}, |
|---|
| 334 | )); |
|---|
| 335 | } |
|---|
| 336 | |
|---|
| 337 | if (defined($old_lines_ref)) { |
|---|
| 338 | my %old_val_of |
|---|
| 339 | = map {($_->label_from_field(1), $_->value())} # converts into a hash |
|---|
| 340 | grep {$_->label_starts_with($prefix)} # gets relevant lines |
|---|
| 341 | @{$old_lines_ref}; |
|---|
| 342 | |
|---|
| 343 | while (my ($key, $val) = each(%old_val_of)) { |
|---|
| 344 | if (exists($changed{$key})) { |
|---|
| 345 | if ($val eq $new_val_of{$key}) { # no change from old to new |
|---|
| 346 | delete($changed{$key}); |
|---|
| 347 | } |
|---|
| 348 | } |
|---|
| 349 | else { # exists in old but not in new |
|---|
| 350 | $changed{$key} = undef; |
|---|
| 351 | } |
|---|
| 352 | } |
|---|
| 353 | } |
|---|
| 354 | |
|---|
| 355 | return (\%changed, \@new_lines); |
|---|
| 356 | } |
|---|
| 357 | |
|---|
| 358 | # ------------------------------------------------------------------------------ |
|---|
| 359 | # SYNOPSIS |
|---|
| 360 | # $rc = $obj->invoke ([CLEAN => 1, ]%args); |
|---|
| 361 | # |
|---|
| 362 | # DESCRIPTION |
|---|
| 363 | # This method invokes the system. If CLEAN is set to true, it will only parse |
|---|
| 364 | # the configuration and set up the destination, but will not invoke the |
|---|
| 365 | # system. See the invoke_setup_dest and the invoke_system methods for list of |
|---|
| 366 | # other arguments in %args. |
|---|
| 367 | # ------------------------------------------------------------------------------ |
|---|
| 368 | |
|---|
| 369 | sub invoke { |
|---|
| 370 | my $self = shift; |
|---|
| 371 | my %args = @_; |
|---|
| 372 | |
|---|
| 373 | # Print diagnostic at beginning of run |
|---|
| 374 | # ---------------------------------------------------------------------------- |
|---|
| 375 | # Name of the system |
|---|
| 376 | (my $name = ref ($self)) =~ s/^FCM1:://; |
|---|
| 377 | |
|---|
| 378 | # Print start time on system run, if verbose is true |
|---|
| 379 | my $date = localtime; |
|---|
| 380 | print $name, ' command started on ', $date, '.', "\n" |
|---|
| 381 | if $self->verbose; |
|---|
| 382 | |
|---|
| 383 | # Start time (seconds since epoch) |
|---|
| 384 | my $otime = time; |
|---|
| 385 | |
|---|
| 386 | # Parse the configuration file |
|---|
| 387 | my $rc = $self->invoke_stage ('Parse configuration', 'parse_cfg'); |
|---|
| 388 | |
|---|
| 389 | # Set up the destination |
|---|
| 390 | $rc = $self->invoke_stage ('Setup destination', 'invoke_setup_dest', %args) |
|---|
| 391 | if $rc; |
|---|
| 392 | |
|---|
| 393 | # Invoke the system |
|---|
| 394 | # ---------------------------------------------------------------------------- |
|---|
| 395 | $rc = $self->invoke_system (%args) if $rc and not $args{CLEAN}; |
|---|
| 396 | |
|---|
| 397 | # Remove empty directories |
|---|
| 398 | $rc = $self->dest->clean (MODE => 'EMPTY') if $rc; |
|---|
| 399 | |
|---|
| 400 | # Print diagnostic at end of run |
|---|
| 401 | # ---------------------------------------------------------------------------- |
|---|
| 402 | # Print lapse time at the end, if verbose is true |
|---|
| 403 | if ($self->verbose) { |
|---|
| 404 | my $total = time - $otime; |
|---|
| 405 | my $s_str = $total > 1 ? 'seconds' : 'second'; |
|---|
| 406 | print '->TOTAL: ', $total, ' ', $s_str, "\n"; |
|---|
| 407 | } |
|---|
| 408 | |
|---|
| 409 | # Report end of system run |
|---|
| 410 | $date = localtime; |
|---|
| 411 | if ($rc) { |
|---|
| 412 | # Success |
|---|
| 413 | print $name, ' command finished on ', $date, '.', "\n" |
|---|
| 414 | if $self->verbose; |
|---|
| 415 | |
|---|
| 416 | } else { |
|---|
| 417 | # Failure |
|---|
| 418 | e_report $name, ' failed on ', $date, '.'; |
|---|
| 419 | } |
|---|
| 420 | |
|---|
| 421 | return $rc; |
|---|
| 422 | } |
|---|
| 423 | |
|---|
| 424 | # ------------------------------------------------------------------------------ |
|---|
| 425 | # SYNOPSIS |
|---|
| 426 | # $rc = $obj->invoke_setup_dest ([CLEAN|FULL => 1], [IGNORE_LOCK => 1]); |
|---|
| 427 | # |
|---|
| 428 | # DESCRIPTION |
|---|
| 429 | # This method sets up the destination and returns true on success. |
|---|
| 430 | # |
|---|
| 431 | # ARGUMENTS |
|---|
| 432 | # CLEAN|FULL - If set to "true", set up the system in "clean|full" mode. |
|---|
| 433 | # Sub-directories and files in the root directory created by |
|---|
| 434 | # the previous invocation of the system will be removed. If |
|---|
| 435 | # not set, the default is to run in "incremental" mode. |
|---|
| 436 | # IGNORE_LOCK - If set to "true", it ignores any lock files that may exist in |
|---|
| 437 | # the destination root directory. |
|---|
| 438 | # ------------------------------------------------------------------------------ |
|---|
| 439 | |
|---|
| 440 | sub invoke_setup_dest { |
|---|
| 441 | my $self = shift; |
|---|
| 442 | my %args = @_; |
|---|
| 443 | |
|---|
| 444 | # Set up destination |
|---|
| 445 | # ---------------------------------------------------------------------------- |
|---|
| 446 | # Print destination in verbose mode |
|---|
| 447 | if ($self->verbose()) { |
|---|
| 448 | printf( |
|---|
| 449 | "Destination: %s@%s:%s\n", |
|---|
| 450 | scalar(getpwuid($<)), |
|---|
| 451 | hostname(), |
|---|
| 452 | $self->dest()->rootdir(), |
|---|
| 453 | ); |
|---|
| 454 | } |
|---|
| 455 | |
|---|
| 456 | my $rc = 1; |
|---|
| 457 | my $out_of_date = 0; |
|---|
| 458 | |
|---|
| 459 | # Check whether lock exists in the destination root |
|---|
| 460 | $rc = $self->check_lock if $rc and not $args{IGNORE_LOCK}; |
|---|
| 461 | |
|---|
| 462 | # Check whether current cache is out of date relative to the inherited ones |
|---|
| 463 | ($rc, $out_of_date) = $self->check_cache if $rc; |
|---|
| 464 | |
|---|
| 465 | # Remove sub-directories and files in destination in "full" mode |
|---|
| 466 | $rc = $self->dest->clean (MODE => 'ALL') |
|---|
| 467 | if $rc and ($args{FULL} or $args{CLEAN} or $out_of_date); |
|---|
| 468 | |
|---|
| 469 | # Create build root directory if necessary |
|---|
| 470 | $rc = $self->dest->create if $rc; |
|---|
| 471 | |
|---|
| 472 | # Set a lock in the destination root |
|---|
| 473 | $rc = $self->dest->set_lock if $rc; |
|---|
| 474 | |
|---|
| 475 | # Generate an as-parsed configuration file |
|---|
| 476 | $self->cfg->print_cfg ($self->dest->parsedcfg); |
|---|
| 477 | |
|---|
| 478 | return $rc; |
|---|
| 479 | } |
|---|
| 480 | |
|---|
| 481 | # ------------------------------------------------------------------------------ |
|---|
| 482 | # SYNOPSIS |
|---|
| 483 | # $rc = $self->invoke_stage ($name, $method, @args); |
|---|
| 484 | # |
|---|
| 485 | # DESCRIPTION |
|---|
| 486 | # This method invokes a named stage of the system, where $name is the name of |
|---|
| 487 | # the stage, $method is the name of the method for invoking the stage and |
|---|
| 488 | # @args are the arguments to the &method. |
|---|
| 489 | # ------------------------------------------------------------------------------ |
|---|
| 490 | |
|---|
| 491 | sub invoke_stage { |
|---|
| 492 | my ($self, $name, $method, @args) = @_; |
|---|
| 493 | |
|---|
| 494 | # Print diagnostic at beginning of a stage |
|---|
| 495 | print '->', $name, ': start', "\n" if $self->verbose; |
|---|
| 496 | my $stime = time; |
|---|
| 497 | |
|---|
| 498 | # Invoke the stage |
|---|
| 499 | my $rc = $self->$method (@args); |
|---|
| 500 | |
|---|
| 501 | # Print diagnostic at end of a stage |
|---|
| 502 | my $total = time - $stime; |
|---|
| 503 | my $s_str = $total > 1 ? 'seconds' : 'second'; |
|---|
| 504 | print '->', $name, ': ', $total, ' ', $s_str, "\n"; |
|---|
| 505 | |
|---|
| 506 | return $rc; |
|---|
| 507 | } |
|---|
| 508 | |
|---|
| 509 | # ------------------------------------------------------------------------------ |
|---|
| 510 | # SYNOPSIS |
|---|
| 511 | # $rc = $self->invoke_system (%args); |
|---|
| 512 | # |
|---|
| 513 | # DESCRIPTION |
|---|
| 514 | # This is a prototype method for invoking the system. |
|---|
| 515 | # ------------------------------------------------------------------------------ |
|---|
| 516 | |
|---|
| 517 | sub invoke_system { |
|---|
| 518 | my $self = shift; |
|---|
| 519 | my %args = @_; |
|---|
| 520 | |
|---|
| 521 | print "Dummy code.\n"; |
|---|
| 522 | |
|---|
| 523 | return 0; |
|---|
| 524 | } |
|---|
| 525 | |
|---|
| 526 | # ------------------------------------------------------------------------------ |
|---|
| 527 | # SYNOPSIS |
|---|
| 528 | # $rc = $obj->parse_cfg($is_for_inheritance); |
|---|
| 529 | # |
|---|
| 530 | # DESCRIPTION |
|---|
| 531 | # This method calls other methods to parse the configuration file. |
|---|
| 532 | # ------------------------------------------------------------------------------ |
|---|
| 533 | |
|---|
| 534 | sub parse_cfg { |
|---|
| 535 | my ($self, $is_for_inheritance) = @_; |
|---|
| 536 | |
|---|
| 537 | # Read config file |
|---|
| 538 | # ---------------------------------------------------------------------------- |
|---|
| 539 | if (!$self->cfg()->src() || !$self->cfg()->read_cfg($is_for_inheritance)) { |
|---|
| 540 | return; |
|---|
| 541 | } |
|---|
| 542 | |
|---|
| 543 | if ($self->cfg->type ne $self->type) { |
|---|
| 544 | w_report 'ERROR: ', $self->cfg->src, ': not a ', $self->type, |
|---|
| 545 | ' config file.'; |
|---|
| 546 | return; |
|---|
| 547 | } |
|---|
| 548 | |
|---|
| 549 | # Strip out optional prefix from all labels |
|---|
| 550 | # ---------------------------------------------------------------------------- |
|---|
| 551 | if ($self->cfg_prefix) { |
|---|
| 552 | for my $line (@{ $self->cfg->lines }) { |
|---|
| 553 | $line->prefix ($self->cfg_prefix); |
|---|
| 554 | } |
|---|
| 555 | } |
|---|
| 556 | |
|---|
| 557 | # Filter lines from the configuration file |
|---|
| 558 | # ---------------------------------------------------------------------------- |
|---|
| 559 | my @cfg_lines = grep { |
|---|
| 560 | $_->slabel and # ignore empty/comment lines |
|---|
| 561 | index ($_->slabel, '%') != 0 and # ignore user variable |
|---|
| 562 | not $_->slabel_starts_with_cfg ('INC') # ignore INC line |
|---|
| 563 | } @{ $self->cfg->lines }; |
|---|
| 564 | |
|---|
| 565 | # Parse the lines to read in the various settings, by calling the methods: |
|---|
| 566 | # $self->parse_cfg_XXX, where XXX is: header, inherit, dest, and the values |
|---|
| 567 | # in the list @{ $self->cfg_methods }. |
|---|
| 568 | # ---------------------------------------------------------------------------- |
|---|
| 569 | my $rc = 1; |
|---|
| 570 | for my $name (@{ $self->cfg_methods }) { |
|---|
| 571 | my $method = 'parse_cfg_' . $name; |
|---|
| 572 | $self->$method (\@cfg_lines) or $rc = 0; |
|---|
| 573 | } |
|---|
| 574 | |
|---|
| 575 | # Report warnings/errors |
|---|
| 576 | # ---------------------------------------------------------------------------- |
|---|
| 577 | for my $line (@cfg_lines) { |
|---|
| 578 | $rc = 0 if not $line->parsed; |
|---|
| 579 | my $mesg = $line->format_error; |
|---|
| 580 | w_report $mesg if $mesg; |
|---|
| 581 | } |
|---|
| 582 | |
|---|
| 583 | return ($rc); |
|---|
| 584 | } |
|---|
| 585 | |
|---|
| 586 | # ------------------------------------------------------------------------------ |
|---|
| 587 | # SYNOPSIS |
|---|
| 588 | # $rc = $self->parse_cfg_dest (\@cfg_lines); |
|---|
| 589 | # |
|---|
| 590 | # DESCRIPTION |
|---|
| 591 | # This method parses the destination settings in the @cfg_lines. |
|---|
| 592 | # ------------------------------------------------------------------------------ |
|---|
| 593 | |
|---|
| 594 | sub parse_cfg_dest { |
|---|
| 595 | my ($self, $cfg_lines) = @_; |
|---|
| 596 | |
|---|
| 597 | my $rc = 1; |
|---|
| 598 | |
|---|
| 599 | # DEST/DIR declarations |
|---|
| 600 | # ---------------------------------------------------------------------------- |
|---|
| 601 | my @lines = grep { |
|---|
| 602 | $_->slabel_starts_with_cfg ('DEST') or $_->slabel_starts_with_cfg ('DIR') |
|---|
| 603 | } @$cfg_lines; |
|---|
| 604 | |
|---|
| 605 | # Only ROOTDIR declarations are accepted |
|---|
| 606 | for my $line (@lines) { |
|---|
| 607 | my ($d, $method) = $line->slabel_fields; |
|---|
| 608 | $d = lc $d; |
|---|
| 609 | if ($method) { |
|---|
| 610 | $method = lc($method); |
|---|
| 611 | } |
|---|
| 612 | |
|---|
| 613 | # Backward compatibility |
|---|
| 614 | $d = 'dest' if $d eq 'dir'; |
|---|
| 615 | |
|---|
| 616 | # Default to "rootdir" |
|---|
| 617 | $method = 'rootdir' if (not $method) or $method eq 'root'; |
|---|
| 618 | |
|---|
| 619 | # Only "rootdir" can be set |
|---|
| 620 | next unless $method eq 'rootdir'; |
|---|
| 621 | |
|---|
| 622 | $self->$d->$method (&expand_tilde ($line->value)); |
|---|
| 623 | $line->parsed (1); |
|---|
| 624 | } |
|---|
| 625 | |
|---|
| 626 | # Make sure root directory is set |
|---|
| 627 | # ---------------------------------------------------------------------------- |
|---|
| 628 | if (not $self->dest->rootdir) { |
|---|
| 629 | w_report 'ERROR: ', $self->cfg->actual_src, |
|---|
| 630 | ': destination root directory not set.'; |
|---|
| 631 | $rc = 0; |
|---|
| 632 | } |
|---|
| 633 | |
|---|
| 634 | # Inherit destinations |
|---|
| 635 | # ---------------------------------------------------------------------------- |
|---|
| 636 | @{$self->dest()->inherit()} = (); |
|---|
| 637 | my @nodes = @{$self->inherit()}; |
|---|
| 638 | while (my $node = pop(@nodes)) { |
|---|
| 639 | push(@nodes, @{$node->inherit()}); |
|---|
| 640 | push(@{$self->dest()->inherit()}, $node->dest()); |
|---|
| 641 | } |
|---|
| 642 | @{$self->dest()->inherit()} = reverse(@{$self->dest()->inherit()}); |
|---|
| 643 | |
|---|
| 644 | return $rc; |
|---|
| 645 | } |
|---|
| 646 | |
|---|
| 647 | # ------------------------------------------------------------------------------ |
|---|
| 648 | # SYNOPSIS |
|---|
| 649 | # $rc = $self->parse_cfg_header (\@cfg_lines); |
|---|
| 650 | # |
|---|
| 651 | # DESCRIPTION |
|---|
| 652 | # This method parses the header setting in the @cfg_lines. |
|---|
| 653 | # ------------------------------------------------------------------------------ |
|---|
| 654 | |
|---|
| 655 | sub parse_cfg_header { |
|---|
| 656 | my ($self, $cfg_lines) = @_; |
|---|
| 657 | |
|---|
| 658 | # Set header lines as "parsed" |
|---|
| 659 | map {$_->parsed (1)} grep {$_->slabel_starts_with_cfg ('CFGFILE')} @$cfg_lines; |
|---|
| 660 | |
|---|
| 661 | return 1; |
|---|
| 662 | } |
|---|
| 663 | |
|---|
| 664 | # ------------------------------------------------------------------------------ |
|---|
| 665 | # SYNOPSIS |
|---|
| 666 | # $rc = $self->parse_cfg_inherit (\@cfg_lines); |
|---|
| 667 | # |
|---|
| 668 | # DESCRIPTION |
|---|
| 669 | # This method parses the inherit setting in the @cfg_lines. |
|---|
| 670 | # ------------------------------------------------------------------------------ |
|---|
| 671 | |
|---|
| 672 | sub parse_cfg_inherit { |
|---|
| 673 | my ($self, $cfg_lines) = @_; |
|---|
| 674 | |
|---|
| 675 | # USE declaration |
|---|
| 676 | # ---------------------------------------------------------------------------- |
|---|
| 677 | my @lines = grep {$_->slabel_starts_with_cfg ('USE')} @$cfg_lines; |
|---|
| 678 | |
|---|
| 679 | # Check for cyclic dependency |
|---|
| 680 | if (@lines and grep {$_ eq $self->cfg->actual_src} @{ $self->inherited }) { |
|---|
| 681 | # Error if current configuration file is in its own inheritance hierarchy |
|---|
| 682 | w_report 'ERROR: ', $self->cfg->actual_src, ': attempt to inherit itself.'; |
|---|
| 683 | $_->error ($_->label . ': ignored due to cyclic dependency.') for (@lines); |
|---|
| 684 | return 0; |
|---|
| 685 | } |
|---|
| 686 | |
|---|
| 687 | my $rc = 1; |
|---|
| 688 | |
|---|
| 689 | for my $line (@lines) { |
|---|
| 690 | # Invoke new instance of the current class |
|---|
| 691 | my $use = ref ($self)->new; |
|---|
| 692 | |
|---|
| 693 | # Set configuration file, inheritance hierarchy |
|---|
| 694 | # and attempt to parse the configuration |
|---|
| 695 | $use->cfg->src (&expand_tilde ($line->value)); |
|---|
| 696 | $use->inherited ([$self->cfg->actual_src, @{ $self->inherited }]); |
|---|
| 697 | $use->parse_cfg(1); # 1 = is for inheritance |
|---|
| 698 | |
|---|
| 699 | # Add to list of inherit configurations |
|---|
| 700 | push @{ $self->inherit }, $use; |
|---|
| 701 | |
|---|
| 702 | $line->parsed (1); |
|---|
| 703 | } |
|---|
| 704 | |
|---|
| 705 | # Check locks in inherited destination |
|---|
| 706 | # ---------------------------------------------------------------------------- |
|---|
| 707 | for my $use (@{ $self->inherit }) { |
|---|
| 708 | $rc = 0 unless $use->check_lock; |
|---|
| 709 | } |
|---|
| 710 | |
|---|
| 711 | return $rc; |
|---|
| 712 | } |
|---|
| 713 | |
|---|
| 714 | # ------------------------------------------------------------------------------ |
|---|
| 715 | # SYNOPSIS |
|---|
| 716 | # @cfglines = $obj->to_cfglines (); |
|---|
| 717 | # |
|---|
| 718 | # DESCRIPTION |
|---|
| 719 | # This method returns the configuration lines of this object. |
|---|
| 720 | # ------------------------------------------------------------------------------ |
|---|
| 721 | |
|---|
| 722 | sub to_cfglines { |
|---|
| 723 | my ($self) = @_; |
|---|
| 724 | |
|---|
| 725 | my @inherited_dests = map { |
|---|
| 726 | FCM1::CfgLine->new ( |
|---|
| 727 | label => $self->cfglabel ('USE'), value => $_->dest->rootdir |
|---|
| 728 | ); |
|---|
| 729 | } @{ $self->inherit }; |
|---|
| 730 | |
|---|
| 731 | return ( |
|---|
| 732 | FCM1::CfgLine::comment_block ('File header'), |
|---|
| 733 | FCM1::CfgLine->new ( |
|---|
| 734 | label => $self->cfglabel ('CFGFILE') . $FCM1::Config::DELIMITER . 'TYPE', |
|---|
| 735 | value => $self->type, |
|---|
| 736 | ), |
|---|
| 737 | FCM1::CfgLine->new ( |
|---|
| 738 | label => $self->cfglabel ('CFGFILE') . $FCM1::Config::DELIMITER . 'VERSION', |
|---|
| 739 | value => '1.0', |
|---|
| 740 | ), |
|---|
| 741 | FCM1::CfgLine->new (), |
|---|
| 742 | |
|---|
| 743 | @inherited_dests, |
|---|
| 744 | |
|---|
| 745 | FCM1::CfgLine::comment_block ('Destination'), |
|---|
| 746 | ($self->dest->to_cfglines()), |
|---|
| 747 | ); |
|---|
| 748 | } |
|---|
| 749 | |
|---|
| 750 | # ------------------------------------------------------------------------------ |
|---|
| 751 | |
|---|
| 752 | 1; |
|---|
| 753 | |
|---|
| 754 | __END__ |
|---|