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

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

Remove svn keywords

File size: 20.1 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 (exists $exp_inc{uc ($self->type)} and
235        uc ($start ? $start->label : $label) eq $self->cfglabel ('INC') and
236        not defined $cont) {
237      # Current configuration file requires expansion of INC declarations
238      # The start/current line is an INC declaration
239      # The current line is not a continuation or is the end of the continuation
240
241      # Get lines from an "include" configuration file
242      my $src = ($start ? $start->value : $value);
243      $src   .= '@' . $self->pegrev if $here and $self->pegrev;
244
245      if ($src) {
246        # Invoke a new instance to read the source
247        my $cfg = Fcm::CfgFile->new (
248          SRC => expand_tilde ($src), TYPE => $self->type,
249        );
250
251        $cfg->read_cfg;
252
253        # Add lines to the lines array in the current configuration file
254        $comment = 'INC ' . $src . ' ';
255        push @{$self->lines}, Fcm::CfgLine->new (
256          comment => $comment . '# Start',
257          number  => ($start ? $start->number : $line_num),
258          src     => $self->actual_src,
259          warning => $warning,
260        );
261        push @{ $self->lines }, @{ $cfg->lines };
262        push @{$self->lines}, Fcm::CfgLine->new (
263          comment => $comment . '# End',
264          src     => $self->actual_src,
265        );
266
267      } else {
268        push @{$self->lines}, Fcm::CfgLine->new (
269          number  => $line_num,
270          src     => $self->actual_src,
271          warning => 'empty INC declaration.'
272        );
273      }
274
275    } else {
276      # Push label:value pair into lines array
277      push @{$self->lines}, Fcm::CfgLine->new (
278        label   => $label,
279        value   => ($label ? $value : ''),
280        comment => $comment,
281        number  => $line_num,
282        src     => $self->actual_src,
283        warning => $warning,
284      );
285    }
286
287    next if defined $cont; # current line not a continuation
288
289    my $slabel = ($start ? $start->label : $label);
290    my $svalue = ($start ? $start->value : $value);
291    next unless $slabel;
292
293    # Check config file type and version
294    if (index (uc ($slabel), $self->cfglabel ('CFGFILE')) == 0) {
295      my @words = split /$Fcm::Config::DELIMITER_PATTERN/, $slabel;
296      shift @words;
297
298      my $name = @words ? lc ($words[0]) : 'type';
299
300      if ($self->can ($name)) {
301        $self->$name ($svalue);
302      }
303    }
304
305    # Set internal variable
306    $slabel =~ s/^\%//; # Remove leading "%" from label
307
308    $self->config->variable ($slabel, $svalue)
309      unless exists $cfg_keywords{$slabel};
310  }
311
312  # Report and reset warnings
313  # ----------------------------------------------------------------------------
314  for my $line (@{ $self->lines }) {
315    w_report $line->format_warning if $line->warning;
316    $line->warning (undef);
317  }
318
319  return @{ $self->lines };
320
321}
322
323# ------------------------------------------------------------------------------
324# SYNOPSIS
325#   $rc = $obj->print_cfg ($file, [$force]);
326#
327# DESCRIPTION
328#   This method prints the content of current configuration file. If no
329#   argument is specified, it prints output to the standard output. If $file is
330#   specified, and is a writable file name, the output is sent to the file.  If
331#   the file already exists, its content is compared to the current output.
332#   Nothing will be written if the content is unchanged unless $force is
333#   specified. Otherwise, for typed configuration files, the existing file is
334#   renamed using a prefix that contains its last modified time. The method
335#   returns 1 if there is no error.
336# ------------------------------------------------------------------------------
337
338sub print_cfg {
339  my ($self, $file, $force) = @_;
340
341  # Count maximum number of characters in the labels, (for pretty printing)
342  my $max_label_len = 0;
343  for my $line (@{ $self->lines }) {
344    next unless $line->label;
345    my $label_len  = length $line->label;
346    $max_label_len = $label_len if $label_len > $max_label_len;
347  }
348
349  # Output string
350  my $out = '';
351
352  # Append each line of the config file to the output string
353  for my $line (@{ $self->lines }) {
354    $out .= $line->print_line ($max_label_len - length ($line->label) + 1);
355    $out .= "\n";
356  }
357
358  if ($out) {
359    my $old_select = select;
360
361    # Open file if necessary
362    if ($file) {
363      # Make sure the host directory exists and is writable
364      my $dirname = dirname $file;
365      if (not -d $dirname) {
366        print 'Make directory: ', $dirname, "\n" if $self->verbose;
367        mkpath $dirname;
368      }
369      croak $dirname, ': cannot write to config file directory, abort'
370        unless -d $dirname and -w $dirname;
371
372      if (-f $file and not $force) {
373        if (-r $file) {
374          # Read old config file to see if content has changed
375          open IN, '<', $file or croak $file, ': cannot open (', $!, '), abort';
376          my $in_lines = '';
377          while (my $line = <IN>) {
378            $in_lines .= $line;
379          }
380          close IN or croak $file, ': cannot close (', $!, '), abort';
381
382          # Return if content is up-to-date
383          if ($in_lines eq $out) {
384            print 'No change in ', lc ($self->type), ' cfg: ', $file, "\n"
385              if $self->verbose > 1 and $self->type;
386            return 1;
387          }
388        }
389
390        # If config file already exists, make sure it is writable
391        if (-w $file) {
392          if ($self->type) {
393            # Existing config file writable, rename it using its time stamp
394            my $mtime = (stat $file)[9];
395            my ($sec, $min, $hour, $mday, $mon, $year) = (gmtime $mtime)[0 .. 5];
396            my $timestamp = sprintf '%4d%2.2d%2.2d_%2.2d%2.2d%2.2d_',
397                            $year + 1900, $mon + 1, $mday, $hour, $min, $sec;
398            my $oldfile   = File::Spec->catfile (
399              $dirname, $timestamp . basename ($file)
400            );
401            rename $file, $oldfile;
402            print 'Rename existing ', lc ($self->type), ' cfg: ',
403                  $oldfile, "\n" if $self->verbose > 1;
404          }
405
406        } else {
407          # Existing config file not writable, throw an error
408          croak $file, ': config file not writable, abort';
409        }
410      }
411
412      # Open file and select file handle
413      open OUT, '>', $file
414        or croak $file, ': cannot open config file (', $!, '), abort';
415      select OUT;
416    }
417
418    # Print output
419    print $out;
420
421    # Close file if necessary
422    if ($file) {
423      select $old_select;
424      close OUT or croak $file, ': cannot close config file (', $!, '), abort';
425
426      if ($self->type and $self->verbose > 1) {
427        print 'Generated ', lc ($self->type), ' cfg: ', $file, "\n";
428
429      } elsif ($self->verbose > 2) {
430        print 'Generated cfg: ', $file, "\n";
431      }
432    }
433
434  } else {
435    # Warn if nothing to print
436    my $warning = 'Empty configuration';
437    $warning   .= ' - nothing written to file: ' . $file if $file;
438    carp $warning if $self->type;
439  }
440
441  return 1;
442}
443
444# ------------------------------------------------------------------------------
445# SYNOPSIS
446#   @lines = $self->_get_cfg_lines ();
447#
448# DESCRIPTION
449#   This internal method reads from a configuration file residing in a
450#   Subversion repository or in the normal file system.
451# ------------------------------------------------------------------------------
452
453sub _get_cfg_lines {
454  my $self  = shift;
455  my @lines = ();
456
457  my $verbose = $self->verbose;
458
459  my ($src) = $self->src();
460  if ($src =~ qr{\A([A-Za-z][\w\+-\.]*):}xms) { # is a URI
461    $src = Fcm::Keyword::expand($src);
462    # Config file resides in a SVN repository
463    # --------------------------------------------------------------------------
464    # Set URL source and version
465    my $rev = 'HEAD';
466
467    # Extract version from source if it exists
468    if ($src =~ s{\@ ([^\@]+) \z}{}xms) {
469      $rev = $1;
470    }
471
472    $src = Fcm::Util::tidy_url($src);
473
474    # Check whether URL is a config file
475    my $rc;
476    my @cmd = (qw/svn cat/, $src . '@' . $rev);
477    @lines = &run_command (
478      \@cmd, METHOD => 'qx', DEVNULL => 1, RC => \$rc, ERROR => 'ignore',
479    );
480
481    # Error in "svn cat" command
482    if ($rc) {
483      # See whether specified config file is a known type
484      my %cfgname = %{ $self->setting ('CFG_NAME') };
485      my $key     = uc $self->type;
486      my $file    = exists $cfgname{$key} ? $cfgname{$key} : '';
487
488      # If config file is a known type, specified URL may be a directory
489      if ($file) {
490        # Check whether a config file with a default name exists in the URL
491        my $path = $src . '/' . $file;
492        my @cmd  = (qw/svn cat/, $path . '@' . $rev);
493
494        @lines = &run_command (
495          \@cmd, METHOD => 'qx', DEVNULL => 1, RC => \$rc, ERROR => 'ignore',
496        );
497
498        # Check whether a config file with a default name exists under the "cfg"
499        # sub-directory of the URL
500        if ($rc) {
501          my $cfgdir = $self->setting (qw/DIR CFG/);
502          $path   = $src . '/' . $cfgdir . '/' . $file;
503          my @cmd = (qw/svn cat/, $path . '@' . $rev);
504
505          @lines  = &run_command (
506            \@cmd, METHOD => 'qx', DEVNULL => 1, RC => \$rc, ERROR => 'ignore',
507          );
508        }
509
510        $src = $path unless $rc;
511      }
512    }
513
514    if ($rc) {
515      # Error in "svn cat"
516      croak 'Unable to locate config file from "', $self->src, '", abort';
517
518    } else {
519      # Print diagnostic, if necessary
520      if ($verbose and $self->type and $self->type =~ /$expand_type/) {
521        print 'Config file (', $self->type, '): ', $src;
522        print '@', $rev if $rev;
523        print "\n";
524      }
525    }
526
527    # Record the actual source location
528    $self->pegrev ($rev);
529    $self->actual_src ($src);
530
531  } else {
532    # Config file resides in the normal file system
533    # --------------------------------------------------------------------------
534    my $src = $self->src;
535
536    if (-d $src) { # Source is a directory
537      croak 'Config file "', $src, '" is a directory, abort' if not $self->type;
538
539      # Get name of the config file by looking at the type
540      my %cfgname = %{ $self->setting ('CFG_NAME') };
541      my $key     = uc $self->type;
542      my $file    = exists $cfgname{$key} ? $cfgname{$key} : '';
543
544      if ($file) {
545        my $cfgdir = $self->setting (qw/DIR CFG/);
546
547        # Check whether a config file with a default name exists in the
548        # specified path, then check whether a config file with a default name
549        # exists under the "cfg" sub-directory of the specified path
550        if (-f File::Spec->catfile ($self->src, $file)) {
551          $src = File::Spec->catfile ($self->src, $file);
552
553        } elsif (-f File::Spec->catfile ($self->src, $cfgdir, $file)) {
554          $src = File::Spec->catfile ($self->src, $cfgdir, $file);
555
556        } else {
557          croak 'Unable to locate config file from "', $self->src, '", abort';
558        }
559
560      } else {
561        croak 'Unknown config file type "', $self->type, '", abort';
562      }
563    }
564
565    if (-r $src) {
566      open FILE, '<', $src;
567      print 'Config file (', $self->type, '): ', $src, "\n"
568        if $verbose and $self->type and $self->type =~ /$expand_type/;
569
570      @lines = readline 'FILE';
571      close FILE;
572
573    } else {
574      croak 'Unable to read config file "', $src, '", abort';
575    }
576
577    # Record the actual source location
578    $self->actual_src ($src);
579  }
580
581  return @lines;
582}
583
584# ------------------------------------------------------------------------------
585# SYNOPSIS
586#   $string = $self->_expand_variable ($string, $env[, \%recursive]);
587#
588# DESCRIPTION
589#   This internal method expands variables in $string. If $env is true, it
590#   expands environment variables. Otherwise, it expands local variables. If
591#   %recursive is set, it indicates that this method is being called
592#   recursively. In which case, it must not attempt to expand a variable that
593#   exists in the keys of %recursive.
594# ------------------------------------------------------------------------------
595
596sub _expand_variable {
597  my ($self, $string, $env, $recursive) = @_;
598
599  # Pattern for environment/local variable
600  my @patterns = $env
601    ? (qr#\$([A-Z][A-Z0-9_]+)#, qr#\$\{([A-Z][A-Z0-9_]+)\}#)
602    : (qr#%(\w+(?:::[\w\.-]+)*)#, qr#%\{(\w+(?:(?:::|/)[\w\.-]+)*)\}#);
603
604  my $ret = '';
605  my $warning = undef;
606  while ($string) {
607    # Find the first match in $string
608    my ($prematch, $match, $postmatch, $var_label);
609    for my $pattern (@patterns) {
610      next unless $string =~ /$pattern/;
611      if ((not defined $prematch) or length ($`) < length ($prematch)) {
612        $prematch = $`;
613        $match = $&;
614        $var_label = $1;
615        $postmatch = $';
616      }
617    }
618
619    if ($match) {
620      $ret .= $prematch;
621      $string = $postmatch;
622
623      # Get variable value from environment or local configuration
624      my $variable = $env
625                     ? (exists $ENV{$var_label} ? $ENV{$var_label} : undef)
626                     : $self->config->variable ($var_label);
627
628      if ($env and $var_label eq 'HERE' and not defined $variable) {
629        $variable = dirname ($self->actual_src);
630        $variable = File::Spec->rel2abs ($variable) if not &is_url ($variable);
631      }
632
633      # Substitute match with value of variable
634      if (defined $variable) {
635        my $cyclic = 0;
636        if ($recursive) {
637          if (exists $recursive->{$var_label}) {
638            $cyclic = 1;
639
640          } else {
641            $recursive->{$var_label} = 1;
642          }
643
644        } else {
645          $recursive = {$var_label => 1};
646        }
647
648        if ($cyclic) {
649          $warning .= ', ' if $warning;
650          $warning .= $match . ': cyclic dependency, variable not expanded';
651          $ret .= $variable;
652
653        } else {
654          my ($r, $w) = $self->_expand_variable ($variable, $env, $recursive);
655          $ret .= $r;
656          if ($w) {
657            $warning .= ', ' if $warning;
658            $warning .= $w;
659          }
660        }
661
662      } else {
663        $warning .= ', ' if $warning;
664        $warning .= $match . ': variable not expanded';
665        $ret .= $match;
666      }
667
668    } else {
669      $ret .= $string;
670      $string = "";
671    }
672  }
673
674  return ($ret, $warning);
675}
676
6771;
678
679__END__
Note: See TracBrowser for help on using the repository browser.