discourse-legacysite-perl/site/glist/lib/GT/Config.pm

# ====================================================================
# 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