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/FCM/lib/Fcm – NEMO

source: vendors/FCM/lib/Fcm/CfgFile.pm @ 10134

Last change on this file since 10134 was 10134, checked in by dguibert, 6 years ago

fcm: fix fortran interface generation with perl 5.12+

this patch applies both patches from:

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