package CGI::Ex::Conf; =head1 NAME CGI::Ex::Conf - Conf Reader/Writer for many different data format types =cut ###----------------------------------------------------------------### # Copyright 2007 - Paul Seamons # # Distributed under the Perl Artistic License without warranty # ###----------------------------------------------------------------### use strict; use base qw(Exporter); use Carp qw(croak); use vars qw($VERSION @DEFAULT_PATHS $DEFAULT_EXT %EXT_READERS %EXT_WRITERS $DIRECTIVE $IMMUTABLE_QR $IMMUTABLE_KEY %CACHE $HTML_KEY @EXPORT_OK $NO_WARN_ON_FAIL ); @EXPORT_OK = qw(conf_read conf_write in_cache); $VERSION = '2.24'; $DEFAULT_EXT = 'conf'; %EXT_READERS = ('' => \&read_handler_yaml, 'conf' => \&read_handler_yaml, 'json' => \&read_handler_json, 'val_json' => \&read_handler_json, 'ini' => \&read_handler_ini, 'pl' => \&read_handler_pl, 'sto' => \&read_handler_storable, 'storable' => \&read_handler_storable, 'val' => \&read_handler_yaml, 'xml' => \&read_handler_xml, 'yaml' => \&read_handler_yaml, 'yml' => \&read_handler_yaml, 'html' => \&read_handler_html, 'htm' => \&read_handler_html, ); %EXT_WRITERS = ('' => \&write_handler_yaml, 'conf' => \&write_handler_yaml, 'ini' => \&write_handler_ini, 'json' => \&write_handler_json, 'val_json' => \&write_handler_json, 'pl' => \&write_handler_pl, 'sto' => \&write_handler_storable, 'storable' => \&write_handler_storable, 'val' => \&write_handler_yaml, 'xml' => \&write_handler_xml, 'yaml' => \&write_handler_yaml, 'yml' => \&write_handler_yaml, 'html' => \&write_handler_html, 'htm' => \&write_handler_html, ); ### $DIRECTIVE controls how files are looked for when namespaces are not absolute. ### If directories 1, 2 and 3 are passed and each has a config file ### LAST would return 3, FIRST would return 1, and MERGE will ### try to put them all together. Merge behavior of hashes ### is determined by $IMMUTABLE_\w+ variables. $DIRECTIVE = 'LAST'; # LAST, MERGE, FIRST $IMMUTABLE_QR = qr/_immu(?:table)?$/i; $IMMUTABLE_KEY = 'immutable'; ###----------------------------------------------------------------### sub new { my $class = shift || __PACKAGE__; my $args = shift || {}; return bless {%$args}, $class; } sub paths { my $self = shift; return $self->{paths} ||= \@DEFAULT_PATHS; } ###----------------------------------------------------------------### sub conf_read { my $file = shift; my $args = shift || {}; my $ext; ### they passed the right stuff already if (ref $file) { if (UNIVERSAL::isa($file, 'SCALAR')) { if ($$file =~ /^\s*) { return html_parse_yaml_load($$file, $args); # allow for ref to a YAML string } else { return yaml_load($$file); # allow for ref to a YAML string } } else { return $file; } ### allow for a pre-cached reference } elsif (exists $CACHE{$file} && ! $args->{no_cache}) { return $CACHE{$file}; ### if contains a newline - treat it as a YAML string } elsif (index($file,"\n") != -1) { return yaml_load($file); ### otherwise base it off of the file extension } elsif ($args->{file_type}) { $ext = $args->{file_type}; } elsif ($file =~ /\.(\w+)$/) { $ext = $1; } else { $ext = defined($args->{default_ext}) ? $args->{default_ext} : defined($DEFAULT_EXT) ? $DEFAULT_EXT : ''; $file = length($ext) ? "$file.$ext" : $file; } ### determine the handler my $handler = $EXT_READERS{$ext} || croak "Unknown file extension: $ext"; ### don't die if the file is not found - do die otherwise if (! -e $file) { eval { die "Conf file $file not found\n" }; warn "Conf file $file not found" if ! $args->{'no_warn_on_fail'} && ! $NO_WARN_ON_FAIL; return; } return eval { scalar $handler->($file, $args) } || die "Error while reading conf file $file\n$@"; } sub read_ref { my $self = shift; my $file = shift; my $args = shift || {}; return conf_read($file, {%$self, %$args}); } ### allow for different kinds of merging of arguments ### allow for key fallback on hashes ### allow for immutable values on hashes sub read { my $self = shift; my $namespace = shift; my $args = shift || {}; my $REF = $args->{ref} || undef; # can pass in existing set of options my $IMMUTABLE = $args->{immutable} || {}; # can pass existing immutable types $self = $self->new() if ! ref $self; ### allow for fast short ciruit on path lookup for several cases my $directive; my @paths = (); if (ref($namespace) # already a ref || index($namespace,"\n") != -1 # yaml string to read in || $namespace =~ m|^\.{0,2}/.+$| # absolute or relative file ) { push @paths, $namespace; $directive = 'FIRST'; ### use the default directories } else { $directive = uc($args->{directive} || $self->{directive} || $DIRECTIVE); $namespace =~ s|::|/|g; # allow perlish style namespace my $paths = $args->{paths} || $self->paths || croak "No paths found during read on $namespace"; $paths = [$paths] if ! ref $paths; if ($directive eq 'LAST') { # LAST shall be FIRST $directive = 'FIRST'; $paths = [reverse @$paths] if $#$paths != 0; } foreach my $path (@$paths) { next if exists $CACHE{$path} && ! $CACHE{$path}; push @paths, "$path/$namespace"; } } ### make sure we have at least one path if ($#paths == -1) { croak "Couldn't find a path for namespace $namespace. Perhaps you need to pass paths => \@paths"; } ### now loop looking for a ref foreach my $path (@paths) { my $ref = $self->read_ref($path, $args) || next; if (! $REF) { if (UNIVERSAL::isa($ref, 'ARRAY')) { $REF = []; } elsif (UNIVERSAL::isa($ref, 'HASH')) { $REF = {}; } else { croak "Unknown config type of \"".ref($ref)."\" for namespace $namespace"; } } elsif (! UNIVERSAL::isa($ref, ref($REF))) { croak "Found different reference types for namespace $namespace" . " - wanted a type ".ref($REF); } if (ref($REF) eq 'ARRAY') { if ($directive eq 'MERGE') { push @$REF, @$ref; next; } splice @$REF, 0, $#$REF + 1, @$ref; last; } else { my $immutable = delete $ref->{$IMMUTABLE_KEY}; my ($key,$val); if ($directive eq 'MERGE') { while (($key,$val) = each %$ref) { next if $IMMUTABLE->{$key}; my $immute = $key =~ s/$IMMUTABLE_QR//o; $IMMUTABLE->{$key} = 1 if $immute || $immutable; $REF->{$key} = $val; } next; } delete $REF->{$key} while $key = each %$REF; while (($key,$val) = each %$ref) { my $immute = $key =~ s/$IMMUTABLE_QR//o; $IMMUTABLE->{$key} = 1 if $immute || $immutable; $REF->{$key} = $val; } last; } } $REF->{"Immutable Keys"} = $IMMUTABLE if scalar keys %$IMMUTABLE; return $REF; } ###----------------------------------------------------------------### sub read_handler_ini { my $file = shift; require Config::IniHash; return Config::IniHash::ReadINI($file); } sub read_handler_pl { my $file = shift; ### do has odd behavior in that it turns a simple hashref ### into hash - help it out a little bit my @ref = do $file; return ($#ref != 0) ? {@ref} : $ref[0]; } sub read_handler_json { my $file = shift; local *IN; open (IN, $file) || die "Couldn't open $file: $!"; CORE::read(IN, my $text, -s $file); close IN; require JSON; return scalar JSON::jsonToObj($text); } sub read_handler_storable { my $file = shift; require Storable; return Storable::retrieve($file); } sub read_handler_yaml { my $file = shift; local *IN; open (IN, $file) || die "Couldn't open $file: $!"; CORE::read(IN, my $text, -s $file); close IN; return yaml_load($text); } sub yaml_load { my $text = shift; require YAML; my @ret = eval { YAML::Load($text) }; if ($@) { die "$@"; } return ($#ret == 0) ? $ret[0] : \@ret; } sub read_handler_xml { my $file = shift; require XML::Simple; return XML::Simple::XMLin($file); } ### this handler will only function if a html_key (such as validation) ### is specified - actually this somewhat specific to validation - but ### I left it as a general use for other types ### is specified sub read_handler_html { my $file = shift; my $args = shift; if (! eval { require YAML }) { my $err = $@; my $found = 0; my $i = 0; while (my($pkg, $file, $line, $sub) = caller($i++)) { return undef if $sub =~ /\bpreload_files$/; } die $err; } ### get the html local *IN; open (IN, $file) || return undef; CORE::read(IN, my $html, -s $file); close IN; return html_parse_yaml_load($html, $args); } sub html_parse_yaml_load { my $html = shift; my $args = shift || {}; my $key = $args->{html_key} || $HTML_KEY; return undef if ! $key || $key !~ /^\w+$/; my $str = ''; my @order = (); while ($html =~ m{ (document\. # global javascript | var\s+ # local javascript | <\w+\s+[^>]*?) # input, form, select, textarea tag \Q$key\E # the key \s*=\s* # an equals sign ([\"\']) # open quote (.+?[^\\]) # something in between \2 # close quote }xsg) { my ($line, $quot, $yaml) = ($1, $2, $3); if ($line =~ /^(document\.|var\s)/) { # js variable $yaml =~ s/\\$quot/$quot/g; $yaml =~ s/\\n\\\n?/\n/g; $yaml =~ s/\\\\/\\/g; $yaml =~ s/\s*$/\n/s; # fix trailing newline $str = $yaml; # use last one found } else { # inline attributes $yaml =~ s/\s*$/\n/s; # fix trailing newline if ($line =~ m/