source: OFFICIAL/FCM_V1.3/lib/Fcm/ConfigSystem.pm

Last change on this file was 1, checked in by fcm, 15 years ago

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