source: LMDZ5/branches/testing/tools/fcm/lib/Fcm/CfgFile.pm @ 5444

Last change on this file since 5444 was 1665, checked in by Laurent Fairhead, 12 years ago

Version testing basée sur la r1628

http://lmdz.lmd.jussieu.fr/utilisateurs/distribution-du-modele/versions-intermediaires

Testing release based on r1628
File size: 25.2 KB
RevLine 
[1578]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
19# Standard pragma
20use warnings;
21use strict;
22
23# Standard modules
24use Carp;
25use File::Basename;
26use File::Path;
27use File::Spec;
28use File::Spec::Functions;
29
30# FCM component modules
31use Fcm::Util;
32
33# Local module variables
34my $expand_type   = 'bld|ext'; # config file type that needs variable expansions
35
36# ------------------------------------------------------------------------------
37# SYNOPSIS
38#   $cfgfile = Fcm::CfgFile->new (CONFIG=> $config, SRC => $src, TYPE => $type);
39#
40# DESCRIPTION
41#   This method constructs a new instance of the Fcm::CfgFile class.
42#
43# ARGUMENTS
44#   CONFIG - reference to a Fcm::Config instance
45#   SRC    - configuration file source
46#   TYPE   - type of expected configuration file
47# ------------------------------------------------------------------------------
48
49sub new {
50  my $this  = shift;
51  my %args  = @_;
52  my $class = ref $this || $this;
53
54  my $self = {
55    CONFIG     => exists $args{CONFIG} ? $args{CONFIG} : &main::cfg,
56    SRC        => exists $args{SRC}    ? $args{SRC}    : undef,
57    TYPE       => exists $args{TYPE}   ? $args{TYPE}   : undef,
58
59    # Version of the configuration file
60    VERSION    => undef,
61
62    # List of references to hash tables for each line in the file
63    LINES      => [],
64
65    # Actual source of configuration file
66    ACTUAL_SRC => undef,
67    PEGREV     => undef,
68  };
69  bless $self, $class;
70  return $self;
71}
72
73# ------------------------------------------------------------------------------
74# SYNOPSIS
75#   $config = $cfgfile->config;
76#
77# DESCRIPTION
78#   This method returns a reference to the Fcm::Config instance.
79# ------------------------------------------------------------------------------
80
81sub config {
82  my $self = shift;
83
84  return $self->{CONFIG};
85}
86
87# ------------------------------------------------------------------------------
88# SYNOPSIS
89#   $src = $cfgfile->src ();
90#   $cfgfile->src ($src);
91#
92# DESCRIPTION
93#   This method returns the specified source of the configuration file. If an
94#   argument is specified, the source of the configuration file is modified to
95#   the value of the argument.
96# ------------------------------------------------------------------------------
97
98sub src {
99  my $self = shift;
100
101  if (@_) {
102    $self->{SRC} = shift;
103  }
104
105  return $self->{SRC};
106}
107
108# ------------------------------------------------------------------------------
109# SYNOPSIS
110#   $src = $cfgfile->actual_src ();
111#
112# DESCRIPTION
113#   This method returns the actual source of the configuration file. If an
114#   argument is specified, the source of the configuration file is modified to
115#   the value of the argument.
116# ------------------------------------------------------------------------------
117
118sub actual_src {
119  my $self = shift;
120
121  return $self->{ACTUAL_SRC};
122}
123
124# ------------------------------------------------------------------------------
125# SYNOPSIS
126#   $rev = $cfgfile->pegrev ();
127#
128# DESCRIPTION
129#   This method returns the peg revision of the configuration file.
130# ------------------------------------------------------------------------------
131
132sub pegrev {
133  my $self = shift;
134
135  return $self->{PEGREV};
136}
137
138# ------------------------------------------------------------------------------
139# SYNOPSIS
140#   $type = $cfgfile->type ();
141#   $cfgfile->type ($type);
142#
143# DESCRIPTION
144#   This method returns the configuration file type. If an argument is
145#   specified, the type is set to the value of the argument.
146# ------------------------------------------------------------------------------
147
148sub type {
149  my $self = shift;
150
151  if (@_) {
152    $self->{TYPE} = shift;
153  }
154
155  return $self->{TYPE};
156}
157
158# ------------------------------------------------------------------------------
159# SYNOPSIS
160#   $version = $cfgfile->version ();
161#
162# DESCRIPTION
163#   This method returns the version of the configuration file.
164# ------------------------------------------------------------------------------
165
166sub version {
167  my $self = shift;
168
169  return $self->{VERSION};
170}
171
172# ------------------------------------------------------------------------------
173# SYNOPSIS
174#   @lines = $cfgfile->lines ();
175#
176# DESCRIPTION
177#   This method returns an array containing all "lines" in the configuration
178#   file. Each "line" is a reference to a hash table with the following keys:
179#
180#   SRC     - the source of the configuration file
181#   NUMBER  - the line number in the source
182#   LABEL   - the label of the of the configuration line
183#   VALUE   - the value of the configuration line
184#   COMMENT - comment in the configuration line
185# ------------------------------------------------------------------------------
186
187sub lines {
188  my $self = shift;
189
190  return @{ $self->{LINES} };
191}
192
193# ------------------------------------------------------------------------------
194# SYNOPSIS
195#   $line = $cfgfile->line ($line_number);
196#
197# DESCRIPTION
198#   This method return a "line" at $line_number in the configuration file. A
199#   "line" is a reference to a hash table with the following keys:
200#
201#   SRC     - the source of the configuration file
202#   NUMBER  - the line number in the source
203#   LABEL   - the label of the of the configuration line
204#   VALUE   - the value of the configuration line
205#   COMMENT - comment in the configuration line
206# ------------------------------------------------------------------------------
207
208sub line {
209  my $self     = shift;
210  my $line_num = shift;
211
212  if (exists $self->{LINES}[$line_num]) {
213    return $self->{LINES}[$line_num]; # returns a ref to a label:value pair hash
214
215  } else {
216    return undef;
217  }
218}
219
220# ------------------------------------------------------------------------------
221# SYNOPSIS
222#   $cfgfile->add_line (
223#     LABEL   => $label,
224#     VALUE   => $value,
225#     COMMENT => $comment,
226#     SRC     => $src,
227#     NUMBER  => $line_number
228#   );
229#
230# DESCRIPTION
231#   This method adds a "line" to the configuration file. LABEL is the
232#   configuration line label. VALUE is the configuration line value. COMMENT
233#   is the comment in the line. VALUE should only be specified if LABEL is
234#   specified. COMMENT can be specified without LABEL. In such case, the whole
235#   line is a comment line. A blank line is inserted if no argument is
236#   specified. SRC can be specified to indicate the name of the source file
237#   from which this line is obtained. If not specified, the source file of the
238#   current configuration file is used. NUMBER can be specified to indicate
239#   the line number of the source file from which this line is obtained.
240# ------------------------------------------------------------------------------
241
242sub add_line {
243  my $self = shift;
244  my %args = @_;
245
246  my $line = {
247    SRC     => exists $args{SRC    } ? $args{SRC    } : $self->actual_src,
248    NUMBER  => exists $args{NUMBER } ? $args{NUMBER } : 0,
249    LABEL   => exists $args{LABEL  } ? $args{LABEL  } : '',
250    VALUE   => exists $args{VALUE  } ? $args{VALUE  } : '',
251    COMMENT => exists $args{COMMENT} ? $args{COMMENT} : '',
252  };
253
254  push @{ $self->{LINES} }, $line;
255
256  return $line;
257}
258
259# ------------------------------------------------------------------------------
260# SYNOPSIS
261#   $cfgfile->add_comment_block ($line1, [$line2, ...]);
262#
263# DESCRIPTION
264#   This method adds a comment block to the configuration file. Each argument
265#   represents a line in the comment block.
266# ------------------------------------------------------------------------------
267
268sub add_comment_block {
269  my $self = shift;
270
271  $self->add_line (COMMENT => '-' x 78,);
272
273  while (my $line = shift @_) {
274    $self->add_line (COMMENT => $line,)
275  }
276
277  $self->add_line (COMMENT => '-' x 78,);
278  $self->add_line;
279
280  return;
281}
282
283# ------------------------------------------------------------------------------
284# SYNOPSIS
285#   $cfgfile->add_header ();
286#
287# DESCRIPTION
288#   This method adds a header to the configuration file, with its type and
289#   type version. It returns 1 on success.
290# ------------------------------------------------------------------------------
291
292sub add_header {
293  my $self = shift;
294
295  return undef unless $self->{TYPE};
296
297  $self->{VERSION} = $self->config->setting ('CFG_VERSION', uc ($self->{TYPE}))
298    if not $self->{VERSION};
299
300  $self->add_comment_block ('File header');
301
302  $self->add_line (
303    LABEL => $self->config->setting (qw/CFG_LABEL CFGFILE TYPE/),
304    VALUE => $self->{TYPE},
305  );
306
307  $self->add_line (
308    LABEL => $self->config->setting (qw/CFG_LABEL CFGFILE VERSION/),
309    VALUE => $self->{VERSION},
310  );
311
312  $self->add_line;
313
314  return 1;
315}
316
317# ------------------------------------------------------------------------------
318# SYNOPSIS
319#   $exist = $cfg->label_exists ($label);
320#   @lines = $cfg->label_exists ($label);
321#
322# DESCRIPTION
323#   This method returns the (number of) "lines" with their LABEL matching the
324#   argument $label.
325# ------------------------------------------------------------------------------
326
327sub label_exists {
328  my $self  = shift;
329  my $label = shift;
330
331  return grep {$_->{LABEL} eq $label} @{ $self->{LINES} };
332}
333
334# ------------------------------------------------------------------------------
335# SYNOPSIS
336#   $mtime = $cfgfile->mtime ();
337#
338# DESCRIPTION
339#   This method returns the modified time of the configuration file source.
340# ------------------------------------------------------------------------------
341
342sub mtime {
343  my $self  = shift;
344  my $mtime = undef;
345
346  if (-f $self->{SRC}) {
347    $mtime = (stat $self->{SRC})[9];
348  }
349
350  return $mtime;
351}
352
353# ------------------------------------------------------------------------------
354# SYNOPSIS
355#   $read = $cfgfile->read_cfg ();
356#
357# DESCRIPTION
358#   This method reads the current configuration file. It returns the number of
359#   lines read from the config file, or "undef" if it fails. The result is
360#   placed in the LINES array of the current instance, and can be accessed via
361#   the "lines" method.
362# ------------------------------------------------------------------------------
363
364sub read_cfg {
365  my $self = shift;
366
367  my @lines = $self->_get_cfg_lines;
368
369  # List of CFG labels
370  my %cfg_labels = %{ $self->config->setting ('CFG_LABEL') };
371
372  # List of CFG types that need INC declarations expansion
373  my %exp_inc    = ();
374  for (split (/,/, $self->config->setting ('CFG_EXP_INC'))) {
375    $exp_inc{uc ($_)} = 1;
376  }
377
378  # List of CFG labels that are reserved keywords
379  my %cfg_keywords = ();
380  for (split (/,/, $self->config->setting ('CFG_KEYWORD'))) {
381    $cfg_keywords{$cfg_labels{$_}} = 1;
382  }
383
384  # Loop each line, to separate lines into label : value pairs
385  my $cont = undef;
386  my $here = undef;
387  for my $line_num (1 .. @lines) {
388    my $line = $lines[$line_num - 1];
389    chomp $line;
390
391    my $label   = '';
392    my $value   = '';
393    my $comment = '';
394
395    # If this line is a continuation, set $start to point to the line that
396    # starts this continuation. Otherwise, set $start to undef
397    my $start   = defined ($cont) ? $self->line ($cont) : undef;
398
399    if ($line =~ /^(\s*#.*)$/) { # comment line
400      $comment = $1;
401
402    } elsif ($line =~ /\S/) {    # non-blank line
403      if (defined $cont) {
404        # Previous line has a continuation mark
405        $value = $line;
406
407        # Separate value and comment
408        if ($value =~ s/((?:\s+|^)#\s+.*)$//) {
409          $comment = $1;
410        }
411
412        # Remove leading spaces
413        $value =~ s/^\s*\\?//;
414
415        # Expand environment variables
416        $value = $self->_expand_variable ($value, 1) if $value;
417
418        # Expand internal variables
419        $value = $self->_expand_variable ($value) if $value;
420
421        # Get "line" that begins the current continuation
422        ($start->{VALUE} .= $value) =~ s/\\$//;
423
424      } else {
425        # Previous line does not have a continuation mark
426        if ($line =~ /^\s*(\S+)(?:\s+(.*))?$/) {
427          # Check line contains a valid label:value pair
428          $label = $1;
429          $value = defined ($2) ? $2 : '';
430
431          # Separate value and comment
432          if ($value =~ s/((?:\s+|^)#\s+.*)$//) {
433            $comment = $1;
434          }
435
436          # Remove trailing spaces
437          $value =~ s/\s+$//;
438
439          # Value begins with $HERE?
440          $here  = ($value =~ /\$\{?HERE\}?(?:[^A-Z_]|$)/);
441
442          # Expand environment variables
443          $value = $self->_expand_variable ($value, 1) if $value;
444
445          # Expand internal variables
446          $value = $self->_expand_variable ($value) if $value;
447        }
448      }
449
450      # Determine whether current line ends with a continuation mark
451      if ($value =~ s/\\$//) {
452        $cont = scalar ($self->lines) unless $cont;
453
454      } else {
455        $cont = undef;
456      }
457    }
458
459    if (exists $exp_inc{uc ($self->type)} and
460        uc ($start ? $start->{LABEL} : $label) eq $cfg_labels{INC} and
461        not defined $cont) {
462      # Current configuration file requires expansion of INC declarations
463      # The start/current line is an INC declaration
464      # The current line is not a continuation or is the end of the continuation
465
466      # Get lines from an "include" configuration file
467      my $src = ($start ? $start->{VALUE} : $value);
468      $src   .= '@' . $self->pegrev if $here and $self->pegrev;
469
470      if ($src) {
471        # Invoke a new instance to read the source
472        my $cfg = Fcm::CfgFile->new (
473          SRC    => expand_tilde ($src),
474          TYPE   => $self->type,
475          CONFIG => $self->config,
476        );
477
478        $cfg->read_cfg;
479
480        # Add lines to the "LINES" array in the current configuration file
481        $comment = 'INC ' . $src . ' ';
482        $self->add_line (
483          COMMENT => $comment . '# Start',
484          NUMBER  => ($start ? $start->{NUMBER} : $line_num),
485        );
486        $self->add_line (%{ $_ }) for (($cfg->lines));
487        $self->add_line (COMMENT => $comment . '# End');
488
489      } else {
490        $self->add_line (NUMBER  => $line_num);
491        w_report 'Warning: ', $self->actual_src, ': line ', $line_num,
492                 ': empty INC declaration.' if $self->config->verbose > 2;
493      }
494
495    } else {
496      # Push label:value pair into "LINES" array
497      $self->add_line (
498        LABEL   => $label,
499        VALUE   => ($label ? $value : ''),
500        COMMENT => $comment,
501        NUMBER  => $line_num,
502      );
503    }
504
505    next if defined $cont; # current line not a continuation
506
507    my $slabel = ($start ? $start->{LABEL} : $label);
508    my $svalue = ($start ? $start->{VALUE} : $value);
509    next unless $slabel;
510
511    # Check config file type and version
512    if (uc ($slabel) eq $cfg_labels{CFGFILE}{TYPE}) {
513      $self->type ($svalue);
514
515    } elsif (uc ($slabel) eq $cfg_labels{CFGFILE}{VERSION}) {
516      $self->version ($svalue);
517    }
518
519    # Set internal variable
520    $slabel =~ s/^\%//; # Remove leading "%" from label
521
522    $self->config->assign_variable (
523      LABEL => $slabel,
524      VALUE => $svalue,
525    ) unless exists $cfg_keywords{$slabel};
526  }
527
528  return $self->lines;
529
530}
531
532# ------------------------------------------------------------------------------
533# SYNOPSIS
534#   $rc = $cfgfile->print_cfg ($file);
535#
536# DESCRIPTION
537#   This method prints the content of current configuration file. If no
538#   argument is specified, it prints output to the standard output. If $file
539#   is specified, and is a writable file name, the output is sent to the file.
540#   If the file already exists, its content is compared to the current output.
541#   Nothing will be written if the content is unchanged. Otherwise, for typed
542#   configuration files, the existing file is renamed using a prefix that
543#   contains its last modified time. The method returns 1 if there is no
544#   error.
545# ------------------------------------------------------------------------------
546
547sub print_cfg {
548  my $self = shift;
549  my $file = shift;
550
551  # Count maximum number of characters in the labels, (for pretty printing)
552  my $max_label_len = 0;
553  for my $line (@{ $self->{LINES} }) {
554    next unless $line->{LABEL};
555    my $label_len  = length $line->{LABEL};
556    $max_label_len = $label_len if $label_len > $max_label_len;
557  }
558
559  # Output string
560  my $out = '';
561
562  # Append each line of the config file to the output string
563  for my $line (@{ $self->{LINES} }) {
564    my $label   = $line->{LABEL};
565    my $value   = $line->{VALUE};
566    my $comment = $line->{COMMENT};
567
568    if ($label) {
569      # Line up label/value for pretty printing
570      $label   = $label . ' ' x ($max_label_len - length ($label));
571      $comment =~ s/^\s+/ / if $comment;
572
573      $out .= $label;
574      $out .= ' ' . $value if defined $value;
575
576    } else {
577      # Make sure comments begin with a "#"
578      $comment = '# ' . $comment if $comment and $comment !~ /^\s*($|#)/;
579      $comment =~ s/^\s*//;
580    }
581
582    $out .= $comment if $comment;
583    $out .= "\n";
584  }
585
586  if ($out) {
587
588    my $old_select = select;
589
590    # Open file if necessary
591    if ($file) {
592      # Make sure the host directory exists and is writable
593      my $dirname = dirname $file;
594      if (not -d $dirname) {
595        print 'Make directory: ', $dirname, "\n" if $self->config->verbose;
596        mkpath $dirname;
597      }
598      croak 'Cannot write to config file directory: "', $dirname, '", abort'
599        unless -d $dirname and -w $dirname;
600
601      # If config file already exists, make sure it is writable
602      if (-f $file) {
603        if (-r $file) {
604          # Read old config file to see if content has changed
605          open IN, '<', $file;
606          my $in_lines = '';
607          while (my $line = <IN>) {
608            $in_lines .= $line;
609          }
610          close IN;
611
612          # Return if content is up-to-date
613          if ($in_lines eq $out) {
614            print 'No change in ', lc ($self->{TYPE}), ' cfg: ', $file,
615                  "\n" if $self->config->verbose > 1 and $self->{TYPE};
616            return;
617          }
618        }
619
620        if (-w $file) {
621          if ($self->{TYPE}) {
622            # Existing config file writable, rename it using its time stamp
623            my $mtime = (stat $file)[9];
624            my ($sec, $min, $hour, $mday, $mon, $year) = (gmtime $mtime)[0 .. 5];
625            my $timestamp = sprintf '%4d%2.2d%2.2d_%2.2d%2.2d%2.2d_',
626                            $year + 1900, $mon + 1, $mday, $hour, $min, $sec;
627            my $oldfile   = catfile $dirname, $timestamp . basename ($file);
628            rename $file, $oldfile;
629            print 'Renamed existing ', lc ($self->{TYPE}), ' cfg: ',
630                  $oldfile, "\n" if $self->config->verbose > 1;
631          }
632        } else {
633          # Existing config file not writable, throw an error
634          croak 'Config file "', $file, '" not writable, abort';
635        }
636      }
637
638      # Open file and select file handle
639      open OUT, '>', $file
640        or croak 'Cannot write to config file "', $file, '" (', $!, '), abort';
641      select OUT;
642    }
643
644    # Print output
645    print $out;
646
647    # Close file if necessary
648    if ($file) {
649      select $old_select;
650      close OUT;
651
652      if ($self->{TYPE} and $self->config->verbose > 1) {
653        print 'Generated ', lc ($self->{TYPE}), ' cfg: ', $file, "\n";
654      } elsif ($self->config->verbose > 2) {
655        print 'Generated cfg: ', $file, "\n";
656      }
657    }
658
659  } else {
660
661    # Warn if nothing to print
662    my $warning = 'Empty configuration';
663    $warning   .= ' - nothing written to file: "' . $file . '"' if $file;
664    carp $warning if $self->{TYPE};
665
666  }
667
668  return 1;
669}
670
671# ------------------------------------------------------------------------------
672# SYNOPSIS
673#   @lines = $self->_get_cfg_lines ();
674#
675# DESCRIPTION
676#   This internal method reads from a configuration file residing in a
677#   Subversion repository or in the normal file system.
678# ------------------------------------------------------------------------------
679
680sub _get_cfg_lines {
681  my $self  = shift;
682  my @lines = ();
683
684  my $verbose = $self->config->verbose;
685
686  # Expand URL keywords if necessary
687  {
688    my $src = expand_url_keyword (URL => $self->src, CFG => $self->config);
689    $self->src ($src) if $src ne $self->src;
690  }
691
692  if (&is_url ($self->src)) {
693    # Config file resides in a SVN repository
694    # --------------------------------------------------------------------------
695    # Set URL source and version
696    my $src = $self->src;
697    my $rev = 'HEAD';
698
699    # Extract version from source if it exists
700    if ($src =~ s/@(.+)$//) {
701      $rev = $1;
702    }
703
704    # Expand revision keyword, if required
705    $rev = expand_rev_keyword (REV => $rev, URL => $src, HEAD => 1);
706
707    # Check whether URL is a config file
708    my $rc;
709    my @cmd = (qw/svn cat/, $src . '@' . $rev);
710    @lines = &run_command (
711      \@cmd, METHOD => 'qx', DEVNULL => 1, RC => \$rc, ERROR => 'ignore',
712    );
713
714    # Error in "svn cat" command
715    if ($rc) {
716      # See whether specified config file is a known type
717      my %cfgname = %{ $self->config->setting ('CFG_NAME') };
718      my $key     = uc $self->type;
719      my $file    = exists $cfgname{$key} ? $cfgname{$key} : '';
720
721      # If config file is a known type, specified URL may be a directory
722      if ($file) {
723        # Check whether a config file with a default name exists in the URL
724        my $sep  = $self->config->setting (qw/MISC DIR_SEPARATOR/);
725        my $path = $src . $sep . $file;
726        my @cmd  = (qw/svn cat/, $path . '@' . $rev);
727
728        @lines = &run_command (
729          \@cmd, METHOD => 'qx', DEVNULL => 1, RC => \$rc, ERROR => 'ignore',
730        );
731
732        # Check whether a config file with a default name exists under the "cfg"
733        # sub-directory of the URL
734        if ($rc) {
735          my $cfgdir = $self->config->setting (qw/DIR CFG/);
736          $path   = $src . $sep . $cfgdir . $sep . $file;
737          my @cmd = (qw/svn cat/, $path . '@' . $rev);
738
739          @lines  = &run_command (
740            \@cmd, METHOD => 'qx', DEVNULL => 1, RC => \$rc, ERROR => 'ignore',
741          );
742        }
743
744        $src = $path unless $rc;
745      }
746    }
747
748    if ($rc) {
749      # Error in "svn cat"
750      croak 'Unable to locate config file from "', $self->src, '", abort';
751
752    } else {
753      # Print diagnostic, if necessary
754      if ($verbose and $self->type and $self->type =~ /$expand_type/) {
755        print '# Config file (', $self->type, '): ', $src;
756        print '@', $rev if $rev;
757        print "\n";
758      }
759    }
760
761    # Record the actual source location
762    $self->{PEGREV    } = $rev;
763    $self->{ACTUAL_SRC} = $src;
764
765  } else {
766    # Config file resides in the normal file system
767    # --------------------------------------------------------------------------
768    my $src = $self->src;
769
770    if (-d $src) { # Source is a directory
771      croak 'Config file "', $src, '" is a directory, abort' if not $self->type;
772
773      # Get name of the config file by looking at the type
774      my %cfgname = %{ $self->config->setting ('CFG_NAME') };
775      my $key     = uc $self->type;
776      my $file    = exists $cfgname{$key} ? $cfgname{$key} : '';
777
778      if ($file) {
779        my $cfgdir = $self->config->setting (qw/DIR CFG/);
780
781        # Check whether a config file with a default name exists in the
782        # specified path, then check whether a config file with a default name
783        # exists under the "cfg" sub-directory of the specified path
784        if (-f catfile $self->src, $file) {
785          $src = catfile $self->src, $file;
786
787        } elsif (-f catfile ($self->src, $cfgdir, $file)) {
788          $src = catfile $self->src, $cfgdir, $file;
789
790        } else {
791          croak 'Unable to locate config file from "', $self->src, '", abort';
792        }
793
794      } else {
795        croak 'Unknown config file type "', $self->type, '", abort';
796      }
797    }
798
799    if (-r $src) {
800      open FILE, '<', $src;
801      print '# Config file (', $self->type, '): ', $src, "\n"
802        if $verbose and $self->type and $self->type =~ /$expand_type/;
803
804      @lines = readline 'FILE';
805      close FILE;
806
807    } else {
808      croak 'Unable to read config file "', $src, '", abort';
809    }
810
811    # Record the actual source location
812    $self->{ACTUAL_SRC} = $src;
813  }
814
815  return @lines;
816}
817
818# ------------------------------------------------------------------------------
819# SYNOPSIS
820#   $string = $self->_expand_variable ($string[, $env]);
821#
822# DESCRIPTION
823#   This internal method expands variables in $string. If $env is specified
824#   and is true, it expands environment variables. Otherwise, it expands
825#   local variables.
826# ------------------------------------------------------------------------------
827
828sub _expand_variable {
829  my ($self, $string, $env) = @_;
830
831  # Pattern for environment/local variable
832  my $pattern = $env ? '\$\{?([A-Z][A-Z0-9_]+)\}?' : '%\{?([\w:]+)\}?';
833
834  while ($string and $string =~ /$pattern/) {
835    my $var_label = $1; # variable label
836
837    # Get variable value from environment or local configuration
838    my $variable = $env
839                   ? (exists $ENV{$var_label} ? $ENV{$var_label} : undef)
840                   : $self->config->variable ($var_label);
841
842    $variable = dirname ($self->actual_src)
843      if $env and $var_label eq 'HERE' and not defined $variable;
844
845    # Substitute match with value of variable
846    if (defined $variable) {
847      $string =~ s/$pattern/$variable/;
848
849    } else {
850      w_report 'Warning: ', $self->actual_src, ': variable "',
851               ($env ? '$' : '%'), $var_label, '" not expanded.';
852      last;
853    }
854  }
855
856  return $string;
857}
858
8591;
860
861__END__
Note: See TracBrowser for help on using the repository browser.