File Coverage

lib/CPANPLUS/YACSmoke/IniFiles.pm
Criterion Covered Total %
statement 243 737 32.9
branch 99 432 22.9
condition 12 71 16.9
subroutine 22 69 31.8
pod 34 34 100.0
total 410 1343 30.5


line stmt bran cond sub pod time code
1             package CPANPLUS::YACSmoke::IniFiles;
2             $CPANPLUS::YACSmoke::IniFiles::VERSION = '1.04';
3             require 5.004;
4 10     10   66 use strict;
  10         18  
  10         310  
5 10     10   51 use Carp;
  10         20  
  10         676  
6 10     10   70 use Symbol 'gensym','qualify_to_ref'; # For the 'any data type' hack
  10         22  
  10         73020  
7              
8             @CPANPLUS::YACSmoke::IniFiles::errors = ( );
9              
10             # $Header: /home/shlomi/progs/perl/cpan/Config/IniFiles/config-inifiles-cvsbackup/config-inifiles/IniFiles.pm,v 2.41 2003-12-08 10:50:56 domq Exp $
11              
12             =head1 NAME
13              
14             Config::IniFiles - A module for reading .ini-style configuration files.
15              
16             =head1 SYNOPSIS
17              
18             use Config::IniFiles;
19             my $cfg = Config::IniFiles->new( -file => "/path/configfile.ini" );
20             print "The value is " . $cfg->val( 'Section', 'Parameter' ) . "."
21             if $cfg->val( 'Section', 'Parameter' );
22              
23             =head1 DESCRIPTION
24              
25             Config::IniFiles provides a way to have readable configuration files outside
26             your Perl script. Configurations can be imported (inherited, stacked,...),
27             sections can be grouped, and settings can be accessed from a tied hash.
28              
29             =head1 FILE FORMAT
30              
31             INI files consist of a number of sections, each preceded with the
32             section name in square brackets, followed by parameter names and
33             their values.
34              
35             [a section]
36             Parameter=Value
37              
38             [section 2]
39             AnotherParameter=Some value
40             Setting=Something else
41             Parameter=Different scope than the one in the first section
42              
43             The first non-blank character of the line indicating a section must
44             be a left bracket and the last non-blank character of a line indicating
45             a section must be a right bracket. The characters making up the section
46             name can be any symbols at all. However section names must be unique.
47              
48             Parameters are specified in each section as Name=Value. Any spaces
49             around the equals sign will be ignored, and the value extends to the
50             end of the line (including any whitespace at the end of the line.
51             Parameter names are localized to the namespace of the section, but must
52             be unique within a section.
53              
54             Both the hash mark (#) and the semicolon (;) are comment characters.
55             by default (this can be changed by configuration). Lines that begin with
56             either of these characters will be ignored. Any amount of whitespace may
57             precede the comment character.
58              
59             Multi-line or multi-valued parameters may also be defined ala UNIX
60             "here document" syntax:
61              
62             Parameter=<
63             value/line 1
64             value/line 2
65             EOT
66              
67             You may use any string you want in place of "EOT". Note that whatever
68             follows the "<<" and what appears at the end of the text MUST match
69             exactly, including any trailing whitespace.
70              
71             Alternately, as a configuration option (default is off), continuation
72             lines can be allowed:
73              
74             [Section]
75             Parameter=this parameter \
76             spreads across \
77             a few lines
78              
79              
80             =head1 USAGE -- Object Interface
81              
82             Get a new Config::IniFiles object with the I method:
83              
84             $cfg = Config::IniFiles->new( -file => "/path/config_file.ini" );
85             $cfg = new Config::IniFiles -file => "/path/config_file.ini";
86              
87             Optional named parameters may be specified after the configuration
88             file name. See the I in the B section, below.
89              
90             Values from the config file are fetched with the val method:
91              
92             $value = $cfg->val('Section', 'Parameter');
93              
94             If you want a multi-line/value field returned as an array, just
95             specify an array as the receiver:
96              
97             @values = $cfg->val('Section', 'Parameter');
98              
99             =head1 METHODS
100              
101             =head2 new ( [-option=>value ...] )
102              
103             Returns a new configuration object (or "undef" if the configuration
104             file has an error, in which case check the global C<@Config::IniFiles::errors>
105             array for reasons why). One Config::IniFiles object is required per configuration
106             file. The following named parameters are available:
107              
108             =over 10
109              
110              
111             =item I<-file> filename
112              
113             Specifies a file to load the parameters from. This 'file' may actually be
114             any of the following things:
115              
116             1) the pathname of a file
117              
118             $cfg = Config::IniFiles->new( -file => "/path/to/config_file.ini" );
119              
120             2) a simple filehandle
121              
122             $cfg = Config::IniFiles->new( -file => STDIN );
123              
124             3) a filehandle glob
125              
126             open( CONFIG, "/path/to/config_file.ini" );
127             $cfg = Config::IniFiles->new( -file => *CONFIG );
128              
129             4) a reference to a glob
130              
131             open( CONFIG, "/path/to/config_file.ini" );
132             $cfg = Config::IniFiles->new( -file => \*CONFIG );
133              
134             5) an IO::File object
135              
136             $io = IO::File->new( "/path/to/config_file.ini" );
137             $cfg = Config::IniFiles->new( -file => $io );
138              
139             or
140              
141             open my $fh, '<', "/path/to/config_file.ini" or die $!;
142             $cfg = Config::IniFiles->new( -file => $fh );
143              
144             6) A reference to a scalar (requires newer versions of IO::Scalar)
145              
146             $ini_file_contents = <
147             [section name]
148             Parameter=A value
149             Setting=Another value
150             EOT
151            
152             $cfg = Config::IniFiles->new( -file => \$ini_file_contents );
153              
154              
155             If this option is not specified, (i.e. you are creating a config file from scratch)
156             you must specify a target file using L in order to save the parameters.
157              
158              
159             =item I<-default> section
160              
161             Specifies a section to be used for default values. For example, in the
162             following configuration file, if you look up the "permissions" parameter
163             in the "joe" section, there is none.
164              
165             [all]
166             permissions=Nothing
167            
168             [jane]
169             name=Jane
170             permissions=Open files
171              
172             [joe]
173             name=Joseph
174              
175             If you create your Config::IniFiles object with a default section of "all" like this:
176              
177             $cfg = Config::IniFiles->new( -file => "file.ini", -default => "all" );
178            
179             Then requsting a value for a "permissions" in the [joe] section will
180             check for a value from [all] before returning undef.
181              
182             $permissions = $cfg->val( "joe", "permissions"); // returns "Nothing"
183              
184              
185             =item I<-fallback> section
186              
187             Specifies a section to be used for parameters outside a section. Default is none.
188             Without -fallback specified (which is the default), reading a configuration file
189             which has a parameter outside a section will fail. With this set to, say,
190             "GENERAL", this configuration:
191              
192             wrong=wronger
193              
194             [joe]
195             name=Joseph
196              
197             will be assumed as:
198              
199             [GENERAL]
200             wrong=wronger
201              
202             [joe]
203             name=Joseph
204              
205             Note that Config::IniFiles will also omit the fallback section header when
206             outputing such configuration.
207              
208             =item I<-nocase> 0|1
209              
210             Set -nocase => 1 to handle the config file in a case-insensitive
211             manner (case in values is preserved, however). By default, config
212             files are case-sensitive (i.e., a section named 'Test' is not the same
213             as a section named 'test'). Note that there is an added overhead for
214             turning off case sensitivity.
215              
216              
217             =item I<-import> object
218              
219             This allows you to import or inherit existing setting from another
220             Config::IniFiles object. When importing settings from another object,
221             sections with the same name will be merged and parameters that are
222             defined in both the imported object and the I<-file> will take the
223             value of given in the I<-file>.
224              
225             If a I<-default> section is also given on this call, and it does not
226             coincide with the default of the imported object, the new default
227             section will be used instead. If no I<-default> section is given,
228             then the default of the imported object will be used.
229              
230              
231             =item I<-allowcontinue> 0|1
232              
233             Set -allowcontinue => 1 to enable continuation lines in the config file.
234             i.e. if a line ends with a backslash C<\>, then the following line is
235             appended to the parameter value, dropping the backslash and the newline
236             character(s).
237              
238             Default behavior is to keep a trailing backslash C<\> as a parameter
239             value. Note that continuation cannot be mixed with the "here" value
240             syntax.
241              
242              
243             =item I<-allowempty> 0|1
244              
245             If set to 1, then empty files are allowed at L
246             time. If set to 0 (the default), an empty configuration file is considered
247             an error.
248              
249              
250             =item I<-negativedeltas> 0|1
251              
252             If set to 1 (the default if importing this object from another one),
253             parses and honors lines of the following form in the configuration
254             file:
255              
256             ; [somesection] is deleted
257              
258             or
259              
260             [inthissection]
261             ; thisparameter is deleted
262              
263             If set to 0 (the default if not importing), these comments are treated
264             like ordinary ones.
265              
266             The L1)> form will output such
267             comments to indicate deleted sections or parameters. This way,
268             reloading a delta file using the same imported object produces the
269             same results in memory again. See L for more
270             details.
271              
272             =item I<-commentchar> 'char'
273              
274             The default comment character is C<#>. You may change this by specifying
275             this option to another character. This can be any character except
276             alphanumeric characters, square brackets or the "equal" sign.
277              
278              
279             =item I<-allowedcommentchars> 'chars'
280              
281             Allowed default comment characters are C<#> and C<;>. By specifying this
282             option you may change the range of characters that are used to denote a
283             comment line to include any set of characters
284              
285             Note: that the character specified by B<-commentchar> (see above) is
286             I part of the allowed comment characters.
287              
288             Note 2: The given string is evaluated as a regular expression character
289             class, so '\' must be escaped if you wish to use it.
290              
291              
292             =item I<-reloadwarn> 0|1
293              
294             Set -reloadwarn => 1 to enable a warning message (output to STDERR)
295             whenever the config file is reloaded. The reload message is of the
296             form:
297              
298             PID reloading config file at YYYY.MM.DD HH:MM:SS
299              
300             Default behavior is to not warn (i.e. -reloadwarn => 0).
301              
302             This is generally only useful when using Config::IniFiles in a server
303             or daemon application. The application is still responsible for determining
304             when the object is to be reloaded.
305              
306              
307             =item I<-nomultiline> 0|1
308              
309             Set -nomultiline => 1 to output multi-valued parameter as:
310              
311             param=value1
312             param=value2
313              
314             instead of the default:
315              
316             param=<
317             value1
318             value2
319             EOT
320              
321             As the later might not be compatible with all applications.
322              
323             =back
324              
325             =cut
326              
327             sub new {
328 4     4 1 15 my $class = shift;
329 4         37 my %parms = @_;
330              
331 4         77 my $errs = 0;
332 4         21 my @groups = ( );
333              
334 4         117 my $self = bless {
335             default => '',
336             fallback =>undef,
337             fallback_used => 0,
338             imported =>undef,
339             v =>{},
340             cf => undef,
341             firstload => 1,
342             nomultiline => 0,
343             }, $class;
344              
345 4 50 33     69 if( ref($parms{-import}) && ($parms{-import}->isa('CPANPLUS::YACSmoke::IniFiles')) ) {
    50          
346 0         0 $self->{imported}=$parms{-import}; # ReadConfig will load the data
347 0         0 $self->{negativedeltas}=1;
348             } elsif( defined $parms{-import} ) {
349 0         0 carp "Invalid -import value \"$parms{-import}\" was ignored.";
350             } # end if
351 4         19 delete $parms{-import};
352              
353             # Copy the original parameters so we
354             # can use them when we build new sections
355 4         14 %{$self->{startup_settings}} = %parms;
  4         39  
356              
357             # Parse options
358 4         13 my($k, $v);
359 4         8 local $_;
360 4         28 $self->{nocase} = 0;
361              
362             # Handle known parameters first in this order,
363             # because each() could return parameters in any order
364 4 50       22 if (defined ($v = delete $parms{'-file'})) {
365             # Should we be pedantic and check that the file exists?
366             # .. no, because now it could be a handle, IO:: object or something else
367 4         9 $self->{cf} = $v;
368             }
369 4 50       20 if (defined ($v = delete $parms{'-nocase'})) {
370 0 0       0 $self->{nocase} = $v ? 1 : 0;
371             }
372 4 50       22 if (defined ($v = delete $parms{'-default'})) {
373 0 0       0 $self->{default} = $self->{nocase} ? lc($v) : $v;
374             }
375 4 50       14 if (defined ($v = delete $parms{'-fallback'})) {
376 0 0       0 $self->{fallback} = $self->{nocase} ? lc($v) : $v;
377             }
378 4 50       12 if (defined ($v = delete $parms{'-reloadwarn'})) {
379 0 0       0 $self->{reloadwarn} = $v ? 1 : 0;
380             }
381 4 50       22 if (defined ($v = delete $parms{'-nomultiline'})) {
382 0 0       0 $self->{nomultiline} = $v ? 1 : 0;
383             }
384 4 50       17 if (defined ($v = delete $parms{'-allowcontinue'})) {
385 0 0       0 $self->{allowcontinue} = $v ? 1 : 0;
386             }
387 4 50       12 if (defined ($v = delete $parms{'-allowempty'})) {
388 0 0       0 $self->{allowempty} = $v ? 1 : 0;
389             }
390 4 50       32 if (defined ($v = delete $parms{'-negativedeltas'})) {
391 0 0       0 $self->{negativedeltas} = $v ? 1 : 0;
392             }
393 4 50       25 if (defined ($v = delete $parms{'-commentchar'})) {
394 0 0 0     0 if(!defined $v || length($v) != 1) {
    0          
395 0         0 carp "Comment character must be unique.";
396 0         0 $errs++;
397             }
398             elsif($v =~ /[\[\]=\w]/) {
399             # must not be square bracket, equal sign or alphanumeric
400 0         0 carp "Illegal comment character.";
401 0         0 $errs++;
402             }
403             else {
404 0         0 $self->{comment_char} = $v;
405             }
406             }
407 4 50       15 if (defined ($v = delete $parms{'-allowedcommentchars'})) {
408             # must not be square bracket, equal sign or alphanumeric
409 0 0 0     0 if(!defined $v || $v =~ /[\[\]=\w]/) {
410 0         0 carp "Illegal value for -allowedcommentchars.";
411 0         0 $errs++;
412             }
413             else {
414 0         0 $self->{allowed_comment_char} = $v;
415             }
416             }
417 4 50       14 $self->{comment_char} = '#' unless exists $self->{comment_char};
418 4 50       35 $self->{allowed_comment_char} = ';' unless exists $self->{allowed_comment_char};
419             # make sure that comment character is always allowed
420 4         15 $self->{allowed_comment_char} .= $self->{comment_char};
421              
422 4         10 $self->{_comments_at_end_of_file} = [];
423              
424             # Any other parameters are unkown
425 4         27 while (($k, $v) = each %parms) {
426 0         0 carp "Unknown named parameter $k=>$v";
427 0         0 $errs++;
428             }
429              
430 4 50       12 return undef if $errs;
431            
432 4 50       60 if ($self->ReadConfig) {
433 4         19 return $self;
434             } else {
435 0         0 return undef;
436             }
437             }
438              
439              
440             =head2 val ($section, $parameter [, $default] )
441              
442             Returns the value of the specified parameter (C<$parameter>) in section
443             C<$section>, returns undef (or C<$default> if specified) if no section or
444             no parameter for the given section exists.
445              
446              
447             If you want a multi-line/value field returned as an array, just
448             specify an array as the receiver:
449              
450             @values = $cfg->val('Section', 'Parameter');
451              
452             A multi-line/value field that is returned in a scalar context will be
453             joined using $/ (input record separator, default is \n) if defined,
454             otherwise the values will be joined using \n.
455              
456             =cut
457              
458             sub val {
459 11     11 1 50 my ($self, $sect, $parm, $def) = @_;
460              
461             # Always return undef on bad parameters
462 11 50       35 return if not defined $sect;
463 11 50       25 return if not defined $parm;
464            
465 11 50       26 if ($self->{nocase}) {
466 0         0 $sect = lc($sect);
467 0         0 $parm = lc($parm);
468             }
469            
470             my $val = defined($self->{v}{$sect}{$parm}) ?
471             $self->{v}{$sect}{$parm} :
472 11 100       48 $self->{v}{$self->{default}}{$parm};
473            
474             # If the value is undef, make it $def instead (which could just be undef)
475 11 100       27 $val = $def unless defined $val;
476            
477             # Return the value in the desired context
478 11 100       29 if (wantarray) {
    50          
479 8 50       25 if (ref($val) eq "ARRAY") {
    100          
480 0         0 return @$val;
481             } elsif (defined($val)) {
482 4         21 return $val;
483             } else {
484 4         13 return;
485             }
486             } elsif (ref($val) eq "ARRAY") {
487 0 0       0 if (defined ($/)) {
488 0         0 return join "$/", @$val;
489             } else {
490 0         0 return join "\n", @$val;
491             }
492             } else {
493 3         43 return $val;
494             }
495             }
496              
497              
498              
499             =head2 exists($section, $parameter)
500              
501             True if and only if there exists a section C<$section>, with
502             a parameter C<$parameter> inside, not counting default values.
503              
504             =cut
505              
506             sub exists {
507 0     0 1 0 my ($self, $sect, $parm)=@_;
508              
509 0 0       0 if ($self->{nocase}) {
510 0         0 $sect = lc($sect);
511 0         0 $parm = lc($parm);
512             }
513            
514 0         0 return (exists $self->{v}{$sect}{$parm});
515             }
516              
517              
518              
519             =head2 push ($section, $parameter, $value, [ $value2, ...])
520              
521             Pushes new values at the end of existing value(s) of parameter
522             C<$parameter> in section C<$section>. See below for methods to write
523             the new configuration back out to a file.
524              
525             You may not set a parameter that didn't exist in the original
526             configuration file. B will return I if this is
527             attempted. See B below to do this. Otherwise, it returns 1.
528              
529             =cut
530              
531             sub push {
532 0     0 1 0 my ($self, $sect, $parm, @vals)=@_;
533              
534 0 0       0 return undef if not defined $sect;
535 0 0       0 return undef if not defined $parm;
536              
537 0 0       0 if ($self->{nocase}) {
538 0         0 $sect = lc($sect);
539 0         0 $parm = lc($parm);
540             }
541              
542 0 0       0 return undef if (! defined($self->{v}{$sect}{$parm}));
543              
544 0 0       0 return 1 if (! @vals);
545              
546 0         0 $self->_touch_parameter($sect, $parm);
547              
548             $self->{EOT}{$sect}{$parm} = 'EOT' if
549 0 0       0 (!defined $self->{EOT}{$sect}{$parm});
550              
551             $self->{v}{$sect}{$parm} = [$self->{v}{$sect}{$parm}] unless
552 0 0       0 (ref($self->{v}{$sect}{$parm}) eq "ARRAY");
553              
554 0         0 CORE::push @{$self->{v}{$sect}{$parm}}, @vals;
  0         0  
555 0         0 return 1;
556             }
557              
558             =head2 setval ($section, $parameter, $value, [ $value2, ... ])
559              
560             Sets the value of parameter C<$parameter> in section C<$section> to
561             C<$value> (or to a set of values). See below for methods to write
562             the new configuration back out to a file.
563              
564             You may not set a parameter that didn't exist in the original
565             configuration file. B will return I if this is
566             attempted. See B below to do this. Otherwise, it returns 1.
567              
568             =cut
569              
570             sub setval {
571 0     0 1 0 my $self = shift;
572 0         0 my $sect = shift;
573 0         0 my $parm = shift;
574 0         0 my @val = @_;
575              
576 0 0       0 return undef if not defined $sect;
577 0 0       0 return undef if not defined $parm;
578              
579 0 0       0 if ($self->{nocase}) {
580 0         0 $sect = lc($sect);
581 0         0 $parm = lc($parm);
582             }
583              
584 0 0       0 if (defined($self->{v}{$sect}{$parm})) {
585 0         0 $self->_touch_parameter($sect, $parm);
586 0 0       0 if (@val > 1) {
587 0         0 $self->{v}{$sect}{$parm} = \@val;
588 0         0 $self->{EOT}{$sect}{$parm} = 'EOT';
589             } else {
590 0         0 $self->{v}{$sect}{$parm} = shift @val;
591             }
592 0         0 return 1;
593             } else {
594 0         0 return undef;
595             }
596             }
597              
598             =head2 newval($section, $parameter, $value [, $value2, ...])
599              
600             Assignes a new value, C<$value> (or set of values) to the
601             parameter C<$parameter> in section C<$section> in the configuration
602             file.
603              
604             =cut
605              
606             sub newval {
607 5     5 1 9 my $self = shift;
608 5         10 my $sect = shift;
609 5         8 my $parm = shift;
610 5         18 my @val = @_;
611            
612 5 50       15 return undef if not defined $sect;
613 5 50       13 return undef if not defined $parm;
614              
615 5 50       16 if ($self->{nocase}) {
616 0         0 $sect = lc($sect);
617 0         0 $parm = lc($parm);
618             }
619              
620 5         15 $self->AddSection($sect);
621              
622 5         14 CORE::push(@{$self->{parms}{$sect}}, $parm)
623 5 50       12 unless (grep {/^\Q$parm\E$/} @{$self->{parms}{$sect}} );
  1         11  
  5         37  
624              
625 5         30 $self->_touch_parameter($sect, $parm);
626 5 50       24 if (@val > 1) {
627 0         0 $self->{v}{$sect}{$parm} = \@val;
628 0 0       0 $self->{EOT}{$sect}{$parm} = 'EOT' unless defined $self->{EOT}{$sect}{$parm};
629             } else {
630 5         27 $self->{v}{$sect}{$parm} = shift @val;
631             }
632 5         16 return 1
633             }
634              
635             =head2 delval($section, $parameter)
636              
637             Deletes the specified parameter from the configuration file
638              
639             =cut
640              
641             sub delval {
642 0     0 1 0 my $self = shift;
643 0         0 my $sect = shift;
644 0         0 my $parm = shift;
645            
646 0 0       0 return undef if not defined $sect;
647 0 0       0 return undef if not defined $parm;
648              
649 0 0       0 if ($self->{nocase}) {
650 0         0 $sect = lc($sect);
651 0         0 $parm = lc($parm);
652             }
653              
654 0         0 @{$self->{parms}{$sect}} = grep !/^\Q$parm\E$/, @{$self->{parms}{$sect}};
  0         0  
  0         0  
655 0         0 $self->_touch_parameter($sect, $parm);
656 0         0 delete $self->{v}{$sect}{$parm};
657 0         0 return 1
658             }
659              
660             =head2 ReadConfig
661              
662             Forces the configuration file to be re-read. Returns undef if the
663             file can not be opened, no filename was defined (with the C<-file>
664             option) when the object was constructed, or an error occurred while
665             reading.
666              
667             If an error occurs while parsing the INI file the @Config::IniFiles::errors
668             array will contain messages that might help you figure out where the
669             problem is in the file.
670              
671             =cut
672              
673             # Auxillary function to make deep (aliasing-free) copies of data
674             # structures. Ignores blessed objects in tree (could be taught not
675             # to, if needed)
676             sub _deepcopy {
677 0     0   0 my $ref=shift;
678              
679 0 0       0 if (! ref($ref)) { return $ref; }
  0         0  
680              
681 0         0 local $_;
682              
683 0 0       0 if (UNIVERSAL::isa($ref, "ARRAY")) {
684 0         0 return [map {_deepcopy($_)} @$ref];
  0         0  
685             }
686              
687 0 0       0 if (UNIVERSAL::isa($ref, "HASH")) {
688 0         0 my $return={};
689 0         0 foreach my $k (keys %$ref) {
690 0         0 $return->{$k}=_deepcopy($ref->{$k});
691             }
692 0         0 return $return;
693             }
694              
695 0         0 carp "Unhandled data structure in $ref, cannot _deepcopy()";
696             }
697              
698             # Internal method, gets the next line, taking proper care of line endings.
699             sub _nextline {
700 21     21   96 my ($self, $fh)=@_;
701 21         43 local $_;
702 21 100       60 if (!exists $self->{line_ends}) {
703             # no $self->{line_ends} is a hint set by caller that we are at
704             # the first line (kludge kludge).
705             {
706 4         8 local $/=\1;
  4         21  
707 4         10 my $nextchar;
708 4         7 do {
709 36         128 $nextchar=<$fh>;
710 36 50       71 return undef if (!defined $nextchar);
711 36         129 $_ .= $nextchar;
712             } until (m/((\015|\012|\025|\n)$)/s);
713 4         34 $self->{line_ends}=$1;
714 4 50       25 if ($nextchar eq "\x0d") {
715             # peek at the next char
716 0         0 $nextchar = <$fh>;
717 0 0       0 if ($nextchar eq "\x0a") {
718 0         0 $self->{line_ends} .= "\x0a";
719             } else {
720 0         0 seek $fh, -1, 1;
721             }
722             }
723             }
724              
725             # If there's a UTF BOM (Byte-Order-Mark) in the first
726             # character of the first line then remove it before processing
727             # (http://www.unicode.org/unicode/faq/utf_bom.html#22)
728 4         14 s/^//;
729              
730 4         21 return $_;
731             } else {
732 17         64 local $/=$self->{line_ends};
733 17         119 return scalar <$fh>;
734             }
735             }
736              
737             # Internal method, closes or resets the file handle. To be called
738             # whenever ReadConfig() returns.
739             sub _rollback {
740 4     4   12 my ($self, $fh)=@_;
741             # Only close if this is a filename, if it's
742             # an open handle, then just roll back to the start
743 4 50       14 if( !ref($self->{cf}) ) {
744 4         43 close($fh);
745             } else {
746             # Attempt to rollback to beginning, no problem if this fails (e.g. STDIN)
747 0         0 seek( $fh, 0, 0 );
748             } # end if
749             }
750              
751              
752             sub ReadConfig {
753 4     4 1 13 my $self = shift;
754              
755 4         27 my($lineno, $sect);
756 4         0 my($group, $groupmem);
757 4         0 my($parm, $val);
758 4         0 my @cmts;
759              
760 4         10 @CPANPLUS::YACSmoke::IniFiles::errors = ( );
761              
762             # Initialize (and clear out) storage hashes
763 4         34 $self->{sects} = [];
764 4         29 $self->{parms} = {};
765 4         31 $self->{group} = {};
766 4         14 $self->{v} = {};
767 4         17 $self->{sCMT} = {};
768 4         17 $self->{pCMT} = {};
769 4         29 $self->{EOT} = {};
770 4         14 $self->{mysects} = []; # A pair of hashes to remember which params are loaded
771 4         11 $self->{myparms} = {}; # or set using the API vs. imported - useful for
772             # import shadowing, see below, and WriteConfig(-delta=>1)
773              
774 4 50       20 if( defined $self->{imported} ) {
775             # Run up the import tree to the top, then reload coming
776             # back down, maintaining the imported file names and our
777             # file name.
778             # This is only needed on a re-load though
779 0 0       0 $self->{imported}->ReadConfig() unless ($self->{firstload});
780              
781 0         0 foreach my $field (qw(sects parms group v sCMT pCMT EOT)) {
782 0         0 $self->{$field} = _deepcopy($self->{imported}->{$field});
783             }
784             } # end if
785            
786             return 1 if (
787             (not exists $self->{cf}) or
788             (not defined $self->{cf}) or
789 4 50 33     101 ($self->{cf} eq '')
      33        
790             );
791            
792 4         11 my $nocase = $self->{nocase};
793              
794             # If this is a reload and we want warnings then send one to the STDERR log
795 4 50 33     19 unless( $self->{firstload} || !$self->{reloadwarn} ) {
796 0         0 my ($ss, $mm, $hh, $DD, $MM, $YY) = (localtime(time))[0..5];
797             printf STDERR
798             "PID %d reloading config file %s at %d.%02d.%02d %02d:%02d:%02d\n",
799 0         0 $$, $self->{cf}, $YY+1900, $MM+1, $DD, $hh, $mm, $ss;
800             }
801            
802             # Turn off. Future loads are reloads
803 4         9 $self->{firstload} = 0;
804              
805             # Get a filehandle, allowing almost any type of 'file' parameter
806 4         56 my $fh = $self->_make_filehandle( $self->{cf} );
807 4 50       15 if (!$fh) {
808 0         0 carp "Failed to open $self->{cf}: $!";
809 0         0 return undef;
810             }
811            
812             # Get mod time of file so we can retain it (if not from STDIN)
813             # also check if it's a real file (could have been a filehandle made from a scalar).
814 4 50 33     100 if (ref($fh) ne "IO::Scalar" && -e $fh)
815             {
816 4         54 my @stats = stat $fh;
817 4 50       49 $self->{file_mode} = sprintf("%04o", $stats[2]) if defined $stats[2];
818             }
819            
820            
821             # The first lines of the file must be blank, comments or start with [
822 4         27 my $first = '';
823 4         19 my $allCmt = $self->{allowed_comment_char};
824            
825 4         10 local $_;
826 4         8 delete $self->{line_ends}; # Marks start of parsing for _nextline()
827 4         39 while ( defined($_ = $self->_nextline($fh)) ) {
828 9         75 s/(\015\012?|\012|\025|\n)$//; # remove line ending char(s)
829 9         22 $lineno++;
830 9 50       247 if (/^\s*$/) { # ignore blank lines
    50          
    100          
    50          
831 0         0 next;
832             }
833             elsif (/^\s*[$allCmt]/) { # collect comments
834 0 0 0     0 if ($self->{negativedeltas} &&
835             m/^$self->{comment_char} (.*) is deleted$/) {
836 0         0 my $todelete=$1;
837 0 0       0 if ($todelete =~ m/^\[(.*)\]$/) {
838 0         0 $self->DeleteSection($1);
839             } else {
840 0         0 $self->delval($sect, $todelete);
841             }
842             } else {
843 0         0 CORE::push(@cmts, $_);
844             }
845 0         0 next;
846             }
847             elsif (/^\s*\[\s*(\S|\S.*\S)\s*\]\s*$/) { # New Section
848 4         18 $sect = $1;
849 4 50       15 if ($self->{nocase}) {
850 0         0 $sect = lc($sect);
851             }
852 4         29 $self->AddSection($sect);
853 4         48 $self->SetSectionComment($sect, @cmts);
854 4         17 @cmts = ();
855             }
856             elsif (($parm, $val) = /^\s*([^=]*?[^=\s])\s*=\s*(.*)$/) { # new parameter
857 5 50 33     22 if ((!defined($sect)) and defined($self->{fallback}))
858             {
859 0         0 $sect = $self->{fallback};
860 0         0 $self->{fallback_used}++;
861             }
862 5 50       21 if (!defined $sect) {
863 0         0 CORE::push(@CPANPLUS::YACSmoke::IniFiles::errors, sprintf('%d: %s', $lineno,
864             qq#parameter found outside a section#));
865 0         0 $self->_rollback($fh);
866 0         0 return undef;
867             }
868              
869 5 50       13 $parm = lc($parm) if $nocase;
870 5         14 my @val = ( );
871 5         15 my $eotmark;
872 5 100       34 if ($val =~ /^<<(.*)$/) { # "here" value
873 4         15 $eotmark = $1;
874 4         9 my $foundeot = 0;
875 4         6 my $startline = $lineno;
876 4         16 while ( defined($_=$self->_nextline($fh)) ) {
877 8         40 s/(\015\012?|\012|\025|\n)$//; # remove line ending char(s)
878 8         12 $lineno++;
879 8 100       19 if ($_ eq $eotmark) {
880 4         7 $foundeot = 1;
881 4         10 last;
882             } else {
883             # Untaint
884 4         23 /(.*)/ms;
885 4         15 CORE::push(@val, $1);
886             }
887             }
888 4 50       11 if (! $foundeot) {
889 0         0 CORE::push(@CPANPLUS::YACSmoke::IniFiles::errors, sprintf('%d: %s', $startline,
890             qq#no end marker ("$eotmark") found#));
891 0         0 $self->_rollback();
892 0         0 return undef;
893             }
894             } else { # no here value
895              
896             # process continuation lines, if any
897 1   33     6 while($self->{allowcontinue} && $val =~ s/\\$//) {
898 0         0 $_ = $self->_nextline($fh);
899 0         0 s/(\015\012?|\012|\025|\n)$//; # remove line ending char(s)
900 0         0 $lineno++;
901 0         0 $val .= $_;
902             }
903 1         4 @val = $val;
904             }
905             # Now load value
906 5 50 33     24 if (exists $self->{v}{$sect}{$parm} &&
      0        
907             exists $self->{myparms}{$sect} &&
908 0         0 grep( /^\Q$parm\E$/, @{$self->{myparms}{$sect}}) ) {
909 0         0 $self->push($sect, $parm, @val);
910             } else {
911             # Loaded parameters shadow imported ones, instead of appending
912             # to them
913 5         19 $self->newval($sect, $parm, @val);
914             }
915 5         31 $self->SetParameterComment($sect, $parm, @cmts);
916 5         11 @cmts = ( );
917 5 100       35 $self->SetParameterEOT($sect,$parm,$eotmark) if (defined $eotmark);
918              
919             } else {
920 0         0 CORE::push(@CPANPLUS::YACSmoke::IniFiles::errors, sprintf("Line \%d in file " . $self->{cf} . " is mal-formed:\n\t\%s", $lineno, $_));
921             }
922             } # End main parsing loop
923              
924             # Special case: return undef if file is empty. (suppress this line to
925             # restore the more intuitive behaviour of accepting empty files)
926 4 0 33     13 if (! keys %{$self->{v}} && ! $self->{allowempty}) {
  4         27  
927 0         0 CORE::push @CPANPLUS::YACSmoke::IniFiles::errors, "Empty file treated as error";
928 0         0 $self->_rollback($fh);
929 0         0 return undef;
930             }
931              
932 4 50       18 if( defined (my $defaultsect=$self->{startup_settings}->{-default}) ) {
933 0         0 $self->AddSection($defaultsect);
934             } # end if
935              
936 4         19 $self->_SetEndComments(@cmts);
937              
938 4         20 $self->_rollback($fh);
939 4 50       34 @CPANPLUS::YACSmoke::IniFiles::errors ? undef : 1;
940             }
941              
942              
943             =head2 Sections
944              
945             Returns an array containing section names in the configuration file.
946             If the I option was turned on when the config object was
947             created, the section names will be returned in lowercase.
948              
949             =cut
950              
951             sub Sections {
952 0     0 1 0 my $self = shift;
953 0 0       0 return @{$self->{sects}} if ref $self->{sects} eq 'ARRAY';
  0         0  
954 0         0 return ();
955             }
956              
957             =head2 SectionExists ( $sect_name )
958              
959             Returns 1 if the specified section exists in the INI file, 0 otherwise (undefined if section_name is not defined).
960              
961             =cut
962              
963             sub SectionExists {
964 9     9 1 19 my $self = shift;
965 9         14 my $sect = shift;
966            
967 9 50       37 return undef if not defined $sect;
968            
969 9 50       34 if ($self->{nocase}) {
970 0         0 $sect = lc($sect);
971             }
972            
973 9 50       30 return undef() if not defined $sect;
974 9 100       13 return 1 if (grep {/^\Q$sect\E$/} @{$self->{sects}});
  5         78  
  9         31  
975 4         20 return 0;
976             }
977              
978             =head2 AddSection ( $sect_name )
979              
980             Ensures that the named section exists in the INI file. If the section already
981             exists, nothing is done. In this case, the "new" section will possibly contain
982             data already.
983              
984             If you really need to have a new section with no parameters in it, check that
985             the name that you're adding isn't in the list of sections already.
986              
987             =cut
988              
989             sub AddSection {
990 9     9 1 14 my $self = shift;
991 9         16 my $sect = shift;
992            
993 9 50       21 return undef if not defined $sect;
994            
995 9 50       23 if ($self->{nocase}) {
996 0         0 $sect = lc($sect);
997             }
998            
999 9 100       29 return if $self->SectionExists($sect);
1000 4         26 CORE::push @{$self->{sects}}, $sect unless
1001 4 50       14 grep /^\Q$sect\E$/, @{$self->{sects}};
  4         15  
1002 4         35 $self->_touch_section($sect);
1003              
1004 4         22 $self->SetGroupMember($sect);
1005            
1006             # Set up the parameter names and values lists
1007 4 50       23 $self->{parms}{$sect} = [] unless ref $self->{parms}{$sect} eq 'ARRAY';
1008 4 50       18 if (!defined($self->{v}{$sect})) {
1009 4         11 $self->{sCMT}{$sect} = [];
1010 4         8 $self->{pCMT}{$sect} = {}; # Comments above parameters
1011 4         11 $self->{parms}{$sect} = [];
1012 4         11 $self->{v}{$sect} = {};
1013             }
1014             }
1015              
1016             # Marks a section as modified by us (this includes deleted by us).
1017             sub _touch_section {
1018 13     13   29 my ($self, $sect)=@_;
1019              
1020 13   50     39 $self->{mysects} ||= [];
1021 4         11 CORE::push @{$self->{mysects}}, $sect unless
1022 13 100       20 grep /^\Q$sect\E$/, @{$self->{mysects}};
  13         107  
1023             }
1024              
1025             # Marks a parameter as modified by us (this includes deleted by us).
1026             sub _touch_parameter {
1027 9     9   34 my ($self, $sect, $parm)=@_;
1028              
1029 9         27 $self->_touch_section($sect);
1030 9 50       28 return if (!exists $self->{v}{$sect});
1031 9   100     59 $self->{myparms}{$sect} ||= [];
1032 5         17 CORE::push @{$self->{myparms}{$sect}}, $parm unless
1033 9 100       15 grep /^\Q$parm\E$/, @{$self->{myparms}{$sect}};
  9         80  
1034             }
1035              
1036              
1037             =head2 DeleteSection ( $sect_name )
1038              
1039             Completely removes the entire section from the configuration.
1040              
1041             =cut
1042              
1043             sub DeleteSection {
1044 0     0 1 0 my $self = shift;
1045 0         0 my $sect = shift;
1046            
1047 0 0       0 return undef if not defined $sect;
1048            
1049 0 0       0 if ($self->{nocase}) {
1050 0         0 $sect = lc($sect);
1051             }
1052              
1053             # This is done the fast way, change if data structure changes!!
1054 0         0 delete $self->{v}{$sect};
1055 0         0 delete $self->{sCMT}{$sect};
1056 0         0 delete $self->{pCMT}{$sect};
1057 0         0 delete $self->{EOT}{$sect};
1058 0         0 delete $self->{parms}{$sect};
1059 0         0 delete $self->{myparms}{$sect};
1060              
1061 0         0 @{$self->{sects}} = grep !/^\Q$sect\E$/, @{$self->{sects}};
  0         0  
  0         0  
1062 0         0 $self->_touch_section($sect);
1063              
1064 0 0       0 if( $sect =~ /^(\S+)\s+\S+/ ) {
1065 0         0 my $group = $1;
1066 0 0       0 if( defined($self->{group}{$group}) ) {
1067 0         0 @{$self->{group}{$group}} = grep !/^\Q$sect\E$/, @{$self->{group}{$group}};
  0         0  
  0         0  
1068             } # end if
1069             } # end if
1070              
1071 0         0 return 1;
1072             } # end DeleteSection
1073              
1074             =head2 Parameters ($sect_name)
1075              
1076             Returns an array containing the parameters contained in the specified
1077             section.
1078              
1079             =cut
1080              
1081             sub Parameters {
1082 0     0 1 0 my $self = shift;
1083 0         0 my $sect = shift;
1084            
1085 0 0       0 return undef if not defined $sect;
1086            
1087 0 0       0 if ($self->{nocase}) {
1088 0         0 $sect = lc($sect);
1089             }
1090            
1091 0 0       0 return @{$self->{parms}{$sect}} if ref $self->{parms}{$sect} eq 'ARRAY';
  0         0  
1092 0         0 return ();
1093             }
1094              
1095             =head2 Groups
1096              
1097             Returns an array containing the names of available groups.
1098            
1099             Groups are specified in the config file as new sections of the form
1100              
1101             [GroupName MemberName]
1102              
1103             This is useful for building up lists. Note that parameters within a
1104             "member" section are referenced normally (i.e., the section name is
1105             still "Groupname Membername", including the space) - the concept of
1106             Groups is to aid people building more complex configuration files.
1107              
1108             =cut
1109              
1110             sub Groups {
1111 0     0 1 0 my $self = shift;
1112 0 0       0 return keys %{$self->{group}} if ref $self->{group} eq 'HASH';
  0         0  
1113 0         0 return ();
1114             }
1115              
1116             =head2 SetGroupMember ( $sect )
1117              
1118             Makes sure that the specified section is a member of the appropriate group.
1119              
1120             Only intended for use in newval.
1121              
1122             =cut
1123              
1124             sub SetGroupMember {
1125 4     4 1 8 my $self = shift;
1126 4         7 my $sect = shift;
1127            
1128 4 50       11 return undef if not defined $sect;
1129            
1130 4 50       61 return(1) unless $sect =~ /^(\S+)\s+\S+/;
1131            
1132 0         0 my $group = $1;
1133 0 0       0 if (not exists($self->{group}{$group})) {
1134 0         0 $self->{group}{$group} = [];
1135             }
1136 0 0       0 if (not grep {/^\Q$sect\E$/} @{$self->{group}{$group}}) {
  0         0  
  0         0  
1137 0         0 CORE::push @{$self->{group}{$group}}, $sect;
  0         0  
1138             }
1139             }
1140              
1141             =head2 RemoveGroupMember ( $sect )
1142              
1143             Makes sure that the specified section is no longer a member of the
1144             appropriate group. Only intended for use in DeleteSection.
1145              
1146             =cut
1147              
1148             sub RemoveGroupMember {
1149 0     0 1 0 my $self = shift;
1150 0         0 my $sect = shift;
1151            
1152 0 0       0 return undef if not defined $sect;
1153            
1154 0 0       0 return(1) unless $sect =~ /^(\S+)\s+\S+/;
1155            
1156 0         0 my $group = $1;
1157 0 0       0 return unless exists $self->{group}{$group};
1158 0         0 @{$self->{group}{$group}} = grep {!/^\Q$sect\E$/} @{$self->{group}{$group}};
  0         0  
  0         0  
  0         0  
1159             }
1160              
1161             =head2 GroupMembers ($group)
1162              
1163             Returns an array containing the members of specified $group. Each element
1164             of the array is a section name. For example, given the sections
1165              
1166             [Group Element 1]
1167             ...
1168              
1169             [Group Element 2]
1170             ...
1171              
1172             GroupMembers would return ("Group Element 1", "Group Element 2").
1173              
1174             =cut
1175              
1176             sub GroupMembers {
1177 0     0 1 0 my $self = shift;
1178 0         0 my $group = shift;
1179            
1180 0 0       0 return undef if not defined $group;
1181            
1182 0 0       0 if ($self->{nocase}) {
1183 0         0 $group = lc($group);
1184             }
1185            
1186 0 0       0 return @{$self->{group}{$group}} if ref $self->{group}{$group} eq 'ARRAY';
  0         0  
1187 0         0 return ();
1188             }
1189              
1190             =head2 SetWriteMode ($mode)
1191              
1192             Sets the mode (permissions) to use when writing the INI file.
1193              
1194             $mode must be a string representation of the octal mode.
1195              
1196             =cut
1197              
1198             sub SetWriteMode
1199             {
1200 0     0 1 0 my $self = shift;
1201 0         0 my $mode = shift;
1202 0 0       0 return undef if not defined ($mode);
1203 0 0       0 return undef if not ($mode =~ m/[0-7]{3,3}/);
1204 0         0 $self->{file_mode} = $mode;
1205 0         0 return $mode;
1206             }
1207              
1208             =head2 GetWriteMode ($mode)
1209              
1210             Gets the current mode (permissions) to use when writing the INI file.
1211              
1212             $mode is a string representation of the octal mode.
1213              
1214             =cut
1215              
1216             sub GetWriteMode
1217             {
1218 0     0 1 0 my $self = shift;
1219 0 0       0 return undef if not exists $self->{file_mode};
1220 0         0 return $self->{file_mode};
1221             }
1222              
1223             =head2 WriteConfig ($filename [, %options])
1224              
1225             Writes out a new copy of the configuration file. A temporary file
1226             (ending in '-new') is written out and then renamed to the specified
1227             filename. Also see B below.
1228              
1229             If C<-delta> is set to a true value in %options, and this object was
1230             imported from another (see L), only the differences between this
1231             object and the imported one will be recorded. Negative deltas will be
1232             encoded into comments, so that a subsequent invocation of I
1233             with the same imported object produces the same results (see the
1234             I<-negativedeltas> option in L).
1235              
1236             C<%options> is not required.
1237              
1238             Returns true on success, C on failure.
1239              
1240             =cut
1241              
1242             sub WriteConfig {
1243 0     0 1 0 my ($self, $file, %parms)=@_;
1244 0 0       0 %parms = () unless %parms;
1245            
1246 0 0       0 return undef unless defined $file;
1247            
1248            
1249             # If we are using a filename, then do mode checks and write to a
1250             # temporary file to avoid a race condition
1251 0 0       0 if( !ref($file) ) {
1252 0 0 0     0 if (-e $file) {
    0          
1253 0 0       0 if (not (-w $file))
1254             {
1255             #carp "File $file is not writable. Refusing to write config";
1256 0         0 return undef;
1257             }
1258 0         0 my $mode = (stat $file)[2];
1259 0         0 $self->{file_mode} = sprintf "%04o", ($mode & 0777);
1260             #carp "Using mode $self->{file_mode} for file $file";
1261             } elsif (defined($self->{file_mode}) and not (oct($self->{file_mode}) & 0222)) {
1262             #carp "Store mode $self->{file_mode} prohibits writing config";
1263             }
1264            
1265 0         0 my $new_file = $file . "-new";
1266 0         0 local(*F);
1267 0 0       0 open(F, "> $new_file") || do {
1268 0         0 carp "Unable to write temp config file $new_file: $!";
1269 0         0 return undef;
1270             };
1271 0         0 my $oldfh = select(F);
1272 0         0 $self->OutputConfig($parms{-delta});
1273 0         0 close(F);
1274 0         0 select($oldfh);
1275 0 0       0 rename( $new_file, $file ) || do {
1276 0         0 carp "Unable to rename temp config file ($new_file) to $file: $!";
1277 0         0 return undef;
1278             };
1279 0 0       0 if (exists $self->{file_mode}) {
1280 0         0 chmod oct($self->{file_mode}), $file;
1281             }
1282            
1283             } # Otherwise, reset to the start of the file and write, unless we are using STDIN
1284             else {
1285             # Get a filehandle, allowing almost any type of 'file' parameter
1286             ## NB: If this were a filename, this would fail because _make_file
1287             ## opens a read-only handle, but we have already checked that case
1288             ## so re-using the logic is ok [JW/WADG]
1289 0         0 my $fh = $self->_make_filehandle( $file );
1290 0 0       0 if (!$fh) {
1291 0         0 carp "Could not find a filehandle for the input stream ($file): $!";
1292 0         0 return undef;
1293             }
1294            
1295            
1296             # Only roll back if it's not STDIN (if it is, Carp)
1297 0 0       0 if( $fh == \*STDIN ) {
1298 0         0 carp "Cannot write configuration file to STDIN.";
1299             } else {
1300 0         0 seek( $fh, 0, 0 );
1301 0         0 my $oldfh = select($fh);
1302 0         0 $self->OutputConfig($parms{-delta});
1303 0         0 seek( $fh, 0, 0 );
1304 0         0 select($oldfh);
1305             } # end if
1306              
1307             } # end if (filehandle/name)
1308            
1309 0         0 return 1;
1310            
1311             }
1312              
1313             =head2 RewriteConfig
1314              
1315             Same as WriteConfig, but specifies that the original configuration
1316             file should be rewritten.
1317              
1318             =cut
1319              
1320             sub RewriteConfig {
1321 0     0 1 0 my $self = shift;
1322            
1323             return undef if (
1324             (not exists $self->{cf}) or
1325             (not defined $self->{cf}) or
1326 0 0 0     0 ($self->{cf} eq '')
      0        
1327             );
1328            
1329             # Return whatever WriteConfig returns :)
1330 0         0 $self->WriteConfig($self->{cf});
1331             }
1332              
1333             =head2 GetFileName
1334              
1335             Returns the filename associated with this INI file.
1336              
1337             If no filename has been specified, returns undef.
1338              
1339             =cut
1340              
1341             sub GetFileName
1342             {
1343 0     0 1 0 my $self = shift;
1344 0         0 my $filename;
1345 0 0       0 if (exists $self->{cf}) {
1346 0         0 $filename = $self->{cf};
1347             } else {
1348 0         0 undef $filename;
1349             }
1350 0         0 return $filename;
1351             }
1352              
1353             =head2 SetFileName ($filename)
1354              
1355             If you created the Config::IniFiles object without initialising from
1356             a file, or if you just want to change the name of the file to use for
1357             ReadConfig/RewriteConfig from now on, use this method.
1358              
1359             Returns $filename if that was a valid name, undef otherwise.
1360              
1361             =cut
1362              
1363             sub SetFileName {
1364 0     0 1 0 my $self = shift;
1365 0         0 my $newfile = shift;
1366            
1367 0 0       0 return undef if not defined $newfile;
1368            
1369 0 0       0 if ($newfile ne "") {
1370 0         0 $self->{cf} = $newfile;
1371 0         0 return $self->{cf};
1372             }
1373 0         0 return undef;
1374             }
1375              
1376             =head2 $ini->OutputConfig($delta)
1377              
1378             Writes OutputConfig to STDOUT. Use select() to redirect STDOUT to
1379             the output target before calling this function. Optional argument
1380             should be set to 1 if writing only delta.
1381              
1382             =cut
1383              
1384             sub _OutputParam {
1385 0     0   0 my ($self, $sect, $parm, $val, $ors, $output_cb) = @_;
1386              
1387 0 0 0     0 if ((@$val <= 1) or $self->{nomultiline}) {
1388 0         0 foreach (@{$val}) {
  0         0  
1389 0         0 $output_cb->("$parm=$_$ors");
1390             }
1391             }
1392             else
1393             {
1394 0   0     0 my $eotmark = $self->{EOT}{$sect}{$parm} || 'EOT';
1395              
1396             # Make sure the $eotmark does not occur inside the string.
1397 0         0 my @letters = ('A' .. 'Z');
1398 0         0 my $joined_val = join(q{ }, @$val);
1399 0         0 while (index($joined_val, $eotmark) >= 0)
1400             {
1401 0         0 $eotmark .= $letters[rand(@letters)];
1402             }
1403              
1404 0         0 $output_cb->("$parm= <<$eotmark$ors");
1405 0         0 foreach (@{$val}) {
  0         0  
1406 0         0 $output_cb->("$_$ors");
1407             }
1408 0         0 $output_cb->("$eotmark$ors");
1409             }
1410              
1411 0         0 return;
1412             }
1413              
1414             sub OutputConfig {
1415 0     0 1 0 my ($self, $delta) = @_;
1416              
1417 0         0 my($sect, $parm, @cmts);
1418 0   0     0 my $ors = $self->{line_ends} || $\ || "\n"; # $\ is normally unset, but use input by default
1419 0         0 my $notfirst = 0;
1420 0         0 local $_;
1421             SECT:
1422 0 0       0 foreach $sect (@{$self->{$delta ? "mysects" : "sects"}}) {
  0         0  
1423 0 0       0 if (!defined $self->{v}{$sect}) {
1424 0 0       0 if ($delta) {
1425 0         0 print "$self->{comment_char} [$sect] is deleted$ors";
1426             } else {
1427 0 0       0 warn "Weird unknown section $sect" if $^W;
1428             }
1429 0         0 next SECT;
1430             }
1431 0 0       0 next unless defined $self->{v}{$sect};
1432 0 0       0 print $ors if $notfirst;
1433 0         0 $notfirst = 1;
1434 0 0 0     0 if ((ref($self->{sCMT}{$sect}) eq 'ARRAY') &&
1435 0         0 (@cmts = @{$self->{sCMT}{$sect}})) {
1436 0         0 foreach (@cmts) {
1437 0         0 print "$_$ors";
1438             }
1439             }
1440              
1441 0 0 0     0 if (!
1442             ($self->{fallback_used} and $sect eq $self->{fallback})
1443             )
1444             {
1445 0         0 print "[$sect]$ors";
1446             }
1447 0 0       0 next unless ref $self->{v}{$sect} eq 'HASH';
1448              
1449             PARM:
1450 0 0       0 foreach $parm (@{$self->{$delta ? "myparms" : "parms"}{$sect}}) {
  0         0  
1451 0 0       0 if (!defined $self->{v}{$sect}{$parm}) {
1452 0 0       0 if ($delta) {
1453 0         0 print "$self->{comment_char} $parm is deleted$ors";
1454             } else {
1455 0 0       0 warn "Weird unknown parameter $parm" if $^W;
1456             }
1457 0         0 next PARM;
1458             }
1459 0 0 0     0 if ((ref($self->{pCMT}{$sect}{$parm}) eq 'ARRAY') &&
1460 0         0 (@cmts = @{$self->{pCMT}{$sect}{$parm}})) {
1461 0         0 foreach (@cmts) {
1462 0         0 print "$_$ors";
1463             }
1464             }
1465              
1466 0         0 my $val = $self->{v}{$sect}{$parm};
1467 0 0       0 next if ! defined ($val); # No parameter exists !!
1468              
1469             $self->_OutputParam(
1470             $sect,
1471             $parm,
1472             ((ref($val) eq 'ARRAY')
1473             ? $val
1474             : [split /[$ors]/, $val, -1]
1475             ),
1476             $ors,
1477 0     0   0 sub { print @_; },
1478 0 0       0 );
1479             }
1480             }
1481 0         0 foreach my $comment ($self->_GetEndComments()) {
1482 0         0 print "$comment$ors";
1483             }
1484 0         0 return 1;
1485             }
1486              
1487             =head2 SetSectionComment($section, @comment)
1488              
1489             Sets the comment for section $section to the lines contained in @comment.
1490              
1491             Each comment line will be prepended with the comment charcter (default
1492             is C<#>) if it doesn't already have a comment character (ie: if the
1493             line does not start with whitespace followed by an allowed comment
1494             character, default is C<#> and C<;>).
1495              
1496             To clear a section comment, use DeleteSectionComment ($section)
1497              
1498             =cut
1499              
1500             sub SetSectionComment
1501             {
1502 4     4 1 23 my $self = shift;
1503 4         10 my $sect = shift;
1504 4         10 my @comment = @_;
1505              
1506 4 50       15 return undef if not defined $sect;
1507 4 50       12 return undef unless @comment;
1508            
1509 0 0       0 if ($self->{nocase}) {
1510 0         0 $sect = lc($sect);
1511             }
1512            
1513 0         0 $self->_touch_section($sect);
1514 0         0 $self->{sCMT}{$sect} = [];
1515             # At this point it's possible to have a comment for a section that
1516             # doesn't exist. This comment will not get written to the INI file.
1517            
1518 0         0 CORE::push @{$self->{sCMT}{$sect}}, $self->_markup_comments(@comment);
  0         0  
1519 0         0 return scalar @comment;
1520             }
1521              
1522              
1523              
1524             # this helper makes sure that each line is preceded with the correct comment
1525             # character
1526             sub _markup_comments
1527             {
1528 0     0   0 my $self = shift;
1529 0         0 my @comment = @_;
1530              
1531 0         0 my $allCmt = $self->{allowed_comment_char};
1532 0         0 my $cmtChr = $self->{comment_char};
1533 0         0 foreach (@comment) {
1534 0 0       0 m/^\s*[$allCmt]/ or ($_ = "$cmtChr $_");
1535             }
1536 0         0 @comment;
1537             }
1538              
1539              
1540              
1541             =head2 GetSectionComment ($section)
1542              
1543             Returns a list of lines, being the comment attached to section $section. In
1544             scalar context, returns a string containing the lines of the comment separated
1545             by newlines.
1546              
1547             The lines are presented as-is, with whatever comment character was originally
1548             used on that line.
1549              
1550             =cut
1551              
1552             sub GetSectionComment
1553             {
1554 0     0 1 0 my $self = shift;
1555 0         0 my $sect = shift;
1556              
1557 0 0       0 return undef if not defined $sect;
1558            
1559 0 0       0 if ($self->{nocase}) {
1560 0         0 $sect = lc($sect);
1561             }
1562            
1563 0 0       0 if (exists $self->{sCMT}{$sect}) {
1564 0         0 my @ret = @{$self->{sCMT}{$sect}};
  0         0  
1565 0 0       0 if (wantarray()) {
1566 0         0 return @ret;
1567             }
1568             else {
1569 0 0       0 if (defined ($/)) {
1570 0         0 return join "$/", @ret;
1571             } else {
1572 0         0 return join "\n", @ret;
1573             }
1574             }
1575             } else {
1576 0         0 return undef;
1577             }
1578             }
1579              
1580             =head2 DeleteSectionComment ($section)
1581              
1582             Removes the comment for the specified section.
1583              
1584             =cut
1585              
1586             sub DeleteSectionComment
1587             {
1588 0     0 1 0 my $self = shift;
1589 0         0 my $sect = shift;
1590            
1591 0 0       0 return undef if not defined $sect;
1592            
1593 0 0       0 if ($self->{nocase}) {
1594 0         0 $sect = lc($sect);
1595             }
1596 0         0 $self->_touch_section($sect);
1597              
1598 0         0 delete $self->{sCMT}{$sect};
1599             }
1600              
1601             =head2 SetParameterComment ($section, $parameter, @comment)
1602              
1603             Sets the comment attached to a particular parameter.
1604              
1605             Any line of @comment that does not have a comment character will be
1606             prepended with one. See L above
1607              
1608             =cut
1609              
1610             sub SetParameterComment
1611             {
1612 5     5 1 11 my $self = shift;
1613 5         8 my $sect = shift;
1614 5         9 my $parm = shift;
1615 5         11 my @comment = @_;
1616              
1617 5 50       34 defined($sect) || return undef;
1618 5 50       24 defined($parm) || return undef;
1619 5 50       24 @comment || return undef;
1620            
1621 0 0       0 if ($self->{nocase}) {
1622 0         0 $sect = lc($sect);
1623 0         0 $parm = lc($parm);
1624             }
1625            
1626 0         0 $self->_touch_parameter($sect, $parm);
1627 0 0       0 if (not exists $self->{pCMT}{$sect}) {
1628 0         0 $self->{pCMT}{$sect} = {};
1629             }
1630            
1631 0         0 $self->{pCMT}{$sect}{$parm} = [];
1632             # Note that at this point, it's possible to have a comment for a parameter,
1633             # without that parameter actually existing in the INI file.
1634 0         0 CORE::push @{$self->{pCMT}{$sect}{$parm}}, $self->_markup_comments(@comment);
  0         0  
1635 0         0 return scalar @comment;
1636             }
1637              
1638             sub _SetEndComments
1639             {
1640 4     4   8 my $self = shift;
1641 4         9 my @comments = @_;
1642              
1643 4         11 $self->{_comments_at_end_of_file} = \@comments;
1644              
1645 4         28 return 1;
1646             }
1647              
1648             sub _GetEndComments {
1649 0     0   0 my $self = shift;
1650              
1651 0         0 return @{$self->{_comments_at_end_of_file}};
  0         0  
1652             }
1653              
1654             =head2 GetParameterComment ($section, $parameter)
1655              
1656             Gets the comment attached to a parameter. In list context returns all
1657             comments - in scalar context returns them joined by newlines.
1658              
1659             =cut
1660              
1661             sub GetParameterComment
1662             {
1663 0     0 1 0 my $self = shift;
1664 0         0 my $sect = shift;
1665 0         0 my $parm = shift;
1666            
1667 0 0       0 defined($sect) || return undef;
1668 0 0       0 defined($parm) || return undef;
1669            
1670 0 0       0 if ($self->{nocase}) {
1671 0         0 $sect = lc($sect);
1672 0         0 $parm = lc($parm);
1673             };
1674            
1675 0 0       0 exists($self->{pCMT}{$sect}) || return undef;
1676 0 0       0 exists($self->{pCMT}{$sect}{$parm}) || return undef;
1677            
1678 0         0 my @comment = @{$self->{pCMT}{$sect}{$parm}};
  0         0  
1679 0 0       0 return wantarray() ? @comment : join((defined $/ ? $/ : "\n"), @comment);
    0          
1680             }
1681              
1682             =head2 DeleteParameterComment ($section, $parmeter)
1683              
1684             Deletes the comment attached to a parameter.
1685              
1686             =cut
1687              
1688             sub DeleteParameterComment
1689             {
1690 0     0 1 0 my $self = shift;
1691 0         0 my $sect = shift;
1692 0         0 my $parm = shift;
1693            
1694 0 0       0 defined($sect) || return undef;
1695 0 0       0 defined($parm) || return undef;
1696            
1697 0 0       0 if ($self->{nocase}) {
1698 0         0 $sect = lc($sect);
1699 0         0 $parm = lc($parm);
1700             };
1701            
1702             # If the parameter doesn't exist, our goal has already been achieved
1703 0 0       0 exists($self->{pCMT}{$sect}) || return 1;
1704 0 0       0 exists($self->{pCMT}{$sect}{$parm}) || return 1;
1705              
1706 0         0 $self->_touch_parameter($sect, $parm);
1707 0         0 delete $self->{pCMT}{$sect}{$parm};
1708 0         0 return 1;
1709             }
1710              
1711             =head2 GetParameterEOT ($section, $parameter)
1712              
1713             Accessor method for the EOT text (in fact, style) of the specified parameter. If any text is used as an EOT mark, this will be returned. If the parameter was not recorded using HERE style multiple lines, GetParameterEOT returns undef.
1714              
1715             =cut
1716              
1717             sub GetParameterEOT
1718             {
1719 0     0 1 0 my $self = shift;
1720 0         0 my $sect = shift;
1721 0         0 my $parm = shift;
1722              
1723 0 0       0 defined($sect) || return undef;
1724 0 0       0 defined($parm) || return undef;
1725            
1726 0 0       0 if ($self->{nocase}) {
1727 0         0 $sect = lc($sect);
1728 0         0 $parm = lc($parm);
1729             };
1730              
1731 0 0       0 if (not exists $self->{EOT}{$sect}) {
1732 0         0 $self->{EOT}{$sect} = {};
1733             }
1734              
1735 0 0       0 if (not exists $self->{EOT}{$sect}{$parm}) {
1736 0         0 return undef;
1737             }
1738 0         0 return $self->{EOT}{$sect}{$parm};
1739             }
1740              
1741             =head2 $cfg->SetParameterEOT ($section, $parameter, $EOT)
1742              
1743             Accessor method for the EOT text for the specified parameter. Sets the HERE style marker text to the value $EOT. Once the EOT text is set, that parameter will be saved in HERE style.
1744              
1745             To un-set the EOT text, use DeleteParameterEOT ($section, $parameter).
1746              
1747             =cut
1748              
1749             sub SetParameterEOT
1750             {
1751 4     4 1 9 my $self = shift;
1752 4         7 my $sect = shift;
1753 4         7 my $parm = shift;
1754 4         9 my $EOT = shift;
1755              
1756 4 50       9 defined($sect) || return undef;
1757 4 50       10 defined($parm) || return undef;
1758 4 50       10 defined($EOT) || return undef;
1759            
1760 4 50       13 if ($self->{nocase}) {
1761 0         0 $sect = lc($sect);
1762 0         0 $parm = lc($parm);
1763             };
1764              
1765 4         13 $self->_touch_parameter($sect, $parm);
1766 4 100       13 if (not exists $self->{EOT}{$sect}) {
1767 3         15 $self->{EOT}{$sect} = {};
1768             }
1769              
1770 4         19 $self->{EOT}{$sect}{$parm} = $EOT;
1771             }
1772              
1773             =head2 DeleteParameterEOT ($section, $parmeter)
1774              
1775             Removes the EOT marker for the given section and parameter.
1776             When writing a configuration file, if no EOT marker is defined
1777             then "EOT" is used.
1778              
1779             =cut
1780              
1781             sub DeleteParameterEOT
1782             {
1783 0     0 1 0 my $self = shift;
1784 0         0 my $sect = shift;
1785 0         0 my $parm = shift;
1786            
1787 0 0       0 defined($sect) || return undef;
1788 0 0       0 defined($parm) || return undef;
1789            
1790 0 0       0 if ($self->{nocase}) {
1791 0         0 $sect = lc($sect);
1792 0         0 $parm = lc($parm);
1793             }
1794              
1795 0         0 $self->_touch_parameter($sect, $parm);
1796 0         0 delete $self->{EOT}{$sect}{$parm};
1797             }
1798              
1799              
1800             =head2 Delete
1801              
1802             Deletes the entire configuration file in memory.
1803              
1804             =cut
1805              
1806             sub Delete {
1807 0     0 1 0 my $self = shift;
1808              
1809 0         0 foreach my $section ($self->Sections()) {
1810 0         0 $self->DeleteSection($section);
1811             }
1812              
1813 0         0 return 1;
1814             } # end Delete
1815              
1816              
1817              
1818             =head1 USAGE -- Tied Hash
1819              
1820             =head2 tie %ini, 'Config::IniFiles', (-file=>$filename, [-option=>value ...] )
1821              
1822             Using C, you can tie a hash to a B object. This creates a new
1823             object which you can access through your hash, so you use this instead of the
1824             B method. This actually creates a hash of hashes to access the values in
1825             the INI file. The options you provide through C are the same as given for
1826             the B method, above.
1827              
1828             Here's an example:
1829              
1830             use Config::IniFiles;
1831            
1832             my %ini
1833             tie %ini, 'Config::IniFiles', ( -file => "/path/configfile.ini" );
1834              
1835             print "We have $ini{Section}{Parameter}." if $ini{Section}{Parameter};
1836              
1837             Accessing and using the hash works just like accessing a regular hash and
1838             many of the object methods are made available through the hash interface.
1839              
1840             For those methods that do not coincide with the hash paradigm, you can use
1841             the Perl C function to get at the underlying object tied to the hash
1842             and call methods on that object. For example, to write the hash out to a new
1843             ini file, you would do something like this:
1844              
1845             tied( %ini )->WriteConfig( "/newpath/newconfig.ini" ) ||
1846             die "Could not write settings to new file.";
1847              
1848             =head2 $val = $ini{$section}{$parameter}
1849              
1850             Returns the value of $parameter in $section.
1851              
1852             Multiline values accessed through a hash will be returned
1853             as a list in list context and a concatenated value in scalar
1854             context.
1855              
1856             =head2 $ini{$section}{$parameter} = $value;
1857              
1858             Sets the value of C<$parameter> in C<$section> to C<$value>.
1859              
1860             To set a multiline or multiv-alue parameter just assign an
1861             array reference to the hash entry, like this:
1862              
1863             $ini{$section}{$parameter} = [$value1, $value2, ...];
1864              
1865             If the parameter did not exist in the original file, it will
1866             be created. However, Perl does not seem to extend autovivification
1867             to tied hashes. That means that if you try to say
1868              
1869             $ini{new_section}{new_paramters} = $val;
1870              
1871             and the section 'new_section' does not exist, then Perl won't
1872             properly create it. In order to work around this you will need
1873             to create a hash reference in that section and then assign the
1874             parameter value. Something like this should do nicely:
1875              
1876             $ini{new_section} = {};
1877             $ini{new_section}{new_paramters} = $val;
1878              
1879             =head2 %hash = %{$ini{$section}}
1880              
1881             Using the tie interface, you can copy whole sections of the
1882             ini file into another hash. Note that this makes a copy of
1883             the entire section. The new hash in no longer tied to the
1884             ini file, In particular, this means -default and -nocase
1885             settings will not apply to C<%hash>.
1886              
1887              
1888             =head2 $ini{$section} = {}; %{$ini{$section}} = %parameters;
1889              
1890             Through the hash interface, you have the ability to replace
1891             the entire section with a new set of parameters. This call
1892             will fail, however, if the argument passed in NOT a hash
1893             reference. You must use both lines, as shown above so that
1894             Perl recognizes the section as a hash reference context
1895             before COPYing over the values from your C<%parameters> hash.
1896              
1897             =head2 delete $ini{$section}{$parameter}
1898              
1899             When tied to a hash, you can use the Perl C function
1900             to completely remove a parameter from a section.
1901              
1902             =head2 delete $ini{$section}
1903              
1904             The tied interface also allows you to delete an entire
1905             section from the ini file using the Perl C function.
1906              
1907             =head2 %ini = ();
1908              
1909             If you really want to delete B the items in the ini file, this
1910             will do it. Of course, the changes won't be written to the actual
1911             file unless you call B on the object tied to the hash.
1912              
1913             =head2 Parameter names
1914              
1915             =over 4
1916              
1917             =item my @keys = keys %{$ini{$section}}
1918              
1919             =item while (($k, $v) = each %{$ini{$section}}) {...}
1920              
1921             =item if( exists %{$ini{$section}}, $parameter ) {...}
1922              
1923             =back
1924              
1925             When tied to a hash, you use the Perl C and C
1926             functions to iteratively list the parameters (C) or
1927             parameters and their values (C) in a given section.
1928              
1929             You can also use the Perl C function to see if a
1930             parameter is defined in a given section.
1931              
1932             Note that none of these will return parameter names that
1933             are part of the default section (if set), although accessing
1934             an unknown parameter in the specified section will return a
1935             value from the default section if there is one.
1936              
1937              
1938             =head2 Section names
1939              
1940             =over 4
1941              
1942             =item foreach( keys %ini ) {...}
1943              
1944             =item while (($k, $v) = each %ini) {...}
1945              
1946             =item if( exists %ini, $section ) {...}
1947              
1948             =back
1949              
1950             When tied to a hash, you use the Perl C and C
1951             functions to iteratively list the sections in the ini file.
1952              
1953             You can also use the Perl C function to see if a
1954             section is defined in the file.
1955              
1956             =cut
1957              
1958             ############################################################
1959             #
1960             # TIEHASH Methods
1961             #
1962             # Description:
1963             # These methods allow you to tie a hash to the
1964             # Config::IniFiles object. Note that, when tied, the
1965             # user wants to look at thinks like $ini{sec}{parm}, but the
1966             # TIEHASH only provides one level of hash interace, so the
1967             # root object gets asked for a $ini{sec}, which this
1968             # implements. To further tie the {parm} hash, the internal
1969             # class Config::IniFiles::_section, is provided, below.
1970             #
1971             ############################################################
1972             # ----------------------------------------------------------
1973             # Date Modification Author
1974             # ----------------------------------------------------------
1975             # 2000May09 Created method JW
1976             # ----------------------------------------------------------
1977             sub TIEHASH {
1978 0     0   0 my $class = shift;
1979 0         0 my %parms = @_;
1980              
1981             # Get a new object
1982 0         0 my $self = $class->new( %parms );
1983              
1984 0         0 return $self;
1985             } # end TIEHASH
1986              
1987              
1988             # ----------------------------------------------------------
1989             # Date Modification Author
1990             # ----------------------------------------------------------
1991             # 2000May09 Created method JW
1992             # ----------------------------------------------------------
1993             sub FETCH {
1994 0     0   0 my $self = shift;
1995 0         0 my( $key ) = @_;
1996              
1997 0 0       0 $key = lc($key) if( $self->{nocase} );
1998 0 0       0 return if (! $self->{v}{$key});
1999              
2000 0         0 my %retval;
2001 0         0 tie %retval, 'CPANPLUS::YACSmoke::IniFiles::_section', $self, $key;
2002 0         0 return \%retval;
2003              
2004             } # end FETCH
2005              
2006             # ----------------------------------------------------------
2007             # Date Modification Author
2008             # ----------------------------------------------------------
2009             # 2000Jun14 Fixed bug where wrong ref was saved JW
2010             # 2000Oct09 Fixed possible but in %parms with defaults JW
2011             # 2001Apr04 Fixed -nocase problem in storing JW
2012             # ----------------------------------------------------------
2013             sub STORE {
2014 0     0   0 my $self = shift;
2015 0         0 my( $key, $ref ) = @_;
2016              
2017 0 0       0 return undef unless ref($ref) eq 'HASH';
2018              
2019 0 0       0 $key = lc($key) if( $self->{nocase} );
2020              
2021 0         0 $self->AddSection($key);
2022 0         0 $self->{v}{$key} = {%$ref};
2023 0         0 $self->{parms}{$key} = [keys %$ref];
2024 0         0 $self->{myparms}{$key} = [keys %$ref];
2025 0         0 1;
2026             } # end STORE
2027              
2028              
2029             # ----------------------------------------------------------
2030             # Date Modification Author
2031             # ----------------------------------------------------------
2032             # 2000May09 Created method JW
2033             # 2000Dec17 Now removes comments, groups and EOTs too JW
2034             # 2001Arp04 Fixed -nocase problem JW
2035             # ----------------------------------------------------------
2036             sub DELETE {
2037 0     0   0 my $self = shift;
2038 0         0 my( $key ) = @_;
2039              
2040 0         0 my $retval=$self->FETCH($key);
2041 0         0 $self->DeleteSection($key);
2042 0         0 return $retval;
2043             } # end DELETE
2044              
2045              
2046             # ----------------------------------------------------------
2047             # Date Modification Author
2048             # ----------------------------------------------------------
2049             # 2000May09 Created method JW
2050             # ----------------------------------------------------------
2051             sub CLEAR {
2052 0     0   0 my $self = shift;
2053              
2054 0         0 return $self->Delete();
2055             } # end CLEAR
2056              
2057             # ----------------------------------------------------------
2058             # Date Modification Author
2059             # ----------------------------------------------------------
2060             # 2000May09 Created method JW
2061             # ----------------------------------------------------------
2062             sub FIRSTKEY {
2063 0     0   0 my $self = shift;
2064              
2065 0         0 $self->{tied_enumerator}=0;
2066 0         0 return $self->NEXTKEY();
2067             } # end FIRSTKEY
2068              
2069              
2070             # ----------------------------------------------------------
2071             # Date Modification Author
2072             # ----------------------------------------------------------
2073             # 2000May09 Created method JW
2074             # ----------------------------------------------------------
2075             sub NEXTKEY {
2076 0     0   0 my $self = shift;
2077 0         0 my( $last ) = @_;
2078              
2079 0         0 my $i=$self->{tied_enumerator}++;
2080 0         0 my $key=$self->{sects}[$i];
2081 0 0       0 return if (! defined $key);
2082 0 0       0 return wantarray ? ($key, $self->FETCH($key)) : $key;
2083             } # end NEXTKEY
2084              
2085              
2086             # ----------------------------------------------------------
2087             # Date Modification Author
2088             # ----------------------------------------------------------
2089             # 2000May09 Created method JW
2090             # 2001Apr04 Fixed -nocase bug and false true bug JW
2091             # ----------------------------------------------------------
2092             sub EXISTS {
2093 0     0   0 my $self = shift;
2094 0         0 my( $key ) = @_;
2095 0         0 return $self->SectionExists($key);
2096             } # end EXISTS
2097              
2098              
2099             # ----------------------------------------------------------
2100             # DESTROY is used by TIEHASH and the Perl garbage collector,
2101             # ----------------------------------------------------------
2102             # Date Modification Author
2103             # ----------------------------------------------------------
2104             # 2000May09 Created method JW
2105             # ----------------------------------------------------------
2106       0     sub DESTROY {
2107             # my $self = shift;
2108             } # end if
2109              
2110              
2111             # ----------------------------------------------------------
2112             # Sub: _make_filehandle
2113             #
2114             # Args: $thing
2115             # $thing An input source
2116             #
2117             # Description: Takes an input source of a filehandle,
2118             # filehandle glob, reference to a filehandle glob, IO::File
2119             # object or scalar filename and returns a file handle to
2120             # read from it with.
2121             # ----------------------------------------------------------
2122             # Date Modification Author
2123             # ----------------------------------------------------------
2124             # 06Dec2001 Added to support input from any source JW
2125             # ----------------------------------------------------------
2126             sub _make_filehandle {
2127 4     4   12 my $self = shift;
2128              
2129             #
2130             # This code is 'borrowed' from Lincoln D. Stein's GD.pm module
2131             # with modification for this module. Thanks Lincoln!
2132             #
2133            
2134 10     10   104 no strict 'refs';
  10         23  
  10         2407  
2135 4         7 my $thing = shift;
2136              
2137 4 50       21 if (ref($thing) eq "SCALAR") {
2138 0 0       0 if (eval { require IO::Scalar; $IO::Scalar::VERSION >= 2.109; }) {
  0         0  
  0         0  
2139 0         0 return IO::Scalar->new($thing);
2140             } else {
2141 0 0       0 warn "SCALAR reference as file descriptor requires IO::stringy ".
2142             "v2.109 or later" if ($^W);
2143 0         0 return;
2144             }
2145             }
2146              
2147 4 50       58 return $thing if defined(fileno $thing);
2148             # return $thing if defined($thing) && ref($thing) && defined(fileno $thing);
2149            
2150             # otherwise try qualifying it into caller's package
2151 4         40 my $fh = qualify_to_ref($thing,caller(1));
2152 4 50       211 return $fh if defined(fileno $fh);
2153             # return $fh if defined($thing) && ref($thing) && defined(fileno $fh);
2154            
2155             # otherwise treat it as a file to open
2156 4         15 $fh = gensym;
2157 4 50       224 open($fh,$thing) || return;
2158            
2159 4         23 return $fh;
2160             } # end _make_filehandle
2161              
2162             ############################################################
2163             #
2164             # INTERNAL PACKAGE: Config::IniFiles::_section
2165             #
2166             # Description:
2167             # This package is used to provide a single-level TIEHASH
2168             # interface to the sections in the IniFile. When tied, the
2169             # user wants to look at thinks like $ini{sec}{parm}, but the
2170             # TIEHASH only provides one level of hash interace, so the
2171             # root object gets asked for a $ini{sec} and must return a
2172             # has reference that accurately covers the '{parm}' part.
2173             #
2174             # This package is only used when tied and is inter-woven
2175             # between the sections and their parameters when the TIEHASH
2176             # method is called by Perl. It's a very simple implementation
2177             # of a tied hash object that simply maps onto the object API.
2178             #
2179             ############################################################
2180             # Date Modification Author
2181             # ----------------------------------------------------------
2182             # 2000.May.09 Created to excapsulate TIEHASH interface JW
2183             ############################################################
2184             package Config::IniFiles::_section;
2185             $Config::IniFiles::_section::VERSION = '1.04';
2186 10     10   77 use strict;
  10         28  
  10         262  
2187 10     10   69 use Carp;
  10         39  
  10         5226  
2188              
2189             # ----------------------------------------------------------
2190             # Sub: Config::IniFiles::_section::TIEHASH
2191             #
2192             # Args: $class, $config, $section
2193             # $class The class that this is being tied to.
2194             # $config The parent Config::IniFiles object
2195             # $section The section this tied object refers to
2196             #
2197             # Description: Builds the object that implements accesses to
2198             # the tied hash.
2199             # ----------------------------------------------------------
2200             # Date Modification Author
2201             # ----------------------------------------------------------
2202             # ----------------------------------------------------------
2203             sub TIEHASH {
2204 0     0     my $proto = shift;
2205 0   0       my $class = ref($proto) || $proto;
2206 0           my ($config, $section)=@_;
2207              
2208             # Make a new object
2209 0           return bless {config=>$config, section=>$section}, $class;
2210             } # end TIEHASH
2211              
2212              
2213             # ----------------------------------------------------------
2214             # Sub: Config::IniFiles::_section::FETCH
2215             #
2216             # Args: $key
2217             # $key The name of the key whose value to get
2218             #
2219             # Description: Returns the value associated with $key. If
2220             # the value is a list, returns a list reference.
2221             # ----------------------------------------------------------
2222             # Date Modification Author
2223             # ----------------------------------------------------------
2224             # 2000Jun15 Fixed bugs in -default handler JW
2225             # 2000Dec07 Fixed another bug in -deault handler JW
2226             # 2002Jul04 Returning scalar values (Bug:447532) AS
2227             # ----------------------------------------------------------
2228             sub FETCH {
2229 0     0     my ($self, $key)=@_;
2230 0           my @retval=$self->{config}->val($self->{section}, $key);
2231 0 0         return (@retval <= 1) ? $retval[0] : \@retval;
2232             } # end FETCH
2233              
2234              
2235             # ----------------------------------------------------------
2236             # Sub: Config::IniFiles::_section::STORE
2237             #
2238             # Args: $key, @val
2239             # $key The key under which to store the value
2240             # @val The value to store, either an array or a scalar
2241             #
2242             # Description: Sets the value for the specified $key
2243             # ----------------------------------------------------------
2244             # Date Modification Author
2245             # ----------------------------------------------------------
2246             # 2001Apr04 Fixed -nocase bug JW
2247             # ----------------------------------------------------------
2248             sub STORE {
2249 0     0     my ($self, $key, @val)=@_;
2250 0           return $self->{config}->newval($self->{section}, $key, @val);
2251             } # end STORE
2252              
2253              
2254             # ----------------------------------------------------------
2255             # Sub: Config::IniFiles::_section::DELETE
2256             #
2257             # Args: $key
2258             # $key The key to remove from the hash
2259             #
2260             # Description: Removes the specified key from the hash and
2261             # returns its former value.
2262             # ----------------------------------------------------------
2263             # Date Modification Author
2264             # ----------------------------------------------------------
2265             # 2001Apr04 Fixed -nocase bug JW
2266             # ----------------------------------------------------------
2267             sub DELETE {
2268 0     0     my ($self, $key)=@_;
2269 0           my $retval=$self->{config}->val($self->{section}, $key);
2270 0           $self->{config}->delval($self->{section}, $key);
2271 0           return $retval;
2272             } # end DELETE
2273              
2274             # ----------------------------------------------------------
2275             # Sub: Config::IniFiles::_section::CLEAR
2276             #
2277             # Args: (None)
2278             #
2279             # Description: Empties the entire hash
2280             # ----------------------------------------------------------
2281             # Date Modification Author
2282             # ----------------------------------------------------------
2283             # ----------------------------------------------------------
2284             sub CLEAR {
2285 0     0     my ($self) = @_;
2286 0           return $self->{config}->DeleteSection($self->{section});
2287             } # end CLEAR
2288              
2289             # ----------------------------------------------------------
2290             # Sub: Config::IniFiles::_section::EXISTS
2291             #
2292             # Args: $key
2293             # $key The key to look for
2294             #
2295             # Description: Returns whether the key exists
2296             # ----------------------------------------------------------
2297             # Date Modification Author
2298             # ----------------------------------------------------------
2299             # 2001Apr04 Fixed -nocase bug JW
2300             # ----------------------------------------------------------
2301             sub EXISTS {
2302 0     0     my ($self, $key)=@_;
2303 0           return $self->{config}->exists($self->{section},$key);
2304             } # end EXISTS
2305              
2306             # ----------------------------------------------------------
2307             # Sub: Config::IniFiles::_section::FIRSTKEY
2308             #
2309             # Args: (None)
2310             #
2311             # Description: Returns the first key in the hash
2312             # ----------------------------------------------------------
2313             # Date Modification Author
2314             # ----------------------------------------------------------
2315             # ----------------------------------------------------------
2316             sub FIRSTKEY {
2317 0     0     my $self = shift;
2318              
2319 0           $self->{tied_enumerator}=0;
2320 0           return $self->NEXTKEY();
2321             } # end FIRSTKEY
2322              
2323             # ----------------------------------------------------------
2324             # Sub: Config::IniFiles::_section::NEXTKEY
2325             #
2326             # Args: $last
2327             # $last The last key accessed by the interator
2328             #
2329             # Description: Returns the next key in line
2330             # ----------------------------------------------------------
2331             # Date Modification Author
2332             # ----------------------------------------------------------
2333             # ----------------------------------------------------------
2334             sub NEXTKEY {
2335 0     0     my $self = shift;
2336 0           my( $last ) = @_;
2337              
2338 0           my $i=$self->{tied_enumerator}++;
2339 0           my @keys = $self->{config}->Parameters($self->{section});
2340 0           my $key=$keys[$i];
2341 0 0         return if (! defined $key);
2342 0 0         return wantarray ? ($key, $self->FETCH($key)) : $key;
2343             } # end NEXTKEY
2344              
2345              
2346             # ----------------------------------------------------------
2347             # Sub: Config::IniFiles::_section::DESTROY
2348             #
2349             # Args: (None)
2350             #
2351             # Description: Called on cleanup
2352             # ----------------------------------------------------------
2353             # Date Modification Author
2354             # ----------------------------------------------------------
2355             # ----------------------------------------------------------
2356       0     sub DESTROY {
2357             # my $self = shift
2358             } # end DESTROY
2359              
2360             1;
2361              
2362             =head1 IMPORT / DELTA FEATURES
2363              
2364             The I<-import> option to L allows one to stack one
2365             I object on top of another (which might be itself
2366             stacked in turn and so on recursively, but this is beyond the
2367             point). The effect, as briefly explained in L, is that the
2368             fields appearing in the composite object will be a superposition of
2369             those coming from the ``original'' one and the lines coming from the
2370             file, the latter taking precedence. For example, let's say that
2371             C<$master> and C were created like this:
2372              
2373             my $master = Config::IniFiles->new(-file => "master.ini");
2374             my $overlay = Config::IniFiles->new(-file => "overlay.ini",
2375             -import => $master);
2376              
2377             If the contents of C and C are respectively
2378              
2379             ; master.ini
2380             [section1]
2381             arg0=unchanged from master.ini
2382             arg1=val1
2383              
2384             [section2]
2385             arg2=val2
2386              
2387             and
2388              
2389             ; overlay.ini
2390             [section1]
2391             arg1=overriden
2392              
2393             Then C<< $overlay->val("section1", "arg1") >> is "overriden", while
2394             C<< $overlay->val("section1", "arg0") >> is "unchanged from
2395             master.ini".
2396              
2397             This feature may be used to ship a ``global defaults'' configuration
2398             file for a Perl application, that can be overridden piecewise by a
2399             much shorter, per-site configuration file. Assuming UNIX-style path
2400             names, this would be done like this:
2401              
2402             my $defaultconfig = Config::IniFiles->new
2403             (-file => "/usr/share/myapp/myapp.ini.default");
2404             my $config = Config::IniFiles->new
2405             (-file => "/etc/myapp.ini", -import => $defaultconfig);
2406             # Now use $config and forget about $defaultconfig in the rest of
2407             # the program
2408              
2409             Starting with version 2.39, I also provides features
2410             to keep the importing / per-site configuration file small, by only
2411             saving those options that were modified by the running program. That
2412             is, if one calls
2413              
2414             $overlay->setval("section1", "arg1", "anotherval");
2415             $overlay->newval("section3", "arg3", "val3");
2416             $overlay->WriteConfig(-delta=>1);
2417              
2418             C would now contain
2419              
2420             ; overlay.ini
2421             [section1]
2422             arg1=anotherval
2423              
2424             [section3]
2425             arg3=val3
2426              
2427             This is called a I (see L). The untouched
2428             [section2] and arg0 do not appear, and the config file is therefore
2429             shorter; while of course, reloading the configuration into C<$master>
2430             and C<$overlay>, either through C<< $overlay->ReadConfig() >> or through
2431             the same code as above (e.g. when application restarts), would yield
2432             exactly the same result had the overlay object been saved in whole to
2433             the file system.
2434              
2435             The only problem with this delta technique is one cannot delete the
2436             default values in the overlay configuration file, only change
2437             them. This is solved by a file format extension, enabled by the
2438             I<-negativedeltas> option to L: if, say, one would delete
2439             parameters like this,
2440              
2441             $overlay->DeleteSection("section2");
2442             $overlay->delval("section1", "arg0");
2443             $overlay->WriteConfig(-delta=>1);
2444              
2445             The I file would now read:
2446              
2447             ; overlay.ini
2448             [section1]
2449             ; arg0 is deleted
2450             arg1=anotherval
2451              
2452             ; [section2] is deleted
2453              
2454             [section3]
2455             arg3=val3
2456              
2457             Assuming C<$overlay> was later re-read with C<< -negativedeltas => 1 >>,
2458             the parser would interpret the deletion comments to yield the correct
2459             result, that is, [section2] and arg0 would cease to exist in the
2460             C<$overlay> object.
2461              
2462             =cut
2463              
2464              
2465             =head1 DIAGNOSTICS
2466              
2467             =head2 @Config::IniFiles::errors
2468              
2469             Contains a list of errors encountered while parsing the configuration
2470             file. If the I method returns B, check the value of this
2471             to find out what's wrong. This value is reset each time a config file
2472             is read.
2473              
2474             =head1 BUGS
2475              
2476             =over 3
2477              
2478             =item *
2479              
2480             The output from [Re]WriteConfig/OutputConfig might not be as pretty as
2481             it can be. Comments are tied to whatever was immediately below them.
2482             And case is not preserved for Section and Parameter names if the -nocase
2483             option was used.
2484              
2485             =item *
2486              
2487             No locking is done by [Re]WriteConfig. When writing servers, take
2488             care that only the parent ever calls this, and consider making your
2489             own backup.
2490              
2491             =back
2492              
2493             =head1 Data Structure
2494              
2495             Note that this is only a reference for the package maintainers - one of the
2496             upcoming revisions to this package will include a total clean up of the
2497             data structure.
2498              
2499             $iniconf->{cf} = "config_file_name"
2500             ->{startup_settings} = \%orginal_object_parameters
2501             ->{firstload} = 0 OR 1
2502             ->{imported} = $object WHERE $object->isa("Config::IniFiles")
2503             ->{nocase} = 0
2504             ->{reloadwarn} = 0
2505             ->{sects} = \@sections
2506             ->{mysects} = \@sections
2507             ->{sCMT}{$sect} = \@comment_lines
2508             ->{group}{$group} = \@group_members
2509             ->{parms}{$sect} = \@section_parms
2510             ->{myparms}{$sect} = \@section_parms
2511             ->{EOT}{$sect}{$parm} = "end of text string"
2512             ->{pCMT}{$sect}{$parm} = \@comment_lines
2513             ->{v}{$sect}{$parm} = $value OR \@values
2514              
2515             =head1 AUTHOR and ACKNOWLEDGEMENTS
2516              
2517             The original code was written by Scott Hutton.
2518             Then handled for a time by Rich Bowen (thanks!),
2519             It is now managed by Jeremy Wadsack,
2520             with many contributions from various other people.
2521              
2522             In particular, special thanks go to (in roughly chronological order):
2523              
2524             Bernie Cosell, Alan Young, Alex Satrapa, Mike Blazer, Wilbert van de Pieterman,
2525             Steve Campbell, Robert Konigsberg, Scott Dellinger, R. Bernstein,
2526             Daniel Winkelmann, Pires Claudio, Adrian Phillips,
2527             Marek Rouchal, Luc St Louis, Adam Fischler, Kay Rpke, Matt Wilson,
2528             Raviraj Murdeshwar and Slaven Rezic, Florian Pfaff
2529              
2530             Geez, that's a lot of people. And apologies to the folks who were missed.
2531              
2532             If you want someone to bug about this, that would be:
2533              
2534             Jeremy Wadsack
2535              
2536             If you want more information, or want to participate, go to:
2537              
2538             http://sourceforge.net/projects/config-inifiles/
2539              
2540             Please send bug reports to config-inifiles-bugs@lists.sourceforge.net
2541              
2542             Development discussion occurs on the mailing list
2543             config-inifiles-dev@lists.sourceforge.net, which you can subscribe
2544             to by going to the project web site (link above).
2545              
2546             This program is free software; you can redistribute it and/or
2547             modify it under the same terms as Perl itself.
2548              
2549             =cut
2550              
2551             1;
2552              
2553             # Please keep the following within the last four lines of the file
2554             #[JW for editor]:mode=perl:tabSize=8:indentSize=2:noTabs=true:indentOnEnter=true:
2555