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

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

creation de larborescence
File size: 20.3 KB
Line 
1#!/usr/bin/perl
2# ------------------------------------------------------------------------------
3# NAME
4#   Fcm::CfgFile
5#
6# DESCRIPTION
7#   This class is used for reading and writing FCM config files. A FCM config
8#   file is a line-based text file that provides information on how to perform
9#   a particular task using the FCM system.
10#
11# COPYRIGHT
12#   (C) Crown copyright Met Office. All rights reserved.
13#   For further details please refer to the file COPYRIGHT.txt
14#   which you should have received as part of this distribution.
15# ------------------------------------------------------------------------------
16
17package Fcm::CfgFile;
18@ISA = qw(Fcm::Base);
19
20# Standard pragma
21use warnings;
22use strict;
23
24# Standard modules
25use Carp;
26use File::Basename;
27use File::Path;
28use File::Spec;
29
30# FCM component modules
31use Fcm::Base;
32use Fcm::CfgLine;
33use Fcm::Config;
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  # Expand URL keywords if necessary
460  {
461    my $src = expand_url_keyword (URL => $self->src, CFG => $self->config);
462    $self->src ($src) if $src ne $self->src;
463  }
464
465  if (&is_url ($self->src)) {
466    # Config file resides in a SVN repository
467    # --------------------------------------------------------------------------
468    # Set URL source and version
469    my $src = $self->src;
470    my $rev = 'HEAD';
471
472    # Extract version from source if it exists
473    if ($src =~ s/@(.+)$//) {
474      $rev = $1;
475    }
476
477    # Expand revision keyword, if required
478    $rev = expand_rev_keyword (REV => $rev, URL => $src, HEAD => 1);
479
480    # Check whether URL is a config file
481    my $rc;
482    my @cmd = (qw/svn cat/, $src . '@' . $rev);
483    @lines = &run_command (
484      \@cmd, METHOD => 'qx', DEVNULL => 1, RC => \$rc, ERROR => 'ignore',
485    );
486
487    # Error in "svn cat" command
488    if ($rc) {
489      # See whether specified config file is a known type
490      my %cfgname = %{ $self->setting ('CFG_NAME') };
491      my $key     = uc $self->type;
492      my $file    = exists $cfgname{$key} ? $cfgname{$key} : '';
493
494      # If config file is a known type, specified URL may be a directory
495      if ($file) {
496        # Check whether a config file with a default name exists in the URL
497        my $path = $src . '/' . $file;
498        my @cmd  = (qw/svn cat/, $path . '@' . $rev);
499
500        @lines = &run_command (
501          \@cmd, METHOD => 'qx', DEVNULL => 1, RC => \$rc, ERROR => 'ignore',
502        );
503
504        # Check whether a config file with a default name exists under the "cfg"
505        # sub-directory of the URL
506        if ($rc) {
507          my $cfgdir = $self->setting (qw/DIR CFG/);
508          $path   = $src . '/' . $cfgdir . '/' . $file;
509          my @cmd = (qw/svn cat/, $path . '@' . $rev);
510
511          @lines  = &run_command (
512            \@cmd, METHOD => 'qx', DEVNULL => 1, RC => \$rc, ERROR => 'ignore',
513          );
514        }
515
516        $src = $path unless $rc;
517      }
518    }
519
520    if ($rc) {
521      # Error in "svn cat"
522      croak 'Unable to locate config file from "', $self->src, '", abort';
523
524    } else {
525      # Print diagnostic, if necessary
526      if ($verbose and $self->type and $self->type =~ /$expand_type/) {
527        print 'Config file (', $self->type, '): ', $src;
528        print '@', $rev if $rev;
529        print "\n";
530      }
531    }
532
533    # Record the actual source location
534    $self->pegrev ($rev);
535    $self->actual_src ($src);
536
537  } else {
538    # Config file resides in the normal file system
539    # --------------------------------------------------------------------------
540    my $src = $self->src;
541
542    if (-d $src) { # Source is a directory
543      croak 'Config file "', $src, '" is a directory, abort' if not $self->type;
544
545      # Get name of the config file by looking at the type
546      my %cfgname = %{ $self->setting ('CFG_NAME') };
547      my $key     = uc $self->type;
548      my $file    = exists $cfgname{$key} ? $cfgname{$key} : '';
549
550      if ($file) {
551        my $cfgdir = $self->setting (qw/DIR CFG/);
552
553        # Check whether a config file with a default name exists in the
554        # specified path, then check whether a config file with a default name
555        # exists under the "cfg" sub-directory of the specified path
556        if (-f File::Spec->catfile ($self->src, $file)) {
557          $src = File::Spec->catfile ($self->src, $file);
558
559        } elsif (-f File::Spec->catfile ($self->src, $cfgdir, $file)) {
560          $src = File::Spec->catfile ($self->src, $cfgdir, $file);
561
562        } else {
563          croak 'Unable to locate config file from "', $self->src, '", abort';
564        }
565
566      } else {
567        croak 'Unknown config file type "', $self->type, '", abort';
568      }
569    }
570
571    if (-r $src) {
572      open FILE, '<', $src;
573      print 'Config file (', $self->type, '): ', $src, "\n"
574        if $verbose and $self->type and $self->type =~ /$expand_type/;
575
576      @lines = readline 'FILE';
577      close FILE;
578
579    } else {
580      croak 'Unable to read config file "', $src, '", abort';
581    }
582
583    # Record the actual source location
584    $self->actual_src ($src);
585  }
586
587  return @lines;
588}
589
590# ------------------------------------------------------------------------------
591# SYNOPSIS
592#   $string = $self->_expand_variable ($string, $env[, \%recursive]);
593#
594# DESCRIPTION
595#   This internal method expands variables in $string. If $env is true, it
596#   expands environment variables. Otherwise, it expands local variables. If
597#   %recursive is set, it indicates that this method is being called
598#   recursively. In which case, it must not attempt to expand a variable that
599#   exists in the keys of %recursive.
600# ------------------------------------------------------------------------------
601
602sub _expand_variable {
603  my ($self, $string, $env, $recursive) = @_;
604
605  # Pattern for environment/local variable
606  my @patterns = $env
607    ? (qr#\$([A-Z][A-Z0-9_]+)#, qr#\$\{([A-Z][A-Z0-9_]+)\}#)
608    : (qr#%(\w+(?:::[\w\.-]+)*)#, qr#%\{(\w+(?:(?:::|/)[\w\.-]+)*)\}#);
609
610  my $ret = '';
611  my $warning = undef;
612  while ($string) {
613    # Find the first match in $string
614    my ($prematch, $match, $postmatch, $var_label);
615    for my $pattern (@patterns) {
616      next unless $string =~ /$pattern/;
617      if ((not defined $prematch) or length ($`) < length ($prematch)) {
618        $prematch = $`;
619        $match = $&;
620        $var_label = $1;
621        $postmatch = $';
622      }
623    }
624
625    if ($match) {
626      $ret .= $prematch;
627      $string = $postmatch;
628
629      # Get variable value from environment or local configuration
630      my $variable = $env
631                     ? (exists $ENV{$var_label} ? $ENV{$var_label} : undef)
632                     : $self->config->variable ($var_label);
633
634      if ($env and $var_label eq 'HERE' and not defined $variable) {
635        $variable = dirname ($self->actual_src);
636        $variable = File::Spec->rel2abs ($variable) if not &is_url ($variable);
637      }
638
639      # Substitute match with value of variable
640      if (defined $variable) {
641        my $cyclic = 0;
642        if ($recursive) {
643          if (exists $recursive->{$var_label}) {
644            $cyclic = 1;
645
646          } else {
647            $recursive->{$var_label} = 1;
648          }
649
650        } else {
651          $recursive = {$var_label => 1};
652        }
653
654        if ($cyclic) {
655          $warning .= ', ' if $warning;
656          $warning .= $match . ': cyclic dependency, variable not expanded';
657          $ret .= $variable;
658
659        } else {
660          my ($r, $w) = $self->_expand_variable ($variable, $env, $recursive);
661          $ret .= $r;
662          if ($w) {
663            $warning .= ', ' if $warning;
664            $warning .= $w;
665          }
666        }
667
668      } else {
669        $warning .= ', ' if $warning;
670        $warning .= $match . ': variable not expanded';
671        $ret .= $match;
672      }
673
674    } else {
675      $ret .= $string;
676      $string = "";
677    }
678  }
679
680  return ($ret, $warning);
681}
682
6831;
684
685__END__
Note: See TracBrowser for help on using the repository browser.