source: vendors/FCM/lib/Fcm/ConfigSystem.pm @ 15268

Last change on this file since 15268 was 15268, checked in by clem, 3 months ago

commit solution of the defect #2622 found by Jean-Marc for compilation on Jean-Zay machines. Great improvement.

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