File Coverage

blib/lib/ConfigReader/Simple.pm
Criterion Covered Total %
statement 191 191 100.0
branch 72 72 100.0
condition 3 3 100.0
subroutine 28 28 100.0
pod 17 17 100.0
total 311 311 100.0


line stmt bran cond sub pod time code
1             package ConfigReader::Simple;
2 15     15   70320 use strict;
  15         39  
  15         399  
3 15     15   71 use warnings;
  15         21  
  15         358  
4 15     15   61 no warnings;
  15         22  
  15         567  
5              
6 15     15   6897 use subs qw(_init_errors);
  15         363  
  15         62  
7 15     15   687 use vars qw($VERSION $AUTOLOAD %ERROR $ERROR $Warn $Die);
  15         26  
  15         1025  
8              
9 15     15   76 use Carp qw(croak carp);
  15         25  
  15         31845  
10              
11             $ERROR = '';
12             $VERSION = '1.295';
13             $Warn = 0;
14             $Die = '';
15              
16             our $DEBUG = 0;
17             my $Error = '';
18              
19             sub SUCCESS() { 1 };
20             sub FAILURE() { 0 };
21              
22             =encoding utf8
23              
24             =head1 NAME
25              
26             ConfigReader::Simple - A simple line-oriented configuration file parser
27              
28             =head1 SYNOPSIS
29              
30             use ConfigReader::Simple;
31              
32             # parse one file
33             $config = ConfigReader::Simple->new("configrc", [qw(Foo Bar Baz Quux)]);
34              
35             # parse multiple files, in order
36             $config = ConfigReader::Simple->new_multiple(
37             Files => [ "global", "configrc" ],
38             Keys => [qw(Foo Bar Baz Quux)]
39             );
40              
41             my @directives = $config->directives;
42              
43             $config->get( "Foo" );
44              
45             if( $config->exists( "Bar" ) ) {
46             print "Bar was in the config file\n";
47             }
48              
49             # copy an object to play with it separately
50             my $clone = $config->clone;
51              
52             # only affects clone
53             $clone->set( "Foo", "Buster" );
54              
55             # save the config to a single file
56             $clone->save( "configrc" )
57              
58             # save the config to a single file, but only with
59             # certain directives
60             $clone->save( "configrc" => [qw(Foo Bar)] )
61              
62             # save to multiple configuration files
63             $clone->save(
64             "configrc" => [qw(Foo Bar)],
65             "global" => [qw(Baz Quux)],
66             );
67              
68             =head1 DESCRIPTION
69              
70             C reads and parses simple configuration files.
71             It is designed to be smaller and simpler than the C
72             module and is more suited to simple configuration files.
73              
74             =head2 The configuration file format
75              
76             The configuration file uses a line-oriented format, meaning
77             that the directives do not have containers. The values can
78             be split across lines with a continuation character, but for
79             the most part everything ends up on the same line.
80              
81             The first group of non-whitespace characters is the
82             "directive", or the name of the configuration item. The
83             linear whitespace after that separates the directive from
84             the "value", which is the rest of the line, including any
85             other whitespace.
86              
87             In this example, the directive is "Camel" and the value is
88             "Dromedary".
89              
90             Camel Dromedary
91              
92             Optionally, you can use a equal sign to separate the directive
93             from the value.
94              
95             Camel=Dromedary
96              
97             The equal sign can also have whitespace on either or both
98             sides.
99              
100             Camel = Dromedary
101             Camel= Dromedary
102              
103             In the next example, the directive is "Llama" and the value
104             is "Live from Peru"
105              
106             Llama Live from Peru
107              
108             This is the same, to C, as the following
109             which has more whitespace between the directive and the value.
110              
111             Llama Live from Peru
112              
113             You can also enclose the value in single or double quotes.
114              
115             Llama "Live from Peru"
116             Llama 'Live from Peru'
117             Llama='Live from Peru'
118              
119             In some cases you may want to split the logical line across
120             two lines, perhaps to see it better in a terminal window.
121             For that, use a \ followed only by whitespace. To split the
122             last entry across two lines, we use the \ at the end of the
123             line. These three entries are the same:
124              
125             Llama Live from Peru
126              
127             Llama Live from \
128             Peru
129              
130             Llama Live \
131             from \
132             Peru
133              
134             If a line is only whitespace, or the first non-whitespace character is
135             a #, the Perl comment character, C ignores the
136             line unless it is the continuation of the previous line.
137              
138             =head2 Methods
139              
140             =over 4
141              
142             =item new ( FILENAME, DIRECTIVES )
143              
144             Creates a C object.
145              
146             C tells the instance where to look for the
147             configuration file. If FILENAME cannot be found, an error
148             message for the file is added to the %ERROR hash with the
149             FILENAME as a key, and a combined error message appears in
150             $ERROR.
151              
152             C is an optional argument and is a reference to
153             an array. Each member of the array should contain one valid
154             directive. A directive is the name of a key that must occur
155             in the configuration file. If it is not found, the method
156             croaks. The directive list may contain all the keys in the
157             configuration file, a sub set of keys or no keys at all.
158              
159             The C method is really a wrapper around C.
160              
161             =cut
162              
163             sub new {
164 11     11 1 5561 my $class = shift;
165 11         20 my $filename = shift;
166 11         18 my $keyref = shift;
167              
168 11 100       36 $keyref = [] unless defined $keyref;
169              
170 11 100       44 my $self = $class->new_multiple(
171             Files => [ defined $filename ? $filename : () ],
172             Keys => $keyref
173             );
174              
175 11         25 return $self;
176             }
177              
178             =item new_multiple( Files => ARRAY_REF, Keys => ARRAY_REF )
179              
180             Create a configuration object from several files listed
181             in the anonymous array value for the C key. The
182             module reads the files in the same order that they appear
183             in the array. Later values override earlier ones. This
184             allows you to specify global configurations which you
185             may override with more specific ones:
186              
187             ConfigReader::Simple->new_multiple(
188             Files => [ qw( /etc/config /usr/local/etc/config /home/usr/config ) ],
189             );
190              
191             This function croaks if the values are not array references.
192              
193             If this method cannot read a file, an error message for that
194             file is added to the C<%ERROR> hash with the filename as a key,
195             and a combined error message appears in C<$ERROR>. Processing
196             the list of filenames continues if a file cannot be found,
197             which may produced undesired results. You can disable this
198             feature by setting the C<$ConfigReader::Simple::Die> variable
199             to a true value.
200              
201             =cut
202              
203             sub new_multiple {
204 17     17 1 4327 _init_errors();
205              
206 17         25 my $class = shift;
207 17         48 my %args = @_;
208              
209 17         28 my $self = {};
210              
211 17 100       128 $args{'Keys'} = [] unless defined $args{'Keys'};
212              
213             croak( __PACKAGE__ . ': Files argument must be an array reference')
214 17 100       387 unless ref $args{'Files'} eq ref [];
215             croak( __PACKAGE__ . ': Keys argument must be an array reference')
216 15 100       176 unless ref $args{'Keys'} eq ref [];
217              
218 14         23 $self->{"filenames"} = $args{'Files'};
219 14         26 $self->{"validkeys"} = $args{'Keys'};
220              
221 14         22 bless $self, $class;
222              
223 14         21 foreach my $file ( @{ $self->{"filenames"} } ) {
  14         45  
224 12         28 my $result = $self->parse( $file );
225 12 100 100     897 croak $Error if( not $result and $Die );
226              
227 11 100       30 $ERROR{$file} = $Error unless $result;
228             }
229              
230 13         38 $ERROR = join "\n", map { $ERROR{$_} } keys %ERROR;
  1         6  
231              
232 13         36 return $self;
233             }
234              
235             =item new_string( Strings => ARRAY_REF, Keys => ARRAY_REF )
236              
237             Create a configuration object from several strings listed
238             in the anonymous array value for the C key. The
239             module reads the strings in the same order that they appear
240             in the array. Later values override earlier ones. This
241             allows you to specify global configurations which you
242             may override with more specific ones:
243              
244             ConfigReader::Simple->new_strings(
245             Strings => [ \$global, \$local ],
246             );
247              
248             This function croaks if the values are not array references.
249              
250             =cut
251              
252             sub new_string {
253 9     9 1 6306 _init_errors;
254              
255 9         13 my $class = shift;
256 9         25 my %args = @_;
257              
258 9         19 my $self = {};
259              
260 9 100       31 $args{'Keys'} = [] unless defined $args{'Keys'};
261              
262             croak( __PACKAGE__ . ': Strings argument must be an array reference')
263 9 100       300 unless ref $args{'Strings'} eq ref [];
264             croak( __PACKAGE__ . ': Keys argument must be an array reference')
265 7 100       116 unless ref $args{'Keys'} eq ref [];
266              
267 6         13 bless $self, $class;
268              
269 6         17 $self->{"strings"} = $args{'Strings'};
270 6         26 $self->{"validkeys"} = $args{'Keys'};
271              
272 6         11 foreach my $string_ref ( @{ $self->{"strings"} } ) {
  6         14  
273 6 100       127 croak( __PACKAGE__ . ': Element of Strings is not a scalar reference' )
274             unless ref $string_ref eq ref \ '';
275 5         16 $self->parse_string( $string_ref );
276             }
277              
278 5         18 return $self;
279             }
280              
281             =item add_config_file( FILENAME )
282              
283             Parse another configuration file and add its directives to the
284             current configuration object. Any directives already defined
285             will be replaced with the new values found in FILENAME.
286              
287             =cut
288              
289             sub add_config_file {
290 4     4 1 3695 _init_errors;
291              
292 4         10 my( $self, $filename ) = @_;
293              
294 4 100       16 return unless $self->parse( $filename );
295              
296 2         4 push @{ $self->{"filenames"} }, $filename;
  2         5  
297              
298 2         9 return 1;
299             }
300              
301             =item files
302              
303             Return the list of configuration files associated with this
304             object. The order of the return values is the order of parsing,
305             so the first value is the first file parsed (and subsequent files may
306             mask it).
307              
308             =cut
309              
310 4     4 1 12 sub files { @{ $_[0]->{"filenames"} } }
  4         11  
