source: LMDZ6/branches/Ocean_skin/tools/fcm/lib/Fcm/CfgFile.pm @ 5088

Last change on this file since 5088 was 3605, checked in by lguez, 5 years ago

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