New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
CfgFile.pm in vendors/lib/FCM1 – NEMO

source: vendors/lib/FCM1/CfgFile.pm @ 10669

Last change on this file since 10669 was 10669, checked in by nicolasmartin, 5 years ago

Import latest FCM release from Github into the repository for testing
File size: 18.6 KB
Line 
1# ------------------------------------------------------------------------------
2# (C) British Crown Copyright 2006-17 Met Office.
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::CfgFile
21#
22# DESCRIPTION
23#   This class is used for reading and writing FCM config files. A FCM config
24#   file is a line-based text file that provides information on how to perform
25#   a particular task using the FCM system.
26#
27# ------------------------------------------------------------------------------
28
29package FCM1::CfgFile;
30@ISA = qw(FCM1::Base);
31
32# Standard pragma
33use warnings;
34use strict;
35
36# Standard modules
37use Carp;
38use File::Basename;
39use File::Path;
40use File::Spec;
41
42# FCM component modules
43use FCM1::Base;
44use FCM1::CfgLine;
45use FCM1::Config;
46use FCM1::Keyword;
47use FCM1::Util;
48
49# List of property methods for this class
50my @scalar_properties = (
51  'actual_src', # actual source of configuration file
52  'lines',      # list of lines, FCM1::CfgLine objects
53  'pegrev',     # peg revision of configuration file
54  'src',        # source of configuration file
55  'type',       # type of configuration file
56  'version',    # version of configuration file
57);
58
59# ------------------------------------------------------------------------------
60# SYNOPSIS
61#   $obj = FCM1::CfgFile->new (%args);
62#
63# DESCRIPTION
64#   This method constructs a new instance of the FCM1::CfgFile class. See above
65#   for allowed list of properties. (KEYS should be in uppercase.)
66# ------------------------------------------------------------------------------
67
68sub new {
69  my $this  = shift;
70  my %args  = @_;
71  my $class = ref $this || $this;
72
73  my $self = FCM1::Base->new (%args);
74
75  bless $self, $class;
76
77  for (@scalar_properties) {
78    $self->{$_} = exists $args{uc ($_)} ? $args{uc ($_)} : undef;
79  }
80
81  return $self;
82}
83
84# ------------------------------------------------------------------------------
85# SYNOPSIS
86#   $value = $obj->X;
87#   $obj->X ($value);
88#
89# DESCRIPTION
90#   Details of these properties are explained in @scalar_properties.
91# ------------------------------------------------------------------------------
92
93for my $name (@scalar_properties) {
94  no strict 'refs';
95
96  *$name = sub {
97    my $self = shift;
98
99    if (@_) {
100      $self->{$name} = $_[0];
101    }
102
103    if (not defined $self->{$name}) {
104      if ($name eq 'lines') {
105        $self->{$name} = [];
106      }
107    }
108
109    return $self->{$name};
110  }
111}
112
113# ------------------------------------------------------------------------------
114# SYNOPSIS
115#   $mtime = $obj->mtime ();
116#
117# DESCRIPTION
118#   This method returns the modified time of the configuration file source.
119# ------------------------------------------------------------------------------
120
121sub mtime {
122  my $self  = shift;
123  my $mtime = undef;
124
125  if (-f $self->src) {
126    $mtime = (stat $self->src)[9];
127  }
128
129  return $mtime;
130}
131
132# ------------------------------------------------------------------------------
133# SYNOPSIS
134#   $read = $obj->read_cfg($is_for_inheritance);
135#
136# DESCRIPTION
137#   This method reads the current configuration file. It returns the number of
138#   lines read from the config file, or "undef" if it fails. The result is
139#   placed in the LINES array of the current instance, and can be accessed via
140#   the "lines" method.
141# ------------------------------------------------------------------------------
142
143sub read_cfg {
144  my ($self, $is_for_inheritance) = @_;
145
146  my @lines = $self->_get_cfg_lines($is_for_inheritance);
147
148  # List of CFG types that need INC declarations expansion
149  my %exp_inc    = ();
150  for (split (/$FCM1::Config::DELIMITER_LIST/, $self->setting ('CFG_EXP_INC'))) {
151    $exp_inc{uc ($_)} = 1;
152  }
153
154  # List of CFG labels that are reserved keywords
155  my %cfg_keywords = ();
156  for (split (/$FCM1::Config::DELIMITER_LIST/, $self->setting ('CFG_KEYWORD'))) {
157    $cfg_keywords{$self->cfglabel ($_)} = 1;
158  }
159
160  # Loop each line, to separate lines into label : value pairs
161  my $cont = undef;
162  my $here = undef;
163  for my $line_num (1 .. @lines) {
164    my $line = $lines[$line_num - 1];
165    chomp $line;
166
167    my $label   = '';
168    my $value   = '';
169    my $comment = '';
170
171    # If this line is a continuation, set $start to point to the line that
172    # starts this continuation. Otherwise, set $start to undef
173    my $start = defined ($cont) ? $self->lines->[$cont] : undef;
174    my $warning = undef;
175
176    if ($line =~ /^(\s*#.*)$/) { # comment line
177      $comment = $1;
178
179    } elsif ($line =~ /\S/) {    # non-blank line
180      if (defined $cont) {
181        # Previous line has a continuation mark
182        $value = $line;
183
184        # Separate value and comment
185        if ($value =~ s/((?:\s+|^)#\s+.*)$//) {
186          $comment = $1;
187        }
188
189        # Remove leading spaces
190        $value =~ s/^\s*\\?//;
191
192        # Expand environment variables
193        my $warn;
194        ($value, $warn) = $self->_expand_variable ($value, 1) if $value;
195        $warning .= ($warning ? ', ' : '') . $warn if $warn;
196
197        # Expand internal variables
198        ($value, $warn) = $self->_expand_variable ($value, 0) if $value;
199        $warning .= ($warning ? ', ' : '') . $warn if $warn;
200
201        # Get "line" that begins the current continuation
202        my $v = $start->value . $value;
203        $v =~ s/\\$//;
204        $start->value ($v);
205
206      } else {
207        # Previous line does not have a continuation mark
208        if ($line =~ /^\s*(\S+)(?:\s+(.*))?$/) {
209          # Check line contains a valid label:value pair
210          $label = $1;
211          $value = defined ($2) ? $2 : '';
212
213          # Separate value and comment
214          if ($value =~ s/((?:\s+|^)#\s+.*)$//) {
215            $comment = $1;
216          }
217
218          # Remove trailing spaces
219          $value =~ s/\s+$//;
220
221          # Value begins with $HERE?
222          $here  = ($value =~ /\$\{?HERE\}?(?:[^A-Z_]|$)/);
223
224          # Expand environment variables
225          my $warn;
226          ($value, $warn) = $self->_expand_variable ($value, 1) if $value;
227          $warning .= ($warning ? ', ' : '') . $warn if $warn;
228
229          # Expand internal variables
230          ($value, $warn) = $self->_expand_variable ($value, 0) if $value;
231          $warning .= ($warning ? ', ' : '') . $warn if $warn;
232        }
233      }
234
235      # Determine whether current line ends with a continuation mark
236      if ($value =~ s/\\$//) {
237        $cont = scalar (@{ $self->lines }) unless defined $cont;
238
239      } else {
240        $cont = undef;
241      }
242    }
243
244    if (    defined($self->type())
245        &&  exists($exp_inc{uc($self->type())})
246        &&  uc($start ? $start->label() : $label) eq $self->cfglabel('INC')
247        &&  !defined($cont)
248    ) {
249      # Current configuration file requires expansion of INC declarations
250      # The start/current line is an INC declaration
251      # The current line is not a continuation or is the end of the continuation
252
253      # Get lines from an "include" configuration file
254      my $src = ($start ? $start->value : $value);
255      $src   .= '@' . $self->pegrev if $here and $self->pegrev;
256
257      if ($src) {
258        # Invoke a new instance to read the source
259        my $cfg = FCM1::CfgFile->new (
260          SRC => expand_tilde ($src), TYPE => $self->type,
261        );
262
263        $cfg->read_cfg;
264
265        # Add lines to the lines array in the current configuration file
266        $comment = 'INC ' . $src . ' ';
267        push @{$self->lines}, FCM1::CfgLine->new (
268          comment => $comment . '# Start',
269          number  => ($start ? $start->number : $line_num),
270          src     => $self->actual_src,
271          warning => $warning,
272        );
273        push @{ $self->lines }, @{ $cfg->lines };
274        push @{$self->lines}, FCM1::CfgLine->new (
275          comment => $comment . '# End',
276          src     => $self->actual_src,
277        );
278
279      } else {
280        push @{$self->lines}, FCM1::CfgLine->new (
281          number  => $line_num,
282          src     => $self->actual_src,
283          warning => 'empty INC declaration.'
284        );
285      }
286
287    } else {
288      # Push label:value pair into lines array
289      push @{$self->lines}, FCM1::CfgLine->new (
290        label   => $label,
291        value   => ($label ? $value : ''),
292        comment => $comment,
293        number  => $line_num,
294        src     => $self->actual_src,
295        warning => $warning,
296      );
297    }
298
299    next if defined $cont; # current line not a continuation
300
301    my $slabel = ($start ? $start->label : $label);
302    my $svalue = ($start ? $start->value : $value);
303    next unless $slabel;
304
305    # Check config file type and version
306    if (index (uc ($slabel), $self->cfglabel ('CFGFILE')) == 0) {
307      my @words = split /$FCM1::Config::DELIMITER_PATTERN/, $slabel;
308      shift @words;
309
310      my $name = @words ? lc ($words[0]) : 'type';
311
312      if ($self->can ($name)) {
313        $self->$name ($svalue);
314      }
315    }
316
317    # Set internal variable
318    $slabel =~ s/^\%//; # Remove leading "%" from label
319
320    $self->config->variable ($slabel, $svalue)
321      unless exists $cfg_keywords{$slabel};
322  }
323
324  # Report and reset warnings
325  # ----------------------------------------------------------------------------
326  for my $line (@{ $self->lines }) {
327    w_report $line->format_warning if $line->warning;
328    $line->warning (undef);
329  }
330
331  return @{ $self->lines };
332
333}
334
335# ------------------------------------------------------------------------------
336# SYNOPSIS
337#   $rc = $obj->print_cfg ($file, [$force]);
338#
339# DESCRIPTION
340#   This method prints the content of current configuration file. If no
341#   argument is specified, it prints output to the standard output. If $file is
342#   specified, and is a writable file name, the output is sent to the file.  If
343#   the file already exists, its content is compared to the current output.
344#   Nothing will be written if the content is unchanged unless $force is
345#   specified. Otherwise, for typed configuration files, the existing file is
346#   renamed using a prefix that contains its last modified time. The method
347#   returns 1 if there is no error.
348# ------------------------------------------------------------------------------
349
350sub print_cfg {
351  my ($self, $file, $force) = @_;
352
353  # Count maximum number of characters in the labels, (for pretty printing)
354  my $max_label_len = 0;
355  for my $line (@{ $self->lines }) {
356    next unless $line->label;
357    my $label_len  = length $line->label;
358    $max_label_len = $label_len if $label_len > $max_label_len;
359  }
360
361  # Output string
362  my $out = '';
363
364  # Append each line of the config file to the output string
365  for my $line (@{ $self->lines }) {
366    $out .= $line->print_line ($max_label_len - length ($line->label) + 1);
367    $out .= "\n";
368  }
369
370  if ($out) {
371    my $out_handle = select();
372
373    # Open file if necessary
374    if ($file) {
375      # Make sure the host directory exists and is writable
376      my $dirname = dirname $file;
377      if (not -d $dirname) {
378        print 'Make directory: ', $dirname, "\n" if $self->verbose;
379        mkpath $dirname;
380      }
381      croak $dirname, ': cannot write to config file directory, abort'
382        unless -d $dirname;
383
384      if (-f $file and not $force) {
385        # Read old config file to see if content has changed
386        open(my $handle, '<', $file) || croak("$file: $!\n");
387        my $in_lines = '';
388        while (my $line = readline($handle)) {
389          $in_lines .= $line;
390        }
391        close($handle);
392
393        # Return if content is up-to-date
394        if ($in_lines eq $out) {
395          print 'No change in ', lc ($self->type), ' cfg: ', $file, "\n"
396            if $self->verbose > 1 and $self->type;
397          return 1;
398        }
399
400        # If config file already exists, make sure it is writable
401        if ($self->type) {
402          # Existing config file writable, rename it using its time stamp
403          my $mtime = (stat $file)[9];
404          my ($sec, $min, $hour, $mday, $mon, $year) = (gmtime $mtime)[0 .. 5];
405          my $timestamp = sprintf '%4d%2.2d%2.2d_%2.2d%2.2d%2.2d_',
406                          $year + 1900, $mon + 1, $mday, $hour, $min, $sec;
407          my $oldfile   = File::Spec->catfile (
408            $dirname, $timestamp . basename ($file)
409          );
410          rename $file, $oldfile;
411          print 'Rename existing ', lc ($self->type), ' cfg: ',
412                $oldfile, "\n" if $self->verbose > 1;
413        }
414      }
415
416      # Open file and select file handle
417      open(my $handle, '>', $file) || croak("$file: $!\n");
418      $out_handle = $handle;
419    }
420
421    # Print output
422    print($out_handle $out);
423
424    # Close file if necessary
425    if ($file) {
426      close($out_handle) || croak("$file: $!\n");
427
428      if ($self->type and $self->verbose > 1) {
429        print 'Generated ', lc ($self->type), ' cfg: ', $file, "\n";
430
431      } elsif ($self->verbose > 2) {
432        print 'Generated cfg: ', $file, "\n";
433      }
434    }
435
436  } else {
437    # Warn if nothing to print
438    my $warning = 'Empty configuration';
439    $warning   .= ' - nothing written to file: ' . $file if $file;
440    carp $warning if $self->type;
441  }
442
443  return 1;
444}
445
446# ------------------------------------------------------------------------------
447# SYNOPSIS
448#   @lines = $self->_get_cfg_lines($is_for_inheritance);
449#
450# DESCRIPTION
451#   This internal method opens the configuration file and returns its contents
452#   as an array of lines. If the $self->src() is given as a URI, the method
453#   tries to read it with "svn cat". Otherwise, the method tries to read
454#   $self->src() with open() and readline(). If $self->type() is not a known
455#   type, $self->src() can only be a regular file and $is_for_inheritance is
456#   ignored.  Otherwise, $self->src() can be a regular file or a directory and
457#   $is_for_inheritance is used to determine the behaviour for searching the
458#   directory for a configuration file. If $is_for_inheritance is set, the
459#   config file may be located at "$src/cfg/$type.cfg". If $is_for_inheritance
460#   is not set, the config file may be located at "$src/$type.cfg" or
461#   "$src/cfg/$type.cfg".
462# ------------------------------------------------------------------------------
463
464sub _get_cfg_lines {
465  my ($self, $is_for_inheritance) = @_;
466  my $DIAG = sub {};
467  my @paths_refs = ([]);
468  if ($self->type() && exists($self->setting('CFG_NAME')->{uc($self->type())})) {
469    my $base = $self->setting('CFG_NAME')->{uc($self->type())};
470    if (!$is_for_inheritance) {
471      push(@paths_refs, [$base]);
472    }
473    push(@paths_refs, [$self->setting(qw/DIR CFG/), $base]);
474    if ($self->verbose()) {
475      $DIAG = sub {printf("Config file (%s): %s\n", $self->type(), @_)};
476    }
477  }
478  if ($self->src() =~ qr{\A([A-Za-z][\w\+-\.]*):}xms) {
479    # $self->src() is a URI, try "svn cat"
480    my $src = FCM1::Util::tidy_url(FCM1::Keyword::expand($self->src()));
481    my ($uri, $rev) = $src =~ qr{\A(.+?)(?:\@([^\@]+))?\z}msx;
482    $rev ||= 'HEAD';
483    for my $paths_ref (@paths_refs) {
484      my $path = join('/', $uri, @{$paths_ref}) . '@' . $rev;
485      local($@);
486      my @lines = eval {
487        run_command([qw/svn cat/, $path], METHOD => 'qx', DEVNULL => 1);
488      };
489      if (!$@) {
490        $self->pegrev($rev);
491        $self->actual_src($path);
492        $DIAG->($path);
493        return @lines;
494      }
495    }
496  }
497  else {
498    # $self->src() is not a URI, assume that it resides in the file system
499    for my $paths_ref (@paths_refs) {
500      my $path = File::Spec->catfile($self->src(), @{$paths_ref});
501      if (-e $path && !-d $path) { # "-f $path" returns false for "/dev/null"
502        open(my $handle, '<', $path)
503          || croak("$path: cannot open config file, abort: $!");
504        my @lines = readline($handle);
505        close($handle);
506        $self->actual_src($path);
507        $DIAG->($path);
508        return @lines;
509      }
510    }
511  }
512  croak(sprintf("%s: cannot locate config file, abort", $self->src()));
513}
514
515# ------------------------------------------------------------------------------
516# SYNOPSIS
517#   $string = $self->_expand_variable ($string, $env[, \%recursive_set]);
518#
519# DESCRIPTION
520#   This internal method expands variables in $string. If $env is true, it
521#   expands environment variables. Otherwise, it expands local variables. If
522#   %recursive_set is specified, it indicates that this method is being called
523#   recursively. In which case, it must not attempt to expand a variable that
524#   exists in the keys of %recursive_set.
525# ------------------------------------------------------------------------------
526
527sub _expand_variable {
528  my ($self, $string, $env, $recursive_set_ref) = @_;
529
530  # Pattern for environment/local variable
531  my @patterns = $env
532    ? (qr#\$([A-Z][A-Z0-9_]+)#, qr#\$\{([A-Z][A-Z0-9_]+)\}#)
533    : (qr#%(\w+(?:::[\w\.-]+)*)#, qr#%\{(\w+(?:(?:::|/)[\w\.-]+)*)\}#);
534
535  my $ret = '';
536  my $warning = undef;
537  while ($string) {
538    # Find the first match in $string
539    my ($prematch, $match, $postmatch, $var_label);
540    for my $pattern (@patterns) {
541      next unless $string =~ /$pattern/;
542      if ((not defined $prematch) or length ($`) < length ($prematch)) {
543        $prematch = $`;
544        $match = $&;
545        $var_label = $1;
546        $postmatch = $';
547      }
548    }
549
550    if ($match) {
551      $ret .= $prematch;
552      $string = $postmatch;
553
554      # Get variable value from environment or local configuration
555      my $variable = $env
556                     ? (exists $ENV{$var_label} ? $ENV{$var_label} : undef)
557                     : $self->config->variable ($var_label);
558
559      if ($env and $var_label eq 'HERE' and not defined $variable) {
560        $variable = dirname ($self->actual_src);
561        $variable = File::Spec->rel2abs ($variable) if not &is_url ($variable);
562      }
563
564      # Substitute match with value of variable
565      if (defined $variable) {
566        my %set = (($recursive_set_ref ? %{$recursive_set_ref} : ()));
567        if (exists($set{$var_label})) {
568          $warning .= ', ' if $warning;
569          $warning .= $match . ': cyclic dependency, variable not expanded';
570          $ret .= $variable;
571
572        } else {
573          my ($r, $w)
574            = $self->_expand_variable($variable, $env, {%set, $var_label => 1});
575          $ret .= $r;
576          if ($w) {
577            $warning .= ', ' if $warning;
578            $warning .= $w;
579          }
580        }
581
582      } else {
583        $warning .= ', ' if $warning;
584        $warning .= $match . ': variable not expanded';
585        $ret .= $match;
586      }
587
588    } else {
589      $ret .= $string;
590      $string = "";
591    }
592  }
593
594  return ($ret, $warning);
595}
596
5971;
598
599__END__
Note: See TracBrowser for help on using the repository browser.