File Coverage

blib/lib/RSH/ConfigFile.pm
Criterion Covered Total %
statement 312 390 80.0
branch 79 148 53.3
condition 23 56 41.0
subroutine 25 30 83.3
pod 19 19 100.0
total 458 643 71.2


line stmt bran cond sub pod time code
1             # ------------------------------------------------------------------------------
2             # Copyright © 2003 by Matt Luker. All rights reserved.
3             #
4             # Revision:
5             #
6             # $Header$
7             #
8             # ------------------------------------------------------------------------------
9              
10             =head1 NAME
11              
12             RSH::ConfigFile - Configuration File
13              
14             =head1 SYNOPSIS
15              
16             use RSH::ConfigFile;
17              
18             my $config = new RSH::ConfigFile filename => 'foo.config';
19             $config->load();
20             my $setting = $config->{setting};
21             $config->{setting} = 'new value';
22             $config->save();
23              
24             =head1 ABSTRACT
25              
26             RSH::ConfigFile is a configuration file that uses standard text
27             'key = value' lines, where value can be a string, an array, or
28             a hash.
29              
30             =head1 DESCRIPTION
31              
32             While using XML and YAML are both possible solutions
33             for a config file syntax, both suffer from having very specific syntax,
34             punctuation, or whitespace requirements. This module seeks to
35             use a simple, more robust config file syntax. In addition to
36             having simple "key = value" syntax, values can also be more
37             complex structures.
38              
39             This format is not a replacement for XML, YAML, or dump formats.
40             It seeks to be simple and readable while providing the ability to
41             specify slightly more complicated values then just plain strings.
42              
43             =cut
44              
45             package RSH::ConfigFile;
46              
47 2     2   26814 use 5.008;
  2         7  
  2         84  
48 2     2   12 use strict;
  2         4  
  2         64  
49 2     2   13 use warnings;
  2         3  
  2         116  
50              
51             use overload
52 2         18 '""' => \&string,
53 2     2   1976 '%{}' => \&get_hash;
  2         1190  
54              
55              
56 2     2   1080 use FileHandle;
  2         14473  
  2         14  
57 2     2   2959 use File::Copy "cp";
  2         5883  
  2         138  
58 2     2   13 use Digest::MD5;
  2         5  
  2         72  
59 2     2   688 use RSH::Exception;
  2         6  
  2         296  
60 2     2   12182 use RSH::SmartHash;
  2         6  
  2         45  
61 2     2   459 use RSH::LockFile;
  2         6  
  2         134  
62 2     2   19 use RSH::FileUtil qw(get_filehandle);
  2         3  
  2         10384  
