File Coverage

blib/lib/CGI/Ex/Conf.pm
Criterion Covered Total %
statement 89 327 27.2
branch 27 186 14.5
condition 24 112 21.4
subroutine 12 31 38.7
pod 7 26 26.9
total 159 682 23.3


line stmt bran cond sub pod time code
1             package CGI::Ex::Conf;
2              
3             =head1 NAME
4              
5             CGI::Ex::Conf - Conf Reader/Writer for many different data format types
6              
7             =head1 VERSION
8              
9             version 2.52
10              
11             =cut
12              
13             ###----------------------------------------------------------------###
14             # Copyright - Paul Seamons #
15             # Distributed under the Perl Artistic License without warranty #
16             ###----------------------------------------------------------------###
17              
18 2     2   1455 use strict;
  2         4  
  2         51  
19 2     2   8 use warnings;
  2         2  
  2         95  
20 2     2   11 use Exporter qw(import);
  2         3  
  2         60  
21 2     2   8 use Carp qw(croak);
  2         3  
  2         8141  
22              
23             our @EXPORT_OK = qw(conf_read conf_write in_cache);
24              
25             our $VERSION = '2.52'; # VERSION
26              
27             our $DEFAULT_EXT = 'conf';
28             our @DEFAULT_PATHS;
29              
30             our %EXT_READERS = (
31             '' => \&read_handler_yaml,
32             'conf' => \&read_handler_yaml,
33             'json' => \&read_handler_json,
34             'val_json' => \&read_handler_json,
35             'ini' => \&read_handler_ini,
36             'pl' => \&read_handler_pl,
37             'sto' => \&read_handler_storable,
38             'storable' => \&read_handler_storable,
39             'val' => \&read_handler_yaml,
40             'xml' => \&read_handler_xml,
41             'yaml' => \&read_handler_yaml,
42             'yml' => \&read_handler_yaml,
43             'html' => \&read_handler_html,
44             'htm' => \&read_handler_html,
45             );
46              
47             our %EXT_WRITERS = (
48             '' => \&write_handler_yaml,
49             'conf' => \&write_handler_yaml,
50             'ini' => \&write_handler_ini,
51             'json' => \&write_handler_json,
52             'val_json' => \&write_handler_json,
53             'pl' => \&write_handler_pl,
54             'sto' => \&write_handler_storable,
55             'storable' => \&write_handler_storable,
56             'val' => \&write_handler_yaml,
57             'xml' => \&write_handler_xml,
58             'yaml' => \&write_handler_yaml,
59             'yml' => \&write_handler_yaml,
60             'html' => \&write_handler_html,
61             'htm' => \&write_handler_html,
62             );
63              
64             ### $DIRECTIVE controls how files are looked for when namespaces are not absolute.
65             ### If directories 1, 2 and 3 are passed and each has a config file
66             ### LAST would return 3, FIRST would return 1, and MERGE will
67             ### try to put them all together. Merge behavior of hashes
68             ### is determined by $IMMUTABLE_\w+ variables.
69             our $DIRECTIVE = 'LAST'; # LAST, MERGE, FIRST
70              
71             our $IMMUTABLE_QR = qr/_immu(?:table)?$/i;
72              
73             our $IMMUTABLE_KEY = 'immutable';
74              
75             our $NO_WARN_ON_FAIL;
76              
77             our $HTML_KEY;
78              
79             our %CACHE;
80              
81             ###----------------------------------------------------------------###
82              
83             sub new {
84 4   50 4 0 487 my $class = shift || __PACKAGE__;
85 4   100     24 my $args = shift || {};
86              
87 4         35 return bless {%$args}, $class;
88             }
89              
90             sub paths {
91 1     1 0 2 my $self = shift;
92 1   50     5 return $self->{paths} ||= \@DEFAULT_PATHS;
93             }
94              
95             ###----------------------------------------------------------------###
96              
97             sub conf_read {
98 3     3 1 7 my $file = shift;
99 3   50     7 my $args = shift || {};
100 3         6 my $ext;
101              
102             ### they passed the right stuff already
103 3 100 33     58 if (ref $file) {
    50          
    50          
    100          
    50          
104 1 50       3 if (UNIVERSAL::isa($file, 'SCALAR')) {
105 0 0       0 if ($$file =~ /^\s*
106 0         0 return html_parse_yaml_load($$file, $args); # allow for ref to a YAML string
107             } else {
108 0         0 return yaml_load($$file); # allow for ref to a YAML string
109             }
110             } else {
111 1         8 return $file;
112             }
113              
114             ### allow for a pre-cached reference
115             } elsif (exists $CACHE{$file} && ! $args->{no_cache}) {
116 0         0 return $CACHE{$file};
117              
118             ### if contains a newline - treat it as a YAML string
119             } elsif (index($file,"\n") != -1) {
120 0         0 return yaml_load($file);
121              
122             ### otherwise base it off of the file extension
123             } elsif ($args->{file_type}) {
124 1         4 $ext = $args->{file_type};
125             } elsif ($file =~ /\.(\w+)$/) {
126 1         4 $ext = $1;
127             } else {
128             $ext = defined($args->{default_ext}) ? $args->{default_ext}
129 0 0       0 : defined($DEFAULT_EXT) ? $DEFAULT_EXT
    0          
130             : '';
131 0 0       0 $file = length($ext) ? "$file.$ext" : $file;
132             }
133              
134             ### determine the handler
135 2   33     7 my $handler = $EXT_READERS{$ext} || croak "Unknown file extension: $ext";
136              
137             ### don't die if the file is not found - do die otherwise
138 2 100       58 if (! -e $file) {
139 1         3 eval { die "Conf file $file not found\n" };
  1         6  
140 1 0 33     3 warn "Conf file $file not found" if ! $args->{'no_warn_on_fail'} && ! $NO_WARN_ON_FAIL;
141 1         6 return;
142             }
143              
144 1   50     2 return eval { scalar $handler->($file, $args) } || die "Error while reading conf file $file\n$@";
145             }
146              
147             sub read_ref {
148 1     1 1 2 my $self = shift;
149 1         3 my $file = shift;
150 1   50     3 my $args = shift || {};
151 1         4 return conf_read($file, {%$self, %$args});
152             }
153              
154             ### allow for different kinds of merging of arguments
155             ### allow for key fallback on hashes
156             ### allow for immutable values on hashes
157             sub read {
158 1     1 1 2 my $self = shift;
159 1         2 my $namespace = shift;
160 1   50     3 my $args = shift || {};
161 1   50     4 my $REF = $args->{ref} || undef; # can pass in existing set of options
162 1   50     11 my $IMMUTABLE = $args->{immutable} || {}; # can pass existing immutable types
163              
164 1 50       5 $self = $self->new() if ! ref $self;
165              
166             ### allow for fast short ciruit on path lookup for several cases
167 1         1 my $directive;
168 1         3 my @paths = ();
169 1 50 33     8 if (ref($namespace) # already a ref
      33        
170             || index($namespace,"\n") != -1 # yaml string to read in
171             || $namespace =~ m|^\.{0,2}/.+$| # absolute or relative file
172             ) {
173 0         0 push @paths, $namespace;
174 0         0 $directive = 'FIRST';
175              
176             ### use the default directories
177             } else {
178 1   33     10 $directive = uc($args->{directive} || $self->{directive} || $DIRECTIVE);
179 1         2 $namespace =~ s|::|/|g; # allow perlish style namespace
180 1   33     4 my $paths = $args->{paths} || $self->paths
181             || croak "No paths found during read on $namespace";
182 1 50       9 $paths = [$paths] if ! ref $paths;
183 1 50       4 if ($directive eq 'LAST') { # LAST shall be FIRST
184 0         0 $directive = 'FIRST';
185 0 0       0 $paths = [reverse @$paths] if $#$paths != 0;
186             }
187 1         2 foreach my $path (@$paths) {
188 1 50 33     4 next if exists $CACHE{$path} && ! $CACHE{$path};
189 1         4 push @paths, "$path/$namespace";
190             }
191             }
192              
193             ### make sure we have at least one path
194 1 50       3 if ($#paths == -1) {
195 0         0 croak "Couldn't find a path for namespace $namespace. Perhaps you need to pass paths => \@paths";
196             }
197              
198             ### now loop looking for a ref
199 1         2 foreach my $path (@paths) {
200 1   50     4 my $ref = $self->read_ref($path, $args) || next;
201 0 0       0 if (! $REF) {
    0          
202 0 0       0 if (UNIVERSAL::isa($ref, 'ARRAY')) {
    0          
203 0         0 $REF = [];
204             } elsif (UNIVERSAL::isa($ref, 'HASH')) {
205 0         0 $REF = {};
206             } else {
207 0         0 croak "Unknown config type of \"".ref($ref)."\" for namespace $namespace";
208             }
209             } elsif (! UNIVERSAL::isa($ref, ref($REF))) {
210 0         0 croak "Found different reference types for namespace $namespace"
211             . " - wanted a type ".ref($REF);
212             }
213 0 0       0 if (ref($REF) eq 'ARRAY') {
214 0 0       0 if ($directive eq 'MERGE') {
215 0         0 push @$REF, @$ref;
216 0         0 next;
217             }
218 0         0 splice @$REF, 0, $#$REF + 1, @$ref;
219 0         0 last;
220             } else {
221 0         0 my $immutable = delete $ref->{$IMMUTABLE_KEY};
222 0         0 my ($key,$val);
223 0 0       0 if ($directive eq 'MERGE') {
224 0         0 while (($key,$val) = each %$ref) {
225 0 0       0 next if $IMMUTABLE->{$key};
226 0         0 my $immute = $key =~ s/$IMMUTABLE_QR//o;
227 0 0 0     0 $IMMUTABLE->{$key} = 1 if $immute || $immutable;
228 0         0 $REF->{$key} = $val;
229             }
230 0         0 next;
231             }
232 0         0 delete $REF->{$key} while $key = each %$REF;
233 0         0 while (($key,$val) = each %$ref) {
234 0         0 my $immute = $key =~ s/$IMMUTABLE_QR//o;
235 0 0 0     0 $IMMUTABLE->{$key} = 1 if $immute || $immutable;
236 0         0 $REF->{$key} = $val;
237             }
238 0         0 last;
239             }
240             }
241 1 50       10 $REF->{"Immutable Keys"} = $IMMUTABLE if scalar keys %$IMMUTABLE;
242 1         12 return $REF;
243             }
244              
245             ###----------------------------------------------------------------###
246              
247             sub read_handler_ini {
248 0     0 0 0 my $file = shift;
249 0         0 require Config::IniHash;
250 0         0 return Config::IniHash::ReadINI($file);
251             }
252              
253             sub read_handler_pl {
254 1     1 0 2 my $file = shift;
255             ### do has odd behavior in that it turns a simple hashref
256             ### into hash - help it out a little bit
257 1         228 my @ref = do $file;
258 1 50       9 return ($#ref != 0) ? {@ref} : $ref[0];
259             }
260              
261             sub read_handler_json {
262 0     0 0 0 my $file = shift;
263 0         0 local *IN;
264 0 0       0 open (IN, $file) || die "Couldn't open $file: $!";
265 0         0 CORE::read(IN, my $text, -s $file);
266 0         0 close IN;
267 0         0 require JSON;
268 0 0       0 my $decode = JSON->can('decode') ? 'decode' : 'jsonToObj';
269 0         0 return scalar JSON->new->$decode($text);
270             }
271              
272             sub read_handler_storable {
273 0     0 0 0 my $file = shift;
274 0         0 require Storable;
275 0         0 return Storable::retrieve($file);
276             }
277              
278             sub read_handler_yaml {
279 0     0 0 0 my $file = shift;
280 0         0 local *IN;
281 0 0       0 open (IN, $file) || die "Couldn't open $file: $!";
282 0         0 CORE::read(IN, my $text, -s $file);
283 0         0 close IN;
284 0         0 return yaml_load($text);
285             }
286              
287             sub yaml_load {
288 0     0 0 0 my $text = shift;
289 0         0 require YAML;
290 0         0 my @ret = eval { YAML::Load($text) };
  0         0  
291 0 0       0 if ($@) {
292 0         0 die "$@";
293             }
294 0 0       0 return ($#ret == 0) ? $ret[0] : \@ret;
295             }
296              
297             sub read_handler_xml {
298 0     0 0 0 my $file = shift;
299 0         0 require XML::Simple;
300 0         0 return XML::Simple::XMLin($file);
301             }
302              
303             ### this handler will only function if a html_key (such as validation)
304             ### is specified - actually this somewhat specific to validation - but
305             ### I left it as a general use for other types
306              
307             ### is specified
308             sub read_handler_html {
309 0     0 0 0 my $file = shift;
310 0         0 my $args = shift;
311 0 0       0 if (! eval { require YAML }) {
  0         0  
312 0         0 my $err = $@;
313 0         0 my $found = 0;
314 0         0 my $i = 0;
315 0         0 while (my($pkg, $file, $line, $sub) = caller($i++)) {
316 0 0       0 return undef if $sub =~ /\bpreload_files$/;
317             }
318 0         0 die $err;
319             }
320              
321             ### get the html
322 0         0 local *IN;
323 0 0       0 open (IN, $file) || return undef;
324 0         0 CORE::read(IN, my $html, -s $file);
325 0         0 close IN;
326              
327 0         0 return html_parse_yaml_load($html, $args);
328             }
329              
330             sub html_parse_yaml_load {
331 0     0 0 0 my $html = shift;
332 0   0     0 my $args = shift || {};
333 0   0     0 my $key = $args->{html_key} || $HTML_KEY;
334 0 0 0     0 return undef if ! $key || $key !~ /^\w+$/;
335              
336 0         0 my $str = '';
337 0         0 my @order = ();
338 0         0 while ($html =~ m{
339             (document\. # global javascript
340             | var\s+ # local javascript
341             | <\w+\s+[^>]*?) # input, form, select, textarea tag
342             \Q$key\E # the key
343             \s*=\s* # an equals sign
344             ([\"\']) # open quote
345             (.+?[^\\]) # something in between
346             \2 # close quote
347             }xsg) {
348 0         0 my ($line, $quot, $yaml) = ($1, $2, $3);
349 0 0       0 if ($line =~ /^(document\.|var\s)/) { # js variable
350 0         0 $yaml =~ s/\\$quot/$quot/g;
351 0         0 $yaml =~ s/\\n\\\n?/\n/g;
352 0         0 $yaml =~ s/\\\\/\\/g;
353 0         0 $yaml =~ s/\s*$/\n/s; # fix trailing newline
354 0         0 $str = $yaml; # use last one found
355             } else { # inline attributes
356 0         0 $yaml =~ s/\s*$/\n/s; # fix trailing newline
357 0 0       0 if ($line =~ m/
    0          
358 0 0       0 $yaml =~ s/^\Q$1\E//m if $yaml =~ m/^( +)/s;
359 0         0 $str .= $yaml;
360              
361             } elsif ($line =~ m/\bname\s*=\s*('[^\']*'|"[^\"]*"|\S+)/) {
362 0         0 my $key = $1;
363 0         0 push @order, $key;
364 0         0 $yaml =~ s/^/ /mg; # indent entire thing
365 0         0 $yaml =~ s/^(\ *[^\s&*\{\[])/\n$1/; # add first newline
366 0         0 $str .= "$key:$yaml";
367             }
368             }
369             }
370 0 0 0     0 $str .= "group order: [".join(", ",@order)."]\n"
      0        
371             if $str && $#order != -1 && $key eq 'validation';
372              
373 0 0       0 return undef if ! $str;
374 0         0 my $ref = eval { yaml_load($str) };
  0         0  
375 0 0       0 if ($@) {
376 0         0 my $err = "$@";
377 0 0       0 if ($err =~ /line:\s+(\d+)/) {
378 0         0 my $line = $1;
379 0         0 while ($str =~ m/(.+)/gm) {
380 0 0       0 next if -- $line;
381 0         0 $err .= "LINE = \"$1\"\n";
382 0         0 last;
383             }
384             }
385 0         0 die $err;
386             }
387 0         0 return $ref;
388             }
389              
390             ###----------------------------------------------------------------###
391              
392             sub conf_write {
393 1     1 0 7979 my $file = shift;
394 1   33     4 my $conf = shift || croak "Missing conf";
395 1   50     3 my $args = shift || {};
396 1         2 my $ext;
397              
398 1 50 33     6 if (ref $file) {
    50          
    50          
    50          
    0          
399 0         0 croak "Invalid filename for write: $file";
400              
401             } elsif (index($file,"\n") != -1) {
402 0         0 croak "Cannot use a yaml string as a filename during write";
403              
404             ### allow for a pre-cached reference
405             } elsif (exists $CACHE{$file} && ! $args->{no_cache}) {
406 0         0 warn "Cannot write back to a file that is in the cache";
407 0         0 return 0;
408              
409             ### otherwise base it off of the file extension
410             } elsif ($args->{file_type}) {
411 1         2 $ext = $args->{file_type};
412             } elsif ($file =~ /\.(\w+)$/) {
413 0         0 $ext = $1;
414             } else {
415             $ext = defined($args->{default_ext}) ? $args->{default_ext}
416 0 0       0 : defined($DEFAULT_EXT) ? $DEFAULT_EXT
    0          
417             : '';
418 0 0       0 $file = length($ext) ? "$file.$ext" : $file;
419             }
420              
421             ### determine the handler
422 1         2 my $handler;
423 1 50       2 if ($args->{handler}) {
424             $handler = (UNIVERSAL::isa($args->{handler},'CODE'))
425 0 0       0 ? $args->{handler} : $args->{handler}->{$ext};
426             }
427 1 50       13 if (! $handler) {
428 1   33     6 $handler = $EXT_WRITERS{$ext} || croak "Unknown file extension: $ext";
429             }
430              
431 1   50     2 return eval { scalar $handler->($file, $conf, $args) } || die "Error while writing conf file $file\n$@";
432             }
433              
434             sub write_ref {
435 0     0 1 0 my $self = shift;
436 0         0 my $file = shift;
437 0         0 my $conf = shift;
438 0   0     0 my $args = shift || {};
439 0         0 conf_write($file, $conf, {%$self, %$args});
440             }
441              
442             ### Allow for writing out conf values
443             ### Allow for writing out the correct filename (if there is a path array)
444             ### Allow for not writing out immutable values on hashes
445             sub write {
446 0     0 1 0 my $self = shift;
447 0         0 my $namespace = shift;
448 0   0     0 my $conf = shift || croak "Must pass hashref to write out"; # the info to write
449 0   0     0 my $args = shift || {};
450 0   0     0 my $IMMUTABLE = $args->{immutable} || {}; # can pass existing immutable types
451              
452 0 0       0 $self = $self->new() if ! ref $self;
453              
454             ### allow for fast short ciruit on path lookup for several cases
455 0         0 my $directive;
456 0         0 my @paths = ();
457 0 0 0     0 if (ref($namespace) # already a ref
    0          
458             || $namespace =~ m|^\.{0,2}/.+$| # absolute or relative file
459             ) {
460 0         0 push @paths, $namespace;
461 0         0 $directive = 'FIRST';
462              
463             } elsif (index($namespace,"\n") != -1) { # yaml string - can't write that
464 0         0 croak "Cannot use a yaml string as a namespace for write";
465              
466             ### use the default directories
467             } else {
468 0   0     0 $directive = uc($args->{directive} || $self->{directive} || $DIRECTIVE);
469 0         0 $namespace =~ s|::|/|g; # allow perlish style namespace
470 0   0     0 my $paths = $args->{paths} || $self->paths
471             || croak "No paths found during write on $namespace";
472 0 0       0 $paths = [$paths] if ! ref $paths;
473 0 0       0 if ($directive eq 'LAST') { # LAST shall be FIRST
474 0         0 $directive = 'FIRST';
475 0 0       0 $paths = [reverse @$paths] if $#$paths != 0;
476             }
477 0         0 foreach my $path (@$paths) {
478 0 0 0     0 next if exists $CACHE{$path} && ! $CACHE{$path};
479 0         0 push @paths, "$path/$namespace";
480             }
481             }
482              
483             ### make sure we have at least one path
484 0 0       0 if ($#paths == -1) {
485 0         0 croak "Couldn't find a path for namespace $namespace. Perhaps you need to pass paths => \@paths";
486             }
487              
488 0         0 my $path;
489 0 0 0     0 if ($directive eq 'FIRST') {
    0          
490 0         0 $path = $paths[0];
491             } elsif ($directive eq 'LAST' || $directive eq 'MERGE') {
492 0         0 $path = $paths[-1];
493             } else {
494 0         0 croak "Unknown directive ($directive) during write of $namespace";
495             }
496              
497             ### remove immutable items (if any)
498 0 0 0     0 if (UNIVERSAL::isa($conf, 'HASH') && $conf->{"Immutable Keys"}) {
499 0         0 $conf = {%$conf}; # copy the values - only for immutable
500 0         0 my $IMMUTABLE = delete $conf->{"Immutable Keys"};
501 0         0 foreach my $key (keys %$IMMUTABLE) {
502 0         0 delete $conf->{$key};
503             }
504             }
505              
506             ### finally write it out
507 0         0 $self->write_ref($path, $conf);
508              
509 0         0 return 1;
510             }
511              
512             ###----------------------------------------------------------------###
513              
514             sub write_handler_ini {
515 0     0 0 0 my $file = shift;
516 0         0 my $ref = shift;
517 0         0 require Config::IniHash;
518 0         0 return Config::IniHash::WriteINI($file, $ref);
519             }
520              
521             sub write_handler_pl {
522 1     1 0 2 my $file = shift;
523 1         1 my $ref = shift;
524             ### do has odd behavior in that it turns a simple hashref
525             ### into hash - help it out a little bit
526 1         5 require Data::Dumper;
527 1         2 local $Data::Dump::Purity = 1;
528 1         2 local $Data::Dumper::Sortkeys = 1;
529 1         3 local $Data::Dumper::Quotekeys = 0;
530 1         1 local $Data::Dumper::Pad = ' ';
531 1         3 local $Data::Dumper::Varname = 'VunderVar';
532 1         5 my $str = Data::Dumper->Dumpperl([$ref]);
533 1 50       244 if ($str =~ s/^(.+?=\s*)//s) {
534 1         2 my $l = length($1);
535 1         16 $str =~ s/^\s{1,$l}//mg;
536             }
537 1 50       5 if ($str =~ /\$VunderVar/) {
538 0         0 die "Ref to be written contained circular references - can't write";
539             }
540              
541 1         2 local *OUT;
542 1 50       62 open (OUT, ">$file") || die $!;
543 1         15 print OUT $str;
544 1         145 close OUT;
545             }
546              
547             sub write_handler_json {
548 0     0 0   my $file = shift;
549 0           my $ref = shift;
550 0           require JSON;
551 0           my $str;
552 0 0         if (JSON->can('encode')) {
553 0           my $j = JSON->new;
554 0           $j->canonical(1);
555 0           $j->pretty;
556 0           $str = $j->encode($ref);
557             } else {
558 0           $str = JSON->new->objToJson($ref, {pretty => 1, indent => 2});
559             }
560 0           local *OUT;
561 0 0         open (OUT, ">$file") || die $!;
562 0           print OUT $str;
563 0           close(OUT);
564             }
565              
566             sub write_handler_storable {
567 0     0 0   my $file = shift;
568 0           my $ref = shift;
569 0           require Storable;
570 0           return Storable::store($ref, $file);
571             }
572              
573             sub write_handler_yaml {
574 0     0 0   my $file = shift;
575 0           my $ref = shift;
576 0           require YAML;
577 0           return YAML::DumpFile($file, $ref);
578             }
579              
580             sub write_handler_xml {
581 0     0 0   my $file = shift;
582 0           my $ref = shift;
583 0           require XML::Simple;
584 0           local *OUT;
585 0 0         open (OUT, ">$file") || die $!;
586 0           print OUT scalar(XML::Simple->new->XMLout($ref, noattr => 1));
587 0           close(OUT);
588             }
589              
590             sub write_handler_html {
591 0     0 0   my $file = shift;
592 0           my $ref = shift;
593 0           die "Write of conf information to html is not supported";
594             }
595              
596             ###----------------------------------------------------------------###
597              
598             sub preload_files {
599 0     0 1   my $self = shift;
600 0   0       my $paths = shift || $self->paths;
601              
602             ### what extensions do we look for
603 0           my %EXT;
604 0 0         if ($self->{'handler'}) {
605 0 0         if (UNIVERSAL::isa($self->{'handler'},'HASH')) {
606 0           %EXT = %{ $self->{'handler'} };
  0            
607             }
608             } else {
609 0           %EXT = %EXT_READERS;
610 0 0 0       if (! $self->{'html_key'} && ! $HTML_KEY) {
611 0           delete $EXT{$_} foreach qw(html htm);
612             }
613             }
614 0 0         return if ! keys %EXT;
615              
616             ### look in the paths for the files
617 0 0         foreach my $path (ref($paths) ? @$paths : $paths) {
618 0           $path =~ s|//+|/|g;
619 0           $path =~ s|/$||;
620 0 0         next if exists $CACHE{$path};
621 0 0         if (-f $path) {
    0          
622 0 0         my $ext = ($path =~ /\.(\w+)$/) ? $1 : '';
623 0 0         next if ! $EXT{$ext};
624 0           $CACHE{$path} = $self->read($path);
625             } elsif (-d _) {
626 0           $CACHE{$path} = 1;
627 0           require File::Find;
628             File::Find::find(sub {
629 0 0   0     return if exists $CACHE{$File::Find::name};
630 0 0         return if $File::Find::name =~ m|/CVS/|;
631 0 0         return if ! -f;
632 0 0         my $ext = (/\.(\w+)$/) ? $1 : '';
633 0 0         return if ! $EXT{$ext};
634 0           $CACHE{$File::Find::name} = $self->read($File::Find::name);
635 0           }, "$path/");
636             } else {
637 0           $CACHE{$path} = 0;
638             }
639             }
640             }
641              
642             sub in_cache {
643 0 0   0 1   my ($self, $file) = (@_ == 2) ? @_ : (undef, shift());
644 0   0       return exists($CACHE{$file}) || 0;
645             }
646              
647             ###----------------------------------------------------------------###
648              
649             1;
650              
651             __END__