Source

dlconfreader / lib / Daybo / ConfReader.pm

Full commit
  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
#!/usr/bin/perl -w
#
# Daybo Logic Configuration Reader
# Copyright (C) 2010,2012 Daybo Logic
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
# 1. Redistributions of source code must retain the above copyright
#    notice, this list of conditions and the following disclaimer.
# 2. Redistributions in binary form must reproduce the above copyright
#    notice, this list of conditions and the following disclaimer in the
#    documentation and/or other materials provided with the distribution.
# 3. Neither the name of the project nor the names of its contributors
#    may be used to endorse or promote products derived from this software
#    without specific prior written permission.
#
# THIS SOFTWARE IS PROVIDED BY THE PROJECT AND CONTRIBUTORS ``AS IS'' AND
# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
# ARE DISCLAIMED.  IN NO EVENT SHALL THE PROJECT OR CONTRIBUTORS BE LIABLE
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
# SUCH DAMAGE.
#
#----------------------------------------------------------------------------

=item Daybo::ConfReader

The ConfReader provided by the dl-libconfreader-perl package is a package which provides a simple
way to read configuration files in a .ini [section] key=value format.
Anything outside of a section will be read into an undefined sectopnm, which allows reading other
forms of configuration file too.  This was written due to the lack of consistency on CPAN for similar
packages.  We rely on liberror-perl for exceptions, although this has now been deprecated.

=cut

use Error qw(:try);

package Daybo::ConfReader;
use Data::Dumper;

our $VERSION = '2.1.0'; # Keep in sync with debian/changelog
use constant DEFAULT_SECTION => ('DEFAULT');
#----------------------------------------------------------------------------
=item new

Create a new Daybo::ConfReader object.

Parameters:
FileName
	The path, either fully qualified, or relative to the configuration file you
	wish to read.  This is optional, you may also use the SetFn method.
	The config file will be read immediately if passed here.  This could result
	in an exception being raised.

Returns:
	Blessed object for handling configuration files of the type ConfReader

=cut
#----------------------------------------------------------------------------
sub new
{
	my $proto = $_[0];
	my $class = ref($proto) || $proto;
	my $self = {
		_fn => undef,
		# deep_hash is a list of all section names, and further key/value mappings.
		_deep_hash => { },
		# nonkvd; Names of sections map to lists of any non key-value data encountered.
		_nonkvd => { }
 	};

	my $Fn = $_[1];
	bless($self, $class);

	if ( $self && $Fn ) {
		$self = undef unless ( $self->SetFn($Fn) );
		$self->Reload() if ( $self );
	}
	return $self;
}
#----------------------------------------------------------------------------
=item DESTROY

This function is used to destroy the object, releasing all memory used
by keys in memory.  The object cannot be re-used after it is destroyed.

Parameters:
	None

Returns:
	None

=cut
#----------------------------------------------------------------------------
sub DESTROY
{
	my $self = $_[0];
	$self->{_fn} = undef;
	if ( defined($self->{_deep_hash}) ) {
		foreach my $k ( keys(%{ $self->{_deep_hash} }) ) {
			delete($self->{_deep_hash}->{$k});
		}
		$self->{_deep_hash} = undef;
	}
	return;
}
#----------------------------------------------------------------------------
=item GetSections

Parameters:
SectionsPtr
	Pass a reference to an array which will hold the names of the sections within
	the configuration file.  If not specified, the result value will still be
	valid.

Returns:
	The number of section names loaded into SectionsPtr will be returned.  Zero
	if there are no sections.  The undefined section (the default) will not be
	counted as a section in its own right, and will not be included.

=cut
#----------------------------------------------------------------------------
sub GetSections
{
	my ( $self, $SectionsPtr ) = @_;
	my $count = 0;

	@$SectionsPtr = ( ) if ( $SectionsPtr );
	foreach my $s ( keys(%{ $self->{_deep_hash} }) ) {
		next if ( $s eq DEFAULT_SECTION() );
		push @$SectionsPtr, $s if ( $SectionsPtr );
		$count++;
	}
	return $count;
}
#----------------------------------------------------------------------------
=item GetKeys

Return the names of all keys within a particular section of the configuration
file.

Parameters:
Section:
	The section name, or undef for those keys not within a section.

KeysPtr:
	A reference to an array which will accept the names of the keys for the
	desired section.  The reference is optional.  Any existing data in the
	array will be lost, if passed.

Returns:
	The number of keys in the section which have been returned via KeysPtr,
	if not KeysPtr is passed, the number of items which are in the section and
	would have been returned is returned.

