File Coverage

blib/lib/Parse/PlainConfig/Legacy.pm
Criterion Covered Total %
statement 402 434 92.6
branch 188 246 76.4
condition 48 61 78.6
subroutine 32 33 96.9
pod 13 13 100.0
total 683 787 86.7


line stmt bran cond sub pod time code
1             # Parse::PlainConfig::Legacy -- Parsing Engine Legacy for Parse::PlainConfig
2             #
3             # (c) 2002 - 2023, Arthur Corliss ,
4             #
5             # $Id: lib/Parse/PlainConfig/Legacy.pm, 3.06 2023/09/23 19:24:20 acorliss Exp $
6             #
7             # This software is licensed under the same terms as Perl, itself.
8             # Please see http://dev.perl.org/licenses/ for more information.
9             #
10             #####################################################################
11              
12             #####################################################################
13             #
14             # Environment definitions
15             #
16             #####################################################################
17              
18             package Parse::PlainConfig::Legacy;
19              
20 15     15   368916 use 5.006;
  15         167  
21              
22 15     15   84 use strict;
  15         58  
  15         525  
23 15     15   83 use warnings;
  15         32  
  15         513  
24 15     15   85 use vars qw($VERSION);
  15         38  
  15         1561  
25              
26             ($VERSION) = ( q$Revision: 3.06 $ =~ /(\d+(?:\.(\d+))+)/sm );
27              
28 15     15   6708 use Parse::PlainConfig::Constants qw(:all);
  15         38  
  15         7050  
29 15     15   7173 use Text::ParseWords;
  15         21084  
  15         962  
30 15     15   7462 use Text::Tabs;
  15         12164  
  15         1510  
31 15     15   106 use Carp;
  15         31  
  15         765  
32 15     15   86 use Fcntl qw(:flock);
  15         28  
  15         1394  
33 15     15   98 use Paranoid;
  15         29  
  15         592  
34 15     15   7805 use Paranoid::Data;
  15         32664  
  15         1004  
35 15     15   129 use Paranoid::Debug;
  15         30  
  15         1012  
36 15     15   9337 use Paranoid::Filesystem;
  15         619865  
  15         1595  
37 15     15   145 use Paranoid::Input;
  15         34  
  15         724  
38 15     15   91 use Paranoid::IO qw(:all);
  15         42  
  15         2429  
39 15     15   8382 use Paranoid::IO::Line;
  15         52990  
  15         59085  
