928 lines
34 KiB
Perl
928 lines
34 KiB
Perl
# ====================================================================
|
|
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
|
#
|
|
# GT::Config
|
|
# Author: Jason Rhinelander
|
|
# CVS Info :
|
|
# $Id: Config.pm,v 1.45 2005/03/21 05:49:39 jagerman Exp $
|
|
#
|
|
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
|
# ====================================================================
|
|
#
|
|
# Description:
|
|
# A module for handling loading and caching of configuration files.
|
|
#
|
|
|
|
package GT::Config;
|
|
# ===============================================================
|
|
|
|
use strict;
|
|
|
|
use GT::Base qw/PERSIST/; # Due to the nature of the config file's hash-like interface, we can't inherit from GT::Base - it sets things in $self. We do need GT::Base for its in_eval function though.
|
|
use GT::Template::Inheritance;
|
|
use GT::AutoLoader;
|
|
|
|
use constants
|
|
DATA => 0,
|
|
INHERITED => 1,
|
|
FILES => 2,
|
|
FILES_MOD => 3,
|
|
CODE_STR => 4;
|
|
|
|
use vars qw(%ATT %ATTRIBS %CACHE %SUB_CACHE $error $ERRORS $VERSION);
|
|
|
|
# %ATT stores the default attribute values
|
|
# %ATTRIBS stores the attributes of each object. Since each object works exactly
|
|
# like a hash ref of the data it represents, these attributes cannot be stored
|
|
# in $self.
|
|
# %CACHE is used to cache any data of objects using the 'cache' option. Each
|
|
# file in here has an array ref value - the first value is a hash ref of the
|
|
# data, the second a hash ref of inherited keys, the third an array of the
|
|
# files inherited from, and the fourth a hash of [size, last modification
|
|
# time] pairs of those files.
|
|
# %SUB_CACHE is exactly like %CACHE, except that values starting with 'sub {'
|
|
# will be compiled into code refs. Each array ref has a fifth value - a hash
|
|
# reference list that stores the original value of any code refs that have
|
|
# been compiled. %SUB_CACHE is only used when you use 'compile_subs'. Also,
|
|
# because different packages can be specified, this stores which package the
|
|
# code ref was compiled in.
|
|
# $error stores any error that occurs. If a load error happens, you'll need to
|
|
# use $error to get the error message (when not using the 'create_ok' option).
|
|
# $ERRORS stores all the error codes
|
|
# $VERSION - $Id: Config.pm,v 1.45 2005/03/21 05:49:39 jagerman Exp $ - The version.
|
|
|
|
$VERSION = sprintf "%d.%03d", q$Revision: 1.45 $ =~ /(\d+)\.(\d+)/;
|
|
|
|
%ATT = (
|
|
inheritance => 0, # If set, looks for .tplinfo files for inheritance.
|
|
local => 0, # If set, will look for "local" directories containing the file. The file will be saved in a "local" subdirectory of the directory given.
|
|
cache => 1, # If set, GT::Config will look in the cache for the object; objects are always stored in the cache, so that ->load(cache => 0) can be used to reload a file.
|
|
create_ok => 0, # If set, you'll get a GT::Config object even if the file doesn't exist. You can then save() it to create the file. If not set, a fatal error occurs if the file cannot be located. Note that if the file exists, but has a syntax error, or cannot be read, a fatal error will occur regardless of this option.
|
|
empty => 0, # If specified, nothing will be read from disk - can be used to force a new, blank config file
|
|
chmod => 0666, # The octal permissions to set on the file immediately after saving
|
|
strict => 0, # If true, a fatal error will occur when attempting to access a key that does not exist.
|
|
debug => 0, # If true, warnings and debugging will be printing to STDERR
|
|
tmpfile => undef, # Possible values: 0, undef, 1. 0 = no tempfile, undef = tempfile if dir writable, 1 = always tempfile
|
|
header => '', # Can be set to anything. When saving, this will go before the data. Keep in mind, this has to be correct Perl. [localtime] in here will be replaced with scalar localtime() when saving.
|
|
compile_subs => '', # Must be set to a package. If set, any value that starts with 'sub {' will be compiled into a code ref, in the package specified.
|
|
sort_order => undef, # Passed to GT::Dumper->dump as 'order' value if set
|
|
tab => "\t", # What to use for a "tab" in the config file. Defaults to an actual tab.
|
|
);
|
|
|
|
# Other attributes used internally:
|
|
# filename => '', # Whatever you give as the filename
|
|
# file => '', # Just the filename (no path)
|
|
# path => '', # The path of the filename
|
|
# files => {}, # A hash of filename => last_mod_time (may contain multiple entries to support inheritance).
|
|
# file_order => [], # The order of the files in 'files'
|
|
# data => {}, # The actual data of the config file.
|
|
# inherited => {}, # Each base key inherited will have $key => 1 in here. Inherited keys are not saved, unless they are changed between load time and save time.
|
|
# compiled => {}, # Any keys that start with 'sub {' will be compiled into code refs if the compile_subs option is on. The code reference is saved here so that recompiling is not necessary
|
|
|
|
$ERRORS = {
|
|
CANT_LOAD => q _Unable to load '%s': %s._,
|
|
CANT_COMPILE => q _Unable to compile '%s': %s._,
|
|
CANT_FIND => q _Config file '%s' does not exist in directory '%s' or has incorrect permissions set._,
|
|
CANT_WRITE => q _Unable to open '%s' for writing: %s._,
|
|
CANT_PRINT => q _Unable to write to file '%s': %s._,
|
|
CANT_RENAME => q _Unable to move '%s' to '%s': %s._,
|
|
WRITE_MISMATCH => q _Unable to save '%s': wrote %d bytes, but file is %d bytes_,
|
|
CANT_CREATE_DIR => q _Unable to create directory '%s': %s._,
|
|
NOT_HASH => q _Config file '%s' did not return a hash reference._,
|
|
BAD_ARGS => q _Bad arguments. Usage: %s_,
|
|
NOT_FILE => q _'%s' does not look like a valid filename_,
|
|
RECURSION => q _Recursive inheritance detected and interrupted: '%s'_,
|
|
UNKNOWN_OPT => q _Unknown option '%s' passed to %s_,
|
|
BAD_KEY => q _The key you attempted to access, '%s', does not exist in '%s'_,
|
|
CANT_COMPILE_CODE => q _Unable to compile '%s' in file '%s': %s_
|
|
};
|
|
|
|
sub load {
|
|
my $class = shift;
|
|
|
|
my (%attribs, %data);
|
|
|
|
tie %data, $class, \%attribs;
|
|
my $self = bless \%data, ref $class || $class;
|
|
|
|
$ATTRIBS{$self} = \%attribs; # hehehe ;-)
|
|
|
|
my $filename = shift or return $self->error(BAD_ARGS => FATAL => 'GT::Config->load("/path/to/config/file", { opts })');
|
|
$attribs{filename} = $filename;
|
|
$attribs{filename_given} = $filename;
|
|
|
|
@attribs{'path', 'file'} = ($filename =~ m|^(.*?)[\\/]?([^\\/]+)$|) or return $self->error(NOT_FILE => FATAL => $filename);
|
|
$attribs{path} = '.' unless length $attribs{path};
|
|
$filename = $attribs{filename} = "$attribs{path}/$attribs{file}"; # _load_data/_load_tree depend on it being like this.
|
|
|
|
my $opts = shift || {};
|
|
ref $opts eq 'HASH' or return $self->error(BAD_ARGS => FATAL => 'GT::Config->load("/path/to/config/file", { opts })');
|
|
|
|
for (keys %ATT) {
|
|
if (/^(?:inheritance|local|cache|create_ok|strict|empty)$/) {
|
|
$attribs{$_} = exists $opts->{$_} ? (delete $opts->{$_} ? 1 : 0) : $ATT{$_};
|
|
}
|
|
elsif ($_ eq 'tmpfile') {
|
|
if (exists $opts->{$_}) {
|
|
my $tmpfile = delete $opts->{$_};
|
|
$attribs{$_} = defined($tmpfile) ? $tmpfile ? 1 : 0 : undef;
|
|
}
|
|
else {
|
|
$attribs{$_} = $ATT{$_};
|
|
}
|
|
}
|
|
else {
|
|
$attribs{$_} = exists $opts->{$_} ? delete $opts->{$_} : $ATT{$_};
|
|
}
|
|
}
|
|
|
|
$self->debug("Received '$filename' for the file to load", 2) if $attribs{debug} >= 2;
|
|
|
|
if (keys %$opts) {
|
|
$self->error(UNKNOWN_OPT => FATAL => keys %$opts => ref($self) . '->load');
|
|
}
|
|
|
|
$self->debug("Loading '$filename' with options: inheritance => '$attribs{inheritance}', local => '$attribs{local}', cache => '$attribs{cache}', create_ok => '$attribs{create_ok}', empty => '$attribs{empty}', chmod => '$attribs{chmod}', strict => '$attribs{strict}', debug => '$attribs{debug}', compile_subs => '$attribs{compile_subs}'") if $attribs{debug};
|
|
$self->debug("Header: '$attribs{header}'", 2) if $attribs{debug} >= 2;
|
|
|
|
if ($attribs{empty}) {
|
|
# An empty config file doesn't get added to the cache
|
|
$self->debug("Not loading any data or cache - 'empty' specified") if $attribs{debug};
|
|
}
|
|
elsif ($attribs{cache} and $attribs{compile_subs} and $SUB_CACHE{$attribs{compile_subs}}->{$filename} and my $debug_unchanged = $self->_is_unchanged(@{$SUB_CACHE{$attribs{compile_subs}}->{$filename}}[FILES, FILES_MOD])) {
|
|
$self->debug("Loading '$filename' from compiled sub cache") if $attribs{debug};
|
|
@attribs{qw{data inherited file_order files compiled}} = @{$SUB_CACHE{$attribs{compile_subs}}->{$filename}};
|
|
$attribs{cache_hit} = 1;
|
|
}
|
|
elsif ($attribs{cache} and not $attribs{compile_subs} and $CACHE{$filename} and $debug_unchanged = $self->_is_unchanged(@{$CACHE{$filename}}[FILES, FILES_MOD])) {
|
|
$self->debug("Loading '$filename' from regular cache") if $attribs{debug};
|
|
@attribs{qw{data inherited file_order files}} = @{$CACHE{$filename}};
|
|
$attribs{cache_hit} = 1;
|
|
}
|
|
else {
|
|
$self->debug("Not loading '$filename' from cache") if $attribs{debug};
|
|
if ($attribs{debug} > 1) { # If the debug level is > 1, display some debugging as to _why_ we aren't loading from cache
|
|
$self->debug("Reason: Caching disabled") if not $attribs{cache};
|
|
if ($attribs{compile_subs} and not $SUB_CACHE{$attribs{compile_subs}}->{$filename}) { $self->debug("Reason: Not in compiled sub cache") }
|
|
elsif (not $attribs{compile_subs} and not $CACHE{$filename}) { $self->debug("Reason: Not in regular cache") }
|
|
$self->debug("Reason: File (or inherited files) have changed") if ($attribs{compile_subs} ? $SUB_CACHE{$attribs{compile_subs}}->{$filename} : $CACHE{$filename}) and not $debug_unchanged;
|
|
}
|
|
$self->_load_data($filename) or return;
|
|
if (@{$attribs{file_order}}) { # Don't cache it if it is a new object
|
|
if ($attribs{compile_subs}) {
|
|
$self->debug("Adding '$filename' (compile package '$attribs{compile_subs}') to the compiled sub cache") if $attribs{debug};
|
|
$SUB_CACHE{$attribs{compile_subs}}->{$filename} = [@attribs{qw{data inherited file_order files compiled}}];
|
|
}
|
|
else {
|
|
$self->debug("Adding '$filename' to the regular cache") if $attribs{debug};
|
|
$CACHE{$filename} = [@attribs{qw{data inherited file_order files}}];
|
|
}
|
|
}
|
|
}
|
|
return $self;
|
|
}
|
|
|
|
$COMPILE{save} = __LINE__ . <<'END_OF_SUB';
|
|
sub save {
|
|
require GT::Dumper;
|
|
my $self = shift;
|
|
my $att = $ATTRIBS{$self};
|
|
|
|
my ($d, $i) = @$att{'data', 'inherited'};
|
|
|
|
my %data;
|
|
for (keys %$d) { # Strip out all inherited data
|
|
next if $i->{$_};
|
|
|
|
$data{$_} = $d->{$_};
|
|
}
|
|
|
|
my $filename = $att->{path};
|
|
|
|
local $!;
|
|
if ($att->{local}) {
|
|
$filename .= "/local";
|
|
if (!-d $filename) { # $filename is misleading - it's currently a path
|
|
# Attempt to create the "local" directory
|
|
mkdir($filename, 0777) or return $self->error(CANT_CREATE_DIR => FATAL => $filename => "$!");
|
|
CORE::chmod(0777, $filename);
|
|
}
|
|
}
|
|
|
|
my $tmpfile = $att->{tmpfile};
|
|
if (not defined $tmpfile) {
|
|
# Base whether or not we use the tempfile on whether or not we can
|
|
# write to the base directory of the file:
|
|
$tmpfile = -w $filename;
|
|
}
|
|
|
|
$filename .= "/$att->{file}";
|
|
|
|
$self->debug("Saving '$filename'") if $att->{debug};
|
|
|
|
my $localtime = scalar localtime;
|
|
my $header = $att->{header};
|
|
if ($header) {
|
|
$header =~ s/\[localtime\]/$localtime/g;
|
|
$header .= "\n" unless $header =~ /\n$/;
|
|
}
|
|
|
|
my $write_filename = $tmpfile ? "$filename.tmp.$$." . time . "." . int rand 10000 : $filename;
|
|
my $printed = 0;
|
|
my $windows = $^O eq 'MSWin32';
|
|
|
|
local *FILE;
|
|
open FILE, "> $write_filename" or return $self->error(CANT_WRITE => FATAL => $write_filename => "$!");
|
|
# Print header, if any:
|
|
if ($header) {
|
|
$printed += length $header;
|
|
$printed += $header =~ y/\n// if $windows; # Windows does \n => \r\n translation on FH output
|
|
unless (print FILE $header) {
|
|
my $err = "$!";
|
|
close FILE;
|
|
unlink $write_filename if $tmpfile;
|
|
return $self->error(CANT_PRINT => FATAL => $write_filename => $err);
|
|
}
|
|
}
|
|
# Print actual data:
|
|
my $dump = GT::Dumper->dump(
|
|
var => '',
|
|
data => \%data,
|
|
sort => 1,
|
|
$att->{sort_order} ? (order => $att->{sort_order}) : (),
|
|
tab => $att->{tab}
|
|
);
|
|
$printed += length $dump;
|
|
$printed += $dump =~ y/\n// if $windows;
|
|
unless (print FILE $dump) {
|
|
my $err = "$!";
|
|
close FILE;
|
|
unlink $write_filename if $tmpfile;
|
|
return $self->error(CANT_PRINT => FATAL => $write_filename => $err);
|
|
}
|
|
# Print the vim info line at the bottom:
|
|
my $viminfo = "\n# vim:syn=perl:ts=4:noet\n";
|
|
$printed += length $viminfo;
|
|
$printed += $viminfo =~ y/\n// if $windows;
|
|
unless (print FILE $viminfo) {
|
|
my $err = "$!";
|
|
close FILE;
|
|
unlink $write_filename if $tmpfile;
|
|
return $self->error(CANT_PRINT => FATAL => $write_filename => $err);
|
|
}
|
|
|
|
close FILE;
|
|
|
|
# Check that the file is the right size, because print() returns true if a
|
|
# _partial_ print succeeded. Ideally we would check -s on the filehandle after
|
|
# each print, but of course that doesn't work on Windows.
|
|
unless ((my $actual = -s $write_filename) == $printed) {
|
|
unlink $write_filename if $tmpfile;
|
|
return $self->error(WRITE_MISMATCH => FATAL => $write_filename => $printed => $actual);
|
|
}
|
|
|
|
if ($tmpfile) {
|
|
$self->debug("'$write_filename' saved; renaming to '$filename'") if $att->{debug} > 1;
|
|
unless (rename $write_filename, $filename) {
|
|
my $err = "$!";
|
|
unlink $write_filename;
|
|
return $self->error(CANT_RENAME => FATAL => $write_filename => $filename => $err);
|
|
}
|
|
}
|
|
|
|
if (defined $att->{chmod}) {
|
|
my $mode = (stat $filename)[2] & 07777;
|
|
CORE::chmod($att->{chmod}, $filename) unless $att->{chmod} == $mode;
|
|
}
|
|
$self->debug("'$filename' saved, $printed bytes.") if $att->{debug};
|
|
return 1;
|
|
}
|
|
END_OF_SUB
|
|
|
|
# Returns true if the current object was loaded from cache, false otherwise.
|
|
sub cache_hit { $ATTRIBS{$_[0]}->{cache_hit} }
|
|
|
|
sub _is_unchanged {
|
|
my ($self, $old_order, $old_mod) = @_;
|
|
my $att = $ATTRIBS{$self};
|
|
$self->debug("Checking for any changes in the file (or inherited files)") if $att->{debug};
|
|
|
|
my @old_order = @$old_order; # Copy the old file_order and file modification
|
|
my %old_mod = %$old_mod; # times. _load_tree will replace them.
|
|
|
|
my $just_do_ok = not (PERSIST or $att->{inheritance} or $att->{local} or $att->{create_ok});
|
|
|
|
$self->_load_tree($just_do_ok);
|
|
|
|
if (@{$att->{file_order}} != @old_order) {
|
|
$self->debug("The old order and the new differ: Old: (@old_order) New: (@{$att->{file_order}})") if $att->{debug};
|
|
return;
|
|
}
|
|
for (0 .. $#old_order) {
|
|
if ($old_order[$_] ne $att->{file_order}->[$_]) {
|
|
$self->debug("The old order and the new differ: Old: (@old_order) New: (@{$att->{file_order}})") if $att->{debug};
|
|
return; # The inherited files are not the same as before
|
|
}
|
|
elsif ($att->{debug} >= 2) {
|
|
$self->debug("Old order and new order do not differ. Old: (@old_order) New: (@{$att->{file_order}})");
|
|
}
|
|
|
|
if ($old_mod{$old_order[$_]}->[0] != $att->{files}->{$old_order[$_]}->[0]) {
|
|
$self->debug("The file size of $old_order[$_] has changed: Old: $old_mod{$old_order[$_]}->[0], New: $att->{files}->{$old_order[$_]}->[0]") if $att->{debug};
|
|
return; # The inherited files have changed in size
|
|
}
|
|
elsif ($old_mod{$old_order[$_]}->[1] != $att->{files}->{$old_order[$_]}->[1]) {
|
|
$self->debug("The modification time of $old_order[$_] has changed: Old: $old_mod{$old_order[$_]}->[1], New: $att->{files}->{$old_order[$_]}->[1]") if $att->{debug};
|
|
return; # The inherited files have a changed mtime
|
|
}
|
|
elsif ($att->{debug} >= 2) {
|
|
$self->debug("The file size and modification time of $old_order[$_] has not changed");
|
|
}
|
|
}
|
|
|
|
$self->debug("No changes have been made") if $att->{debug};
|
|
1; # Here's the prize. Nothing is changed.
|
|
}
|
|
|
|
sub _load_data {
|
|
my $self = shift;
|
|
my $att = $ATTRIBS{$self};
|
|
|
|
my $just_do_ok = not (PERSIST or $att->{inheritance} or $att->{local} or $att->{create_ok});
|
|
|
|
$self->_load_tree($just_do_ok) or return;
|
|
|
|
if ($just_do_ok and not @{$att->{file_order}}) {
|
|
push @{$att->{file_order}}, $att->{filename_given};
|
|
}
|
|
|
|
for my $file (@{$att->{file_order}}) {
|
|
local ($@, $!, $^W);
|
|
$self->debug("do()ing '$file'") if $att->{debug} >= 2;
|
|
my $data = do $file;
|
|
if (!$data and $@) {
|
|
return $self->error(CANT_LOAD => FATAL => $file => "$@");
|
|
}
|
|
elsif (!$data and $!) {
|
|
return $self->error(CANT_COMPILE => FATAL => $file => "$!");
|
|
}
|
|
elsif (ref $data ne 'HASH') {
|
|
return $self->error(NOT_HASH => FATAL => $file);
|
|
}
|
|
if ($just_do_ok or $file eq ($att->{local} ? "$att->{path}/local/$att->{file}" : $att->{filename})) {
|
|
$att->{data} = $data;
|
|
}
|
|
else {
|
|
for (keys %$data) {
|
|
next if exists $att->{data}->{$_};
|
|
$att->{data}->{$_} = $data->{$_};
|
|
$att->{inherited}->{$_} = 1;
|
|
}
|
|
}
|
|
}
|
|
|
|
1; # Returning true means loading was successful.
|
|
}
|
|
|
|
sub _load_tree {
|
|
my $self = shift;
|
|
my $just_do_ok = shift;
|
|
my $att = $ATTRIBS{$self};
|
|
|
|
my $root = $att->{path};
|
|
my $file = $att->{file};
|
|
|
|
if ($att->{inheritance}) {
|
|
$att->{file_order} = [GT::Template::Inheritance->get_all_paths(file => $att->{file}, path => $att->{path})];
|
|
|
|
unless (@{$att->{file_order}} or $att->{create_ok} or $just_do_ok) {
|
|
return $self->error('CANT_FIND' => 'FATAL', $att->{file}, $att->{path});
|
|
# No files found!
|
|
}
|
|
|
|
for (@{$att->{file_order}}) {
|
|
$att->{files}->{$_} = [(stat($_))[7, 9]];
|
|
}
|
|
}
|
|
else {
|
|
if (-e "$root/$file") {
|
|
$att->{file_order} = ["$root/$file"];
|
|
$att->{files}->{"$root/$file"} = [(stat("$root/$file"))[7, 9]];
|
|
}
|
|
elsif ($att->{create_ok} or $just_do_ok) {
|
|
$att->{file_order} = [];
|
|
}
|
|
else {
|
|
return $self->error(CANT_FIND => FATAL => $att->{file}, $att->{path});
|
|
}
|
|
}
|
|
|
|
1;
|
|
}
|
|
|
|
$COMPILE{inheritance} = __LINE__ . <<'END_OF_SUB';
|
|
sub inheritance {
|
|
my $self = shift;
|
|
my $att = $ATTRIBS{$self};
|
|
$att->{inheritance};
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{tmpfile} = __LINE__ . <<'END_OF_SUB';
|
|
sub tmpfile {
|
|
my $self = shift;
|
|
my $att = $ATTRIBS{$self};
|
|
if (@_) {
|
|
my $ret = $att->{tmpfile};
|
|
my $tmpfile = shift;
|
|
$tmpfile = defined($tmpfile) ? $tmpfile ? 1 : 0 : undef;
|
|
$att->{tmpfile} = $tmpfile;
|
|
return $ret;
|
|
}
|
|
$att->{tmpfile};
|
|
}
|
|
END_OF_SUB
|
|
|
|
# Must be specified in load() - this only retrieves the value
|
|
$COMPILE{create_ok} = __LINE__ . <<'END_OF_SUB';
|
|
sub create_ok {
|
|
my $self = shift;
|
|
my $att = $ATTRIBS{$self};
|
|
$att->{create_ok};
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{chmod} = __LINE__ . <<'END_OF_SUB';
|
|
sub chmod {
|
|
my $self = shift;
|
|
my $att = $ATTRIBS{$self};
|
|
if (@_) {
|
|
my $ret = $att->{chmod};
|
|
$att->{chmod} = shift;
|
|
return $ret;
|
|
}
|
|
$att->{chmod};
|
|
}
|
|
END_OF_SUB
|
|
|
|
# Must be specified in load()
|
|
$COMPILE{cache} = __LINE__ . <<'END_OF_SUB';
|
|
sub cache {
|
|
my $self = shift;
|
|
my $att = $ATTRIBS{$self};
|
|
$att->{cache};
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{strict} = __LINE__ . <<'END_OF_SUB';
|
|
sub strict {
|
|
my $self = shift;
|
|
my $att = $ATTRIBS{$self};
|
|
if (@_) {
|
|
my $ret = $att->{strict} ? 1 : 0;
|
|
$att->{strict} = shift() ? 1 : 0;
|
|
return $ret;
|
|
}
|
|
$att->{strict};
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{debug_level} = __LINE__ . <<'END_OF_SUB';
|
|
sub debug_level {
|
|
my $self = shift;
|
|
my $att = $ATTRIBS{$self};
|
|
if (@_) {
|
|
my $ret = $att->{debug};
|
|
$att->{debug} = shift;
|
|
return $ret;
|
|
}
|
|
$att->{debug};
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{debug} = __LINE__ . <<'END_OF_SUB';
|
|
sub debug {
|
|
# -------------------------------------------------------
|
|
# Displays a debugging message.
|
|
#
|
|
my ($self, $msg, $min) = @_;
|
|
my $att = $ATTRIBS{$self};
|
|
|
|
$min ||= 1;
|
|
return if $att->{debug} < $min;
|
|
|
|
my $pkg = ref $self || $self;
|
|
|
|
# Add line numbers if no \n on the debug message
|
|
if (substr($msg, -1) ne "\n") {
|
|
my ($file, $line) = (caller)[1,2];
|
|
$msg .= " at $file line $line.\n";
|
|
}
|
|
|
|
# Remove windows linefeeds (breaks unix terminals).
|
|
$msg =~ s/\r//g unless $^O eq 'MSWin32';
|
|
|
|
print STDERR "$pkg ($$): $msg";
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{header} = __LINE__ . <<'END_OF_SUB';
|
|
sub header {
|
|
my $self = shift;
|
|
my $att = $ATTRIBS{$self};
|
|
if (@_) {
|
|
my $ret = $att->{header};
|
|
$att->{header} = shift || '';
|
|
return $ret;
|
|
}
|
|
$att->{header};
|
|
}
|
|
END_OF_SUB
|
|
|
|
# Be sure to delete the object from %ATTRIBS.
|
|
sub DESTROY {
|
|
delete $ATTRIBS{$_[0]} if keys %ATTRIBS and exists $ATTRIBS{$_[0]};
|
|
}
|
|
|
|
$COMPILE{error} = __LINE__ . <<'END_OF_SUB';
|
|
sub error {
|
|
my ($self, $code, $type, @args) = @_;
|
|
$type = $type && uc $type eq 'WARN' ? 'WARN' : 'FATAL';
|
|
my $pkg = ref $self || $self;
|
|
|
|
$error = _format_err($pkg, $code, @args);
|
|
|
|
if ($type eq 'FATAL') {
|
|
die $error if GT::Base::in_eval();
|
|
|
|
if ($SIG{__DIE__}) {
|
|
die $error;
|
|
}
|
|
else {
|
|
print STDERR $error;
|
|
die "\n";
|
|
}
|
|
}
|
|
elsif ($ATTRIBS{$self}->{debug}) { # A warning, and debugging is on
|
|
if ($SIG{__WARN__}) {
|
|
CORE::warn $error;
|
|
}
|
|
else {
|
|
print STDERR $error;
|
|
}
|
|
}
|
|
return;
|
|
}
|
|
END_OF_SUB
|
|
|
|
sub _format_err {
|
|
# -------------------------------------------------------
|
|
# Formats an error message for output.
|
|
#
|
|
my ($pkg, $code, @args) = @_;
|
|
my $msg = sprintf($ERRORS->{$code} || $code, @args);
|
|
|
|
my ($file, $line) = GT::Base::get_file_line($pkg);
|
|
return "$pkg ($$): $msg at $file line $line.\n";
|
|
}
|
|
|
|
# Tied hash handling
|
|
sub TIEHASH { bless $_[1], $_[0] }
|
|
sub STORE {
|
|
$_[0]->{data}->{$_[1]} = $_[2];
|
|
delete $_[0]->{inherited}->{$_[1]};
|
|
delete $_[0]->{compiled}->{$_[1]};
|
|
}
|
|
sub FETCH {
|
|
my $att = shift; # $_[0] is NOT $self - it is the attribute hashref
|
|
my $key = shift;
|
|
|
|
if ($att->{strict} and not exists $att->{data}->{$key}) {
|
|
return GT::Config->error(BAD_KEY => FATAL => $key, $att->{filename});
|
|
}
|
|
elsif ($att->{compile_subs} and not ref $att->{data}->{$key} and substr($att->{data}->{$key}, 0, 5) eq 'sub {') {
|
|
return $att->{compiled}->{$key} if exists $att->{compiled}->{$key};
|
|
|
|
my ($code, $err);
|
|
# Perl breaks when the eval below contains a 'use' statement. Somehow, Perl
|
|
# thinks it's deeper (in terms of { ... }) than it really is, and so ends up
|
|
# either exiting the subroutine prematurely, or, if we try to work around that
|
|
# by using another subroutine, or returning early, by jumping back one
|
|
# subroutine too many with its return value. So, to get around the whole
|
|
# problem, we wrap the code in double-evals if it contains 'use' or 'BEGIN'.
|
|
# It won't _break_ anything, but unfortunately it does slow compiled_subs
|
|
# globals a little bit slower.
|
|
if ($att->{data}->{$key} =~ /\b(use|no)\s+[\w:]/ or $att->{data}->{$key} =~ /\bBEGIN\b/) {
|
|
$code = eval "package $att->{compile_subs}; my \$ret = eval qq|\Q$att->{data}->{$key}\E|; die qq|\$\@\n| if \$\@; \$ret;";
|
|
}
|
|
else {
|
|
$code = eval "package $att->{compile_subs}; $att->{data}->{$key};";
|
|
}
|
|
$err = "$@";
|
|
|
|
# Perl prior to 5.6.1 breaks on this:
|
|
# perl -e 'my $c = eval "package SomePkg; sub bar { use NotThere }"; eval "package OtherPkg; print 1"; die "$@" if $@'
|
|
# From that, we die with: syntax error at (eval 2) line 1, near "package OtherPkg"
|
|
# This little hack fixes it, but don't ask me why:
|
|
eval "package Hack;" if $] < 5.006001;
|
|
|
|
if (ref $code ne 'CODE') {
|
|
GT::Config->error(CANT_COMPILE_CODE => WARN => $key, $att->{filename}, $err);
|
|
my $error = "Unable to compile '$key': $err";
|
|
$code = sub { $error };
|
|
}
|
|
|
|
return $att->{compiled}->{$key} = $code;
|
|
}
|
|
|
|
$att->{data}->{$key};
|
|
}
|
|
|
|
sub FIRSTKEY { keys %{$_[0]->{data}}; each %{$_[0]->{data}} }
|
|
sub NEXTKEY { each %{$_[0]->{data}} }
|
|
sub EXISTS { exists $_[0]->{data}->{$_[1]} }
|
|
sub DELETE {
|
|
my $val;
|
|
$val = $_[0]->FETCH($_[1]) if defined wantarray;
|
|
delete $_[0]->{inherited}->{$_[1]};
|
|
delete $_[0]->{data}->{$_[1]};
|
|
delete $_[0]->{compiled}->{$_[1]};
|
|
$val;
|
|
}
|
|
sub CLEAR { %{$_[0]->{data}} = %{$_[0]->{inherited}} = %{$_[0]->{compiled}} = () }
|
|
|
|
1;
|
|
|
|
__END__
|
|
|
|
=head1 NAME
|
|
|
|
GT::Config - Dumped-hash configuration handler
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use GT::Config;
|
|
my $Config = GT::Config->load($config_file);
|
|
...
|
|
print $Config->{variable};
|
|
...
|
|
$Config->{othervar} = "something";
|
|
...
|
|
$Config->save;
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
GT::Config provides a simple way to handle loading config files. It can load
|
|
and save any config file consisting of a dumped hash. You can then use the
|
|
object as if it were the actual hash reference from the config file. It
|
|
supports template set inheritance (see L<GT::Template>) and mtime-based
|
|
caching.
|
|
|
|
=head1 METHODS
|
|
|
|
=head2 load
|
|
|
|
There is no C<new()> method. To get a new config object you do:
|
|
|
|
$Config = GT::Config->load("/path/to/config/file", { options });
|
|
|
|
The first argument is the full path to the file to open to read the
|
|
configuration. The file does not necessarily have to exist - see the options
|
|
below.
|
|
|
|
The second argument is a hash reference of options, and is optional. The
|
|
possible options are:
|
|
|
|
=over 4
|
|
|
|
=item inheritance
|
|
|
|
If provided as something true, GT::Config will scan for .tplinfo files looking
|
|
for inherited template sets. This is typically used for loading globals.txt or
|
|
language.txt files from Gossamer Threads products' template sets.
|
|
|
|
Defaults to off.
|
|
|
|
=item local
|
|
|
|
If provided as something true, GT::Config will look for a "local" directory
|
|
containing the file. When using inheritance, a "local" directory will also be
|
|
looked for in each inherited configuration file. However, regardless of the
|
|
C<inheritance> option, "local" configuration files always inherit from their
|
|
non-local counterpart.
|
|
|
|
Additionally, this option causes GT::Config to save the file into a "local"
|
|
directory. Also note that the "local" file will _only_ contain keys that were
|
|
already in the local file, or were assigned to the config object after loading
|
|
the file.
|
|
|
|
Defaults to off.
|
|
|
|
=item cache
|
|
|
|
If provided, will look in the internal cache for a cached copy of the file. If
|
|
none is found, a new GT::Config object will be constructed as usual, then saved
|
|
in the cache.
|
|
|
|
Defaults to on. You must pass C<cache =E<gt> 0> to disable cached loading.
|
|
Note that new objects are always stored in the cache, allowing you to specify
|
|
C<cache =E<gt> 0> to force a reload of a cached file.
|
|
|
|
=item create_ok
|
|
|
|
If set, you'll still get back a GT::Config hash even if the file doesn't exist.
|
|
You can then save() the object to create a new config file. If this option is
|
|
not set, a fatal error will occur when attempting to load a file that does not
|
|
exist.
|
|
|
|
Defaults to off. Pass in C<create_ok =E<gt> 1> if the config file doesn't
|
|
necessarily have to exist (i.e. when creating a new config file).
|
|
|
|
=item empty
|
|
|
|
The C<empty> option is used to create a new, blank config file - it can be
|
|
thought of as a forced version of the C<create_ok> option. It won't read
|
|
B<any> files during loading (and as such completely ignores the C<inheritance>
|
|
and C<cache> options). This is mainly intended to be used when a complete
|
|
replacement of a file is desired, regardless of what is currently on disk.
|
|
|
|
=item chmod
|
|
|
|
The C<chmod> option is used to specify the mode of the saved file. It must be
|
|
passed in octal form, such as 0644 (but B<not> in string form, such as
|
|
C<"0644">). The default is 0666, to allow writing by any users. Though not
|
|
terribly secure, this is the sort of environment most CGI scripts require.
|
|
Setting a chmod value of undef instructs GT::Config to not perform a chmod.
|
|
|
|
=item strict
|
|
|
|
If set, a fatal error will occur when attempting to access a key of the config
|
|
file that does not exist. Note, however, that this only covers the first level
|
|
data structions - C<$CFG-E<gt>{foo}-E<gt>{bar}> will not fatal if C<foo> is a
|
|
hash ref, but C<bar> is not set in that hash reference. C<$CFG-E<gt>{foo}>
|
|
(and C<$CFG-E<gt>{foo}-E<gt>{bar}>) will fatal if the key C<foo> does not exist
|
|
in the config data.
|
|
|
|
=item debug
|
|
|
|
If provided, debugging information will be printed. This will also cause a
|
|
warning to occur if L<"fatal"> is disabled and load fails.
|
|
|
|
Defaults to disabled. Should not be used in production code, except when
|
|
debugging.
|
|
|
|
=item tmpfile
|
|
|
|
Instructs GT::Config to attempt to use a temporary file when saving. If used,
|
|
the contents will be written to a temporary file, then, if successfully
|
|
written, the temporary file will be moved to overwrite the real file. This
|
|
solves a couple of problems. Firstly, a full disk will never result in a
|
|
partial file as if the entire file is not written to the temporary file, it
|
|
will not overwrite the file already stored on disk. Secondly, it avoids a
|
|
potential problem with multiple processes attempting to write to the file at
|
|
the same time.
|
|
|
|
The following values are accepted:
|
|
|
|
0 - Do not use a temporary file
|
|
undef - Use a temporary file if the base directory is writable
|
|
1 - Always use a temporary file
|
|
|
|
The default is C<undef>, which will attempt to use a temporary file is
|
|
possible, but won't fail if the script has permission to modify existing files,
|
|
but not to create new ones.
|
|
|
|
=item header
|
|
|
|
If provided, when saving a file this header will be written above the data.
|
|
Keep in mind that the file must be Perl-compilable, so be careful if you are
|
|
doing anything more than comments.
|
|
|
|
Note that the header may contain the string C<[localtime]>, which will be
|
|
replaced with the return value of C<scalar localtime()> when saving, which is
|
|
generally a value such as: C<Sun Jan 25 15:12:26 2004>.
|
|
|
|
=item tab
|
|
|
|
If provided, this will set what to use for tabs when calling save(). Defaults
|
|
to an actual tab, since that cuts down the file size over using multiple
|
|
spaces, while leaving the file readable.
|
|
|
|
=item compile_subs
|
|
|
|
If provided, any data starting with C<sub {> will be compiled into a
|
|
subroutine. This compilation does not happen until the variable is accessed,
|
|
at which point a fatal error will occur if the code could not be compiled. The
|
|
code referenced will be cached (if using caching), but will be saved as the
|
|
original string (starting with C<sub {>) when L<saving|"save">.
|
|
|
|
B<NOTE:> The argument to compile_subs must be a valid perl package; the code
|
|
reference will be compiled in that package. For example,
|
|
C<compile_subs =E<gt> 'GForum::Post'> will compile the code ref in the
|
|
GForum::Post package. You need to do this to provide access to globals
|
|
variables such as $DB, $IN, etc.
|
|
|
|
=item sort_order
|
|
|
|
If provided, the option will be passed through as the 'order' option of
|
|
GT::Dumper for hash key ordering. See L<GT::Dumper>. GT::Config always sorts
|
|
hash keys - this can be used when the default alphanumeric sort is not
|
|
sufficient.
|
|
|
|
=back
|
|
|
|
=head2 save
|
|
|
|
To save a config file, simply call C<$object-E<gt>save()>. If the object uses
|
|
inheritance, only those keys that were not inherited (or were modified from the
|
|
inherited ones) will be saved.
|
|
|
|
$Config->save();
|
|
|
|
B<NOTE>: B<ALWAYS SAVE AFTER MAKING ANY CHANGES!!!>. If you do not save after
|
|
making changes, the data retrieved from the cache may not be the same as the
|
|
data stored in the configuration file on disk. After making ANY changes make
|
|
absolutely sure that you either undo the change or save the configuration file.
|
|
|
|
=head2 cache_hit
|
|
|
|
Returns whether or not the current object was loaded from cache (1) or loaded
|
|
from disk (undef).
|
|
|
|
=head2 inheritance
|
|
|
|
Returns the inheritance status (1 or 0) of the object.
|
|
|
|
=head2 create_ok
|
|
|
|
Returns the status (1 or 0) of the "create_ok" flag.
|
|
|
|
=head2 tmpfile
|
|
|
|
With no arguments, returns whether or not the object will attempt to use a
|
|
temporary file when saving. Possible values are:
|
|
|
|
0 - Do not use a temporary file
|
|
undef - Use a temporary file if the base directory is writable
|
|
1 - Always use a temporary file
|
|
|
|
You can pass in a single argument of one of the above values to set whether or
|
|
not the object will use a temporary file when saving.
|
|
|
|
=head2 cache
|
|
|
|
This method returns whether or not the object is cached. This cannot be
|
|
enabled/disabled after loading a config file; you must specify it as an
|
|
argument to C<load()> instead.
|
|
|
|
=head2 debug_level
|
|
|
|
This method returns the current debug level.
|
|
|
|
You may provide one argument which sets a new debug level.
|
|
|
|
0 means no debugging, 1 means basic debugging, 2 means heavy debugging.
|
|
|
|
If setting a new debug level, the old debug level is returned.
|
|
|
|
=head2 header
|
|
|
|
This method returns or sets the header that will be printed when saving.
|
|
|
|
With no arguments, returns the header.
|
|
|
|
You may provide one argument which sets a new header. Keep in mind that the
|
|
file must be Perl-compilable, so take care if doing anything other than
|
|
comments.
|
|
|
|
If providing a new header, the old header is returned.
|
|
|
|
Note that the header may contain the value C<[localtime]>, which will be
|
|
replaced with the return value of C<scalar localtime()> when saving.
|
|
|
|
=head2 sort_order
|
|
|
|
This method returns or sets a code reference to be passed through as the
|
|
'order' option of GT::Dumper for hash key ordering. See L<GT::Dumper>.
|
|
GT::Config always sorts hash keys - this can be used when the default
|
|
alphanumeric sort is not sufficient.
|
|
|
|
=head1 SEE ALSO
|
|
|
|
L<GT::Template::Inheritance>
|
|
|
|
=head1 MAINTAINER
|
|
|
|
Jason Rhinelander
|
|
|
|
=head1 COPYRIGHT
|
|
|
|
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
|
http://www.gossamer-threads.com/
|
|
|
|
=head1 VERSION
|
|
|
|
$Id: Config.pm,v 1.45 2005/03/21 05:49:39 jagerman Exp $
|
|
|
|
=cut
|