1package Config::IniHash;
2
3use 5.8.0;
4use Carp;
5use strict;
6use warnings;no warnings 'uninitialized';
7use Symbol;
8use Encode qw(is_utf8);
9
10use Exporter;
11use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
12@ISA = qw(Exporter);
13@EXPORT = qw(&ReadINI &WriteINI &PrintINI);
14@EXPORT_OK = qw(&ReadINI &WriteINI &PrintINI &AddDefaults &ReadSection);
15$VERSION = '3.01.01';
16
17if (0) { # for PerlApp/PerlSvc/PerlCtrl/Perl2Exe
18	require 'Hash/WithDefaults.pm';
19	require 'Hash/Case/Lower.pm';
20	require 'Hash/Case/Upper.pm';
21	require 'Hash/Case/Preserve.pm';
22}
23
24#use vars qw(heredoc systemvars withdefaults forValue);
25$Config::IniHash::case = 'lower';
26	# upper, preserve, toupper, tolower
27$Config::IniHash::heredoc = 0;
28$Config::IniHash::systemvars = 1;
29$Config::IniHash::withdefaults = 0;
30$Config::IniHash::sectionorder = 0;
31$Config::IniHash::allowmultiple = 0;
32$Config::IniHash::comment = qr/^\s*[#;]/;
33$Config::IniHash::layer = '';
34
35*Config::IniHash::allow_multiple = \$Config::IniHash::allowmultiple;
36
37sub BREAK () {1}
38
39sub prepareOpt {
40	my $opt = shift();
41
42	$opt->{case} = $Config::IniHash::case unless exists $opt->{case};
43	$opt->{case} = $opt->{insensitive} if exists $opt->{insensitive}; # for backwards compatibility
44	$opt->{heredoc} = $Config::IniHash::heredoc unless exists $opt->{heredoc};
45	$opt->{systemvars} = $Config::IniHash::systemvars unless exists $opt->{systemvars};
46	$opt->{withdefaults} = $Config::IniHash::withdefaults unless exists $opt->{withdefaults};
47	$opt->{forValue} = $Config::IniHash::forValue unless exists $opt->{forValue};
48	$opt->{sectionorder} = $Config::IniHash::sectionorder unless exists $opt->{sectionorder};
49	$opt->{allowmultiple} = $opt->{allow_multiple} unless exists $opt->{allowmultiple};
50	$opt->{allowmultiple} = $Config::IniHash::allowmultiple unless exists $opt->{allowmultiple};
51	$opt->{comment} = $Config::IniHash::comment unless exists $opt->{comment};
52	$opt->{layer} = $Config::IniHash::layer unless exists $opt->{layer};
53	$opt->{layer} = ':' . $opt->{layer} if $opt->{layer} and $opt->{layer} !~ /^:/;
54
55	if ($opt->{class}) {
56		delete $opt->{withdefaults};
57	} else {
58		for ($opt->{case}) {
59			$_ = lc $_;
60			$_ = 'no' unless $_;
61
62			local $Carp::CarpLevel = 1;
63			/^lower/ and do {
64				if ($opt->{sectionorder} and !ref($opt->{sectionorder})) {
65					$opt->{class} = 'Hash::Case::LowerX';
66				} else {
67					$opt->{class} = 'Hash::Case::Lower';
68				}
69				undef $opt->{forName};
70				BREAK}
71			or
72			/^upper/ and do {
73				$opt->{class} = 'Hash::Case::Upper';
74				undef $opt->{forName};
75				BREAK}
76			or
77			/^preserve/ and do {
78				$opt->{class} = 'Hash::Case::Preserve';
79				undef $opt->{forName};
80				BREAK}
81			or
82			/^toupper/ and do {
83				undef $opt->{class};
84				$opt->{forName} = 'uc';
85				BREAK}
86			or
87			/^tolower/ and do {
88				undef $opt->{class};
89				$opt->{forName} = 'lc';
90				BREAK}
91			or
92			/^(?:no|sensitive)/ and do {
93				undef $opt->{class};
94				undef $opt->{forName};
95				BREAK}
96			or
97				croak "Option 'case' may be set only to:\n\t'lower', 'upper', 'preserve', 'toupper', 'tolower' or 'no'\n";
98
99		}
100
101		if ($opt->{class} and $opt->{class} ne 'Hash::Case::LowerX') {
102			my $class = $opt->{class};
103			my $file = $class;
104			$file =~ s{::}{/}g;
105			if (!$INC{$file.'.pm'}) {
106				eval "use $class;\n1"
107					or croak "ERROR autoloading $class : $@";
108			}
109		}
110
111		if ($opt->{withdefaults} and !$INC{'Hash/WithDefaults.pm'}) {
112			eval "use Hash::WithDefaults;\n1"
113				or croak "ERROR autoloading Hash::WithDefaults : $@";
114		}
115	}
116
117	if (! $opt->{heredoc}) {
118		$opt->{heredoc} = 0;
119	} elsif (lc($opt->{heredoc}) eq 'perl') {
120		$opt->{heredoc} = 'perl'
121	} else {
122		$opt->{heredoc} = 1;
123	}
124	if (defined $opt->{systemvars} and $opt->{systemvars}) {
125		$opt->{systemvars} = \%ENV unless (ref $opt->{systemvars});
126	} else {
127		$opt->{systemvars} = 0;
128	}
129
130	if (! ref $opt->{comment}) {
131		$opt->{comment} = qr/^\s*[$opt->{comment}]/;
132	}
133
134	if (ref $opt->{allowmultiple}) {
135		croak "The allowmultiple option must be a true or false scalar or a reference to a hash of arrays, hashes, regexps or comma separated lists of names!"
136			unless ref $opt->{allowmultiple} eq 'HASH';
137
138		foreach my $section (values %{$opt->{allowmultiple}}) {
139			if (! ref $section) {
140				$section = {map( ($_ => undef), split( /\s*,\s*/, $section))};
141			} elsif (ref $section eq 'ARRAY') {
142				$section = {map( ($_ => undef), @$section)};
143			} elsif (ref $section eq 'Regexp') {
144			} elsif (ref $section ne 'HASH') {
145				croak "The allowmultiple option must be a true or false scalar or a reference to a hash of arrays, hashes, regexps or comma separated lists of names!"
146			}
147		}
148	}
149}
150
151sub ReadINI {
152	my $file = shift;
153	my %opt;
154	if (@_ == 1 and ref $_[0]) {
155		%opt = %{$_[0]};
156	} elsif (@_ % 2 == 0) {
157		%opt = @_;
158	} else {
159		croak("ReadINI expects the filename plus either a reference to a hash of options or a list with even number of items!");
160	}
161	prepareOpt(\%opt);
162
163	my $hash;
164	if ($opt{hash}) {
165		$hash = $opt{hash};
166	} else {
167		$hash = {};
168		tie %$hash, $opt{class}
169			if $opt{class};
170	}
171
172	my $section = '';
173	my $IN;
174	if (ref $file) {
175		my $ref = ref $file;
176		if ($ref eq 'SCALAR') {
177			if (is_utf8($$file)) {
178				$opt{layer} .= ':utf8' unless $opt{layer} =~ /\butf-?8\b/i;
179			}
180			open $IN, "<$opt{layer}", $file; # will read from the referenced scalar
181		} elsif ($ref eq 'ARRAY') {
182			my $data = join "\n", map {s/\r?\n/\n/;chomp;$_} @$file;
183			if (is_utf8($data)) {
184				$opt{layer} .= ':utf8' unless $opt{layer} =~ /\butf-?8\b/i;
185			}
186			open $IN, "<$opt{layer}",\$data; # will read from the referenced scalar
187		} elsif ($ref eq 'HASH') {
188			croak "ReadINI cannot accept a HASH reference as it's parameter!";
189		} else {
190			$IN = $file; #assuming it's a glob or an object that'll know what to do
191		}
192	} else {
193		if ($opt{layer}) {
194			open $IN, "<$opt{layer}", $file or return undef;
195		} else {
196			open $IN, $file or return undef;
197		}
198		my $bom = <$IN>;
199		if ($bom =~ /\r/) {
200			$opt{layer} .= ':crlf';
201		}
202		if (substr($bom, 0, 3) eq "\xEF\xBB\xBF") {
203			$opt{layer} .= ':utf8';
204			close $IN;
205			open $IN, "<$opt{layer}", $file or return undef;
206			read $IN, $bom, 1;
207		} elsif (substr($bom, 0, 1) eq "\x{feff}") {
208			seek($IN,2,0);
209		} else {
210			seek($IN,0,0);
211		}
212	}
213
214	my ($lc,$uc) = ( (defined $opt{forName} and $opt{forName} eq 'lc'), (defined $opt{forName} and $opt{forName} eq 'uc'));
215	if ($opt{sectionorder}) {
216		my $arrayref;
217		if (ref $opt{sectionorder}) {
218			$arrayref = $opt{sectionorder}
219		} else {
220			$arrayref = $hash->{'__SECTIONS__'} = [];
221		}
222		if ($opt{case} eq 'lower' or $opt{case} eq 'tolower') {
223			$opt{sectionorder} = sub {push @$arrayref, lc($_[0])}
224		} elsif ($opt{case} eq 'upper' or $opt{case} eq 'toupper') {
225			$opt{sectionorder} = sub {push @$arrayref, uc($_[0])}
226		} else {
227			$opt{sectionorder} = sub {push @$arrayref, $_[0]}
228		}
229	}
230	my $forValue = $opt{forValue};
231
232	while (<$IN>) {
233
234		$_ =~ $opt{comment} and next;
235
236		if (/^\[(.*)\]/) {
237			$section = $1;
238			$opt{sectionorder}->($section) if $opt{sectionorder};
239			if ($lc) { $section = lc $section} elsif ($uc) { $section = uc $section };
240			unless ($hash->{$section}) {
241				my %tmp = ();
242				if ($opt{withdefaults}) {
243					tie %tmp, 'Hash::WithDefaults', $opt{case};
244				} else {
245					tie %tmp, $opt{class}
246						if $opt{class};
247				}
248				$hash->{$section} = \%tmp;
249			}
250			next;
251		}
252
253		if (/^([^=]*?)\s*=\s*(.*?)\s*$/) {
254			my ($name,$value) = ($1,$2);
255			if ($opt{heredoc} eq 'perl' and $value =~ /^<<(['"])?(.+)\1\s*$/) {
256				my $type = $1;
257				my $terminator = $2;
258				$value = '';
259				while (<$IN>) {
260					chomp;
261					last if $_ eq $terminator;
262					$value .= "\n".$_;
263				}
264				croak "Heredoc value for [$section]$name not closed at end of file!"
265				 unless defined $_;
266				substr ($value, 0, 1) = '';
267
268				if ($type eq '') {
269					$value =~ s/%([^%]*)%/exists($opt{systemvars}{$1}) ? $opt{systemvars}{$1} : "%$1%"/eg if $opt{systemvars};
270				} elsif ($type eq q{"}) {
271					if ($opt{systemvars}) {
272						$value =~ s/%([^%]*)%/$opt{systemvars}{$1}/g;
273					} else {
274						$value =~ s/%([^%]*)%/$ENV{$1}/g;
275					}
276				}
277
278			} elsif ($opt{heredoc} and $value =~ /^<<(.+)\s*$/) {
279				my $terminator = $1;
280				$value = '';
281				while (<$IN>) {
282					chomp;
283					last if $_ eq $terminator;
284					$value .= "\n".$_;
285				}
286				croak "Heredoc value for [$section]$name not closed at end of file!"
287				 unless defined $_;
288				substr ($value, 0, 1) = '';
289				$value =~ s/%([^%]*)%/exists($opt{systemvars}{$1}) ? $opt{systemvars}{$1} : "%$1%"/eg if $opt{systemvars};
290
291			} else {
292				$value =~ s/%([^%]*)%/exists($opt{systemvars}{$1}) ? $opt{systemvars}{$1} : "%$1%"/eg if $opt{systemvars};
293			}
294
295			if ($lc) { $name = lc $name} elsif ($uc) { $name = uc $name };
296			if ($forValue) {
297				$value = $forValue->($name, $value, $section, $hash);
298			}
299			if (defined $value) {
300				if (!$opt{allowmultiple}) {
301					$hash->{$section}{$name} = $value; # overwrite
302				} elsif (!ref $opt{allowmultiple}) {
303					if (exists $hash->{$section}{$name}) {
304						if (ref $hash->{$section}{$name}) {
305							push @{$hash->{$section}{$name}}, $value;
306						} else {
307							$hash->{$section}{$name} = [ $hash->{$section}{$name}, $value]; # second value
308						}
309					} else {
310						$hash->{$section}{$name} = $value; # set
311					}
312				} else {
313					if (exists $opt{allowmultiple}{$section}{$name} or exists $opt{allowmultiple}{'*'}{$name}) {
314						push @{$hash->{$section}{$name}}, $value;
315					} else {
316						$hash->{$section}{$name} = $value; # set
317					}
318				}
319			}
320		}
321	}
322	close $IN;
323	return $hash;
324}
325
326sub WriteINI {
327	my ($file,$hash) = @_;
328	open my $OUT, ">$file" or return undef;
329	if (exists $hash->{'__SECTIONS__'}) {
330		my $all_have_order = (scalar(@{$hash->{'__SECTIONS__'}}) == scalar(keys %$hash)-1);
331		foreach my $section (@{$hash->{'__SECTIONS__'}}) {
332			print $OUT "[$section]\n";
333			my $sec;
334			if (exists $hash->{$section}) {
335				my $sec = $hash->{$section};
336				foreach my $key (sort keys %{$hash->{$section}}) {
337					if ($key =~ /^[#';]/ and ! defined($sec->{$key})) {
338						print $OUT "$key\n";
339					} elsif ($sec->{$key} =~ /\n/) {
340						print $OUT "$key=<<*END_$key*\n$sec->{$key}\n*END_$key*\n";
341					} else {
342						print $OUT "$key=$sec->{$key}\n";
343					}
344				}
345			} else {
346				$all_have_order = 0;
347			}
348			print $OUT "\n";
349		}
350		if (!$all_have_order) {
351			my %ordered; @ordered{@{$hash->{'__SECTIONS__'}}} = ();
352			foreach my $section (keys %$hash) {
353				next if exists($ordered{$section}) or $section eq '__SECTIONS__';
354				print $OUT "[$section]\n";
355				my $sec = $hash->{$section};
356				foreach my $key (sort keys %{$hash->{$section}}) {
357					if ($key =~ /^[#';]/ and ! defined($sec->{$key})) {
358						print $OUT "$key\n";
359					} elsif ($sec->{$key} =~ /\n/) {
360						print $OUT "$key=<<*END_$key*\n$sec->{$key}\n*END_$key*\n";
361					} else {
362						print $OUT "$key=$sec->{$key}\n";
363					}
364				}
365				print $OUT "\n";
366			}
367		}
368	} else {
369		foreach my $section (keys %$hash) {
370			print $OUT "[$section]\n";
371			my $sec = $hash->{$section};
372			foreach my $key (keys %{$hash->{$section}}) {
373				if ($key =~ /^[#';]/ and ! defined($sec->{$key})) {
374					print $OUT "$key\n";
375				} elsif ($sec->{$key} =~ /\n/) {
376					print $OUT "$key=<<*END_$key*\n$sec->{$key}\n*END_$key*\n";
377				} else {
378					print $OUT "$key=$sec->{$key}\n";
379				}
380			}
381			print $OUT "\n";
382		}
383	}
384	close $OUT;
385	return 1;
386}
387*PrintINI = \&WriteINI;
388
389sub AddDefaults {
390	my ($ini, $section, $defaults) = @_;
391
392	croak "$section doesn't exist in the hash!"
393		unless exists $ini->{$section};
394
395	croak "You can call AddDefaults ONLY on hashes created with\n\$Config::IniHash::withdefaults=1 !"
396		unless tied(%{$ini->{$section}}) and tied(%{$ini->{$section}})->isa('Hash::WithDefaults');
397
398	if (ref $defaults) {
399		croak "The defaults must be a section name or a hash ref!"
400			unless ref $defaults eq 'HASH';
401
402		tied(%{$ini->{$section}})->AddDefault($defaults);
403	} else {
404		croak "$defaults doesn't exist in the hash!"
405			unless exists $ini->{$defaults};
406
407		tied(%{$ini->{$section}})->AddDefault($ini->{$defaults});
408	}
409}
410
411
412sub ReadSection {
413	my $text = shift;
414	my %opt = @_;
415	prepareOpt(\%opt);
416
417	my $hash= {};
418	if ($opt{withdefaults}) {
419		tie %$hash, 'Hash::WithDefaults', $opt{case};
420	} else {
421		tie %$hash, $opt{class}
422			if $opt{class};
423	}
424
425	open my $IN, '<', \$text;
426
427	my ($lc,$uc) = ( $opt{forName} eq 'lc', $opt{forName} eq 'uc');
428	my $forValue = $opt{forValue};
429	while (<$IN>) {
430		/^\s*;/ and next;
431
432		if (/^([^=]*?)\s*=\s*(.*?)\s*$/) {
433			my ($name,$value) = ($1,$2);
434			if ($opt{heredoc} and $value =~ /^<<(.+)$/) {
435				my $terminator = $1;
436				$value = '';
437				while (<$IN>) {
438					chomp;
439					last if $_ eq $terminator;
440					$value .= "\n".$_;
441				}
442				croak "Heredoc value for $name not closed at end of string!"
443					unless defined $_;
444				substr ($value, 0, 1) = '';
445			}
446			$value =~ s/%(.*?)%/$opt{systemvars}{$1}/g if $opt{systemvars};
447			if ($lc) { $name = lc $name} elsif ($uc) { $name = uc $name };
448			if ($forValue) {
449				$value = $forValue->($name, $value, undef, $hash);
450			}
451			$hash->{$name} = $value;
452		}
453	}
454	close $IN;
455	return $hash;
456}
457
458package Hash::Case::LowerX;
459use base 'Hash::Case';
460
461use strict;
462use Carp;
463
464sub init($)
465{   my ($self, $args) = @_;
466
467	$self->SUPER::native_init($args);
468
469	croak "No options possible for ".__PACKAGE__
470		if keys %$args;
471
472	$self;
473}
474
475sub FETCH($)  { $_[0]->{($_[1] eq '__SECTIONS__' ? $_[1] : lc $_[1])} }
476sub STORE($$) { $_[0]->{($_[1] eq '__SECTIONS__' ? $_[1] : lc $_[1])} = $_[2] }
477sub EXISTS($) { exists $_[0]->{($_[1] eq '__SECTIONS__' ? $_[1] : lc $_[1])} }
478sub DELETE($) { delete $_[0]->{($_[1] eq '__SECTIONS__' ? $_[1] : lc $_[1])} }
479
4801;
481__END__
482
483=head1 NAME
484
485Config::IniHash - Perl extension for reading and writing INI files
486
487=head1 VERSION
488
489Version 3.00.05
490
491=head1 SYNOPSIS
492
493  use Config::IniHash;
494  $Config = ReadINI 'c:\some\file.ini';
495
496=head1 DESCRIPTION
497
498This module reads and writes INI files.
499
500=head2 Functions
501
502=head3 ReadINI
503
504	$hashreference = ReadINI ($filename, %options)
505	$hashreference = ReadINI (\$data, %options)
506	$hashreference = ReadINI (\@data, %options)
507	$hashreference = ReadINI ($filehandle, %options)
508
509The returned hash contains a reference to a hash for each section of
510the INI.
511
512	[section]
513	name=value
514  leads to
515	$hash->{section}->{name}  = value;
516
517The available options are:
518
519=over 4
520
521=item heredoc
522
523- controls whether the module supports the heredoc syntax :
524
525	name=<<END
526	the
527	many lines
528	long value
529	END
530	othername=value
531
532	0 : heredocs are ignored, $data->{section}{name} will be '<<END'
533	1 : heredocs are supported, $data->{section}{name} will be "the\nmany lines\nlong value"
534		The Perl-lie extensions of name=<<"END" and <<'END' are not supported!
535	'Perl' : heredocs are supported, $data->{section}{name} will be "the\nmany lines\nlong value"
536		The Perl-lie extensions of name=<<"END" and <<'END' are supported.
537		The <<'END' never interpolates %variables%, the "END" always interpolates variables,
538		unlike in other values, the %variables% that are not defined do not stay in the string!
539
540Default: 0 = OFF
541
542
543=item systemvars
544
545- controls whether the (system) variables enclosed in %% are
546interpolated and optionaly contains the values in a hash ref.
547
548	name=%USERNAME%
549  leads to
550	$data->{section}->{name} = "Jenda"
551
552	systemvars = 1	- yes, take values from %ENV
553	systemvars = \%hash	- yes, take values from %hash
554	systemvars = 0	- no
555
556=item case
557
558- controls whether the created hash is case insensitive. The possible values are
559
560  sensitive	- the hash will be case sensitive
561  tolower	- the hash will be case sensitive, all keys are made lowercase
562  toupper	- the hash will be case sensitive, all keys are made uppercase
563  preserve	- the hash will be case insensitive, the case is preserved (tied)
564  lower	- the hash will be case insensitive, all keys are made lowercase (tied)
565  upper	- the hash will be case insensitive, all keys are made uppercase (tied)
566
567=item withdefaults
568
569- controls whether the created section hashes support defaults. See L<Hash::WithDefaults>.
570
571=item class
572
573- allows you to specify the class into which to tie the created hashes. This option overwrites
574the "case" and "withdefaults" options!
575
576You may for example use
577
578  class => 'Tie::IxHash',
579
580to store the sections in hashes that remember the insertion order.
581
582=item sectionorder
583
584- if set to a true value then created hash will contain
585
586	$config->{'__SECTIONS__'} = [ 'the', 'names', 'of', 'the', 'sections', 'in', 'the',
587		'order', 'they', 'were', 'specified', 'in', 'the', 'INI file'];
588
589- if set to an array ref, then the list will be stored in that array, and no $config->{'__SECTIONS__'}
590is created. The case of the section names stored in this array is controled by the "case" option even
591in case you specify the "class".
592
593=item allowmultiple
594
595- if set to a true scalar value then multiple items with the same names in a section
596do not overwrite each other, but result in an array of the values.
597
598- if set to a hash of hashes (or hash of arrays or hash of comma separated item names)
599specifies what items in what sections will end up as
600hashes containing the list of values. All the specified items will be arrays, even if
601there is just a single value. To affect the items in all sections use section name '*'.
602
603By default false.
604
605=item forValue
606
607- allows you to install a callback that will be called for each value as soon as it is read
608but before it is stored in the hash.
609The function is called like this:
610
611  $value = $forValue->($name, $value, $sectionname, $INIhashref);
612
613If the callback returns an undef, the value will not be stored.
614
615=item comment
616
617- regular expression used to identify comments or a string containing the list of characters starting a comment.
618Each line is tested against the regexp is ignored if matches. If you specify a string a regexp like this will be created:
619
620	qr/^\s*[the_list]/
621
622The default is
623
624	qr/^\s*[#;]
625
626=item layer
627
628- the IO layer(s) to use when opening the file. See perldoc C<perlopen>.
629
630If the file is in UTF8 and starts with a BOM it will be automaticaly opened in UTF8 mode and the BOM will be stripped.
631If it doesn't start with the BOM you have to specify the utf8 layer!
632
633=back
634
635You may also set the defaults for the options by modifying the $Config::IniHash::optionname
636variables. These default settings will be used if you do not specify the option in the ReadINI()
637or ReadSection() call.
638
639=head3 AddDefaults
640
641  AddDefaults( $config, 'normal section name', 'default section name');
642  AddDefaults( $config, 'normal section name', \%defaults);
643
644This subroutine adds a some default values into a section. The values are NOT copied into the section,
645but rather the section knows to look up the missing options in the default section or hash.
646
647Eg.
648
649  if (exists $config->{':default'}) {
650	foreach my $section (keys %$config) {
651	  next if $section =~ /^:/;
652	  AddDefaults( $config, $section, ':default');
653	}
654  }
655
656=head3 ReadSection
657
658  $hashreference = ReadSection ($string)
659
660This function parses a string as if it was a section of an INI file and creates a hash with the values.
661It accepts the same options as ReadINI.
662
663=head3 WriteINI
664
665  WriteINI ($filename, $hashreference)
666
667Writes the hash of hashes to a file.
668
669=head3 PrintINI
670
671The same as WriteINI().
672
673=head1 AUTHOR
674
675Jan Krynicky <Jenda@Krynicky.cz>
676http://Jenda.Krynicky.cz
677
678=head1 COPYRIGHT
679
680Copyright (c) 2002-2005 Jan Krynicky <Jenda@Krynicky.cz>. All rights reserved.
681
682This program is free software; you can redistribute it and/or
683modify it under the same terms as Perl itself.
684
685=cut
686