C:\Andy\Dev\Perl\Pitonyak\ConfigFileParser.pm

1 package Pitonyak::ConfigFileParser;
 2 #************************************************************
 3
 4 =head1 NAME
 5
 6 Pitonyak::ConfigFileParser - Handle a configuration file.
 7
 8 =head1 SYNOPSIS
 9
 10 =begin html
 11
 12 <code>
 13 use Pitonyak::ConfigFileParser; 
 14 
 15 my $cfg = new Pitonyak::ConfigFileParser(); 
 16 $cfg->read_config_file('./modules/sample.cfg'); 
 17 print 'keys = ('.join(', ', $cfg->get_keys()).")\n"; 
 18 </code>
 19
 20 =end html
 21
 22 =head1 DESCRIPTION
 23
 24 One might argue that this is nothing more than a light wrapper to read a
 25 configuration file into a hash. The C<< read_config_file method() >>
 26 is pretty smart at processing the file to increase ease of use.
 27
 28 The configuration/properties file contains lines of the form:
 29
 30 C<< <left hand side> = <right hand side> >>
 31
 32 The following parsing rules are used:
 33
 34 =over 4
 35
 36 =item Blank lines are ignored.
 37
 38 =item # is a comment character.
 39
 40 =item Replace ${key} with the key value in the hash.
 41
 42 =item The equal sign separates the keys from the values.
 43
 44 =item leading and trailing space is removed.
 45
 46 =item space around the equal sign is removed.
 47
 48 =item Use a backslash as the escape character
 49
 50 =back
 51
 52 Use the escape character to insert special characters such as the comment, $,
 53 character, equal sign, leading or trailing space, or an escape character.
 54 Escaping characters with no special meaning, such as an 'a', evaluates to
 55 the character 'a'.
 56
 57 You can prevent substitution of ${key} text by using \${key}.
 58 Substitution is done before escape characters are removed. So,the sequence
 59 ${\key} looks to see if there is a key named '\key' for replacement.
 60
 61 Consider the following configuration:
 62
 63 =begin html
 64
 65 <code>
 66 file_base = ./files/ 
 67 partner = john 
 68 ${partner}.loc = ${file_base}${partner}/ 
 69 </code>
 70
 71 =end html
 72
 73 This is equivalent to
 74
 75 =begin html
 76
 77 <code>
 78 file_base = ./files/ 
 79 partner = john 
 80 john.loc = ./files/john/ 
 81 </code>
 82
 83 =end html
 84
 85 =head1 Copyright
 86
 87 Copyright 1998-2007 by Andrew Pitonyak
 88
 89 More reworked code from Andrew's library. As with most of my
 90 code libraries, the code is free as free can be.
 91
 92 =cut
 93
 94 #************************************************************
 95
 96 require Exporter;
 97 $VERSION = '1.02';
 98 @ISA = qw(Exporter);
 99 @EXPORT = qw(
100 );
101
102 @EXPORT_OK = qw(
103 clear
104 clear_key_value
105 config_path
106 config_name
107 copy
108 contains_key
109 get_class_attribute
110 get_config_full_name
111 get_delimited_values
112 get_keys
113 get_hash_ref
114 get_value
115 get_value_default
116 new
117 read_config_file
118 set_key_value
119 set_logger
120 );
121
122 use Carp;
123 use IO::File;
124 use strict;
125 use Pitonyak::DeepCopy qw(deep_copy);
126 use Pitonyak::ADPLogger;
127 use Pitonyak::StringUtil qw(trim_space);
128
129 my %initial_attributes = (
130 'is_ok' => 1, # Has an error occured?
131 'config_name' => 'configfile.cfg',
132 'config_path' => './',
133 );
134
135 #************************************************************
136
137 =pod
138
139 =head2 clear
140
141 =over 4
142
143 =item C<< $cfg->clear() >>
144
145 Clear the entire configuration hash.
146
147 =back
148
149 =cut
150
151 #************************************************************
152 sub clear()
153 {
154 if ($#_ == 0 && UNIVERSAL::isa( $_[0], 'ConfigFileParser' ))
155 {
156 # fastest way to clear a hash is to assign it to an empty list.
157 ${$_[0]->{'config_hash'}} = ();
158 }
159 }
160
161 #************************************************************
162
163 =pod
164
165 =head2 clear_key_value
166
167 =over 4
168
169 =item C<< $cfg->clear_key_value('key_text') >>
170
171 Clear the specified key so that it is no longer in the configuration hash.
172
173 =back
174
175 =cut
176
177 #************************************************************
178
179 sub clear_key_value()
180 {
181 if ($#_ > 0 && UNIVERSAL::isa( $_[0], 'ConfigFileParser' ))
182 {
183 udef( $_[0]->{'config_hash'}->{$_[1]});
184 }
185 }
186
187 #************************************************************
188
189 =pod
190
191 =head2 config_name
192
193 The config_name is the name of the configuration file with the file extension.
194 The full file name is built by concatinating C<< config_path() >> and C<< config_name() >>.
195 The extension is not assumed because it might be '.cfg' or '.properties'.
196
197 =over 4
198
199 =item C<< config_name() >>
200
201 Return the default file name with file extension.
202
203 =item C<< $cfg->config_name() >>
204
205 Return the base log file name for the log object.
206
207 =item C<< $cfg->config_name(file_name) >>
208
209 Set the file name with extension, used for the next read.
210
211 =back
212
213 =cut
214
215 #************************************************************
216
217 sub config_name
218 {
219 return get_class_attribute( @_, 'config_name' );
220 }
221
222 #************************************************************
223
224 =pod
225
226 =head2 config_path
227
228 The config_path identifies the directory containing the log file.
229 The full file name is built by concatinating C<< config_path() >> and C<< config_name() >>.
230
231 =over 4
232
233 =item C<< config_path() >>
234
235 Return the default path during initialization, which is './'.
236
237 =item C<< $cfg->config_path() >>
238
239 Return the the path to the next configuration file to read.
240 Reading a configuration file with a fully specified file name
241 does not cause the path or the file name to be set.
242
243 =item C<< $cfg->config_path(path) >>
244
245 Set the path for the configuration file, which will be used for the next read
246 operation if the file name is not specified.
247 If the provided path does not contain '/' or '\', then '/' is appended to
248 to the path. The path itself is not checked for validity.
249
250 If the provided path is an empty string, then the path is set to the
251 default value.
252
253 =back
254
255 =cut
256
257 #************************************************************
258
259 sub config_path
260 {
261 # If zero arguments, return the initial value.
262 return $initial_attributes{ 'config_path' } if $#_ < 0;
263
264 # If one argument, assume the object is correct and return
265 # the current path.
266 return $_[0]->{ 'config_path' } if $#_ == 0;
267
268 my $obj = shift;
269 my $value = shift;
270
271 if ($value =~ /[\/\\]$/)
272 {
273 $obj->{ 'config_path' } = $value;
274 }
275 elsif ($value eq '')
276 {
277 $obj->{ 'config_path' } = $initial_attributes{ 'config_path' };
278 }
279 else
280 {
281 $obj->{ 'config_path' } = $value.'/';
282 }
283
284 return $obj->{ 'config_path' };
285 }
286
287 #************************************************************
288
289 =pod
290
291 =head2 copy
292
293 =over 4
294
295 =item copy($config_object)
296
297 Make a copy of one ConfigFileParser into another
298
299 C<$obj1->copy($obj2)> is the same as C<$obj1 = $obj2>.
300 The file handle is not copied and the
301 the receiving ConfigFileParser is closed first.
302
303 =back
304
305 =cut
306
307 #************************************************************
308
309 sub copy
310 {
311 foreach my $key ( keys %initial_attributes )
312 {
313 if ($key eq 'logger')
314 {
315 # A normal copy is not sufficient.
316 # I would need to literally generate a copy, but I
317 # see no need to copy the logger.
318 }
319 elsif ( UNIVERSAL::isa( $_[1]->{$key}, 'HASH' ) )
320 {
321 # If I simply copy it over then we both reference the same thing!
322 $_[0]->{$key} = deep_copy( $_[1]->{$key} );
323 }
324 else
325 {
326 $_[0]->{$key} = $_[1]->{$key};
327 }
328 }
329 }
330
331 #************************************************************
332
333 =pod
334
335 =head2 contains_key
336
337 =over 4
338
339 =item C<< $cfg->contains_key(key_name) >>
340
341 Return 1 if the hash contains the key name and 0 otherwise.
342
343 =back
344
345 =cut
346
347 #************************************************************
348
349 sub contains_key()
350 {
351 if (($#_ > 0) && UNIVERSAL::isa( $_[0], 'ConfigFileParser' ))
352 {
353 return defined($_[0]->{'config_hash'}->{$_[1]}) ? 1 : 0;
354 }
355 carp('You must include a key name, such as $obj->contains_key("joe")');
356 return 0;
357 }
358
359 #************************************************************
360
361 =pod
362
363 =head2 get_class_attribute
364
365 The get_class_attribute method utilizes the fact that
366 C<< $obj->method(@parms) >> is the same as
367 C<< method($obj, @parms) >>. This method does not perform type checking
368 to verify that this is true.
369
370 The C<get_class_attribute> method is rarely called directly.
371
372 =over 4
373
374 =item C<< Pitonyak::ADPLogger::get_class_attribute($attribute_name) >>
375
376 With only one paramter, the first parameter is
377 assumed to be an attribute name and the default attribute value
378 is returned.
379
380 =item C<< $obj->get_class_attribute($attribute_name) >>
381
382 With two arguments, the first is assumed
383 to be a C<ADPLogger> object and the second is
384 assumed to be an attribute name.
385 The attribute value for the object is returned.
386
387
388 =item C<< $obj->get_class_attribute($attribute_value, $attribute_name) >>
389
390 With three arguments, the first is assumed to be the object,
391 the second is a new attribute value, and the third is the attribute
392 name to set. Although the order seems odd, this is intentional.
393
394 Consider the method C<< is_ok >> defined as C<< return get_class_attribute( @_, 'is_ok' ); >>
395
396 Remember that C<@_> refers to the argument list passed to the method. In all cases, the last argument
397 passed to C<get_class_attribute> is the attribute name. If the method is called directly,
398 this is the only argument.
399
400 =back
401
402 =cut
403
404 #************************************************************
405
406 sub get_class_attribute
407 {
408 return $initial_attributes{ $_[0] } if $#_ == 0;
409 return $_[0]->{ $_[1] } if $#_ == 1;
410 $_[0]->{ $_[2] } = $_[1];
411 return $_[1];
412 }
413
414 #************************************************************
415
416 =pod
417
418 =head2 get_config_full_name
419
420 =over 4
421
422 =item C<< $cfg->get_config_full_name() >>
423
424 Build and return the full path to the configuration file.
425 Remember that C<< $cfg->config_path() >>
426 returns a string with a trailing '/', so the value returned is equivalent to:
427
428 C<< $cfg->config_path().$cfg->config_name() >>
429
430 =back
431
432 =cut
433
434 #************************************************************
435
436 sub get_config_full_name()
437 {
438 $_[0]->{'config_path'}.$_[0]->{'config_name'};
439 }
440
441 #************************************************************
442
443 =pod
444
445 =head2 get_hash_ref
446
447 =over 4
448
449 =item C<< $cfg->get_hash_ref() >>
450
451 Return a reference to the hash containing the properties.
452 For example, to obtain the value for the key 'peter', you
453 can use C<< $cfg->get_hash_ref()->{'peter'} >> or
454 C<< $cfg->get_value('peter') >>.
455
456 =back
457
458 =cut
459
460 #************************************************************
461 sub get_hash_ref()
462 {
463 return $_[0]->{'config_hash'} if $#_ >= 0 && UNIVERSAL::isa( $_[0], 'ConfigFileParser' );
464 }
465
466 #************************************************************
467
468 =pod
469
470 =head2 get_keys
471
472 =over 4
473
474 =item C<< $cfg->get_keys() >>
475
476 Return the keys in the hash as an array.
477 This is equivalent to
478 C<< keys(%{$cfg->get_hash_ref()}) >>.
479
480 =back
481
482 =cut
483
484 #************************************************************
485
486 sub get_keys()
487 {
488 return keys %{$_[0]->{'config_hash'}} if $#_ >= 0 && UNIVERSAL::isa( $_[0], 'ConfigFileParser' );
489 }
490
491 #************************************************************
492
493 =pod
494
495 =head2 get_value
496
497 =over 4
498
499 =item C<< $cfg->get_value('key') >>
500
501 Return the property value for the specified key.
502 To obtain the value for the key 'peter', you
503 can use C<< $cfg->get_hash_ref()->{'peter'} >> or
504 C<< $cfg->get_value('peter') >>.
505
506 =back
507
508 =cut
509
510 #************************************************************
511
512 sub get_value
513 {
514 return $_[0]->{'config_hash'}->{$_[1]} if $#_ > 0 && UNIVERSAL::isa( $_[0], 'ConfigFileParser' );
515 }
516
517 #************************************************************
518
519 =pod
520
521 =head2 get_value_default
522
523 =over 4
524
525 =item C<< $cfg->get_value_default('key') >>
526
527 This version is identical to C<< $cfg->get_value_default('key') >>,
528 except that it returns an empty string if the key does not exist.
529
530 =item C<< $cfg->get_value_default('key', 'default') >>
531
532 If the property exists, return the value. If the property
533 does not exist, return the specified default value.
534
535 =back
536
537 =cut
538
539 #************************************************************
540
541 sub get_value_default
542 {
543 if ( $#_ > 0 && UNIVERSAL::isa( $_[0], 'ConfigFileParser' ))
544 {
545 return $_[0]->{'config_hash'}->{$_[1]} if defined($_[0]->{'config_hash'}->{$_[1]});
546 }
547 return ($#_ > 1) ? $_[2] : '';
548 }
549
550
551 #************************************************************
552
553 =pod
554
555 =head2 get_delimited_values
556
557 =over 4
558
559 =item C<< $cfg->get_delimited_values('key') >>
560
561 Omitting the delimiter is the same as calling
562 C<< $cfg->get_delimited_values('key', ',') >>.
563
564 =item C<< $cfg->get_delimited_values('key', 'delimiter') >>
565
566 Extract the specified key from the configuration item.
567 Assume that the key contains a list of items delimited with the
568 specified delimiter.
569 Leading and trailing spaces are removed.
570 All of the values are returned as an array.
571
572 =back
573
574 =cut
575
576 #************************************************************
577
578 sub get_delimited_values
579 {
580 my @array;
581 if ($#_ > 0 && UNIVERSAL::isa( $_[0], 'ConfigFileParser' ))
582 {
583 my $obj = shift;
584 my $name = shift;
585 my $delim = ',';
586 $delim = shift if $#_ >= 0;
587 return @array if not defined($obj->{'config_hash'}->{$name});
588 return map {trim_space($_)} split(',', $obj->{'config_hash'}->{$name});
589 }
590 return @array;
591 }
592
593 #************************************************************
594
595 =pod
596
597 =head2 new
598
599 =over 4
600
601 =item C<< $cfg_copy = $cfg->new() >>
602
603 Generate a new copy of a configuration object.
604
605 =back
606
607 =cut
608
609 #************************************************************
610
611 sub new
612 {
613 my $self = shift;
614 my $objref = bless {}, ref($self) || $self;
615 $objref->initialize();
616 if ( ref($self) )
617 {
618 $objref->copy($self);
619 }
620 return $objref;
621 }
622
623 #************************************************************
624
625 =pod
626
627 =head2 read_config_file
628
629 Read a config/properties file from disk and populate this object.
630 The current object is cleared reading the file.
631 Any current values are over-written.
632
633 =over 4
634
635 =item C<< $cfg->read_config_file() >>
636
637 The directory
638 and name must be set using C<config_path()> and C<config_name()>.
639 C<get_config_full_name()> is used to build the full path.
640
641 =item C<< $cfg->read_config_file('full_path_to_file') >>
642
643 Neither C<config_path()> nor C<config_name()> are updated.
644
645 =back
646
647 =cut
648
649 #************************************************************
650
651 sub read_config_file()
652 {
653 if ( $#_ < 0 || !UNIVERSAL::isa( $_[0], 'ConfigFileParser' ))
654 {
655 carp('Usage: obj->read_config_file() or obj->read_config_file(<config_file_name>)');
656 return undef;
657 }
658 my $log = $_[0]->{'config_hash'}->{'logger'} if defined( $_[0]->{'config_hash'}->{'logger'} );
659
660 # Either build the full name, or take it from the argument.
661 my $file_name = ($#_ > 0) ? $_[1] : $_[0]->get_config_full_name();
662
663 # First, read the entire file into an array.
664 # Remove comments, blank lines, as well as leading and trailing white space.
665 my $rc = 0;
666 my $line = 0;
667 my $handle = new IO::File;
668 my ($key, $value);
669 if ( not $handle->open( '<' . $file_name ) )
670 {
671 carp("Unable to open configuration file $file_name because $!");
672 return undef;
673 }
674 else
675 {
676 while (<$handle>)
677 {
678 $key = '';
679 $value = '';
680 ++$line;
681 chomp;
682 s/^\s*//; # leading spaces
683 #
684 # This one is more difficult....
685 # s/(.*?(?<!\\)(?:(\\\\)*))#.*/$1/
686 #
687 # .*? include all preceding text minimally
688 # (?<!\\) Do not allow a preceding backslash
689 # (?:(\\\\)*)) Match any groups of two backslashes
690 # #.* Match a # followed by anything
691 #
692 # This effectively considers the first # not preceded by
693 # an odd number of \ to be a comment.
694 #
695 if ($] >= 5.005)
696 {
697 s/(.*?(?<!\\)(?:(\\\\)*))#.*/$1/;
698 s/(?<!\\)\s*$//; # Trailing spaces not preceded by a \
699
700 # Look for substition values of the form ${key_name}.
701 # Replace these values with entries that have already been read.
702 while (/(?<!\\)\${(.*?)}/)
703 {
704 my $subst_name = $1;
705 my $subst_value = defined($_[0]->{'config_hash'}->{$subst_name}) ? $_[0]->{'config_hash'}->{$subst_name} : '';
706 $log->trace("Config line $line: Replace $subst_name with $subst_value") if defined ($log);
707 s/(?<!\\)(\${.*?})/$subst_value/;
708 }
709
710 if ($_ ne '') # Ignore empty lines
711 {
712 # Ignore lines that do not contain '='
713 if (/(.*?(?<!\\)(?:(\\\\)*))=(.*)$/)
714 {
715 $key = $1;
716 $value = $3;
717 $key =~ s/(?<!\\)\s*$//; # Trailing spaces not preceded by a \
718 $value =~ s/^\s*//; # Leading spaces on the value.
719 $key =~ s/\\(.)/$1/g; # Now remove \ chars
720 $value =~ s/\\(.)/$1/g; # Now remove \ chars
721
722 # Although it might be argued that this is not the best time for this,
723 # property substitution is done now.
724
725 $_[0]->{'config_hash'}->{$key} = $value;
726 $log->trace("Config line $line: ($key)=($value)") if defined ($log);
727 }
728 else
729 {
730 my $error_msg = "Line $line does not contain the '=' character";
731 carp($error_msg);
732 $log->trace($error_msg) if defined ($log);
733 }
734 }
735 }
736 else
737 {
738 my $error_msg = 'Please use a version of perl newer than 5.004';
739 carp($error_msg);
740 $log->trace($error_msg) if defined ($log);
741 return undef;
742 s/(.*?)#.*/$1/; # ?? This is WRONG but supported by perl 5.004
743 s/\s*$//; # ?? This is WRONG but supported by perl 5.004
744 }
745 #s/\\(.)/$1/g; # Now remove \ chars
746 }
747 $handle->close();
748 }
749 return $rc;
750 }
751
752 #************************************************************
753
754 =pod
755
756 =head2 set_key_value
757
758 =over 4
759
760 =item C<< $cfg->set_key_value(key, value) >>
761
762 Set the specified key to the specified value.
763
764 =back
765
766 =cut
767
768 #************************************************************
769 sub set_key_value()
770 {
771 return $_[0]->{'config_hash'}->{$_[1]} = $_[2] if $#_ > 1 && UNIVERSAL::isa( $_[0], 'ConfigFileParser' );
772 }
773
774 #************************************************************
775
776 =pod
777
778 =head2 set_logger
779
780 =over 4
781
782 =item C<< $cfg->set_logger($log) >>
783
784 Add a logger to the ConfigFileParser. If the logger is present, it is
785 used to report errors and trace information.
786
787 =back
788
789 =cut
790
791 #************************************************************
792
793 sub set_logger()
794 {
795 if ($#_ >= 0 && UNIVERSAL::isa( $_[0], 'ConfigFileParser' ))
796 {
797 if ($#_ > 0)
798 {
799 if ( UNIVERSAL::isa( $_[1], 'ADPLogger' ) )
800 {
801 $_[0]->{'config_hash'}->{'logger'} = $_[1];
802 }
803 else
804 {
805 carp('The argument to set_logger must be of type Logger');
806 }
807 }
808 else
809 {
810 udef( $_[0]->{'config_hash'}->{'logger'} );
811
812 }
813 }
814 }
815
816 #************************************************************
817
818 =pod
819
820 =head1 Private Methods
821
822 =head2 initialize
823
824 =over 4
825
826 =item C<< initialize() >>
827
828 The C<< initialize() >> method is called automatically when an object is created.
829 The new method also calls C<< initialize() >> directly
830
831 Initialize the data structure by copying values from the initial attributes hash
832 into the newly created object. Finally, set the read properties hash to
833 an empty reference.
834
835 =back
836
837 =cut
838
839 #************************************************************
840
841 sub initialize
842 {
843 foreach my $key ( keys %initial_attributes )
844 {
845 if ( UNIVERSAL::isa( $initial_attributes{$key}, 'HASH' ) )
846 {
847 # If I simply copy it over then we both reference the same thing!
848 $_[0]->{$key} = deep_copy( $initial_attributes{$key} );
849 }
850 else
851 {
852 $_[0]->{$key} = $initial_attributes{$key};
853 }
854 }
855
856 # Set the initial reference to the configuration hash (will hold file values).
857 $_[0]->{'config_hash'} = {};
858 }
859
860 #************************************************************
861 #** **
862 #** Input : None. **
863 #** **
864 #** Output: None. **
865 #** **
866 #** Notes : Nothing to destroy or close, but just in case.**
867 #** **
868 #************************************************************
869
870 sub DESTROY
871 {
872 }
873
874 1;