311              
312             =item new_from_prototype(
313              
314             Create a clone object. This is the same thing as calling
315             clone().
316              
317             =cut
318              
319             sub new_from_prototype {
320 1     1 1 278 _init_errors;
321              
322 1         1 my $self = shift;
323              
324 1         3 my $clone = $self->clone;
325              
326 1         2 return $clone;
327             }
328              
329             sub AUTOLOAD {
330 15     15   505 my $self = shift;
331              
332 15         21 my $method = $AUTOLOAD;
333              
334 15         91 $method =~ s/.*:://;
335              
336 15         37 $self->get( $method );
337             }
338              
339             sub DESTROY {
340 32     32   14498 return 1;
341             }
342              
343             =item parse( FILENAME )
344              
345             This does the actual work.
346              
347             This is automatically called from C, although you can reparse
348             the configuration file by calling C again.
349              
350             =cut
351              
352             sub parse {
353 20     20 1 6818 my( $self, $file ) = @_;
354              
355 20         32 $Error = '';
356              
357 20 100       622 unless( open CONFIG, $file ) {
358 7         58 $Error = "Could not open configuration file [$file]: $!";
359 7 100       229 carp $Error if $Warn;
360 7         206 return;
361             }
362              
363 13         71 $self->{"file_fields"}{$file} = [];
364              
365 13         855 while( ) {
366 109 100       330 if ( s/\\ \s* $//x ) {
367 19         41 $_ .= ;
368 19 100       64 redo unless eof CONFIG;
369             }
370              
371 91         117 chomp;
372 91 100       386 next if /^\s*(#|$)/;
373              
374 71         134 my ($key, $value) = &parse_line($_);
375             #carp "Key: '$key' Value: '$value'\n" if $DEBUG;
376              
377 71         153 $self->{"config_data"}{$key} = $value;
378 71         84 push @{ $self->{"file_fields"}{$file} }, $key;
  71         262  
379             }
380              
381 13         270 close(CONFIG);
382              
383 13         61 $self->_validate_keys;
384              
385 13         30 return 1;
386             }
387              
388             =item parse_string( SCALAR_REF )
389              
390             Parses the string inside the reference SCALAR_REF just as if
391             it found it in a file.
392              
393             =cut
394              
395             sub parse_string {
396 6     6 1 12 my $self = shift;
397 6         8 my $string = shift;
398              
399 6         45 my @lines = split /\r?\n/, $$string;
400 6         15 chomp( @lines );
401             # carp "A: Found " . @lines . " lines" if $DEBUG;
402              
403 6         31 while( defined( my $line = shift @lines )) {
404             # carp "1: Line is $line" if $DEBUG;
405              
406             CONT: {
407 15 100       23 if ( $line =~ s/\\ \s* $//x ) {
  17         48  
408             # carp "a: reading continuation line $lines[0]" if $DEBUG;
409 3         7 $line .= shift @lines;
410             # carp "b: Line is $line" if $DEBUG;
411 3 100       9 redo CONT unless @lines == 0;
412             }
413             }
414              
415             # carp "2: Line is $line" if $DEBUG;
416              
417 15         27 chomp $line;
418 15 100       58 next if $line =~ /^\s*(#|$)/;
419              
420             # carp "3: Line is $line" if $DEBUG;
421              
422 13         25 my ($key, $value) = &parse_line( $line );
423             # carp "Key: '$key' Value: '$value'" if $DEBUG;
424              
425 13         53 $self->{"config_data"}{$key} = $value;
426             }
427              
428 6         20 $self->_validate_keys;
429              
430 6         12 return 1;
431             }
432              
433             =item get( DIRECTIVE )
434              
435             Returns the parsed value for that directive. For directives
436             which did not have a value in the configuration file, C
437             returns the empty string.
438              
439             =cut
440              
441 81     81 1 5139 sub get { $_[0]->{"config_data"}{$_[1]} }
442              
443             =item set( DIRECTIVE, VALUE )
444              
445             Sets the value for DIRECTIVE to VALUE. The DIRECTIVE
446             need not already exist. This overwrites previous
447             values.
448              
449             The VALUE must be a simple scalar. It cannot be a reference.
450             If the VALUE is a reference, the function prints a warning
451             and returns false.
452              
453             =cut
454              
455             sub set {
456 22     22 1 4486 my $self = shift;
457 22         33 my( $key, $value ) = @_;
458              
459 22 100       40 if( ref $value ) {
460 3         6 $ERROR = "Second argument to set must be a simple scalar";
461 3 100       8 if( $Warn ) {
    100          
462 1         110 carp $ERROR;
463 1         83 return;
464             }
465             elsif( $Die ) {
466 1         213 croak $ERROR;
467             }
468              
469 1         4 return;
470             }
471              
472 19         35 $self->{"config_data"}{$key} = $value;
473             }
474              
475             =item unset( DIRECTIVE )
476              
477             Remove the value from DIRECTIVE, which will still exist. It's
478             value is undef. If the DIRECTIVE does not exist, it will not
479             be created. Returns FALSE if the DIRECTIVE does not already
480             exist, and TRUE otherwise.
481              
482             =cut
483              
484             sub unset {
485 2     2 1 246 my $self = shift;
486 2         4 my $key = shift;
487              
488 2 100       5 return unless $self->exists( $key );
489              
490 1         3 $self->{"config_data"}{$key} = undef;
491              
492 1         4 return 1;
493             }
494              
495             =item remove( DIRECTIVE )
496              
497             Remove the DIRECTIVE. Returns TRUE is DIRECTIVE existed
498             and FALSE otherwise.
499              
500             =cut
501              
502             sub remove {
503 2     2 1 278 my $self = shift;
504 2         4 my $key = shift;
505              
506 2 100       6 return unless $self->exists( $key );
507              
508 1         3 delete $self->{"config_data"}{$key};
509              
510 1         4 return 1;
511             }
512              
513             =item directives()
514              
515             Returns a list of all of the directive names found in the configuration
516             file. The keys are sorted ASCII-betically.
517              
518             =cut
519              
520             sub directives {
521 3     3 1 7 my $self = shift;
522              
523 3         4 my @keys = sort keys %{ $self->{"config_data"} };
  3         23  
524              
525 3         10 return @keys;
526             }
527              
528             =item exists( DIRECTIVE )
529              
530             Return TRUE if the specified directive exists, and FALSE
531             otherwise.
532              
533             =cut
534              
535             sub exists {
536 15     15 1 2513 my $self = shift;
537 15         22 my $name = shift;
538              
539 15         57 return CORE::exists $self->{"config_data"}{ $name };
540             }
541              
542             =item clone
543              
544             Return a copy of the object. The new object is distinct
545             from the original so you can make changes to the new object
546             without affecting the old one.
547              
548             =cut
549              
550             # this is only the first stab at this -- from 35,000
551             # feet in coach class
552             #
553             # I expect that the hash will be very simple. Some keys
554             # might have a reference value, but that reference value
555             # will be "flat", so it won't have references in it.
556              
557             sub clone {
558 2     2 1 321 my $self = shift;
559              
560 2         4 my $clone = bless {}, ref $self;
561              
562 2         3 $clone->{"filenames"} = [ @{ $self->{"filenames"} } ];
  2         5  
563 2         3 $clone->{"validkeys"} = [ @{ $self->{"validkeys"} } ];
  2         4  
564              
565 2         3 foreach my $file ( keys %{ $self->{"file_fields"} } ) {
  2         6  
566             $clone->{"file_fields"}{ $file }
567 2         2 = [ @{ $self->{"file_fields"}{ $file } } ];
  2         7  
568             }
569              
570 2         4 foreach my $key ( $self->directives ) {
571 14         18 $clone->set( $key, $self->get( $key ) );
572             }
573              
574 2         5 return $clone;
575             }
576              
577             =item save( FILENAME [ => ARRAY_REF [, FILENAME => ARRAY_REF ] ] );
578              
579             The save method works in three ways, depending on the argument list.
580              
581             With a single argument, the save function attempts to save all of the
582             field-value pairs of the object to the file named by the argument.
583              
584             $clone->save( "configrc" );
585              
586             With two arguments, the method expects the second argument to be an
587             array reference which lists the directives to save in the file.
588              
589             $clone->save( "configrc" => [qw(Foo Bar)] );
590              
591             With more than two arguments, the method expects filename-list pairs.
592             The method will save in each file the values in their respective
593             array references.
594              
595             $clone->save(
596             "configrc" => [qw(Foo Bar)],
597             "global" => [qw(Baz Quux)],
598             );
599              
600             In the last two cases, the method checks that the value for each pair
601             is an array reference before it affects any files. It croaks if
602             any value is not an array reference.
603              
604             Once the method starts writing files, it tries to write all of the
605             specified files. Even if it has a problem with one of them, it continues
606             onto the next one. The method does not necessarily write the files
607             in the order they appear in the argument list, and it does not check
608             if you specified the same file twice.
609              
610             =cut
611              
612             sub save {
613 9     9 1 7692 my $self = shift;
614 9         18 my @args = @_;
615              
616 9 100       22 if( @args == 0 ) { # no args!
617 1         17 carp "No arguments to method!";
618 1         479 return;
619             }
620              
621 8 100       16 if( @args == 1 ) { # this is a single file
622 1         4 push @args, [ $self->directives ];
623             }
624              
625 8 100       20 unless( @args % 2 == 0 ) { croak "Odd number of arguments" };
  1         11  
626              
627 7         14 my %hash = @args;
628              
629 7         15 foreach my $value ( values %hash ) {
630 8 100       58 croak "Argument is not an array reference"
631             unless ref $value eq ref [];
632             }
633              
634 3         7 foreach my $file ( keys %hash ) {
635 4 100       11 carp $ERROR unless $self->_save( $file, $hash{$file} );
636             }
637              
638 3         441 1;
639             }
640              
641             sub _save {
642 7     7   692 my( $self, $file, $directives ) = @_;
643              
644 7 100       22 unless( ref $directives eq ref [] ) {
645 2         4 $ERROR = 'Argument is not an array reference';
646 2         4 return;
647             }
648              
649 5         8 my $fh;
650 5 100       346 unless( open $fh, ">", $file ) {
651 1         11 $ERROR = $!;
652 1         6 return;
653             }
654              
655 4         17 foreach my $directive ( @$directives ) {
656 12         28 print $fh (
657             join( "\t", $directive, $self->get( $directive ) ),
658             "\n"
659             );
660             }
661              
662 4         207 return SUCCESS;
663             }
664              
665             =begin private
666              
667             =item parse_line( STRING )
668              
669             Internal method. Don't call this directly.
670              
671             Takes a line of text and turns it into the directive and value.
672              
673             =end private
674              
675             =cut
676              
677              
678             sub parse_line {
679 86 100   86 1 2612 return ( $1, $3 ) if $_[0] =~ /
680             ^\s*
681              
682             (
683             [^\s=]+
684             )
685              
686             \s*
687             [=]?
688             \s*
689              
690             (['"]?)
691             (.*?)
692             \2
693              
694             \s*
695              
696             $/x;
697              
698 1         151 croak "Config: Can't parse line: $_[0]\n";
699             }
700              
701             sub _init_errors {
702 31     31   63 %ERROR = ();
703 31         52 $Error = undef;
704 31         48 $ERROR = undef;
705             }
706              
707             =begin private
708              
709             =item _validate_keys
710              
711             If any keys were declared when the object was constructed,
712             check that those keys actually occur in the configuration file.
713             This function croaks if a declared key does not exist.
714              
715             =end private
716              
717             =cut
718              
719             sub _validate_keys {
720 22     22   880 my $self = shift;
721              
722 22 100       71 return SUCCESS unless exists $self->{"validkeys"};
723              
724             croak "validkeys was not an array reference!"
725 20 100       232 unless ref $self->{"validkeys"} eq ref [];
726 19         39 my @keys = eval { @{ $self->{"validkeys"} } };
  19         25  
  19         55  
727              
728 19         39 my @missing = grep { ! exists $self->{"config_data"}{$_} }@keys;
  30         63  
729              
730 19 100       128 croak "Config: required keys [@missing] do not occur in config"
731             if @missing;
732              
733 18         38 return SUCCESS;
734             }
735              
736             =back
737              
738             =head2 Package variables
739              
740             =over 4
741              
742             =item $Die - DEPRECATED
743              
744             If set to a true value, all errors are fatal.
745              
746             =item $ERROR
747              
748             The last error message.
749              
750             =item %ERROR
751              
752             The error messages from unreadable files. The key is
753             the filename and the value is the error message.
754              
755             =item $Warn - DEPRECATED
756              
757             If set to a true value, methods may output warnings.
758              
759             =back
760              
761             =head1 LIMITATIONS/BUGS
762              
763             Directives are case-sensitive.
764              
765             If a directive is repeated, the first instance will silently be
766             ignored.
767              
768             =head1 CREDITS
769              
770             Bek Oberin C<< >> wote the original module
771              
772             Kim Ryan C<< >> adapted the module to make
773             declaring keys optional. Thanks Kim.
774              
775             Alan W. Jurgensen C<< >> added a change to allow
776             the NAME=VALUE format in the configuration file.
777              
778             Andy Lester, C<< >>, for maintaining the module
779             while brian was on active duty.
780              
781             Adam Trickett, C<< >>, added multi-line support.
782             You might want to see his C module.
783              
784             Greg White has been a very patient user and tester.
785              
786             =head1 SOURCE AVAILABILITY
787              
788             The source is in Github:
789              
790             http://github.com/briandfoy/ConfigReader-Simple/
791              
792             =head1 AUTHORS
793              
794             brian d foy, C<< >>
795              
796             =head1 COPYRIGHT AND LICENSE
797              
798             Copyright © 2002-2022, brian d foy . All rights reserved.
799              
800             This program is free software; you can redistribute it and/or modify
801             it under the Artistic License 2.0.
802              
803             =cut
804              
805             1;