=cut
#----------------------------------------------------------------------------
sub GetKeys
{
	my ( $self, $Section, $KeysPtr ) = @_;
	my $count = 0;
	my $s = $Section;

	@$KeysPtr = ( ) if ( $KeysPtr );
	$s = $Section;
	$self->_DeprecatedSection() if ( defined($s) && $s eq DEFAULT_SECTION() );
	$s = DEFAULT_SECTION() unless ( defined($s) );
	foreach my $k ( keys(%{ $self->{_deep_hash}->{$s} }) ) {
		push @$KeysPtr, $k if ( $KeysPtr );
		$count++;
	}
	return $count;
}
#----------------------------------------------------------------------------
=item GetDatum

Return a specific value within the configuration file, given a section and
a key.  Whitespace will be trimmed from the left and right of the returned
value.  If the value does not exist, or you are not within the correct
section, undef is returned.

Parameters:
Section:
	The section which is expected to contain the desired key, must be specified,
	undef should be used if the key is not within a section.

KeyName:
	The name of the key. must be specified.

Returns:
	The value within the key, after whitespace trimming, or undef.

=cut
#----------------------------------------------------------------------------
sub GetDatum
{
	my ( $self, $Section, $KeyName ) = @_;
	my $ret = undef;
	my $s = $Section;

	$self->_DeprecatedSection() if ( defined($s) && $s eq DEFAULT_SECTION() );
	$s = DEFAULT_SECTION() unless ( defined($s) );
	if ( exists($self->{_deep_hash}->{$s}) ) {
		if ( exists($self->{_deep_hash}->{$s}->{$KeyName}) ) {
			$ret = $self->{_deep_hash}->{$s}->{$KeyName};
		}
	}
	return $ret;
}
#----------------------------------------------------------------------------
=item GetLine

