File Coverage

blib/lib/AppConfig/File.pm
Criterion Covered Total %
statement n/a
branch n/a
condition n/a
subroutine n/a
pod n/a
total n/a


line stmt bran cond sub pod time code
1             package AppConfig::File;
2              
3             #============================================================================
4             #
5             # AppConfig::File.pm
6             #
7             # Perl5 module to read configuration files and use the contents therein
8             # to update variable values in an AppConfig::State object.
9             #
10             # Written by Andy Wardley <abw@wardley.org>
11             #
12             # Copyright (C) 1997-2003 Andy Wardley. All Rights Reserved.
13             # Copyright (C) 1997,1998 Canon Research Centre Europe Ltd.
14             #
15             # $Id: File.pm,v 1.62 2004/02/04 10:28:28 abw Exp $
16             #
17             #============================================================================
18              
19             use strict;
20              
21             require 5.005;
22              
23             use AppConfig;
24             use AppConfig::State;
25             use File::HomeDir;
26              
27             use vars qw( $VERSION );
28             BEGIN {
29             $VERSION = '1.64';
30             }
31              
32              
33              
34              
35              
36             #------------------------------------------------------------------------
37             # new($state, $file, [$file, ...])
38             #
39             # Module constructor. The first, mandatory parameter should be a
40             # reference to an AppConfig::State object to which all actions should
41             # be applied. The remaining parameters are assumed to be file names or
42             # file handles for reading and are passed to parse().
43             #
44             # Returns a reference to a newly created AppConfig::File object.
45             #------------------------------------------------------------------------
46              
47             sub new {
48                 my $class = shift;
49                 my $state = shift;
50                 
51                 my $self = {
52                     STATE => $state, # AppConfig::State ref
53                     DEBUG => $state->_debug(), # store local copy of debug
54                     PEDANTIC => $state->_pedantic, # and pedantic flags
55                 };
56              
57                 bless $self, $class;
58              
59             # Find the home directory
60                 $self->{HOME} = File::HomeDir->my_home;
61              
62             # call parse(@_) to parse any files specified as further params
63                 $self->parse(@_) if @_;
64              
65                 return $self;
66             }
67              
68              
69             #------------------------------------------------------------------------
70             # parse($file, [file, ...])
71             #
72             # Reads and parses a config file, updating the contents of the
73             # AppConfig::State referenced by $self->{ STATE } according to the
74             # contents of the file. Multiple files may be specified and are
75             # examined in turn. The method reports any error condition via
76             # $self->{ STATE }->_error() and immediately returns undef if it
77             # encounters a system error (i.e. cannot open one of the files.
78             # Parsing errors such as unknown variables or unvalidated values will
79             # also cause warnings to be raised vi the same _error(), but parsing
80             # continues to the end of the current file and through any subsequent
81             # files. If the PEDANTIC option is set in the $self->{ STATE } object,
82             # the behaviour is overridden and the method returns 0 immediately on
83             # any system or parsing error.
84             #
85             # The EXPAND option for each variable determines how the variable
86             # value should be expanded.
87             #
88             # Returns undef on system error, 0 if all files were parsed but generated
89             # one or more warnings, 1 if all files parsed without warnings.
90             #------------------------------------------------------------------------
91              
92             sub parse {
93                 my $self = shift;
94                 my $warnings = 0;
95                 my $prefix; # [block] defines $prefix
96                 my $file;
97                 my $flag;
98              
99             # take a local copy of the state to avoid much hash dereferencing
100                 my ($state, $debug, $pedantic) = @$self{ qw( STATE DEBUG PEDANTIC ) };
101              
102             # we want to install a custom error handler into the AppConfig::State
103             # which appends filename and line info to error messages and then
104             # calls the previous handler; we start by taking a copy of the
105             # current handler..
106                 my $errhandler = $state->_ehandler();
107              
108             # ...and if it doesn't exist, we craft a default handler
109                 $errhandler = sub { warn(sprintf(shift, @_), "\n") }
110             unless defined $errhandler;
111              
112             # install a closure as a new error handler
113                 $state->_ehandler(
114             sub {
115             # modify the error message
116             my $format = shift;
117             $format .= ref $file
118             ? " at line $."
119             : " at $file line $.";
120              
121             # chain call to prevous handler
122             &$errhandler($format, @_);
123             }
124                 );
125              
126             # trawl through all files passed as params
127                 FILE: while ($file = shift) {
128              
129             # local/lexical vars ensure opened files get closed
130             my $handle;
131             local *FH;
132              
133             # if the file is a reference, we assume it's a file handle, if
134             # not, we assume it's a filename and attempt to open it
135             $handle = $file;
136             if (ref($file)) {
137             $handle = $file;
138              
139             # DEBUG
140             print STDERR "reading from file handle: $file\n" if $debug;
141             }
142             else {
143             # open and read config file
144             open(FH, $file) or do {
145             # restore original error handler and report error
146             $state->_ehandler($errhandler);
147             $state->_error("$file: $!");
148              
149             return undef;
150             };
151             $handle = \*FH;
152              
153             # DEBUG
154             print STDERR "reading file: $file\n" if $debug;
155             }
156              
157             # initialise $prefix to nothing (no [block])
158             $prefix = '';
159              
160             while (<$handle>) {
161             chomp;
162              
163             # Throw away everything from an unescaped # to EOL
164                         s/(^|\s+)#.*/$1/;
165              
166             # add next line if there is one and this is a continuation
167             if (s/\\$// && !eof($handle)) {
168             $_ .= <$handle>;
169             redo;
170             }
171              
172             # Convert \# -> #
173                         s/\\#/#/g;
174              
175             # ignore blank lines
176                         next if /^\s*$/;
177              
178             # strip leading and trailing whitespace
179             s/^\s+//;
180             s/\s+$//;
181              
182             # look for a [block] to set $prefix
183             if (/^\[([^\]]+)\]$/) {
184             $prefix = $1;
185             print STDERR "Entering [$prefix] block\n" if $debug;
186             next;
187             }
188              
189             # split line up by whitespace (\s+) or "equals" (\s*=\s*)
190             if (/^([^\s=]+)(?:(?:(?:\s*=\s*)|\s+)(.*))?/) {
191             my ($variable, $value) = ($1, $2);
192              
193             if (defined $value) {
194             # here document
195             if ($value =~ /^([^\s=]+\s*=)?\s*<<(['"]?)(\S+)\2$/) { # '<<XX' or 'hashkey =<<XX'
196             my $boundary = "$3\n";
197             $value = defined($1) ? $1 : '';
198             while (<$handle>) {
199             last if $_ eq $boundary;
200             $value .= $_;
201             };
202             $value =~ s/[\r\n]$//;
203             } else {
204             # strip any quoting from the variable value
205             $value =~ s/^(['"])(.*)\1$/$2/;
206             };
207             };
208              
209             # strip any leading '+/-' from the variable
210             $variable =~ s/^([\-+]?)//;
211             $flag = $1;
212              
213             # $variable gets any $prefix
214             $variable = $prefix . '_' . $variable
215             if length $prefix;
216              
217             # if the variable doesn't exist, we call set() to give
218             # AppConfig::State a chance to auto-create it
219             unless ($state->_exists($variable)
220             || $state->set($variable, 1)) {
221             $warnings++;
222             last FILE if $pedantic;
223             next;
224             }
225              
226             my $nargs = $state->_argcount($variable);
227              
228             # variables prefixed '-' are reset to their default values
229             if ($flag eq '-') {
230             $state->_default($variable);
231             next;
232             }
233             # those prefixed '+' get set to 1
234             elsif ($flag eq '+') {
235             $value = 1 unless defined $value;
236             }
237              
238             # determine if any extra arguments were expected
239             if ($nargs) {
240             if (defined $value && length $value) {
241             # expand any embedded variables, ~uids or
242             # environment variables, testing the return value
243             # for errors; we pass in any variable-specific
244             # EXPAND value
245             unless ($self->_expand(\$value,
246             $state->_expand($variable), $prefix)) {
247             print STDERR "expansion of [$value] failed\n"
248             if $debug;
249             $warnings++;
250             last FILE if $pedantic;
251             }
252             }
253             else {
254             $state->_error("$variable expects an argument");
255             $warnings++;
256             last FILE if $pedantic;
257             next;
258             }
259             }
260             # $nargs = 0
261             else {
262             # default value to 1 unless it is explicitly defined
263             # as '0' or "off"
264             if (defined $value) {
265             # "off" => 0
266                  $value = 0 if $value =~ /off/i;
267             # any value => 1
268             $value = 1 if $value;
269             }
270             else {
271             # assume 1 unless explicitly defined off/0
272                  $value = 1;
273             }
274             print STDERR "$variable => $value (no expansion)\n"
275             if $debug;
276             }
277            
278             # set the variable, noting any failure from set()
279             unless ($state->set($variable, $value)) {
280             $warnings++;
281             last FILE if $pedantic;
282             }
283             }
284             else {
285             $state->_error("parse error");
286             $warnings++;
287             }
288             }
289                 }
290              
291             # restore original error handler
292                 $state->_ehandler($errhandler);
293                 
294             # return $warnings => 0, $success => 1
295                 return $warnings ? 0 : 1;
296             }
297              
298              
299              
300             #========================================================================
301             # ----- PRIVATE METHODS -----
302             #========================================================================
303              
304             #------------------------------------------------------------------------
305             # _expand(\$value, $expand, $prefix)
306             #
307             # The variable value string, referenced by $value, is examined and any
308             # embedded variables, environment variables or tilde globs (home
309             # directories) are replaced with their respective values, depending on
310             # the value of the second parameter, $expand. The third paramter may
311             # specify the name of the current [block] in which the parser is
312             # parsing. This prefix is prepended to any embedded variable name that
313             # can't otherwise be resolved. This allows the following to work:
314             #
315             # [define]
316             # home = /home/abw
317             # html = $define_home/public_html
318             # html = $home/public_html # same as above, 'define' is prefix
319             #
320             # Modifications are made directly into the variable referenced by $value.
321             # The method returns 1 on success or 0 if any warnings (undefined
322             # variables) were encountered.
323             #------------------------------------------------------------------------
324              
325             sub _expand {
326                 my ($self, $value, $expand, $prefix) = @_;
327                 my $warnings = 0;
328                 my ($sys, $var, $val);
329              
330              
331             # ensure prefix contains something (nothing!) valid for length()
332                 $prefix = "" unless defined $prefix;
333              
334             # take a local copy of the state to avoid much hash dereferencing
335                 my ($state, $debug, $pedantic) = @$self{ qw( STATE DEBUG PEDANTIC ) };
336              
337             # bail out if there's nothing to do
338                 return 1 unless $expand && defined($$value);
339              
340             # create an AppConfig::Sys instance, or re-use a previous one,
341             # to handle platform dependant functions: getpwnam(), getpwuid()
342                 unless ($sys = $self->{ SYS }) {
343             require AppConfig::Sys;
344             $sys = $self->{ SYS } = AppConfig::Sys->new();
345                 }
346              
347                 print STDERR "Expansion of [$$value] " if $debug;
348              
349                 EXPAND: {
350              
351             #
352             # EXPAND_VAR
353             # expand $(var) and $var as AppConfig::State variables
354             #
355             if ($expand & AppConfig::EXPAND_VAR) {
356              
357             $$value =~ s{
358             (?<!\\)\$ (?: \((\w+)\) | (\w+) ) # $2 => $(var) | $3 => $var
359            
360             } {
361             # embedded variable name will be one of $2 or $3
362             $var = defined $1 ? $1 : $2;
363            
364             # expand the variable if defined
365             if ($state->_exists($var)) {
366             $val = $state->get($var);
367             }
368             elsif (length $prefix
369             && $state->_exists($prefix . '_' . $var)) {
370             print STDERR "(\$$var => \$${prefix}_$var) "
371             if $debug;
372             $var = $prefix . '_' . $var;
373             $val = $state->get($var);
374             }
375             else {
376             # raise a warning if EXPAND_WARN set
377             if ($expand & AppConfig::EXPAND_WARN) {
378             $state->_error("$var: no such variable");
379             $warnings++;
380             }
381            
382             # replace variable with nothing
383             $val = '';
384             }
385            
386             # $val gets substituted back into the $value string
387             $val;
388             }gex;
389              
390                         $$value =~ s/\\\$/\$/g;
391              
392             # bail out now if we need to
393             last EXPAND if $warnings && $pedantic;
394             }
395              
396              
397             #
398             # EXPAND_UID
399             # expand ~uid as home directory (for $< if uid not specified)
400             #
401             if ($expand & AppConfig::EXPAND_UID) {
402              
403             $$value =~ s{
404             ~(\w+)? # $1 => username (optional)
405             } {
406             $val = undef;
407            
408             # embedded user name may be in $1
409             if (defined ($var = $1)) {
410             # try and get user's home directory
411             if ($sys->can_getpwnam()) {
412             $val = ($sys->getpwnam($var))[7];
413             }
414             } else {
415             # determine home directory
416             $val = $self->{ HOME };
417             }
418            
419             # catch-all for undefined $dir
420             unless (defined $val) {
421             # raise a warning if EXPAND_WARN set
422             if ($expand & AppConfig::EXPAND_WARN) {
423             $state->_error("cannot determine home directory%s",
424             defined $var ? " for $var" : "");
425             $warnings++;
426             }
427            
428             # replace variable with nothing
429             $val = '';
430             }
431            
432             # $val gets substituted back into the $value string
433             $val;
434             }gex;
435              
436             # bail out now if we need to
437             last EXPAND if $warnings && $pedantic;
438             }
439              
440              
441             #
442             # EXPAND_ENV
443             # expand ${VAR} as environment variables
444             #
445             if ($expand & AppConfig::EXPAND_ENV) {
446              
447             $$value =~ s{
448             ( \$ \{ (\w+) \} )
449             } {
450             $var = $2;
451            
452             # expand the variable if defined
453             if (exists $ENV{ $var }) {
454             $val = $ENV{ $var };
455             } elsif ( $var eq 'HOME' ) {
456             # In the special case of HOME, if not set
457             # use the internal version
458             $val = $self->{ HOME };
459             } else {
460             # raise a warning if EXPAND_WARN set
461             if ($expand & AppConfig::EXPAND_WARN) {
462             $state->_error("$var: no such environment variable");
463             $warnings++;
464             }
465            
466             # replace variable with nothing
467             $val = '';
468             }
469             # $val gets substituted back into the $value string
470             $val;
471             }gex;
472              
473             # bail out now if we need to
474             last EXPAND if $warnings && $pedantic;
475             }
476                 }
477              
478                 print STDERR "=> [$$value] (EXPAND = $expand)\n" if $debug;
479              
480             # return status
481                 return $warnings ? 0 : 1;
482             }
483              
484              
485              
486             #------------------------------------------------------------------------
487             # _dump()
488             #
489             # Dumps the contents of the Config object.
490             #------------------------------------------------------------------------
491              
492             sub _dump {
493                 my $self = shift;
494              
495                 foreach my $key (keys %$self) {
496             printf("%-10s => %s\n", $key,
497             defined($self->{ $key }) ? $self->{ $key } : "<undef>");
498                 }
499             } 
500              
501              
502              
503             1;
504              
505             __END__
506            
507             =head1 NAME
508            
509             AppConfig::File - Perl5 module for reading configuration files.
510            
511             =head1 SYNOPSIS
512            
513             use AppConfig::File;
514            
515             my $state = AppConfig::State->new(\%cfg1);
516             my $cfgfile = AppConfig::File->new($state, $file);
517            
518             $cfgfile->parse($file); # read config file
519            
520             =head1 OVERVIEW
521            
522             AppConfig::File is a Perl5 module which reads configuration files and use
523             the contents therein to update variable values in an AppConfig::State
524             object.
525            
526             AppConfig::File is distributed as part of the AppConfig bundle.
527            
528             =head1 DESCRIPTION
529            
530             =head2 USING THE AppConfig::File MODULE
531            
532             To import and use the AppConfig::File module the following line should appear
533             in your Perl script:
534            
535             use AppConfig::File;
536            
537             AppConfig::File is used automatically if you use the AppConfig module
538             and create an AppConfig::File object through the file() method.
539            
540             AppConfig::File is implemented using object-oriented methods. A new
541             AppConfig::File object is created and initialised using the
542             AppConfig::File->new() method. This returns a reference to a new
543             AppConfig::File object. A reference to an AppConfig::State object
544             should be passed in as the first parameter:
545            
546             my $state = AppConfig::State->new();
547             my $cfgfile = AppConfig::File->new($state);
548            
549             This will create and return a reference to a new AppConfig::File object.
550            
551             =head2 READING CONFIGURATION FILES
552            
553             The C<parse()> method is used to read a configuration file and have the
554             contents update the STATE accordingly.
555            
556             $cfgfile->parse($file);
557            
558             Multiple files maye be specified and will be read in turn.
559            
560             $cfgfile->parse($file1, $file2, $file3);
561            
562             The method will return an undef value if it encounters any errors opening
563             the files. It will return immediately without processing any further files.
564             By default, the PEDANTIC option in the AppConfig::State object,
565             $self->{ STATE }, is turned off and any parsing errors (invalid variables,
566             unvalidated values, etc) will generated warnings, but not cause the method
567             to return. Having processed all files, the method will return 1 if all
568             files were processed without warning or 0 if one or more warnings were
569             raised. When the PEDANTIC option is turned on, the method generates a
570             warning and immediately returns a value of 0 as soon as it encounters any
571             parsing error.
572            
573             Variables values in the configuration files may be expanded depending on
574             the value of their EXPAND option, as determined from the App::State object.
575             See L<AppConfig::State> for more information on variable expansion.
576            
577             =head2 CONFIGURATION FILE FORMAT
578            
579             A configuration file may contain blank lines and comments which are
580             ignored. Comments begin with a '#' as the first character on a line
581             or following one or more whitespace tokens, and continue to the end of
582             the line.
583            
584             # this is a comment
585             foo = bar # so is this
586             url = index.html#hello # this too, but not the '#welcome'
587            
588             Notice how the '#welcome' part of the URL is not treated as a comment
589             because a whitespace character doesn't precede it.
590            
591             Long lines can be continued onto the next line by ending the first
592             line with a '\'.
593            
594             callsign = alpha bravo camel delta echo foxtrot golf hipowls \
595             india juliet kilo llama mike november oscar papa \
596             quebec romeo sierra tango umbrella victor whiskey \
597             x-ray yankee zebra
598            
599             Variables that are simple flags and do not expect an argument (ARGCOUNT =
600             ARGCOUNT_NONE) can be specified without any value. They will be set with
601             the value 1, with any value explicitly specified (except "0" and "off")
602             being ignored. The variable may also be specified with a "no" prefix to
603             implicitly set the variable to 0.
604            
605             verbose # on (1)
606             verbose = 1 # on (1)
607             verbose = 0 # off (0)
608             verbose off # off (0)
609             verbose on # on (1)
610             verbose mumble # on (1)
611             noverbose # off (0)
612            
613             Variables that expect an argument (ARGCOUNT = ARGCOUNT_ONE) will be set to
614             whatever follows the variable name, up to the end of the current line. An
615             equals sign may be inserted between the variable and value for clarity.
616            
617             room = /home/kitchen
618             room /home/bedroom
619            
620             Each subsequent re-definition of the variable value overwrites the previous
621             value.
622            
623             print $config->room(); # prints "/home/bedroom"
624            
625             Variables may be defined to accept multiple values (ARGCOUNT = ARGCOUNT_LIST).
626             Each subsequent definition of the variable adds the value to the list of
627             previously set values for the variable.
628            
629             drink = coffee
630             drink = tea
631            
632             A reference to a list of values is returned when the variable is requested.
633            
634             my $beverages = $config->drinks();
635             print join(", ", @$beverages); # prints "coffee, tea"
636            
637             Variables may also be defined as hash lists (ARGCOUNT = ARGCOUNT_HASH).
638             Each subsequent definition creates a new key and value in the hash array.
639            
640             alias l="ls -CF"
641             alias h="history"
642            
643             A reference to the hash is returned when the variable is requested.
644            
645             my $aliases = $config->alias();
646             foreach my $k (keys %$aliases) {
647             print "$k => $aliases->{ $k }\n";
648             }
649            
650             A large chunk of text can be defined using Perl's "heredoc" quoting
651             style.
652            
653             scalar = <<BOUNDARY_STRING
654             line 1
655             line 2: Space/linebreaks within a HERE document are kept.
656             line 3: The last linebreak (\n) is stripped.
657             BOUNDARY_STRING
658            
659             hash key1 = <<'FOO'
660             * Quotes (['"]) around the boundary string are simply ignored.
661             * Whether the variables in HERE document are expanded depends on
662             the EXPAND option of the variable or global setting.
663             FOO
664            
665             hash = key2 = <<"_bar_"
666             Text within HERE document are kept as is.
667             # comments are treated as a normal text.
668             The same applies to line continuation. \
669             _bar_
670            
671             Note that you cannot use HERE document as a key in a hash or a name
672             of a variable.
673            
674             The '-' prefix can be used to reset a variable to its default value and
675             the '+' prefix can be used to set it to 1
676            
677             -verbose
678             +debug
679            
680             Variable, environment variable and tilde (home directory) expansions
681             Variable values may contain references to other AppConfig variables,
682             environment variables and/or users' home directories. These will be
683             expanded depending on the EXPAND value for each variable or the GLOBAL
684             EXPAND value.
685            
686             Three different expansion types may be applied:
687            
688             bin = ~/bin # expand '~' to home dir if EXPAND_UID
689             tmp = ~abw/tmp # as above, but home dir for user 'abw'
690            
691             perl = $bin/perl # expand value of 'bin' variable if EXPAND_VAR
692             ripl = $(bin)/ripl # as above with explicit parens
693            
694             home = ${HOME} # expand HOME environment var if EXPAND_ENV
695            
696             See L<AppConfig::State> for more information on expanding variable values.
697            
698             The configuration files may have variables arranged in blocks. A block
699             header, consisting of the block name in square brackets, introduces a
700             configuration block. The block name and an underscore are then prefixed
701             to the names of all variables subsequently referenced in that block. The
702             block continues until the next block definition or to the end of the current
703             file.
704            
705             [block1]
706             foo = 10 # block1_foo = 10
707            
708             [block2]
709             foo = 20 # block2_foo = 20
710            
711             =head1 AUTHOR
712            
713             Andy Wardley, E<lt>abw@wardley.orgE<gt>
714            
715             =head1 REVISION
716            
717             $Revision: 1.62 $
718            
719             =head1 COPYRIGHT
720            
721             Copyright (C) 1997-2003 Andy Wardley. All Rights Reserved.
722            
723             Copyright (C) 1997,1998 Canon Research Centre Europe Ltd.
724            
725             This module is free software; you can redistribute it and/or modify it
726             under the same terms as Perl itself.
727            
728             =head1 SEE ALSO
729            
730             AppConfig, AppConfig::State
731            
732             =cut
733