source: branches/UKMO/r6232_tracer_advection/NEMOGCM/EXTERNAL/fcm/lib/Fcm/ConfigSystem.pm @ 9295

Last change on this file since 9295 was 9295, checked in by jcastill, 3 years ago

Remove svn keywords

File size: 22.0 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        if ($val eq $new_val_of{$key}) { # no change from old to new
333          delete($changed{$key});
334        }
335      }
336      else { # exists in old but not in new
337        $changed{$key} = undef;
338      }
339    }
340  }
341
342  return (\%changed, \@new_lines);
343}
344
345# ------------------------------------------------------------------------------
346# SYNOPSIS
347#   $rc = $obj->invoke ([CLEAN => 1, ]%args);
348#
349# DESCRIPTION
350#   This method invokes the system. If CLEAN is set to true, it will only parse
351#   the configuration and set up the destination, but will not invoke the
352#   system. See the invoke_setup_dest and the invoke_system methods for list of
353#   other arguments in %args.
354# ------------------------------------------------------------------------------
355
356sub invoke {
357  my $self = shift;
358  my %args = @_;
359
360  # Print diagnostic at beginning of run
361  # ----------------------------------------------------------------------------
362  # Name of the system
363  (my $name = ref ($self)) =~ s/^Fcm:://;
364
365  # Print start time on system run, if verbose is true
366  my $date = localtime;
367  print $name, ' command started on ', $date, '.', "\n"
368    if $self->verbose;
369
370  # Start time (seconds since epoch)
371  my $otime = time;
372
373  # Parse the configuration file
374  my $rc = $self->invoke_stage ('Parse configuration', 'parse_cfg');
375
376  # Set up the destination
377  $rc = $self->invoke_stage ('Setup destination', 'invoke_setup_dest', %args)
378    if $rc;
379
380  # Invoke the system
381  # ----------------------------------------------------------------------------
382  $rc = $self->invoke_system (%args) if $rc and not $args{CLEAN};
383
384  # Remove empty directories
385  $rc = $self->dest->clean (MODE => 'EMPTY') if $rc;
386
387  # Print diagnostic at end of run
388  # ----------------------------------------------------------------------------
389  # Print lapse time at the end, if verbose is true
390  if ($self->verbose) {
391    my $total = time - $otime;
392    my $s_str = $total > 1 ? 'seconds' : 'second';
393    print '->TOTAL: ', $total, ' ', $s_str, "\n";
394  }
395
396  # Report end of system run
397  $date = localtime;
398  if ($rc) {
399    # Success
400    print $name, ' command finished on ', $date, '.', "\n"
401      if $self->verbose;
402
403  } else {
404    # Failure
405    e_report $name, ' failed on ', $date, '.';
406  }
407
408  return $rc;
409}
410
411# ------------------------------------------------------------------------------
412# SYNOPSIS
413#   $rc = $obj->invoke_setup_dest ([CLEAN|FULL => 1], [IGNORE_LOCK => 1]);
414#
415# DESCRIPTION
416#   This method sets up the destination and returns true on success.
417#
418# ARGUMENTS
419#   CLEAN|FULL   - If set to "true", set up the system in "clean|full" mode.
420#                  Sub-directories and files in the root directory created by
421#                  the previous invocation of the system will be removed. If
422#                  not set, the default is to run in "incremental" mode.
423#   IGNORE_LOCK  - If set to "true", it ignores any lock files that may exist in
424#                  the destination root directory.
425# ------------------------------------------------------------------------------
426
427sub invoke_setup_dest {
428  my $self = shift;
429  my %args = @_;
430
431  # Set up destination
432  # ----------------------------------------------------------------------------
433  # Print destination in verbose mode
434  if ($self->verbose()) {
435    printf(
436      "Destination: %s@%s:%s\n",
437      scalar(getpwuid($<)),
438      hostname(),
439      $self->dest()->rootdir(),
440    );
441  }
442
443  my $rc = 1;
444  my $out_of_date = 0;
445
446  # Check whether lock exists in the destination root
447  $rc = $self->check_lock if $rc and not $args{IGNORE_LOCK};
448
449  # Check whether current cache is out of date relative to the inherited ones
450  ($rc, $out_of_date) = $self->check_cache if $rc;
451
452  # Remove sub-directories and files in destination in "full" mode
453  $rc = $self->dest->clean (MODE => 'ALL')
454    if $rc and ($args{FULL} or $args{CLEAN} or $out_of_date);
455
456  # Create build root directory if necessary
457  $rc = $self->dest->create if $rc;
458
459  # Set a lock in the destination root
460  $rc = $self->dest->set_lock if $rc;
461
462  # Generate an as-parsed configuration file
463  $self->cfg->print_cfg ($self->dest->parsedcfg);
464
465  return $rc;
466}
467
468# ------------------------------------------------------------------------------
469# SYNOPSIS
470#   $rc = $self->invoke_stage ($name, $method, @args);
471#
472# DESCRIPTION
473#   This method invokes a named stage of the system, where $name is the name of
474#   the stage, $method is the name of the method for invoking the stage and
475#   @args are the arguments to the &method.
476# ------------------------------------------------------------------------------
477
478sub invoke_stage {
479  my ($self, $name, $method, @args) = @_;
480
481  # Print diagnostic at beginning of a stage
482  print '->', $name, ': start', "\n" if $self->verbose;
483  my $stime = time;
484
485  # Invoke the stage
486  my $rc = $self->$method (@args);
487
488  # Print diagnostic at end of a stage
489  my $total = time - $stime;
490  my $s_str = $total > 1 ? 'seconds' : 'second';
491  print '->', $name, ': ', $total, ' ', $s_str, "\n";
492
493  return $rc;
494}
495
496# ------------------------------------------------------------------------------
497# SYNOPSIS
498#   $rc = $self->invoke_system (%args);
499#
500# DESCRIPTION
501#   This is a prototype method for invoking the system.
502# ------------------------------------------------------------------------------
503
504sub invoke_system {
505  my $self = shift;
506  my %args = @_;
507
508  print "Dummy code.\n";
509
510  return 0;
511}
512
513# ------------------------------------------------------------------------------
514# SYNOPSIS
515#   $rc = $obj->parse_cfg ();
516#
517# DESCRIPTION
518#   This method calls other methods to parse the configuration file.
519# ------------------------------------------------------------------------------
520
521sub parse_cfg {
522  my $self = shift;
523
524  return unless $self->cfg->src;
525
526  # Read config file
527  # ----------------------------------------------------------------------------
528  return unless $self->cfg->read_cfg;
529
530  if ($self->cfg->type ne $self->type) {
531    w_report 'ERROR: ', $self->cfg->src, ': not a ', $self->type,
532             ' config file.';
533    return;
534  }
535
536  # Strip out optional prefix from all labels
537  # ----------------------------------------------------------------------------
538  if ($self->cfg_prefix) {
539    for my $line (@{ $self->cfg->lines }) {
540      $line->prefix ($self->cfg_prefix);
541    }
542  }
543
544  # Filter lines from the configuration file
545  # ----------------------------------------------------------------------------
546  my @cfg_lines = grep {
547    $_->slabel                   and       # ignore empty/comment lines
548    index ($_->slabel, '%') != 0 and       # ignore user variable
549    not $_->slabel_starts_with_cfg ('INC') # ignore INC line
550  } @{ $self->cfg->lines };
551
552  # Parse the lines to read in the various settings, by calling the methods:
553  # $self->parse_cfg_XXX, where XXX is: header, inherit, dest, and the values
554  # in the list @{ $self->cfg_methods }.
555  # ----------------------------------------------------------------------------
556  my $rc = 1;
557  for my $name (@{ $self->cfg_methods }) {
558    my $method = 'parse_cfg_' . $name;
559    $self->$method (\@cfg_lines) or $rc = 0;
560  }
561
562  # Report warnings/errors
563  # ----------------------------------------------------------------------------
564  for my $line (@cfg_lines) {
565    $rc = 0 if not $line->parsed;
566    my $mesg = $line->format_error;
567    w_report $mesg if $mesg;
568  }
569
570  return ($rc);
571}
572
573# ------------------------------------------------------------------------------
574# SYNOPSIS
575#   $rc = $self->parse_cfg_dest (\@cfg_lines);
576#
577# DESCRIPTION
578#   This method parses the destination settings in the @cfg_lines.
579# ------------------------------------------------------------------------------
580
581sub parse_cfg_dest {
582  my ($self, $cfg_lines) = @_;
583
584  my $rc = 1;
585
586  # DEST/DIR declarations
587  # ----------------------------------------------------------------------------
588  my @lines  = grep {
589    $_->slabel_starts_with_cfg ('DEST') or $_->slabel_starts_with_cfg ('DIR')
590  } @$cfg_lines;
591
592  # Only ROOTDIR declarations are accepted
593  for my $line (@lines) {
594    my ($d, $method) = $line->slabel_fields;
595    $d = lc $d;
596    $method = lc $method;
597
598    # Backward compatibility
599    $d = 'dest' if $d eq 'dir';
600
601    # Default to "rootdir"
602    $method = 'rootdir' if (not $method) or $method eq 'root';
603
604    # Only "rootdir" can be set
605    next unless $method eq 'rootdir';
606
607    $self->$d->$method (&expand_tilde ($line->value));
608    $line->parsed (1);
609  }
610
611  # Make sure root directory is set
612  # ----------------------------------------------------------------------------
613  if (not $self->dest->rootdir) {
614    w_report 'ERROR: ', $self->cfg->actual_src,
615             ': destination root directory not set.';
616    $rc = 0;
617  }
618
619  # Inherit destinations
620  # ----------------------------------------------------------------------------
621  for my $use (@{ $self->inherit }) {
622    push @{ $self->dest->inherit }, (@{ $use->dest->inherit }, $use->dest);
623  }
624
625  return $rc;
626}
627
628# ------------------------------------------------------------------------------
629# SYNOPSIS
630#   $rc = $self->parse_cfg_header (\@cfg_lines);
631#
632# DESCRIPTION
633#   This method parses the header setting in the @cfg_lines.
634# ------------------------------------------------------------------------------
635
636sub parse_cfg_header {
637  my ($self, $cfg_lines) = @_;
638
639  # Set header lines as "parsed"
640  map {$_->parsed (1)} grep {$_->slabel_starts_with_cfg ('CFGFILE')} @$cfg_lines;
641
642  return 1;
643}
644
645# ------------------------------------------------------------------------------
646# SYNOPSIS
647#   $rc = $self->parse_cfg_inherit (\@cfg_lines);
648#
649# DESCRIPTION
650#   This method parses the inherit setting in the @cfg_lines.
651# ------------------------------------------------------------------------------
652
653sub parse_cfg_inherit {
654  my ($self, $cfg_lines) = @_;
655
656  # USE declaration
657  # ----------------------------------------------------------------------------
658  my @lines = grep {$_->slabel_starts_with_cfg ('USE')} @$cfg_lines;
659
660  # Check for cyclic dependency
661  if (@lines and grep {$_ eq $self->cfg->actual_src} @{ $self->inherited }) {
662    # Error if current configuration file is in its own inheritance hierarchy
663    w_report 'ERROR: ', $self->cfg->actual_src, ': attempt to inherit itself.';
664    $_->error ($_->label . ': ignored due to cyclic dependency.') for (@lines);
665    return 0;
666  }
667
668  my $rc = 1;
669
670  for my $line (@lines) {
671    # Invoke new instance of the current class
672    my $use = ref ($self)->new;
673
674    # Set configuration file, inheritance hierarchy
675    # and attempt to parse the configuration
676    $use->cfg->src  (&expand_tilde ($line->value));
677    $use->inherited ([$self->cfg->actual_src, @{ $self->inherited }]);
678    $use->parse_cfg;
679
680    # Add to list of inherit configurations
681    push @{ $self->inherit }, $use;
682
683    $line->parsed (1);
684  }
685
686  # Check locks in inherited destination
687  # ----------------------------------------------------------------------------
688  for my $use (@{ $self->inherit }) {
689    $rc = 0 unless $use->check_lock;
690  }
691
692  return $rc;
693}
694
695# ------------------------------------------------------------------------------
696# SYNOPSIS
697#   @cfglines = $obj->to_cfglines ();
698#
699# DESCRIPTION
700#   This method returns the configuration lines of this object.
701# ------------------------------------------------------------------------------
702
703sub to_cfglines {
704  my ($self) = @_;
705
706  my @inherited_dests = map {
707    Fcm::CfgLine->new (
708      label => $self->cfglabel ('USE'), value => $_->dest->rootdir
709    );
710  } @{ $self->inherit };
711
712  return (
713    Fcm::CfgLine::comment_block ('File header'),
714    Fcm::CfgLine->new (
715      label => $self->cfglabel ('CFGFILE') . $Fcm::Config::DELIMITER . 'TYPE',
716      value => $self->type,
717    ),
718    Fcm::CfgLine->new (
719      label => $self->cfglabel ('CFGFILE') . $Fcm::Config::DELIMITER . 'VERSION',
720      value => '1.0',
721    ),
722    Fcm::CfgLine->new (),
723
724    @inherited_dests,
725
726    Fcm::CfgLine::comment_block ('Destination'),
727    ($self->dest->to_cfglines()),
728  );
729}
730
731# ------------------------------------------------------------------------------
732
7331;
734
735__END__
Note: See TracBrowser for help on using the repository browser.