40              
41             #####################################################################
42             #
43             # Module code follows
44             #
45             #####################################################################
46              
47             {
48             my $ERROR = '';
49              
50             sub ERROR : lvalue {
51 32     32 1 401 $ERROR;
52             }
53             }
54              
55             sub new {
56              
57             # Purpose: Creates a new object
58             # Returns: Object reference if successful, undef if not
59             # Usage: $obj = Parse::PlainConfig->new(%PARAMS);
60              
61 19     19 1 2531 my $class = shift;
62 19         265 my $self = {
63             CONF => {},
64             ORDER => [],
65             FILE => undef,
66             PARAM_DELIM => ':',
67             LIST_DELIM => ',',
68             HASH_DELIM => '=>',
69             AUTOPURGE => 0,
70             COERCE => {},
71             DEFAULTS => {},
72             SMART_PARSER => 0,
73             PADDING => 2,
74             MAX_BYTES => PPC_DEF_SIZE,
75             MTIME => 0,
76             };
77 19         72 my %args = @_;
78 19         52 my ( $k, $v, $rv );
79              
80 19         119 subPreamble( PPCDLEVEL1, '$%', $class, %args );
81              
82 19         3365 bless $self, $class;
83              
84             # Assign all the arguments
85 19         46 $rv = 1;
86 19   50     172 while ( $rv && scalar keys %args ) {
87 12         24 $k = shift @{ [ keys %args ] };
  12         42  
88 12         35 $v = $args{$k};
89 12         31 delete $args{$k};
90 12 50       42 $rv = 0 unless $self->property( $k, $v );
91             }
92              
93 19 50       74 $self = undef unless $rv;
94              
95 19         104 subPostamble( PPCDLEVEL1, '$', $self );
96              
97 19         2054 return $self;
98             }
99              
100             sub property {
101              
102             # Purpose: Gets/sets object property value
103             # Returns: Value of property in Get mode, true/false in set mode
104             # Usage: $value = $obj->property($name);
105             # Usage: $rv = $obj->property($name, $value);
106              
107 58     58 1 6620 my $self = shift;
108 58         159 my @args = @_;
109 58         108 my $arg = $_[0];
110 58         92 my $val = $_[1];
111 58 100       158 my $ival = defined $val ? $val : 'undef';
112 58         95 my $rv = 1;
113 58         103 my ( $k, $v );
114              
115             croak 'Mandatory first argument must be a valid property name'
116 58 100 66     467 unless defined $arg and exists $$self{$arg};
117              
118 57         207 subPreamble( PPCDLEVEL1, '$$', $arg, $val );
119              
120 57 100       6624 pdebug( 'method is in ' . ( scalar @args == 2 ? 'set' : 'get' ) . ' mode',
121             PPCDLEVEL1 );
122 57         1466 $arg = uc $arg;
123              
124             # Validate arguments & value
125 57 100       167 if ( scalar @args == 2 ) {
126              
127 39 100 66     348 if ( $arg eq 'ORDER' ) {
    100 100        
    100          
128              
129             # ORDER must be a list reference
130 2 100       8 unless ( ref $val eq 'ARRAY' ) {
131 1         2 $rv = 0;
132 1         3 Parse::PlainConfig::Legacy::ERROR =
133             pdebug( '%s\'s value must be a list reference',
134             PPCDLEVEL1, $arg );
135             }
136              
137             } elsif ( $arg eq 'CONF' or $arg eq 'COERCE' or $arg eq 'DEFAULTS' ) {
138              
139             # CONF, COERCE, and DEFAULTS must be a hash reference
140 7 100       28 unless ( ref $val eq 'HASH' ) {
141 1         3 $rv = 0;
142 1         3 Parse::PlainConfig::Legacy::ERROR =
143             pdebug( '%s\'s value must be a hash reference',
144             PPCDLEVEL1, $arg );
145             }
146              
147 7 100       21 if ($rv) {
148              
149 6 100       27 if ( $arg eq 'COERCE' ) {
    50          
150              
151             # Validate each key/value pair in COERCE
152 3         11 foreach ( keys %$val ) {
153 6 50       19 $ival = defined $$val{$_} ? $$val{$_} : 'undef';
154 6 100 100     29 unless ( $ival eq 'string'
      100        
155             or $ival eq 'list'
156             or $ival eq 'hash' ) {
157 1         3 Parse::PlainConfig::Legacy::ERROR = pdebug(
158             'coerced data type (%s: %s) not a string, list, or hash',
159             PPCDLEVEL1, $_, $ival
160             );
161 1         4 $rv = 0;
162             }
163             }
164             } elsif ( $arg eq 'DEFAULTS' ) {
165              
166             # Copy over the defaults into CONF (not overriding
167             # existing values)
168 3         7 while ( ( $k, $v ) = each %{ $$self{DEFAULTS} } ) {
  3         19  
169             $$self{CONF}{$k} = { 'Value' => $v }
170 0 0       0 unless exists $$self{CONF}{$k};
171             }
172             }
173             }
174              
175             # TODO: Validate properties like PADDING that have a concrete
176             # TODO: list of valid values?
177              
178             } elsif ( ref $val ne '' ) {
179              
180             # Everything else should be a scalar value
181 1         14 $rv = 0;
182 1         5 Parse::PlainConfig::Legacy::ERROR =
183             pdebug( '%s\'s value must be a scalar value',
184             PPCDLEVEL1, $arg );
185             }
186             }
187              
188             # Set the value if all's kosher
189 57 100       161 if ($rv) {
190 53 100       131 if ( scalar @args == 2 ) {
191              
192             # Assign the value
193 35 100       142 if ( ref $val eq 'ARRAY' ) {
    100          
194              
195             # Copy array contents in
196 1         4 $$self{$arg} = [@$val];
197              
198             } elsif ( ref $val eq 'HASH' ) {
199              
200             # Copy hash contents in
201 5         6624 $$self{$arg} = {%$val};
202              
203             } else {
204              
205             # Assign the scalar value
206 29         89 $$self{$arg} = $val;
207             }
208             } else {
209              
210             # Copy the value
211 18 100 100     75 if ( defined $$self{$arg} and ref $$self{$arg} ne '' ) {
212             $rv =
213             ref $$self{$arg} eq 'ARRAY' ? []
214 2 50       11 : ref $$self{$arg} eq 'HASH' ? {}
    100          
215             : undef;
216 2 50       5 if ( defined $rv ) {
217 2 50       8 unless ( deepCopy( $$self{$arg}, $rv ) ) {
218 0         0 Parse::PlainConfig::Legacy::ERROR =
219             pdebug( 'failed to copy data from %s: %s',
220             PPCDLEVEL1, Paranoid::ERROR, $arg );
221             }
222             } else {
223             Parse::PlainConfig::Legacy::ERROR =
224             pdebug( 'I don\'t know how to copy %s (%s)',
225 0         0 PPCDLEVEL1, $$self{$arg}, $arg );
226             }
227             } else {
228 16         28 $rv = $$self{$arg};
229             }
230             }
231             }
232              
233 57         934 subPostamble( PPCDLEVEL1, '$', $rv );
234              
235 57         5567 return $rv;
236             }
237              
238             sub purge {
239              
240             # Purpose: Performs a manual purge of internal data
241             # Returns: True
242             # Usage: $obj->purge;
243              
244 9     9 1 379 my $self = shift;
245 9         20 my ( $k, $v );
246              
247 9         34 subPreamble( PPCDLEVEL1, '$', $self );
248              
249             # First, purge all existing values
250 9         863 delete @{ $$self{CONF} }{ keys %{ $$self{CONF} } };
  9         80  
  9         55  
251              
252             # Second, apply default values
253 9         25 while ( ( $k, $v ) = each %{ $$self{DEFAULTS} } ) {
  12         61  
254 3         8 $$self{CONF}{$k} = { 'Value' => $v };
255             }
256              
257 9         34 subPostamble( PPCDLEVEL1, '$', 1 );
258              
259 9         830 return 1;
260             }
261              
262             sub read {
263              
264             # Purpose: Reads either the passed filename or an internally recorded one
265             # Returns: True or false depending on success of read & parse
266             # Usage: $rv = $obj->read;
267             # Usage: $rv = $obj->read($filename);
268              
269 26     26 1 242 my $self = shift;
270 26   66     109 my $file = shift || $$self{FILE};
271 26         64 my $rv = 0;
272 26         106 my $oldSize = PIOMAXFSIZE;
273 26         104 my ( $line, @lines );
274              
275 26 50       170 croak 'Optional first argument must be a defined filename or the FILE '
276             . 'property must be set'
277             unless defined $file;
278              
279 26         97 subPreamble( PPCDLEVEL1, '$$', $self, $file );
280              
281             # Reset the error string and update the internal filename
282 26         3097 Parse::PlainConfig::Legacy::ERROR = '';
283 26         66 $$self{FILE} = $file;
284              
285             # Temporarily set the specified size limit
286 26         78 PIOMAXFSIZE = $$self{MAX_BYTES};
287              
288             # Store the file's current mtime
289 26         685 $$self{MTIME} = ( stat $file )[MTIME];
290              
291 26 50       201 if ( detaint( $file, 'filename' ) ) {
292 26 100       10216 if ( slurp( $file, @lines, 1 ) ) {
293              
294             # Empty the current config hash and key order
295 25 100       148269 $self->purge if $$self{AUTOPURGE};
296              
297             # Parse the rc file's lines
298 25         138 $rv = $self->_parse(@lines);
299              
300             } else {
301 1         4467 Parse::PlainConfig::Legacy::ERROR =
302             pdebug( Paranoid::ERROR, PPCDLEVEL1 );
303             }
304             } else {
305 0         0 Parse::PlainConfig::Legacy::ERROR =
306             pdebug( 'Filename failed detaint check', PPCDLEVEL1 );
307             }
308              
309             # Restore old size limit
310 26         125 PIOMAXFSIZE = $oldSize;
311              
312 26         146 subPostamble( PPCDLEVEL1, '$', $rv );
313              
314             # Return the result code
315 26         2593 return $rv;
316             }
317              
318             sub readIfNewer ($) {
319              
320             # Purpose: Performs a file read/parse if the file is newer than last read
321             # Returns: 1 if read/parse was successful, 2 if file is the same age, 0
322             # on any errors
323             # Usage: $rv = $obj->readIfNewer;
324              
325 3     3 1 4001087 my $self = shift;
326 3         29 my $file = $$self{FILE};
327 3         22 my $omtime = $$self{MTIME};
328 3         17 my $rv = 0;
329 3         16 my $mtime;
330              
331 3 50       38 croak 'The FILE property must be set' unless defined $file;
332              
333 3         39 subPreamble( PPCDLEVEL1, '$', $self );
334              
335             # Try to read the file
336 3 100 66     1219 if ( -e $file && -r _ ) {
337              
338             # File exists and appears to be readable, get the mtime
339 2         30 $mtime = ( stat _ )[MTIME];
340 2         23 pdebug( 'current mtime: %s last: %s', PPCDLEVEL2, $mtime, $omtime );
341              
342             # Read the file if it's newer, or return 2
343 2 100       322 $rv = $mtime > $omtime ? $self->read : 2;
344              
345             } else {
346              
347             # Report errors
348 1         12 Parse::PlainConfig::Legacy::ERROR =
349             pdebug( 'file (%s) does not exist or is not readable',
350             PPCDLEVEL1, $file );
351             }
352              
353 3         22 subPostamble( PPCDLEVEL1, '$', $rv );
354              
355             # Return the result code
356 3         500 return $rv;
357             }
358              
359             sub write {
360              
361             # Purpose: Writes the file to disk
362             # Returns: True/False depending on success of write
363             # Usage: $rv = $obj->write;
364             # Usage: $rv = $obj->write($filename);
365              
366 5     5 1 91 my $self = shift;
367 5   66     28 my $file = shift || $$self{FILE};
368 5         13 my $padding = shift;
369 5         17 my $conf = $$self{CONF};
370 5         13 my $order = $$self{ORDER};
371 5         12 my $coerce = $$self{COERCE};
372 5         14 my $smart = $$self{SMART_PARSER};
373 5         14 my $paramDelim = $$self{PARAM_DELIM};
374 5         13 my $hashDelim = $$self{HASH_DELIM};
375 5         11 my $listDelim = $$self{LIST_DELIM};
376 5         12 my $rv = 0;
377 5         11 my $tw = DEFAULT_TW;
378 5         86 my $delimRegex = qr/(?:\Q$hashDelim\E|\Q$listDelim\E)/sm;
379 5         47 my ( @forder, $type, $param, $value, $description, $entry, $out );
380 5         0 my ( $tmp, $tvalue, $lines, $fh );
381              
382             # TODO: Implement non-blocking flock support
383             # TODO: Store read padding and/or use PADDING property value
384              
385 5 50       32 croak 'Optional first argument must be a defined filename or the FILE '
386             . 'property must be set'
387             unless defined $file;
388              
389 5 50       31 $padding = 2 unless defined $padding;
390 5 100       23 $tw -= 2 unless $smart;
391              
392 5         27 subPreamble( PPCDLEVEL1, '$$$', $self, $file, $padding );
393              
394             # Pad the delimiter as specified
395 5 50       786 $paramDelim =
    50          
    50          
396             $padding == 0 ? $paramDelim
397             : $padding == 1 ? " $paramDelim"
398             : $padding == 2 ? "$paramDelim "
399             : " $paramDelim ";
400 5         23 pdebug( 'PARAM_DELIM w/padding is \'%s\'', PPCDLEVEL2, $paramDelim );
401              
402             # Create a list of parameters for output
403 5         235 @forder = @$order;
404 5         75 foreach $tmp ( sort keys %$conf ) {
405 51 100       1018 push @forder, $tmp
406             unless grep /^\Q$tmp\E$/sm, @forder;
407             }
408 5         33 pdebug( "order of params to be written:\n\t%s", PPCDLEVEL2, @forder );
409              
410             # Compose the new output
411 5         523 $out = '';
412 5         21 foreach $param (@forder) {
413              
414             # Determine the datatype
415 51 50       208 $value = exists $$conf{$param} ? $$conf{$param}{Value} : '';
416             $description =
417 51 50       128 exists $$conf{$param} ? $$conf{$param}{Description} : '';
418             $type =
419 51 100       170 exists $$coerce{$param} ? $$coerce{$param}
    100          
    100          
420             : ref $value eq 'HASH' ? 'hash'
421             : ref $value eq 'ARRAY' ? 'list'
422             : 'string';
423 51         155 pdebug( 'adding %s param (%s)', PPCDLEVEL2, $type, $param );
424              
425             # Append the comments
426 51         2404 $out .= $description;
427 51 50       218 $out .= "\n" unless $out =~ /\n$/sm;
428              
429             # Start the new entry with the parameter name and delimiter
430 51         99 $entry = "$param$paramDelim";
431              
432             # Append the value, taking into consideration the smart parser
433             # and coercion settings
434 51 100       159 if ( $type eq 'string' ) {
    100          
435              
436             # String type
437 29         59 $tvalue = $value;
438 29 100 100     117 unless ( $smart && exists $$coerce{$param} ) {
439 19         44 $tvalue =~ s/"/\\"/smg;
440 19 100       152 $tvalue = "\"$tvalue\"" if $tvalue =~ /$delimRegex/sm;
441             }
442 29         74 $lines = "$entry$tvalue";
443              
444             } elsif ( $type eq 'list' ) {
445              
446             # List type
447 17         65 $tvalue = [@$value];
448 17         59 foreach (@$tvalue) {
449 54         123 s/"/\\"/smg;
450 54 100 66     147 if ( $smart && exists $$coerce{$param} ) {
451 20 100       78 $_ = "\"$_\"" if /\Q$listDelim\E/sm;
452             } else {
453 34 100       185 $_ = "\"$_\"" if /$delimRegex/sm;
454             }
455             }
456 17         71 $lines = $entry . join " $listDelim ", @$tvalue;
457              
458             } else {
459              
460             # Hash type
461 5         31 $tvalue = {%$value};
462 5         32 foreach ( keys %$tvalue ) {
463 20         38 $tmp = $_;
464 20         39 $tmp =~ s/"/\\"/smg;
465 20 50       83 $tmp = "\"$tmp\"" if /$delimRegex/sm;
466 20 50       49 if ( $tmp ne $_ ) {
467 0         0 $$tvalue{$tmp} = $$tvalue{$_};
468 0         0 delete $$tvalue{$_};
469             }
470 20         42 $$tvalue{$tmp} =~ s/"/\\"/smg;
471             $$tvalue{$tmp} = "\"$$tvalue{$tmp}\""
472 20 100       106 if $$tvalue{$tmp} =~ /$delimRegex/sm;
473             }
474             $lines = $entry
475             . join " $listDelim ",
476 5         38 map {"$_ $hashDelim $$tvalue{$_}"} sort keys %$tvalue;
  20         70  
477             }
478              
479             # wrap the output to the column width and append to the output
480 51 100       161 $out .= _wrap( '', "\t", $tw, ( $smart ? "\n" : "\\\n" ), $lines );
481 51 50       308 $out .= "\n" unless $out =~ /\n$/sm;
482             }
483              
484             # Write the file
485 5 50       55 if ( detaint( $file, 'filename' ) ) {
486 5 50       2290 if ( open $fh, '>', $file ) {
487              
488             # Write the file
489 5         84 flock $fh, LOCK_EX;
490 5 50       105 if ( print $fh $out ) {
491 5         16 $rv = 1;
492             } else {
493 0         0 Parse::PlainConfig::Legacy::ERROR = $!;
494             }
495 5         234 flock $fh, LOCK_UN;
496 5         193 close $fh;
497              
498             # Store the new mtime on successful writes
499 5 50       128 $$self{MTIME} = ( stat $file )[MTIME] if $rv;
500              
501             } else {
502              
503             # Report the errors
504 0         0 Parse::PlainConfig::Legacy::ERROR =
505             pdebug( 'error writing file: %s', PPCDLEVEL1, $! );
506             }
507             } else {
508              
509             # Detainting filename failed
510 0         0 Parse::PlainConfig::Legacy::ERROR =
511             pdebug( 'illegal characters in filename: %s', PPCDLEVEL1, $file );
512             }
513              
514 5         41 subPostamble( PPCDLEVEL1, '$', $rv );
515              
516 5         648 return $rv;
517             }
518              
519             sub parameters {
520              
521             # Purpose: Returns a list of all parsed parameters
522             # Returns: List of parameter names with configure values
523             # Usage: @params = $obj->parameters;
524              
525 11     11 1 118 my $self = shift;
526 11         23 my @parameters = keys %{ $$self{CONF} };
  11         58  
527              
528 11         44 pdebug( 'called method -- rv: %s', PPCDLEVEL1, @parameters );
529              
530 11         735 return @parameters;
531             }
532              
533             sub parameter {
534              
535             # Purpose: Gets/sets named parameter
536             # Returns: True/false in set mode, Parameter value in get mode
537             # Usage: $rv = $obj->parameter($name);
538             # Usage: $rv = $obj->parameter($name, $value);
539              
540 77     77 1 3003643 my $self = shift;
541 77         209 my @args = @_;
542 77         129 my $param = $args[0];
543 77         122 my $value = $args[1];
544 77 100       185 my $ivalue = defined $value ? $value : 'undef';
545 77         172 my $conf = $$self{CONF};
546 77         123 my $listDelim = $$self{LIST_DELIM};
547 77         135 my $hashDelim = $$self{HASH_DELIM};
548 77         124 my $paramDelim = $$self{PARAM_DELIM};
549             my $coerceType =
550             exists $$self{COERCE}{$param}
551 77 100       200 ? $$self{COERCE}{$param}
552             : 'undef';
553 77         124 my $defaults = $$self{DEFAULTS};
554 77         124 my $rv = 1;
555 77         649 my $delimRegex = qr/(?:\Q$hashDelim\E|\Q$listDelim\E)/sm;
556 77         174 my ( $finalValue, @elements );
557              
558             # TODO: Consider storing a list/hash padding value as well, for use
559             # TODO: in coercion to string.
560              
561 77 50       210 croak 'Mandatory firest argument must be a defined parameter name'
562             unless defined $param;
563              
564 77         264 subPreamble( PPCDLEVEL1, '$$$', $self, $param, $ivalue );
565              
566 77 100       9399 if ( scalar @args == 2 ) {
567 37         114 pdebug( 'method in set mode', PPCDLEVEL1 );
568              
569             # Create a blank record if it hasn't been defined yet
570             $$conf{$param} = {
571             Value => '',
572             Description => '',
573             }
574 37 100       1008 unless exists $$conf{$param};
575              
576             # Start processing value assignment
577 37 100       96 if ( $coerceType ne 'undef' ) {
578 32         104 pdebug( 'coercing into %s', PPCDLEVEL2, $coerceType );
579              
580             # Parameter has a specific data type to be coerced into
581 32 100 100     1469 if ( $coerceType eq 'string' && ref $value ne '' ) {
    100 100        
    100 100        
582              
583             # Coerce values into strings
584 3 100       36 if ( ref $value eq 'ARRAY' ) {
    50          
585              
586             # Convert lists into a string using the list delimiter
587 2         12 foreach (@$value) {
588 7         17 s/"/\\"/smg;
589 7 50       51 $_ = "\"$_\"" if /\Q$listDelim\E/sm;
590             }
591 2         19 $finalValue = join " $listDelim ", @$value;
592              
593             } elsif ( ref $value eq 'HASH' ) {
594              
595             # Convert hashes into a string using the hash & list
596             # delimiters
597 1         9 foreach ( sort keys %$value ) {
598 2         5 $ivalue = $_;
599 2         3 $ivalue =~ s/"/\\"/smg;
600 2 50       30 $ivalue = "\"$ivalue\""
601             if /(?:\Q$hashDelim\E|\Q$listDelim\E)/sm;
602 2 50       12 $$value{$_} = '' unless defined $$value{$_};
603             $$value{$_} = "\"$$value{$_}\""
604 2 50       25 if $$value{$_} =~
605             /(?:\Q$hashDelim\E|\Q$listDelim\E)/sm;
606             push @elements,
607             join " $hashDelim ", $_,
608 2 50       12 ( defined $$value{$_} ? $$value{$_} : '' );
609             }
610 1         8 $finalValue = join " $listDelim ", @elements;
611              
612             } else {
613              
614             # Try to stringify everything else
615 0         0 $finalValue = "$value";
616             }
617              
618             } elsif ( $coerceType eq 'list' && ref $value ne 'ARRAY' ) {
619              
620             # Coerce value into a list
621 3 100       11 if ( ref $value eq 'HASH' ) {
    50          
622              
623             # Convert hashes into a list
624 2         5 $finalValue = [];
625 2         13 foreach ( sort keys %$value ) {
626 4         12 push @$finalValue, $_, $$value{$_};
627             }
628              
629             } elsif ( ref $value eq '' ) {
630              
631             # Convert strings into a list
632 1         24 $self->_parse(
633             split /\n/sm,
634             "$$conf{$param}{Description}\n"
635             . "$param $paramDelim $value"
636             );
637 1         3 $finalValue = $$conf{$param}{Value};
638              
639             } else {
640              
641             # Stringify everything else and put it into an array
642 0         0 $finalValue = ["$value"];
643             }
644              
645             } elsif ( $coerceType eq 'hash' && ref $value ne 'HASH' ) {
646              
647             # Coerce value into a hash
648 3 100       26 if ( ref $value eq 'ARRAY' ) {
    50          
649              
650             # Convert a list into a hash using every two elements
651             # as a key/value pair
652 1 50       9 push @$value, ''
653             unless int( scalar @$value / 2 ) ==
654             scalar @$value / 2;
655 1         4 $finalValue = {@$value};
656              
657             } elsif ( ref $value eq '' ) {
658              
659             # Convert strings into a hash
660 2         24 $self->_parse(
661             split /\n/sm,
662             "$$conf{$param}{Description}\n"
663             . "$param $paramDelim $value"
664             );
665 2         12 $finalValue = $$conf{$param}{Value};
666              
667             } else {
668              
669             # Stringify everything else and put the value into the
670             # hash key
671 0         0 $finalValue = { "$value" => '' };
672             }
673              
674             } else {
675              
676             # No coercion is necessary
677 23         48 $finalValue = $value;
678             }
679              
680             } else {
681 5         25 pdebug( 'no coercion to do', PPCDLEVEL2 );
682 5         149 $finalValue = $value;
683             }
684 37         115 $$conf{$param}{Value} = $finalValue;
685              
686             } else {
687 40         119 pdebug( 'method in retrieve mode', PPCDLEVEL1 );
688             $rv =
689             exists $$conf{$param} ? $$conf{$param}{Value}
690 40 50       1062 : exists $$defaults{$param} ? $$defaults{$param}
    100          
691             : undef;
692             }
693              
694 77         274 subPostamble( PPCDLEVEL1, '$', $rv );
695              
696 77 100       7086 return ref $rv eq 'HASH' ? (%$rv) : ref $rv eq 'ARRAY' ? (@$rv) : $rv;
    100          
697             }
698              
699             sub coerce {
700              
701             # Purpose: Assigns the passed list to a data type and attempts to
702             # coerce each existing value into that data type.
703             # Returns: True or false.
704             # Usage: $rv = $obj->coerce($type, @fields);
705              
706 21     21 1 538 my $self = shift;
707 21         39 my $type = shift;
708 21 50       54 my $itype = defined $type ? $type : 'undef';
709 21         56 my @params = @_;
710 21         39 my $rv = 1;
711              
712 21 50 100     123 croak 'Mandatory first argument must be "string", "list", or "hash"'
      66        
713             unless $itype eq 'string'
714             or $itype eq 'list'
715             or $itype eq 'hash';
716 21 50       64 croak 'Remaining arguments must be defined parameter names'
717             unless @params;
718              
719 21         74 subPreamble( PPCDLEVEL1, '$$@', $self, $type, @params );
720              
721 21         2540 foreach (@params) {
722 45 50       91 if (defined) {
723              
724             # Mark the parameter
725 45         105 $$self{COERCE}{$_} = $type;
726             $self->parameter( $_, $$self{CONF}{$_}{Value} )
727 45 100       142 if exists $$self{CONF}{$_};
728             } else {
729              
730             # Report undefined parameter names
731 0         0 Parse::PlainConfig::Legacy::ERROR =
732             pdebug( 'passed undefined parameter names to coerce',
733             PPCDLEVEL1 );
734 0         0 $rv = 0;
735             }
736             }
737              
738 21         85 subPostamble( PPCDLEVEL1, '$', $rv );
739              
740 21         1927 return $rv;
741             }
742              
743             sub describe {
744              
745             # Purpose: Assigns descriptive comments to specific parameters
746             # Returns: True
747             # Usage: $obj->describe(%descriptions);
748              
749 0     0 1 0 my $self = shift;
750 0         0 my $conf = $$self{CONF};
751 0         0 my $coerce = $$self{COERCE};
752 0         0 my %new = (@_);
753              
754 0         0 subPreamble( PPCDLEVEL1, '$', $self );
755              
756             # TODO: Consider allowing comment tags to be specified
757              
758             # TODO: Consider line splitting and comment tag prepending where
759             # TODO: it's not already done.
760              
761 0         0 foreach ( keys %new ) {
762 0         0 pdebug( '%s is described as \'%s\'', PPCDLEVEL1, $_, $new{$_} );
763 0 0       0 unless ( exists $$conf{$_} ) {
764 0         0 $$conf{$_} = {};
765 0 0       0 if ( exists $$coerce{$_} ) {
766             $$conf{$_}{Value} =
767             $$coerce{$_} eq 'list' ? []
768 0 0       0 : $$coerce{$_} eq 'hash' ? {}
    0          
769             : '';
770             } else {
771 0         0 $$conf{$_}{Value} = '';
772             }
773             }
774 0         0 $$conf{$_}{Description} = $new{$_};
775             }
776              
777 0         0 subPostamble( PPCDLEVEL1, '$', 1 );
778              
779 0         0 return 1;
780             }
781              
782             sub order {
783              
784             # Purpose: Gets/sets order of parameters in file
785             # Returns: Ordered list of named parameters
786             # Usage: @params = $obj->order;
787             # Usage: @params = $obj->order(@newOrder);
788              
789 2     2 1 22 my $self = shift;
790 2         5 my $order = $$self{ORDER};
791 2         6 my @new = (@_);
792              
793 2         6 pdebug( 'entering w/(%s)', PPCDLEVEL1, @new );
794              
795 2 100       123 @$order = (@new) if scalar @new;
796              
797 2         10 pdebug( 'leaving w/rv: %s', PPCDLEVEL1, @$order );
798              
799 2         113 return @$order;
800             }
801              
802             sub _parse {
803              
804             # Purpose: Parses the passed list of lines and extracts comments,
805             # fields, and values and storing everything into the CONF
806             # hash
807             # Returns: True or false
808             # Usage: $rv = $obj->_parse(@lines);
809              
810 28     28   93 my $self = shift;
811 28         67 my $conf = $$self{CONF};
812 28         62 my $order = $$self{ORDER};
813 28         239 my $smart = $$self{SMART_PARSER};
814 28         83 my $tagDelim = $$self{PARAM_DELIM};
815 28         68 my $hashDelim = $$self{HASH_DELIM};
816 28         57 my $listDelim = $$self{LIST_DELIM};
817 28         176 my @lines = @_;
818 28         56 my $rv = 1;
819 28         82 my ( $i, $line, $comment, $entry, $field, $value );
820 28         0 my ( $indentation, $data, $saveEntry );
821              
822             # Make sure some of the properties are sane
823             croak 'LIST_DELIM and HASH_DELIM cannot be the same character sequence!'
824 28 50       107 unless $$self{LIST_DELIM} ne $$self{HASH_DELIM};
825              
826 28         109 subPreamble( PPCDLEVEL1, '$', $self );
827              
828             # Flatten lines using an explicit backslash
829 28         3042 for ( $i = 0; $i <= $#lines; $i++ ) {
830              
831             # Let's disable uninitialized warnings since there's a few
832             # places here we really don't care
833 15     15   139 no warnings 'uninitialized';
  15         35  
  15         21056  
834              
835 685 100       1815 if ( $lines[$i] =~ /\\\s*$/sm ) {
836 174         546 pdebug( 'joining lines %s & %s', PPCDLEVEL2, $i + 1, $i + 2 );
837              
838             # Lop off the trailing whitespace and backslash, preserving
839             # only one space on the assumption that if it's there it's a
840             # natural word break.
841 174         9048 $lines[$i] =~ s/(\s)?\s*\\\s*$/$1/sm;
842              
843             # Concatenate the following line (if there is one) after stripping
844             # off preceding whitespace
845 174 50       454 if ( $i < $#lines ) {
846 174         586 $lines[ $i + 1 ] =~ s/^\s+//sm;
847 174         396 $lines[$i] .= $lines[ $i + 1 ];
848 174         311 splice @lines, $i + 1, 1;
849 174         415 --$i;
850             }
851             }
852             }
853              
854             $saveEntry = sub {
855              
856             # Saves the extracted data into the conf hash and resets
857             # the vars.
858              
859 244     244   356 my ($type);
860              
861 244         2209 ( $field, $value ) =
862             ( $entry =~ /^\s*([^$tagDelim]+?)\s*\Q$tagDelim\E\s*(.*)$/sm );
863 244         795 pdebug( "saving data:\n\t(%s: %s)", PPCDLEVEL2, $field, $value );
864              
865 244 100       10280 if ( exists $$self{COERCE}{$field} ) {
866              
867             # Get the field data type from COERCE
868 27         76 $type = $$self{COERCE}{$field};
869              
870             } else {
871              
872             # Otherwise, try to autodetect data type
873 217 100       1321 $type =
    100          
874             scalar quotewords( qr/\s*\Q$hashDelim\E\s*/sm, 0, $value ) > 1
875             ? 'hash'
876             : scalar quotewords( qr/\s*\Q$listDelim\E\s*/sm, 0, $value ) >
877             1 ? 'list'
878             : 'scalar';
879             }
880 244         61914 pdebug( 'detected type of %s is %s', PPCDLEVEL2, $field, $type );
881              
882             # For all data types we should strip leading/trailing whitespace.
883             # If they really want it they should quote it.
884 244 100       13109 $value =~ s/^\s+|\s+$//smg unless $type eq 'scalar';
885              
886             # We'll apply quotewords to scalar values only if the smart parser is
887             # not being used or if we're not coercing all values into scalar for
888             # this field.
889             #
890             # I hate having to do this but I was an idiot in the previous versions
891             # and this is necessary for backwards compatibility.
892 244 100       744 if ( $type eq 'scalar' ) {
    100          
    100          
893             $value = join '',
894             quotewords( qr/\s*\Q$listDelim\E\s*/sm, 0, $value )
895             unless $smart
896             && exists $$self{COERCE}{$field}
897 112 50 66     857 && $$self{COERCE}{$field} eq 'scalar';
      33        
898             } elsif ( $type eq 'hash' ) {
899 30         479 $value = {
900             quotewords(
901             qr/\s*(?:\Q$hashDelim\E|\Q$listDelim\E)\s*/sm, 0,
902             $value
903             ) };
904             } elsif ( $type eq 'list' ) {
905 88         699 $value = [ quotewords( qr/\s*\Q$listDelim\E\s*/sm, 0, $value ) ];
906             }
907              
908             # Create the parameter record
909 244         25380 $$conf{$field} = {};
910 244         605 $$conf{$field}{Value} = $value;
911 244         499 $$conf{$field}{Description} = $comment;
912 244 100       4196 push @$order, $field unless grep /^\Q$field\E$/sm, @$order;
913 244         958 $comment = $entry = '';
914 28         224 };
915              
916             # Process lines
917 28         74 $comment = $entry = '';
918 28         119 while ( defined( $line = shift @lines ) ) {
919              
920 511 100       2262 if ( $line =~ /^\s*(?:#.*)?$/sm ) {
921              
922             # Grab comments and blank lines
923 208         625 pdebug( "comment/blank line:\n\t%s", PPCDLEVEL3, $line );
924              
925             # First save previous entries if $entry has content
926 208 100 50     8347 &$saveEntry() and $i = 0 if length $entry;
927              
928             # Save the comments
929 208 100       843 $comment = length($comment) > 0 ? "$comment$line\n" : "$line\n";
930              
931             } else {
932              
933             # Grab configuration lines
934              
935             # If this is the first line of a new entry and there's no
936             # PARAM_DELIM skip the line -- something must be wrong.
937             #
938             # TODO: Error out/raise exception
939 303 50 66     1505 unless ( length $entry || $line =~ /\Q$tagDelim\E/sm ) {
940 0         0 pdebug( "skipping spurious text:\n\t%s", PPCDLEVEL3, $line );
941 0         0 next;
942             }
943              
944             # Grab indentation characters and line content
945 303         1305 ( $indentation, $data ) = ( $line =~ /^(\s*)(.+)$/sm );
946 303         926 pdebug( "data line:\n\t%s", PPCDLEVEL3, $data );
947              
948 303 100       11993 if ($smart) {
949              
950             # Smart parsing is enabled
951              
952 121 100       215 if ( length $entry ) {
953              
954             # There's current content
955              
956 96 100       178 if ( length($indentation) > $i ) {
957              
958             # If new indentation is greater than original
959             # indentation we concatenate the lines as a
960             # continuation
961 59         177 $entry .= $data;
962              
963             } else {
964              
965             # Otherwise we treat this a a new entry, so we save
966             # the old and store the current
967 37         82 &$saveEntry();
968 37         132 ( $i, $entry ) = ( length($indentation), $data );
969             }
970              
971             } else {
972              
973             # No current content, so just store the current data and
974             # continue processing
975 25         86 ( $i, $entry ) = ( length($indentation), $data );
976             }
977              
978             } else {
979              
980             # Smart parsing is disabled, so treat every line as a new
981             # entry
982 182         300 $entry = $data;
983 182         330 &$saveEntry();
984             }
985             }
986             }
987 28 100       129 &$saveEntry() if length $entry;
988              
989 28         111 subPostamble( PPCDLEVEL1, '$', $rv );
990              
991 28         3197 return $rv;
992             }
993              
994             sub _wrap {
995              
996             # Purpose: Parses the passed line of test and inserts indentation and
997             # line breaks as needed
998             # Returns: Formated string
999             # Usage: $out = $obj->_wrap($fIndent, $sIndent, $textWidth,
1000             # $lineBreak, $paragraph);
1001              
1002 51     51   105 my $firstIndent = shift;
1003 51         84 my $subIndent = shift;
1004 51         81 my $textWidth = shift;
1005 51         85 my $lineBreak = shift;
1006 51         94 my $paragraph = shift;
1007 51         84 my ( @lines, $segment, $output );
1008              
1009 51         163 subPreamble( PPCDLEVEL2, '$$$$p', $firstIndent, $subIndent,
1010             $textWidth, $lineBreak, $paragraph
1011             );
1012              
1013             # Expand tabs in everything -- sorry everyone
1014 51         8450 ($firstIndent) = expand($firstIndent);
1015 51         1016 ($subIndent) = expand($subIndent);
1016 51         1543 $paragraph = expand("$firstIndent$paragraph");
1017              
1018 51         841 $lines[0] = '';
1019 51         143 while ( length($paragraph) > 0 ) {
1020              
1021             # Get the next string segment (splitting on whitespace)
1022 614         2056 ($segment) = ( $paragraph =~ /^(\s*\S+\s?)/sm );
1023              
1024 614 100       1398 if ( length $segment <= $textWidth - length $lines[-1] ) {
    100          
1025              
1026             # The segment will fit appended to the current line,
1027             # concatenate it
1028 576         990 $lines[-1] .= $segment;
1029              
1030             } elsif ( length $segment <= $textWidth - length $subIndent ) {
1031              
1032             # The segment will fit into the next line, add it
1033 23         44 $lines[-1] .= $lineBreak;
1034 23         57 push @lines, "$subIndent$segment";
1035              
1036             } else {
1037              
1038             # Else, split on the text width
1039 15 50       60 $segment =
1040             $#lines == 0
1041             ? substr $paragraph, 0, $textWidth
1042             : substr $paragraph, 0, $textWidth - length $subIndent;
1043 15 50       38 if ( length $segment > $textWidth - length $lines[-1] ) {
1044 15         32 $lines[-1] .= $lineBreak;
1045 15 50       49 push @lines,
1046             ( $#lines == 0 ? $segment : "$subIndent$segment" );
1047             } else {
1048 0         0 $lines[-1] .= $segment;
1049             }
1050             }
1051 614         839 $paragraph =~ s/^.{@{[length($segment)]}}//sm;
  614         5858  
1052             }
1053 51         134 $lines[-1] .= "\n";
1054              
1055 51         167 $output = join '', @lines;
1056              
1057 51         180 subPostamble( PPCDLEVEL1, 'p', $output );
1058              
1059 51         5189 return $output;
1060             }
1061              
1062             sub hasParameter {
1063              
1064             # Purpose: Checks to see if the specified parameter exists as a
1065             # configuration parameter
1066             # Returns: True or false
1067             # Usage: $rv = $obj->hasParameter($name);
1068              
1069 3     3 1 77 my $self = shift;
1070 3         6 my $param = shift;
1071 3         5 my $rv = 0;
1072 3         5 my @params = ( keys %{ $self->{CONF} }, keys %{ $self->{DEFAULTS} }, );
  3         13  
  3         10  
1073              
1074 3 50       10 croak 'Mandatory first parameter must be a defined parameter name'
1075             unless defined $param;
1076              
1077 3         12 subPreamble( PPCDLEVEL1, '$$', $self, $param );
1078              
1079 3         389 $rv = scalar grep /^\Q$param\E$/sm, @params;
1080              
1081 3         13 subPostamble( PPCDLEVEL1, '$', $rv );
1082              
1083 3         329 return $rv;
1084             }
1085              
1086             1;
1087              
1088             __END__