]>
Dogcows Code - chaz/p5-CGI-Ex/blob - lib/CGI/Ex/Conf.pm
3 ### CGI Extended Conf Reader
5 ###----------------------------------------------------------------###
6 # Copyright 2004 - Paul Seamons #
7 # Distributed under the Perl Artistic License without warranty #
8 ###----------------------------------------------------------------###
10 ### See perldoc at bottom
25 use CGI
::Ex
::Dump
qw(debug dex_warn);
29 $DEFAULT_EXT = 'conf';
31 %EXT_READERS = ('' => \
&read_handler_yaml
,
32 'conf' => \
&read_handler_yaml
,
33 'ini' => \
&read_handler_ini
,
34 'pl' => \
&read_handler_pl
,
35 'sto' => \
&read_handler_storable
,
36 'storable' => \
&read_handler_storable
,
37 'val' => \
&read_handler_yaml
,
38 'xml' => \
&read_handler_xml
,
39 'yaml' => \
&read_handler_yaml
,
40 'yml' => \
&read_handler_yaml
,
41 'html' => \
&read_handler_html
,
42 'htm' => \
&read_handler_html
,
45 %EXT_WRITERS = ('' => \
&write_handler_yaml
,
46 'conf' => \
&write_handler_yaml
,
47 'ini' => \
&write_handler_ini
,
48 'pl' => \
&write_handler_pl
,
49 'sto' => \
&write_handler_storable
,
50 'storable' => \
&write_handler_storable
,
51 'val' => \
&write_handler_yaml
,
52 'xml' => \
&write_handler_xml
,
53 'yaml' => \
&write_handler_yaml
,
54 'yml' => \
&write_handler_yaml
,
55 'html' => \
&write_handler_html
,
56 'htm' => \
&write_handler_html
,
59 ### $DIRECTIVE controls how files are looked for when namespaces are not absolute.
60 ### If directories 1, 2 and 3 are passed and each has a config file
61 ### LAST would return 3, FIRST would return 1, and MERGE will
62 ### try to put them all together. Merge behavior of hashes
63 ### is determined by $IMMUTABLE_\w+ variables.
64 $DIRECTIVE = 'LAST'; # LAST, MERGE, FIRST
66 $IMMUTABLE_QR = qr/_immu(?:table)?$/i;
68 $IMMUTABLE_KEY = 'immutable';
70 ###----------------------------------------------------------------###
73 my $class = shift || __PACKAGE__
;
74 my $self = (@_ && ref($_[0])) ? shift : {@_};
76 return bless $self, $class;
81 return $self->{paths
} ||= \
@DEFAULT_PATHS;
84 ###----------------------------------------------------------------###
89 my $args = shift || {};
92 ### they passed the right stuff already
94 if (UNIVERSAL
::isa
($file, 'SCALAR')) {
95 if ($$file =~ /^\s*</) {
96 return &html_parse_yaml_load
($$file, $self, $args); # allow for ref to a YAML string
98 return &yaml_load
($$file); # allow for ref to a YAML string
104 ### if contains a newline - treat it as a YAML string
105 } elsif (index($file,"\n") != -1) {
106 return &yaml_load
($file);
108 ### otherwise base it off of the file extension
109 } elsif ($args->{file_type
}) {
110 $ext = $args->{file_type
};
111 } elsif ($file =~ /\.(\w+)$/) {
114 $ext = defined($args->{default_ext
}) ? $args->{default_ext
}
115 : defined($self->{default_ext
}) ? $self->{default_ext
}
116 : defined($DEFAULT_EXT) ? $DEFAULT_EXT : '';
117 $file = length($ext) ? "$file.$ext" : $file;
120 ### allow for a pre-cached reference
121 if (exists $CACHE{$file} && ! $self->{no_cache
}) {
122 return $CACHE{$file};
125 ### determine the handler
127 if ($args->{handler
}) {
128 $handler = (UNIVERSAL
::isa
($args->{handler
},'CODE'))
129 ? $args->{handler
} : $args->{handler
}->{$ext};
130 } elsif ($self->{handler
}) {
131 $handler = (UNIVERSAL
::isa
($self->{handler
},'CODE'))
132 ? $self->{handler
} : $self->{handler
}->{$ext};
135 $handler = $EXT_READERS{$ext} || die "Unknown file extension: $ext";
138 return eval { scalar &$handler($file, $self, $args) } || do {
139 debug
"Couldn't read $file: $@" if $DEBUG_ON_FAIL;
140 dex_warn
"Couldn't read $file: $@" if ! $self->{no_warn_on_fail
};
145 ### allow for different kinds of merging of arguments
146 ### allow for key fallback on hashes
147 ### allow for immutable values on hashes
150 my $namespace = shift;
151 my $args = shift || {};
152 my $REF = $args->{ref} || undef; # can pass in existing set of options
153 my $IMMUTABLE = $args->{immutable
} || {}; # can pass existing immutable types
155 $self = $self->new() if ! ref $self;
157 ### allow for fast short ciruit on path lookup for several cases
160 if (ref($namespace) # already a ref
161 || index($namespace,"\n") != -1 # yaml string to read in
162 || $namespace =~ m
|^\
.{0,2}/.+$| # absolute or relative file
164 push @paths, $namespace;
165 $directive = 'FIRST';
167 ### use the default directories
169 $directive = uc($args->{directive
} || $self->{directive
} || $DIRECTIVE);
170 $namespace =~ s
|::|/|g
; # allow perlish style namespace
171 my $paths = $args->{paths
} || $self->paths
172 || die "No paths found during read on $namespace";
173 $paths = [$paths] if ! ref $paths;
174 if ($directive eq 'LAST') { # LAST shall be FIRST
175 $directive = 'FIRST';
176 $paths = [reverse @$paths] if $#$paths != 0;
178 foreach my $path (@$paths) {
179 next if exists $CACHE{$path} && ! $CACHE{$path};
180 push @paths, "$path/$namespace";
184 ### make sure we have at least one path
186 die "Couldn't find a path for namespace $namespace. Perhaps you need to pass paths => \@paths";
189 ### now loop looking for a ref
190 foreach my $path (@paths) {
191 my $ref = $self->read_ref($path, $args) || next;
193 if (UNIVERSAL
::isa
($ref, 'ARRAY')) {
195 } elsif (UNIVERSAL
::isa
($ref, 'HASH')) {
198 die "Unknown config type of \"".ref($ref)."\" for namespace $namespace";
200 } elsif (! UNIVERSAL
::isa
($ref, ref($REF))) {
201 die "Found different reference types for namespace $namespace"
202 . " - wanted a type ".ref($REF);
204 if (ref($REF) eq 'ARRAY') {
205 if ($directive eq 'MERGE') {
209 splice @$REF, 0, $#$REF + 1, @$ref;
212 my $immutable = delete $ref->{$IMMUTABLE_KEY};
214 if ($directive eq 'MERGE') {
215 while (($key,$val) = each %$ref) {
216 next if $IMMUTABLE->{$key};
217 my $immute = $key =~ s/$IMMUTABLE_QR//o;
218 $IMMUTABLE->{$key} = 1 if $immute || $immutable;
223 delete $REF->{$key} while $key = each %$REF;
224 while (($key,$val) = each %$ref) {
225 my $immute = $key =~ s/$IMMUTABLE_QR//o;
226 $IMMUTABLE->{$key} = 1 if $immute || $immutable;
232 $REF->{"Immutable Keys"} = $IMMUTABLE if scalar keys %$IMMUTABLE;
236 ###----------------------------------------------------------------###
238 sub read_handler_ini
{
240 require Config
::IniHash
;
241 return &Config
::IniHash
::ReadINI
($file);
244 sub read_handler_pl
{
246 ### do has odd behavior in that it turns a simple hashref
247 ### into hash - help it out a little bit
249 return ($#ref != 0) ? {@ref} : $ref[0];
252 sub read_handler_storable
{
255 return &Storable
::retrieve
($file);
258 sub read_handler_yaml
{
261 open (IN
, $file) || die "Couldn't open $file: $!";
262 CORE
::read(IN
, my $text, -s
$file);
264 return &yaml_load
($text);
270 my @ret = eval { &YAML
::Load
($text) };
274 return ($#ret == 0) ? $ret[0] : \
@ret;
277 sub read_handler_xml
{
280 return XML
::Simple
::XMLin
($file);
283 ### this handler will only function if a html_key (such as validation)
284 ### is specified - actually this somewhat specific to validation - but
285 ### I left it as a general use for other types
288 sub read_handler_html
{
292 if (! eval {require YAML
}) {
296 while (my($pkg, $file, $line, $sub) = caller($i++)) {
297 return undef if $sub =~ /\bpreload_files$/;
304 open (IN
, $file) || return undef;
305 CORE
::read(IN
, my $html, -s
$file);
308 return &html_parse_yaml_load
($html, $self, $args);
311 sub html_parse_yaml_load
{
313 my $self = shift || {};
314 my $args = shift || {};
315 my $key = $args->{html_key
} || $self->{html_key
} || $HTML_KEY;
316 return undef if ! $key || $key !~ /^\w+$/;
321 (document\
. # global javascript
322 | var\s
+ # local javascript
323 | <\w
+\s
+[^>]*?) # input, form, select, textarea tag
325 \s
*=\s
* # an equals sign
326 ([\"\']) # open quote
327 (.+?[^\\]) # something in between
330 my ($line, $quot, $yaml) = ($1, $2, $3);
331 if ($line =~ /^(document\.|var\s)/) { # js variable
332 $yaml =~ s/\\$quot/$quot/g;
333 $yaml =~ s/\\n\\\n?/\n/g;
334 $yaml =~ s/\\\\/\\/g;
335 $yaml =~ s/\s*$/\n/s; # fix trailing newline
336 $str = $yaml; # use last one found
337 } else { # inline attributes
338 $yaml =~ s/\s*$/\n/s; # fix trailing newline
339 if ($line =~ m/<form/i) {
340 $yaml =~ s/^\Q$1\E//m if $yaml =~ m/^( +)/s;
343 } elsif ($line =~ m/\bname\s*=\s*('[^\']*'|"[^\"]*"|\S+)/) {
346 $yaml =~ s/^/ /mg; # indent entire thing
347 $yaml =~ s/^(\ *[^\s&*\{\[])/\n$1/; # add first newline
348 $str .= "$key:$yaml";
352 $str .= "group order: [".join(", ",@order)."]\n"
353 if $str && $#order != -1 && $key eq 'validation';
355 return undef if ! $str;
356 my $ref = eval {&yaml_load
($str)};
359 if ($err =~ /line:\s+(\d+)/) {
361 while ($str =~ m/(.+)/gm) {
363 $err .= "LINE = \"$1\"\n";
373 ###----------------------------------------------------------------###
375 ### Allow for writing out conf values
376 ### Allow for writing out the correct filename (if there is a path array)
377 ### Allow for not writing out immutable values on hashes
380 my $namespace = shift;
381 my $conf = shift || die "Must pass hashref to write out"; # the info to write
382 my $args = shift || {};
383 my $IMMUTABLE = $args->{immutable
} || {}; # can pass existing immutable types
385 $self = $self->new() if ! ref $self;
387 ### allow for fast short ciruit on path lookup for several cases
390 if (ref($namespace) # already a ref
391 || $namespace =~ m
|^\
.{0,2}/.+$| # absolute or relative file
393 push @paths, $namespace;
394 $directive = 'FIRST';
396 } elsif (index($namespace,"\n") != -1) { # yaml string - can't write that
397 die "Cannot use a yaml string as a namespace for write";
399 ### use the default directories
401 $directive = uc($args->{directive
} || $self->{directive
} || $DIRECTIVE);
402 $namespace =~ s
|::|/|g
; # allow perlish style namespace
403 my $paths = $args->{paths
} || $self->paths
404 || die "No paths found during write on $namespace";
405 $paths = [$paths] if ! ref $paths;
406 if ($directive eq 'LAST') { # LAST shall be FIRST
407 $directive = 'FIRST';
408 $paths = [reverse @$paths] if $#$paths != 0;
410 foreach my $path (@$paths) {
411 next if exists $CACHE{$path} && ! $CACHE{$path};
412 push @paths, "$path/$namespace";
416 ### make sure we have at least one path
418 die "Couldn't find a path for namespace $namespace. Perhaps you need to pass paths => \@paths";
422 if ($directive eq 'FIRST') {
424 } elsif ($directive eq 'LAST' || $directive eq 'MERGE') {
427 die "Unknown directive ($directive) during write of $namespace";
430 ### remove immutable items (if any)
431 if (UNIVERSAL
::isa
($conf, 'HASH') && $conf->{"Immutable Keys"}) {
432 $conf = {%$conf}; # copy the values - only for immutable
433 my $IMMUTABLE = delete $conf->{"Immutable Keys"};
434 foreach my $key (keys %$IMMUTABLE) {
435 delete $conf->{$key};
439 ### finally write it out
440 $self->write_ref($path, $conf);
448 my $conf = shift || die "Missing conf";
449 my $args = shift || {};
453 die "Invalid filename for write: $file";
455 } elsif (index($file,"\n") != -1) {
456 die "Cannot use a yaml string as a filename during write";
458 ### otherwise base it off of the file extension
459 } elsif ($args->{file_type
}) {
460 $ext = $args->{file_type
};
461 } elsif ($file =~ /\.(\w+)$/) {
464 $ext = defined($args->{default_ext
}) ? $args->{default_ext
}
465 : defined($self->{default_ext
}) ? $self->{default_ext
}
466 : defined($DEFAULT_EXT) ? $DEFAULT_EXT : '';
467 $file = length($ext) ? "$file.$ext" : $file;
470 ### allow for a pre-cached reference
471 if (exists $CACHE{$file} && ! $self->{no_cache
}) {
472 warn "Cannot write back to a file that is in the cache";
476 ### determine the handler
478 if ($args->{handler
}) {
479 $handler = (UNIVERSAL
::isa
($args->{handler
},'CODE'))
480 ? $args->{handler
} : $args->{handler
}->{$ext};
481 } elsif ($self->{handler
}) {
482 $handler = (UNIVERSAL
::isa
($self->{handler
},'CODE'))
483 ? $self->{handler
} : $self->{handler
}->{$ext};
486 $handler = $EXT_WRITERS{$ext} || die "Unknown file extension: $ext";
489 return eval { scalar &$handler($file, $conf, $args) } || do {
490 debug
"Couldn't write $file: $@" if $DEBUG_ON_FAIL;
491 dex_warn
"Couldn't write $file: $@" if ! $self->{no_warn_on_fail
};
498 ###----------------------------------------------------------------###
500 sub write_handler_ini
{
503 require Config
::IniHash
;
504 return &Config
::IniHash
::WriteINI
($file, $ref);
507 sub write_handler_pl
{
510 ### do has odd behavior in that it turns a simple hashref
511 ### into hash - help it out a little bit
512 require Data
::Dumper
;
513 local $Data::Dump
::Purity
= 1;
514 local $Data::Dumper
::Sortkeys
= 1;
515 local $Data::Dumper
::Quotekeys
= 0;
516 local $Data::Dumper
::Pad
= ' ';
517 local $Data::Dumper
::Varname
= 'VunderVar';
518 my $str = Data
::Dumper-
>Dumpperl([$ref]);
519 if ($str =~ s/^(.+?=\s*)//s) {
521 $str =~ s/^\s{1,$l}//mg;
523 if ($str =~ /\$VunderVar/) {
524 die "Ref to be written contained circular references - can't write";
528 open (OUT
, ">$file") || die $!;
533 sub write_handler_storable
{
537 return &Storable
::store
($ref, $file);
540 sub write_handler_yaml
{
544 &YAML
::DumpFile
($file, $ref);
547 sub write_handler_xml
{
552 open (OUT
, ">$file") || die $!;
553 print OUT
scalar(XML
::Simple-
>new->XMLout($ref, noattr
=> 1));
557 sub write_handler_html
{
560 die "Write of conf information to html is not supported";
563 ###----------------------------------------------------------------###
567 my $paths = shift || $self->paths;
570 ### what extensions do we look for
572 if ($self->{handler
}) {
573 if (UNIVERSAL
::isa
($self->{handler
},'HASH')) {
574 %EXT = %{ $self->{handler
} };
578 if (! $self->{html_key
} && ! $HTML_KEY) {
579 delete $EXT{$_} foreach qw(html htm);
582 return if ! keys %EXT;
584 ### look in the paths for the files
585 foreach my $path (ref($paths) ? @$paths : $paths) {
588 next if exists $CACHE{$path};
590 my $ext = ($path =~ /\.(\w+)$/) ? $1 : '';
591 next if ! $EXT{$ext};
592 $CACHE{$path} = $self->read($path);
595 &File
::Find
::find
(sub {
596 return if exists $CACHE{$File::Find
::name
};
597 return if $File::Find
::name
=~ m
|/CVS/|;
599 my $ext = (/\.(\w+)$/) ? $1 : '';
600 return if ! $EXT{$ext};
601 $CACHE{$File::Find
::name
} = $self->read($File::Find
::name
);
609 ###----------------------------------------------------------------###
617 CGI::Ex::Conf - CGI Extended Conf Reader
621 my $cob = CGI::Ex::Conf->new;
623 my $full_path_to_file = "/tmp/foo.val"; # supports ini, sto, val, pl, xml
624 my $hash = $cob->read($file);
626 local $cob->{default_ext} = 'conf'; # default anyway
629 my @paths = qw(/tmp, /home/pauls);
630 local $cob->{paths} = \@paths;
631 my $hash = $cob->read('My::NameSpace');
632 # will look in /tmp/My/NameSpace.conf and /home/pauls/My/NameSpace.conf
634 my $hash = $cob->read('My::NameSpace', {paths => ['/tmp']});
635 # will look in /tmp/My/NameSpace.conf
638 local $cob->{directive} = 'MERGE';
639 my $hash = $cob->read('FooSpace');
641 my $hash = $cob->read('FooSpace', {directive => 'MERGE'});
642 # will return merged hashes from /tmp/FooSpace.conf and /home/pauls/FooSpace.conf
643 # immutable keys are preserved from originating files
646 local $cob->{directive} = 'FIRST';
647 my $hash = $cob->read('FooSpace');
648 # will return values from first found file in the path.
651 local $cob->{directive} = 'LAST'; # default behavior
652 my $hash = $cob->read('FooSpace');
653 # will return values from last found file in the path.
657 $cob->write('FooSpace'); # will write it out the changes
661 There are half a million Conf readers out there. Why not add one more.
662 Actually, this module provides a wrapper around the many file formats
663 and the config modules that can handle them. It does not introduce any
666 This module also provides a preload ability which is useful in conjunction
669 Oh - and it writes too.
675 =item C<-E<gt>read_ref>
677 Takes a file and optional argument hashref. Figures out the type
678 of handler to use to read the file, reads it and returns the ref.
679 If you don't need the extended merge functionality, or key fallback,
680 or immutable keys, or path lookup ability - then use this method.
681 Otherwise - use ->read.
685 First argument may be either a perl data structure, yaml string, a
686 full filename, or a file "namespace".
688 The second argument can be a hashref of override values (referred to
691 If the first argument is a perl data structure, it will be
692 copied one level deep and returned (nested structures will contain the
693 same references). A yaml string will be parsed and returned. A full
694 filename will be read using the appropriate handler and returned (a
695 file beginning with a / or ./ or ../ is considered to be a full
696 filename). A file "namespace" (ie "footer" or "my::config" or
697 "what/ever") will be turned into a filename by looking for that
698 namespace in the paths found either in $args->{paths} or in
699 $self->{paths} or in @DEFAULT_PATHS. @DEFAULT_PATHS is empty by
700 default as is $self->{paths} - read makes no attempt to guess what
701 directories to look in. If the namespace has no extension the
702 extension listed in $args->{default_ext} or $self->{default_ext} or
703 $DEFAULT_EXT will be used).
705 my $ref = $cob->read('My::NameSpace', {
706 paths => [qw(/tmp /usr/data)],
709 # would look first for /tmp/My/NameSpace.pl
710 # and then /usr/data/My/NameSpace.pl
712 my $ref = $cob->read('foo.sto', {
713 paths => [qw(/tmp /usr/data)],
716 # would look first for /tmp/foo.sto
717 # and then /usr/data/foo.sto
719 When a namespace is used and there are multiple possible paths, there
720 area a few options to control which file to look for. A directive of
721 'FIRST', 'MERGE', or 'LAST' may be specified in $args->{directive} or
722 $self->{directive} or the default value in $DIRECTIVE will be used
723 (default is 'LAST'). When 'FIRST' is specified the first path that
724 contains the namespace is returned. If 'LAST' is used, the last
725 found path that contains the namespace is returned. If 'MERGE' is
726 used, the data structures are joined together. If they are
727 arrayrefs, they are joined into one large arrayref. If they are
728 hashes, they are layered on top of each other with keys found in later
729 paths overwriting those found in earlier paths. This allows for
730 setting system defaults in a root file, and then allow users to have
733 It is possible to make keys in a root file be immutable (non
734 overwritable) by adding a suffix of _immutable or _immu to the key (ie
735 {foo_immutable => 'bar'}). If a value is found in the file that
736 matches $IMMUTABLE_KEY, the entire file is considered immutable.
737 The immutable defaults may be overriden using $IMMUTABLE_QR and $IMMUTABLE_KEY.
739 =item C<-E<gt>write_ref>
741 Takes a file and the reference to be written. Figures out the type
742 of handler to use to write the file and writes it. If you used the ->read_ref
743 use this method. Otherwise, use ->write.
747 Allows for writing back out the information read in by ->read. If multiple
748 paths where used - the directive 'FIRST' will write the changes to the first
749 file in the path - otherwise the last path will be used. If ->read had found
750 immutable keys, then those keys are removed before writing.
752 =item C<-E<gt>preload_files>
754 Arguments are file(s) and/or directory(s) to preload. preload_files will
755 loop through the arguments, find the files that exist, read them in using
756 the handler which matches the files extension, and cache them by filename
757 in %CACHE. Directories are spidered for file extensions which match those
758 listed in %EXT_READERS. This is useful for a server environment where CPU
759 may be more precious than memory.
763 CGI::Ex::Conf supports the files found in %EXT_READERS by default.
764 Additional types may be added to %EXT_READERS, or a custom handler may be
765 passed via $args->{handler} or $self->{handler}. If the custom handler is
766 a code ref, all files will be passed to it. If it is a hashref, it should
767 contain keys which are extensions it supports, and values which read those
770 Some file types have benefits over others. Storable is very fast, but is
771 binary and not human readable. YAML is readable but very slow. I would
772 suggest using a readable format such as YAML and then using preload_files
773 to load in what you need at run time. All preloaded files are faster than
774 any of the other types.
776 The following is the list of handlers that ships with CGI::Ex::Conf (they
777 will only work if the supporting module is installed on your system):
783 Should be a file containing a perl structure which is the last thing returned.
785 =item C<sto> and C<storable>
787 Should be a file containing a structure stored in Storable format.
790 =item C<yaml> and C<conf> and C<val>
792 Should be a file containing a yaml document. Multiple documents are returned
793 as a single arrayref. Also - any file without an extension and custom handler
794 will be read using YAML. See L<YAML>.
798 Should be a windows style ini file. See L<Config::IniHash>
802 Should be an xml file. It will be read in by XMLin. See L<XML::Simple>.
804 =item C<html> and C<htm>
806 This is actually a custom type intended for use with CGI::Ex::Validate.
807 The configuration to be read is actually validation that is stored
808 inline with the html. The handler will look for any form elements or
809 input elements with an attribute with the same name as in $HTML_KEY. It
810 will also look for a javascript variable by the same name as in $HTML_KEY.
811 All configuration items done this way should be written in YAML.
812 For example, if $HTML_KEY contained 'validation' it would find validation in:
814 <input type=text name=username validation="{required: 1}">
815 # automatically indented and "username:\n" prepended
817 <form name=foo validation="
818 general no_confirm: 1
822 document.validation = "\n\
823 username: {required: 1}\n\
828 var validation = "\n\
829 username: {required: 1}\n\
833 If the key $HTML_KEY is not set, the handler will always return undef
834 without even opening the file.
840 Make a similar write method that handles immutability.
848 This module may be distributed under the same terms as Perl itself.
This page took 0.095493 seconds and 4 git commands to generate.