63              
64             require Exporter;
65              
66             =head2 EXPORT
67              
68             None by default.
69              
70             =cut
71              
72             our @ISA = qw(Exporter);
73              
74             # Items to export into callers namespace by default. Note: do not export
75             # names by default without a very good reason. Use EXPORT_OK instead.
76             # Do not simply export all your public functions/methods/constants.
77              
78             our @EXPORT_OK = qw(
79             );
80              
81             our @EXPORT = qw(
82            
83             );
84              
85             our $VERSION = '1.0.10';
86              
87             # ******************** PUBLIC Class Methods ********************
88              
89             =head2 CLASS METHODS
90              
91             =over
92              
93             =cut
94              
95             =item serialize_value()
96              
97             Converts the value into a string.
98              
99             =cut
100              
101             sub serialize_value {
102 61     61 1 2169 my %args = @_;
103              
104 61         97 my $value = $args{value};
105 61 50       306 if (not defined($value)) { $value = ''; }
  0         0  
106              
107 61 50       123 if (not defined($args{no_quotes})) { $args{no_quotes} = 0; }
  61         107  
108 0   0     0 else { $args{no_quotes} = $args{no_quotes} && 1; }
109              
110             # If it is an array reference
111 61 100       177 if (ref($value) eq 'ARRAY') {
    100          
112 17         21 my @contents = @{$value};
  17         64  
113 17         58 for (my $i = 0; $i < scalar(@contents); $i++) {
114 44 50 33     193 if ( (not $args{no_quotes}) && ($contents[$i] !~ m/^'.*'$/) ) { $contents[$i] = "'". $contents[$i] ."'"; }
  44         158  
115             }
116 17         36 my $str = "[ ";
117 17         49 $str .= join ", ", @contents;
118 17         25 $str .= " ]";
119 17         72 return $str;
120             }
121             # If it is a hash reference
122             elsif (ref($value) eq 'HASH') {
123 12         18 my @contents;
124             my $val;
125 12         19 foreach my $key (sort keys %{$value}) {
  12         72  
126 24         46 $val = $value->{$key};
127 24 50 33     118 if ( (not $args{no_quotes}) && ($val !~ m/^'.*'$/) ) { $val = "'". $val ."'"; }
  24         49  
128 24         82 push @contents, "$key => $val";
129             }
130 12         34 my $str = "{ ";
131 12         35 $str .= join ", ", @contents;
132 12         17 $str .= " }";
133 12         61 return $str;
134             }
135             # Otherwise it is just a scalar/string
136             else {
137 32 50 33     141 if ( (not $args{no_quotes}) && ($value !~ m/^'.*'$/) ) { $value = "'". $value ."'"; }
  32         83  
138 32         110 return $value;
139             }
140             }
141              
142             =item unserialize_value()
143              
144             Tries to unserialize a string into a value.
145              
146             =cut
147              
148             sub unserialize_value {
149 38     38 1 4589 my $str = shift;
150              
151             # print STDERR "# RSH::ConfigFile::unserialize_value(): \$str == [[$str]]\n";
152 38         70 my $val = undef;
153             # Is it an array?
154 38 100       151 if ($str =~ m/^\[(.*)\]$/) {
    100          
155             # print STDERR "# RSH::ConfigFile::unserialize_value(): ARRAY value match\n";
156 11         29 $val = [];
157 11         31 my $str = $1;
158 11         21 $str =~ s/\\,/\\;/;
159 11         45 my @contents = split /,/, $str;
160 11         37 for (my $i = 0; $i < scalar(@contents); $i++) {
161 28         52 $contents[$i] =~ s/\\;/,/;
162 28 50       139 if ($contents[$i] =~ m/^\s*'?(.*?)'?\s*$/) { $contents[$i] = $1; }
  28         99  
163             }
164 11         49 return \@contents;
165             }
166             # Is it a hash?
167             elsif ($str =~ m/^\{(.*)\}$/) {
168             # print STDERR "# RSH::ConfigFile::unserialize_value(): HASH value match\n";
169 7         14 $val = {};
170 7         20 my $str = $1;
171 7         13 $str =~ s/\\,/\\;/;
172 7         29 my @contents = split /,/, $str;
173 7         9 my ($key, $val);
174 0         0 my %content_hash;
175 7         22 for (my $i = 0; $i < scalar(@contents); $i++) {
176 14         30 $contents[$i] =~ s/\\;/,/;
177 14         36 ($key, $val) = split /=>/, $contents[$i];
178 14 50 33     106 if (defined($key) && ($key =~ m/^\s*'?(.*?)'?\s*$/)) { $key = $1; }
  14         33  
179 14 50 33     94 if (defined($val) && ($val =~ m/^\s*'?(.*?)'?\s*$/)) { $val = $1; }
  14         25  
180             # Only act on defined key values for hash
181 14 50       30 if (defined($key)) { $content_hash{$key} = $val; }
  14         53  
182             }
183 7         32 return \%content_hash;
184             }
185             # Otherwise, treat it as a string
186             else {
187             # print STDERR "# RSH::ConfigFile::unserialize_value(): default to STRING value match\n";
188 20         28 $val = $str;
189 20 100       79 if ($val =~ m/^\s*'(.*?)'\s*$/) { $val = $1; }
  15         34  
190             # Otherwise we just assume it is a string without quotes
191 20         63 return $val;
192             }
193             }
194              
195             =item load_config()
196              
197             Factory method; takes a filename, creates a config object, and loads from the file, returning
198             the freshly loaded config object.
199              
200             =cut
201              
202             sub load_config {
203 0     0 1 0 my $filename = shift;
204              
205 0         0 my $config = RSH::ConfigFile->new($filename);
206 0         0 my $success = $config->load();
207 0 0       0 if ($success) { return $config; }
  0         0  
208 0 0       0 if (not $success) { die "Error loading config for file \"$filename\". ERROR: ". $config->error(); }
  0         0  
209             }
210              
211             =back
212              
213             =cut
214              
215             # ******************** Constructor Methods ********************
216              
217             =head2 CONSTRUCTORS
218              
219             =over
220              
221             =cut
222              
223             =item new(%ARGS)
224              
225             Creates a new RSH::ConfigFile object. C<%ARGS> contains
226             arguments to use in initializing the new instance.
227              
228             Params:
229              
230             filename => filename to load from
231             default => reference to a hash to use for default values
232             (will not be saved to file)
233             values => reference to a hash to use for values
234              
235             B<Returns:> A new RSH::ConfigFile object.
236              
237             =cut
238              
239             sub new {
240 2     2 1 1277 my $class = shift;
241 2         8 my %params = @_;
242 2         7 my $filename = $params{filename};
243 2         5 my $default_ref = $params{default};
244 2         4 my $hash_ref = $params{values};
245              
246 2 50       9 if (not defined($default_ref)) { $default_ref = {}; }
  2         5  
247 2 50       6 if (not defined($hash_ref)) { $hash_ref = {}; }
  2         6  
248              
249 2         4 my $dirty = 0;
250 2 50       4 if (%{$hash_ref}) { $dirty = 1; }
  2         13  
  0         0  
251              
252 2         24 tie my %hash, 'RSH::SmartHash', default => $default_ref, values => $hash_ref, dirty => 1;
253            
254 2         4 my $self = {};
255 2         5 $self->{filename} = $filename;
256 2         12 $self->{hash} = \%hash;
257 2         3 $self->{error} = undef;
258 2         5 $self->{warning} = undef;
259 2         4 $self->{file_md5} = undef;
260 2 50 33     12 if (defined($params{no_follow}) && ($params{no_follow} eq '1')) {
261 0         0 $self->{no_follow} = 1;
262             } else {
263 2         60 $self->{no_follow} = 0;
264             }
265 2 50 33     11 if (defined($params{no_quotes}) && ($params{no_quotes} eq '1')) {
266 0         0 $self->{no_quotes} = 1;
267             } else {
268 2         5 $self->{no_quotes} = 0;
269             }
270 2 50 33     9 if (defined($params{compact}) && ($params{compact} eq '1')) {
271 0         0 $self->{compact} = 1;
272             } else {
273 2         6 $self->{compact} = 0;
274             }
275              
276 2         4 bless $self, $class;
277            
278 2         7 return $self;
279             }
280              
281             =back
282              
283             =cut
284              
285             # ******************** PUBLIC Instance Methods ********************
286              
287             =head2 INSTANCE METHODS
288              
289             =cut
290              
291             # ******************** Accessor Methods ********************
292              
293             =head3 Accessors
294              
295             =over
296              
297             =cut
298              
299              
300             =item is_dirty()
301              
302             Read-only accessor for the object's dirty flag. The dirty flag is set
303             whenever a value is changed for the object's hash values.
304              
305             =cut
306              
307             sub is_dirty {
308 4     4 1 8 my $self = shift;
309              
310 4         6 return tied(%{$self->get_hash})->is_dirty();
  4         11  
311             }
312              
313             =item filename()
314              
315             Read-write accessor for filename attribute
316              
317             =cut
318              
319             sub filename {
320 4     4 1 170 my $self = shift;
321 4         7 my $val = shift;
322              
323 4 100       12 if (defined($val)) {
324 2         8 my $old_val = $self->get_hash_val('filename');
325 2         8 $self->set_hash_val('filename', $val);
326 2 100 66     29 if ( (defined($old_val)) and ($old_val ne $val) ) {
327 1         5 $self->set_hash_val('file_md5', undef);
328 1         2 tied(%{$self->get_hash})->dirty(1);
  1         4  
329             }
330             }
331            
332 4         11 return $self->get_hash_val('filename');
333             }
334              
335             =item error()
336              
337             Read-only accessor for error attribute. Error is set when an error occurs on
338             save or load. If a load or save returns false for success, you can check this
339             attribute for the reason why.
340              
341             =cut
342              
343             sub error {
344 4     4 1 1591 my $self = shift;
345            
346 4         16 return $self->get_hash_val('error');
347             }
348              
349             =item warning()
350              
351             Read-only accessor for warning attribute. Warning is set when an warning occurs on
352             save or load. If a load or save returns false for success, you can check this
353             attribute for the reason why.
354              
355             =cut
356              
357             sub warning {
358 4     4 1 631 my $self = shift;
359            
360 4         13 return $self->get_hash_val('warning');
361             }
362              
363             =item md5()
364              
365             Read-only accessor for md5 attribute.
366              
367             =cut
368              
369             sub md5 {
370 10     10 1 5732 my $self = shift;
371            
372 10         34 return $self->get_hash_val('file_md5');
373             }
374              
375             =item no_follow()
376              
377             Read-only accessor for no_follow attribute.
378              
379             =cut
380              
381             sub no_follow {
382 0     0 1 0 my $self = shift;
383 0         0 my $val = shift;
384              
385 0 0       0 if (defined($val)) {
386 0   0     0 $self->{no_follow} = ($val && 1);
387             }
388              
389 0         0 return $self->{no_follow};
390             }
391              
392             =item no_quotes()
393              
394             Read-only accessor for no_quotes attribute.
395              
396             =cut
397              
398             sub no_quotes {
399 0     0 1 0 my $self = shift;
400 0         0 my $val = shift;
401              
402 0 0       0 if (defined($val)) {
403 0   0     0 $self->{no_quotes} = ($val && 1);
404             }
405              
406 0         0 return $self->{no_quotes};
407             }
408              
409             =item compact()
410              
411             Read-only accessor for compact attribute.
412              
413             =cut
414              
415             sub compact {
416 0     0 1 0 my $self = shift;
417 0         0 my $val = shift;
418              
419 0 0       0 if (defined($val)) {
420 0   0     0 $self->{compact} = ($val && 1);
421             }
422              
423 0         0 return $self->{compact};
424             }
425              
426             =back
427              
428             =cut
429              
430             # ******************** Functionality ********************
431              
432             =head3 Functionality
433              
434             =over
435              
436             =cut
437              
438             # ******************** Serialization ********************
439              
440             =item load()
441              
442             Loads the configuration object from a filename.
443              
444             Params:
445              
446             filename => (optional) the file to load from
447              
448             returns: 1 on success, 0 on failure, with exceptions for exceptionally bad errors
449              
450             =cut
451              
452             sub load {
453 3     3 1 944 my $self = shift;
454 3         9 my %params = @_;
455 3         7 my $filename = $params{filename};
456              
457 3         13 $self->set_hash_val('error', undef);
458 3         8 $self->set_hash_val('warning', undef);
459              
460 3 50       10 if (not defined($params{force})) { $params{force} = 0; }
  3         8  
461 3 50       9 if (not defined($params{no_follow})) { $params{no_follow} = $self->{no_follow}; }
  3         13  
462              
463 3 100       13 if (not defined($filename)) { $filename = $self->get_hash_val('filename'); }
  2         5  
464 3 50       9 if (not defined($filename)) {
465 0         0 die new RSH::CodeException message => "Filename is not defined for this config object."
466             }
467              
468 3 50       104 if (not -e $filename) {
469 0         0 die new RSH::FileNotFoundException message => "File \"$filename\" does not exist.";
470             }
471              
472 3         31 my $md5 = new Digest::MD5;
473 3         7 eval {
474 3         17 my $FILE = get_filehandle($filename, 'READ', no_follow => $params{no_follow});
475 3         9 tied(%{$self->get_hash})->CLEAR();
  3         9  
476             # $self->set_hash_val('hash', {}); # reinitialize values--do we want this?
477            
478 3         20 my $key = "";
479 3         8 my $value = "";
480 3         81 while (<$FILE>) {
481 38         129 $md5->add($_); # add, as is, first, so our md5 jibes with the real contents of the file
482 38         58 s/(.*)\r\n$/$1\n/; # we hatesez the Windowsez! Hates it we do!! This happens in w2k3 server
483             # and w2k server perl installations when they get confused about file modes
484             # s/(.*)\r$/$1\n/; # Same thing might happen on a Mac, but I doubt it :-)
485 38 100 66     297 if ((! m/^\s*#.*/) && (m/(\S*)\s*=\s*(\S*)/)) {
486             # suck up next line while current line ends in "\"
487 33         88 while (m/^.*\\\s*$/) {
488 6         20 my $temp = <$FILE>; # grab the next line
489 6 100       22 if (defined($temp)) {
490 5         17 $md5->add($temp);
491 5 100       17 if ($temp !~ m/^\s*#.*/) {
492 4         22 s/^(.*)\\\s*$/$1/; # trim off the trailing \
493 4         16 $_ .= $temp;
494             }
495             } else {
496 1         16 s/^(.*)\\\s*$/$1/; # trim off the trailing \
497 1         3 last; # get out of the loop
498             }
499             }
500 33         172 ($key, $value) = (m/(\S*)\s*=\s*(\S*.*)/);
501 33 50       87 if (defined($key)) {
502 33         75 $self->{$key} = unserialize_value($value);
503             }
504             }
505             }
506 3         63 close $FILE;
507 3         20 my $digest = $md5->hexdigest;
508             #print "# ConfigFile::load(): new md5 for load == $digest\n";
509 3         9 $self->set_hash_val('file_md5', $digest);
510             };
511 3 50       10 if ($@) {
512 0         0 $self->set_hash_val('error', $@);
513 0         0 return 0;
514             }
515              
516 3         6 tied(%{$self->get_hash})->dirty(0);
  3         7  
517 3         24 return 1;
518             }
519              
520             =item save()
521              
522             Saves the values in this config object to the file. If the file exists, formatting will be
523             preserved, with new values being added at the end.
524              
525             Params:
526             filename - (optional) the file to save to
527             force - (optional) 1, force save, 0, rely on dirty flag; method assumes force => 0
528              
529             returns: 1 on success, 0 on failure, with exceptions for exceptionally bad errors
530              
531             =cut
532              
533             sub save {
534 4     4 1 6395 my $self = shift;
535 4         26 my %params = @_;
536 4         12 my $filename = $params{filename};
537              
538 4         22 $self->set_hash_val('error', undef);
539 4         13 $self->set_hash_val('warning', undef);
540              
541 4 100       20 if (not defined($params{force})) { $params{force} = 0; }
  2         6  
542 4 50       14 if (not defined($params{no_follow})) { $params{no_follow} = $self->{no_follow}; }
  4         30  
543 4 50       19 if (not defined($params{no_quotes})) { $params{no_quotes} = $self->{no_quotes}; }
  4         9  
544 4 50       98 if (not defined($params{compact})) { $params{compact} = $self->{compact}; }
  4         10  
545              
546             # If a filename is supplied and it is NOT equal to the filename attribute, assume "always save"
547 4 50 33     21 if ( (defined($filename)) && ($filename ne $self->get_hash_val('filename')) ) { $params{force} = 1; }
  0         0  
548              
549             # If not dirty and we are not forcing a save, stop processing and return success.
550 4 100 66     18 if ((not $self->is_dirty) && (not $params{force}) ) { return 1; }
  1         5  
551              
552 3 50       10 if (not defined($filename)) { $filename = $self->get_hash_val('filename'); }
  3         8  
553 3 50       9 if (not defined($filename)) {
554 0         0 die new RSH::CodeException message => "Filename is not defined for this config object.";
555             }
556              
557 3 100       95 if (not -e $filename) {
558 1 50       4 if (defined($self->get_hash_val('file_md5'))) {
559 0         0 my $ex = new RSH::DataIntegrityException message => "Loaded from file, but saving to empty file.";
560 0 0       0 if (not $params{force}) { die $ex; }
  0         0  
561 0         0 else { $self->set_hash_val('warning', $ex); }
562             }
563             # if file does not exist, don't worry about any formatting
564 1         3 eval {
565 1         11 my $lock = RSH::LockFile->new($filename);
566 1         7 $lock->lock(no_follow => $params{no_follow});
567              
568 1         6 my $FILE = get_filehandle("$filename", 'WRITE', no_follow => $params{no_follow});
569 1         3 my $key = "";
570 1         2 my $value = "";
571 1         3 foreach $key (sort keys %{$self->get_hash}) {
  1         4  
572 11         24 $value = $self->{$key};
573 11 50       29 if (not defined($value)) { $value = ""; } # ensures no errors and proper write to file;
  0         0  
574             # effectively the same thing to write a null string
575 11         31 else { $value = serialize_value(value => $value, no_quotes => $params{no_quotes}); }
576 11 50       25 if (not $params{compact}) {
577 11         30 print $FILE "$key = $value\n";
578             } else {
579 0         0 print $FILE "$key=$value\n";
580             }
581             }
582 1         54 close $FILE;
583              
584 1         10 my $fh = new FileHandle "<$filename";
585 1         85 my $md5 = new Digest::MD5;
586 1         23 $md5->addfile($fh);
587 1         5 $fh->close();;
588 1         18 my $digest = $md5->hexdigest;
589             #print "# ConfigFile::save()[new file]: new md5 for save == $digest\n";
590 1         6 $self->set_hash_val('file_md5', $digest);
591 1         6 $lock->unlock();
592             };
593 1 50       5 if ($@) {
594 0         0 $self->set_hash_val('error', $@);
595 0         0 return 0;
596             }
597             } else {
598             # if file does exist, we need to worry about formatting
599 2 50       14 if (not defined($self->get_hash_val('file_md5'))) {
600 0         0 my $ex = new RSH::DataIntegrityException message => "In-memory data was not loaded from file.";
601 0 0       0 if (not $params{force}) { die $ex; }
  0         0  
602 0         0 else { $self->set_hash_val('warning', $ex); }
603             }
604 2         13 eval {
605 2         38 my $lock = RSH::LockFile->new($filename);
606 2         20 $lock->lock(no_follow => $params{no_follow});
607             # my $rc = system("mv $filename $filename.bak");
608             # if ($rc != 0) { die new RSH::DataIntegrityException message => "Unable to backup original file!"; }
609 2         36 my $rc = cp($filename, "$filename.bak");
610 2 50       935 if ($rc == 0) { die new RSH::DataIntegrityException message => "Unable to backup original file!"; }
  0         0  
611 2         162 $rc = unlink($filename);
612 2 50       9 if ($rc == 0) {
613 0         0 die new RSH::DataIntegrityException
614             message => "Unable to remove original file after backup!";
615             }
616            
617 2         13 my $ORIG_FILE = get_filehandle("$filename.bak", 'READ', no_follow => $params{no_follow});
618 2         34 my $md5 = new Digest::MD5;
619 2         67 $md5->addfile($ORIG_FILE);
620 2         9 $ORIG_FILE->close;
621 2         45 my $orig_md5 = $md5->hexdigest;
622 2 100 66     9 if ( defined($self->get_hash_val('file_md5')) and ($self->get_hash_val('file_md5') ne $orig_md5) ) {
623 1         317 my $ex = new RSH::DataIntegrityException message => "Data file has changed since the last load.";
624 1 50       12 if (not $params{force}) { die $ex; }
  0         0  
625 1         8 else { $self->set_hash_val('warning', $ex); }
626             }
627              
628 2         16 $ORIG_FILE = get_filehandle("$filename.bak", 'READ', no_follow => $params{no_follow});
629 2         18 my $FILE = get_filehandle("$filename", 'WRITE', no_follow => $params{no_follow});
630              
631 2         7 my $key = "";
632 2         4 my $value = "";
633 2         4 my @saved;
634 2         52 while (<$ORIG_FILE>) {
635 27 100 66     218 if ((! m/^\s*#.*/) && (m/(\S*)\s*=\s*(\S*)/)) {
636             # suck up next line while current line ends in "\"
637 22         74 while (m/^.*\\\s*$/) {
638 6         163 my $temp = <$ORIG_FILE>; # grab the next line
639 6 100 100     40 if (defined($temp) && ($temp !~ m/^\s*#.*/)) {
    100          
640 4         29 s/^(.*)\\\s*$/$1/; # trim off the trailing \
641 4         16 $_ .= $temp;
642             } elsif (not defined($temp)) {
643 1         18 s/^(.*)\\\s*$/$1/; # trim off the trailing \
644 1         4 last; # get out of the loop
645             }
646             }
647 22         130 ($key, $value) = (m/(\S*)\s*=\s*(\S*.*)/);
648 22 50 33     97 if ( (defined($key)) && (defined($self->{$key})) ) {
649 22         45 $value = $self->{$key};
650 22 50       63 if (not defined($value)) { $value = ""; } # ensures no errors and proper write to file;
  0         0  
651             # effectively the same thing to write a null string
652 22         56 else { $value = serialize_value(value => $value, no_quotes => $params{no_quotes}); }
653 22 50       50 if (not $params{compact}) {
654 22         70 print $FILE "$key = $value\n";
655             } else {
656 0         0 print $FILE "$key=$value\n";
657             }
658 22         123 push @saved, $key;
659             }
660             } else {
661 5         36 print $FILE $_;
662             }
663             }
664            
665 2         32 close $ORIG_FILE;
666              
667 2         4 my @keys = sort keys %{$self};
  2         6  
668 2 50       17 if (scalar(@saved) < scalar(@keys)) {
669 0         0 for (my $i = 0; $i < scalar(@keys); $i++) {
670 0 0       0 if (grep(/$keys[$i]/, @saved) == 0) {
671 0         0 $value = $self->{$keys[$i]};
672 0 0       0 if (not defined($value)) { $value = ""; } # ensures no errors and proper write to file;
  0         0  
673             # effectively the same thing to write a null string
674 0         0 else { $value = serialize_value(value => $value, no_quotes => $params{no_quotes}); }
675 0 0       0 if (not $params{compact}) {
676 0         0 print $FILE "$keys[$i] = $value\n";
677             } else {
678 0         0 print $FILE "$keys[$i]=$value\n";
679             }
680             }
681             }
682             }
683 2         237 close $FILE;
684              
685 2         16 $FILE = get_filehandle("$filename", 'READ', no_follow => $params{no_follow});
686 2         21 $md5->new;
687 2         40 $md5->addfile($FILE);
688 2         16 $FILE->close();
689 2         42 my $digest = $md5->hexdigest;
690             #print "# ConfigFile::save()[existing file]: new md5 for save == $digest\n";
691 2         10 $self->set_hash_val('file_md5', $digest);
692 2         20 $lock->unlock();
693             };
694 2 50       9 if ($@) {
695 0         0 $self->set_hash_val('error', $@);
696 0         0 return 0;
697             }
698             }
699              
700 3         9 tied(%{$self->get_hash})->dirty(0);
  3         11  
701 3         15 return 1;
702             }
703              
704             =item remove()
705              
706             Removes the config file.
707              
708             =cut
709              
710             sub remove {
711 0     0 1 0 my $self = shift;
712 0         0 my %params = @_;
713 0         0 my $filename = $params{filename};
714              
715 0 0       0 if (not defined($filename)) { $filename = $self->get_hash_val('filename'); }
  0         0  
716 0 0       0 if (not defined($filename)) { die new RSH::CodeException message => "Filename is not defined for this config object." }
  0         0  
717              
718 0 0       0 if (not -e $filename) { return 1; }
  0         0  
719             else {
720 0         0 my $rc = unlink("$filename");
721 0 0       0 if ($rc == 0) { die new RSH::DataIntegrityException message => "Unable to remove file $filename."; }
  0         0  
722 0         0 $self->set_hash_val('file_md5', undef);
723 0         0 return 1;
724             }
725             }
726              
727             # ******************** Overload Methods ********************
728              
729             =item string()
730              
731             Returns a string representation of the object. This is useful for debugging. It is NOT
732             suitable to be used for serializing the object. Use save for that.
733              
734             =cut
735              
736             sub string {
737 3     3 1 426 my $self = shift;
738              
739 3         8 my $str = "{ ";
740 3         5 my $key = "";
741 3         7 my $value = "";
742 3         6 foreach $key (sort keys %{$self->get_hash()}) {
  3         9  
743 25         89 $value = $self->{$key};
744 25 50       75 if (not defined($value)) { $value = "undef"; } # could be confusing if that is the real value ;-)
  0         0  
745 25         50 else { $value = serialize_value(value => $value); }
746             # if this is not the first pair
747 25 100       63 if ($str ne "{ ") { $str .= ", " }
  22         27  
748 25         52 $str .= "$key => $value";
749             }
750 3         15 $str .= " }";
751 3         19 return $str;
752             }
753              
754             =item get_hash()
755              
756             Returns the 'hash' hash reference.
757              
758             Ok, this is a bit confusing if you haven't read the overload manpage, and still
759             confusing if you haven't tried it ;-)
760              
761             The overload maps all attempts to use this object reference as a hash to this method.
762             So, $config->{key} will actually call this method--and what this method does is return the
763             hash table reference in 'hash'. So, a quick step by step is as follows:
764              
765             $config->{key} ==> get_hash($config) ==> (returns 'hash') ==> ('hash')->{key}
766              
767             So this method returns the hash, which is in turn accessed for the key 'key'. Neat and
768             confusing, no?
769              
770             =cut
771              
772             sub get_hash {
773 252     252 1 4241 my $self = shift;
774              
775 252         472 return $self->get_hash_val("hash");
776             }
777              
778             # ******************** "PRIVATE" Instance Methods ********************
779              
780             =begin private
781              
782             =item get_hash_val()
783              
784             Gets past the overload so we can actually get at the $self hash values. All attempts
785             at $self->{key} will actually call get_hash(), so we need a way around that to
786             get at the values of self.
787              
788             Thank you overload manpage!
789              
790             =cut
791              
792             sub get_hash_val {
793 288     288 1 443 my $self = shift;
794 288         348 my $key = shift;
795 288         525 my $class = ref $self;
796 288         627 bless $self, 'overload::dummy'; # Disable overloading of %{}
797 288         501 my $val = $self->{$key};
798 288         461 bless $self, $class; # Restore overloading
799 288         1635 $val;
800             }
801              
802             =item set_hash_val()
803              
804             Gets past the overload so we can actually set the $self hash values.
805              
806             Thank you overload manpage!
807              
808             =cut
809              
810             sub set_hash_val {
811 24     24 1 39 my $self = shift;
812 24         42 my $key = shift;
813 24         32 my $val = shift;
814 24         51 my $class = ref $self;
815 24         65 bless $self, 'overload::dummy'; # Disable overloading of %{}
816 24         47 $self->{$key} = $val;
817 24         56 bless $self, $class; # Restore overloading
818 24         51 $val;
819             }
820              
821             =end private
822              
823             =back
824              
825             =cut
826              
827             # #################### RSH::ConfigFile.pm ENDS ####################
828             1;
829              
830             =head1 SEE ALSO
831              
832             http://www.rshtech.com/software/
833              
834             =head1 AUTHOR
835              
836             Matt Luker C<< <mluker@cpan.org> >>
837              
838             =head1 COPYRIGHT AND LICENSE
839              
840             Copyright 2003-2008 by Matt Luker
841              
842             This library is free software; you can redistribute it and/or modify
843             it under the same terms as Perl itself.
844              
845             =cut
846              
847             __END__
848             # TTGOG
849              
850             # ------------------------------------------------------------------------------
851             #
852             # $Log$
853             # Revision 1.14 2004/04/09 06:18:26 kostya
854             # Added quote escaping capabilities.
855             #
856             # Revision 1.13 2004/01/15 01:07:17 kostya
857             # New version for changes in tests.
858             #
859             # Revision 1.12 2003/12/27 07:46:12 kostya
860             # Fix for an empty element in a hash--i.e. if the last element has a comma after it, generating a null pair
861             #
862             # Revision 1.11 2003/12/27 07:42:07 kostya
863             # Fix for slash-continues and comments
864             #
865             # Revision 1.10 2003/11/14 05:30:17 kostya
866             # Bumped rev.
867             #
868             # Revision 1.9 2003/10/23 05:13:32 kostya
869             # Added some explaination for s// in load.
870             #
871             # Revision 1.8 2003/10/23 05:08:06 kostya
872             # Bumped rev.
873             #
874             # Revision 1.7 2003/10/23 05:06:17 kostya
875             # Added a check for brain-dead Windows perl installations.
876             #
877             # Revision 1.6 2003/10/22 20:56:10 kostya
878             # Bumped rev.
879             #
880             # Revision 1.5 2003/10/22 20:51:02 kostya
881             # Removed OS-specifc assumptions or code
882             #
883             # Revision 1.4 2003/10/15 01:08:12 kostya
884             # Bumped rev for getting licenses in order.
885             #
886             # Revision 1.3 2003/10/15 01:07:00 kostya
887             # documentation and license updates--everything is Artistic.
888             #
889             # Revision 1.2 2003/10/14 22:50:07 kostya
890             # Bumped release
891             #
892             # Revision 1.1.1.1 2003/10/13 01:38:04 kostya
893             # First import
894             #
895             # Revision 1.7 2003/08/30 06:39:05 kostya
896             # Patched undefined key in hash values.
897             #
898             # Revision 1.6 2003/08/23 07:13:28 kostya
899             # Added md5 checksums.
900             #
901             # Revision 1.5 2003/08/23 01:02:32 kostya
902             # Added remove and changed to SmartHash.
903             #
904             # Revision 1.4 2003/08/06 03:31:26 kostya
905             # Change callback and dirty flag work.
906             #
907             # Revision 1.3 2003/08/01 00:52:50 kostya
908             # Latest infrastructure work.
909             #
910             # Revision 1.2 2003/07/30 06:30:49 kostya
911             # Added comments and file-locking.
912             #
913             # Revision 1.1.1.1 2003/07/25 07:06:35 kostya
914             # Initial Import
915             #
916             # ------------------------------------------------------------------------------
917