The GetLine() function returns a specific line from 0 to n-1 relative to the
start of a section in processed terms (this is not an absolute measure, it
excludes comments, blank lines, and key/value data.  There are therefore no
gaps.

Parameters:
Section:
	The section in which to look for the line.  Or undef for the default section.
Line:
	Line number, negative offsets are acceptable, and reverse wrap from the
	end of the block.

Returns:
	The string of the given non-KVM data as requested, or undef.
	If the line number is out of range, undef is returned, although an exception
	is thrown if something other than a number is passed.

NOTES:
	If the section does not exist, undef will be returned.
	You cannot recover a blank line, they are not considered valid config data.
	Line numbers have the last newline character removed during the Reload()
	operation.

=cut
#----------------------------------------------------------------------------
sub GetLine
{
	my $lineRet = undef; # Return value.
	my ( $self, $Section, $Line ) = @_;

	$self->_DeprecatedSection() if ( defined($Section) && $Section eq DEFAULT_SECTION() );
	$Section = DEFAULT_SECTION() unless ( defined($Section) );

	# Check the line number cound be valid.
	if ( defined($Line) ) {
		throw Error::Simple("Invalid line number - $Line")
			if ( $Line !~ m/^(\-)?\d+$/ );
	} else {
		$Line = 0;
	}

	if ( exists($self->{_nonkvd}->{$Section}) ) { # Section has non-KVD data?
		throw Error::Simple('Internal inconsistency in section name data')
			unless ( exists($self->{_deep_hash}->{$Section}) );

		$lineRet = $self->{_nonkvd}->{$Section}->[ $Line ];
	}
	return $lineRet;
}
#----------------------------------------------------------------------------
=item GetLines

The GetLines() function returns all lines, in natural order which are _not_
Key/Value pairs.  Optionally, you can include all Key/Pair data too by setting
IncludeKVD to a true value.  This will be appended to the end of the list,
which may not reflect the true order of the data, as it appears in the source
configuration file(s) as read via Reload().

Parameters:
Section:
	The name of the section, or the default (untitled) section, if undefined.
Lines:
	A reference to a list in the caller's context which will receive the lines,
	this will not be pre-flushed.  This is not a mandatory parameter.  You may
	fetch only the count, if desired.
IncludeKVD:
	All key=value pairs will be appended was if there were raw lines.
	This is an optional parameter.

Returns:
	The number of lines returned.

=cut
#----------------------------------------------------------------------------
sub GetLines
{
	my $i = 0;
	my $retCount = 0;
	my $line;
	my ( $self, $Section, $Lines, $IncludeKVD ) = @_;

	do {
		$line = $self->GetLine($Section, $i++);
		if ( $line ) {
			push(@$Lines, $line) if ( $Lines ); # Caller wants actual data?
			$retCount++; # Always keep count accurate for return value
		}
	} while ( $line );

	if ( $IncludeKVD ) { # Process Key/value pair data as if it were raw
		my @keyNames = ( );
		my $keyCount = $self->GetKeys($Section, \@keyNames);
		for ( my $keyIndex = 0; $keyIndex < $keyCount; $keyIndex++ ) {
			my $thisValue = $self->GetDatum($Section, $keyNames[$keyIndex]);
			next if ( !defined($thisValue) );
			$retCount++;
			next if ( !$Lines );
			push(@$Lines, join('=', $keyNames[$keyIndex], $thisValue));
		}
	}
	return $retCount;
}
#----------------------------------------------------------------------------
=item SetFn

Set the path to the configuration file in prepation for the next reload
operation.

Parameters:
FilePath:
	The full or relative path to the configuration file.  May be undef if
	the filename is to be cleared.

Returns:
	1 if the FilePath is stored and set correctly,
	0 if the FilePath is cleared, or illegal.

=cut
#----------------------------------------------------------------------------
sub SetFn
{
	my $self = $_[0];
	$self->{_fn} = $_[1] if ( $_[1] );
	$self->{_fn} = undef unless ( length($self->{_fn}) );
	return 1 if ( defined($self->{_fn}) );
	return 0;
}
#----------------------------------------------------------------------------
=item Reload

Loads configuration from the currently set filepath into the object,
in addition to any configuration already within the object.  The filename
must be set prior to calling Reload(), or an exception shall be raised.

Multiple calls to the function will override existing values, and, if the
filename has been changed, will merge configurations together in memory,
sharing any common sections if section names collide.

If any given lines of data are not key/value pairs, the line will be stored
in an additional non-KVD list, particular to that section. Which can be
recovered by by calling GetLines() or GetLine() for one specific line.

An exception is raised if the file cannot be opened.

Parameters:
	None

Returns:
	None defined, the return value is reversed for future use.

=cut
#----------------------------------------------------------------------------
sub Reload
{
	my $ret = 0;
	my $self = $_[0];
	my $section = DEFAULT_SECTION();
	$self->SelfCheck();

	if ( open(CONFFILE, ('< ' . $self->{_fn})) ) {
		while ( my $l = <CONFFILE> ) {
			chomp $l;
			next unless ( length($l) );
			$l = $self->StripComment($l);
			next unless ( length($l) );
			if ( $l =~ m/^\[(.*)\]$/ ) {
				$section = $1;
				unless ( exists($self->{_deep_hash}->{$section}) ) {
					my %newSection = ( );
					$self->{_deep_hash}->{$section} = \%newSection;
				}
			} else {
				my ( $k, $v ) = ( '', '' );
				if ( $self->_GetData($l, \$k, \$v) ) {
					$self->{_deep_hash}->{$section}->{$k} = $v;
				} else {
					push(@{ $self->{_nonkvd}->{$section} }, $l);
				}
			}
		}
#print Dumper $self->{_deep_hash};
		close(CONFFILE);
	} else {
		throw Error::Simple(sprintf("Cannot open %s - %s\n", $self->{_fn}, $!));
	}
	return $ret;
}
#----------------------------------------------------------------------------
sub _GetData
{
	my $count = 0;
	my ( $self, $Line, $KeyPtr, $ValuePtr ) = @_;
	( $$KeyPtr, $$ValuePtr ) = split('=', $Line, 2);
	return undef unless ( defined($$KeyPtr) && defined($$ValuePtr) );

	my @Data = ( $KeyPtr, $ValuePtr );
	foreach my $d ( @Data ) {
		$$d =~ s/^\s+//;
		$$d =~ s/\s+$//;
		$count++ if ( length($$d) );
	}
	return 1 if ( $count );
	return 0;
}
#----------------------------------------------------------------------------
sub _DeprecatedSection
{
	warn(sprintf("[%s] is deprecated\n", DEFAULT_SECTION()));
	return;
}
#----------------------------------------------------------------------------
=item SelfCheck

This function raises an exception if the object is not in a state
suitable to load a configuration file.  It is a pre-launch check which
is usually used internally.

Parameters:
	None

Returns:
	None

=cut
#----------------------------------------------------------------------------
sub SelfCheck
{
	my $self = $_[0];
	unless ( defined($self->{_fn}) && defined($self->{_fn}) ) {
		throw Error::Simple(sprintf('Filename not set in %s', __PACKAGE__));
	}
}
#----------------------------------------------------------------------------
=item StripComment

This function will strip remarks from lines of text.  Only one line can
be passed as a time, the function shall return the same string it is
passed, devoid of anything after and including one of several special
characters, understood to denote the start of a comment, including ';'
and '#'.  If these characters occur within a quotation, ' or ", they will be
ignored.

Parameters:
Line:
	A string from a text file, must not be undef

Returns:
	Line, stripped.  The return value is a duplicate of the string,
	the original is not overwritten.

=cut
#----------------------------------------------------------------------------
sub StripComment
{
	my $Stripped;
	my ( $self, $Line ) = @_;

	$Line =~ s/^\s+//; # Trim whitespace
	$Line =~ s/\s+$//;
	$Line =~ /^(([^;#'"]|['"][^'"]*['"])*)/ or die "Unexpected regex failure";
	$Stripped = $1;
	$Stripped =~ s/['"]//g;
	$Stripped =~ s/^\s+//; # Trim whitespace
	$Stripped =~ s/\s+$//;
	return $Stripped;
}
#----------------------------------------------------------------------------
1;