#----------------------------------------------------------------------
# Copyright 1999-2003 Mitel Networks Corporation
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#----------------------------------------------------------------------

package esmith::config;
use strict;
use vars qw($VERSION);
$VERSION = 1.45;

use Sys::Syslog qw(:DEFAULT setlogsock);
use Fcntl qw(:DEFAULT :flock);
use Carp qw(cluck);

my $Default_Config = '/home/e-smith/db/configuration';

=pod

=head1 NAME

esmith::config - Access e-smith config files via hashes

=head1 SYNOPSIS

use esmith::config;

my %config;
my $config_obj = tie %config, 'esmith::config', $config_file;

# Read in the value of Wibble from the $config_file.
print $config{Wibble};

# Write out the value of Wibble to the $config_file.
$config{Wibble} = 42;

my $filename = $config_obj->filename;

=head1 DESCRIPTION

The esmith::config package enables Perl programs to read and write
entries from the e-smith configuration file using a simple hash
interface.

The configuration file has a simple ASCII representation,
with one "key=value" entry per line.

=begin testing

use_ok('esmith::config');
chdir '10e-smith-lib';

%Expect = ( foo              => 'bar',
'this key'       => 'has whitespace',
'that key '      => 'has trailing whitespace',
' another key'   => 'has leading whitespace',
'this value'     => ' has leading whitespace',
'that value'     => 'has trailing whitespace ',
'tricky value'   => 'with=equals.',
          );

=end testing

=head2 Tying

tie %config, 'esmith::config', $config_file;

Reads in the configuration from the given $config_file, returning a
tied hash (%config) populated with the keys & values from the
$config_file which you can then use like a normal hash.  Any writes or
deletes are immediately written back to the $config_file.

If no $config_file is supplied it falls back to the environment variable 
ESMITH_CONFIG_DB, and finally defaults to F</home/e-smith/db/configuration>

If the $config_file doesn't exist it will create one for you.

=begin testing

my %config;
tie %config, 'esmith::config', 'dummy.conf';
ok( tied %config,                'tie worked' );
is( $config{foo}, 'bar',         '  theres stuff in it' );
ok( !exists $config{FILENAME},   '  it only contains config info');
is( tied(%config)->{FILENAME},     'dummy.conf',
'  and the real object is inside');

tie %config, 'esmith::config', 'I_dont_exist';
ok( tied %config,        'tying a non-existant file' );
is( keys %config, 0,    '  and its empty' );
$config{foo} = 42;
isnt( -s 'I_dont_exist', 0 );
untie %config;
ok( unlink 'I_dont_exist' );

$ENV{ESMITH_CONFIG_DB} = "dummy.conf";
tie %config, 'esmith::config';
ok( tied %config,                'tie to ESMITH_CONFIG_DB worked' );
is_deeply(\%config, \%Expect, "  picked up data");

=end testing

=head2 Methods

You can get at the underlying esmith::config object by using tied().

my $config_obj = tied %config;

it has a few useful methods.

=over 4

=item filename

my $file = $config_obj->filename;

Gets the config filename this object is tied to.

=begin testing

my %config;
my $obj = tie %config, 'esmith::config', 'dummy.conf';
is( $obj->filename, 'dummy.conf', 'filename()' );

=end testing

=cut

sub filename {
    my($self) = shift;
    return $self->{FILENAME};
}

=back

=begin _private

=head2 Private methods

=over 4

=item _readconf

my $config = _readconf($config_file);

Returns a hash ref of config key/value pairs read out of the given
$config_file.  If $config_file doesn't exist an empty hash ref will be
returned.

_readconf() understands the config file to be formatted as individual
lines of simply:

key=value

any further complexity of parsing the value is handled elsewhere.

=end _private

=begin testing

my $config = esmith::config::_readconf('dummy.conf');
isnt( keys %$config, 0,  '_readconf() got something' );
is_deeply( $config, \%Expect, '  read in the right values' );

$config = esmith::config::_readconf('I_dont_exist');
isa_ok( $config, 'HASH', '_readconf from a non-existent file' );
is( keys %$config, 0,    '  and its empty' );

=end testing

=cut

sub _readconf
{
    my ($self, $filename) = @_;

    my %config = ();

    unless (open (FH, $filename)) 
    {
        if (-f $filename)
        {
            &log("Config: ERROR: \"$filename\" exists but is not readable");
        }
        return \%config;
    }

    my $binmode = $self->_read_binmode;
    binmode(FH, $binmode) if $binmode;
    while (my $line = <FH>)
    {
        chomp $line;

        # BLIND UNTAINT!  Much code wrongly depends on this and
        # they should be moved away from it.
        $line =~ /(.*)/;
        $line = $1;

        # ignore comments and blank lines
        next if $line =~ /^\s*$/ || $line =~ /^\s*#/;

        my($key, $value) = split /=/, $line, 2;
        $config{$key} = $value;
    }

    close(FH);

    return \%config;
}

=begin _private

=item _writeconf

my $success = _writeconf($config_file, \%config);

The given $config_file is overwritten using the entries in %config.

Returns whether or not the write succeded.

=end _private

=begin testing

my $scratch = 'scratch.conf';
ok( esmith::config::_writeconf($scratch, \%Expect),  
'_writeconf() says it worked' );
is_deeply( esmith::config::_readconf($scratch), \%Expect,   
'   wrote the right things' );
unlink $scratch;

=end testing

=cut

sub _writeconf
{
    my ($self, $filename, $config) = @_;

    eval {
        if (-f $filename && ! -r $filename)
        {
            die "'$filename' exists but is not readable\n";
        }

        sysopen (FH, "$filename.$$", O_RDWR | O_CREAT, 0660)
            or die "Cannot open $filename.$$: $!\n";
        my $binmode = $self->_write_binmode;
        binmode(FH, $binmode) if $binmode;

        die "Error writing to $filename.$$: $!" unless
        printf FH <<EOF, scalar localtime;
# DO NOT MODIFY THIS FILE.
# This file is automatically maintained by the Mitel Networks SME Server
# configuration software.  Manually editing this file may put your 
# system in an unknown state.
#
# updated: %s
EOF

        foreach my $key (sort keys %$config)
        {
            print FH "$key=$config->{$key}\n"
                or die "Error writing to $filename.$$: $!";
        }

        close (FH) or die "Error closing $filename.$$: $!";

        rename("$filename.$$", $filename)
            or die "Couldn't rename $filename.$$ to $filename: $!";

        my $gid = getgrnam ('admin') || 0;
        chown (0, $gid, $filename);
    };

    if($@) {
        chomp $@;
        &log($@);
        &log("'$filename' will not be updated");
        return;
    }
    else {
        return 1;
    }
}

=begin _private

=item B<_lock_write>

=item B<_lock_read>

$self->_lock_write;
$self->_lock_read;

Sets up read (shared) or write (exclusive) locks on the config file.
This is actually locking a semaphore file.

Returns if the lock succeeded or failed.

=item B<_unlock>

$self->_unlock

Unlocks the config file.

=end _private

=cut

sub _lock_write { $_[0]->_lock(LOCK_EX) }
sub _lock_read  { $_[0]->_lock(LOCK_SH) }

sub _lock {
    return if $] eq 5.006; # Locking is broken in perl 5.6.0
    my($self, $lock) = @_;

    my $semaphore = $self->{SEMAPHORE_FILE} = $self->{FILENAME}.'.lock';

    eval {
        open(my $fh, ">>$semaphore") or
        die "Can't open '$semaphore' semaphore: $!";
        $self->{SEMAPHORE} = $fh;

        flock($fh, $lock) or
        die "Can't lock '$semaphore' semaphore: $!";
    };
    if( $@ ) {
        warn $@;
        return;
    }
    else {
        return 1;
    }
}


sub _unlock {
    return if $] eq 5.006; # Locking is broken in perl 5.6.0
    my($self) = @_;

    eval {
        flock($self->{SEMAPHORE}, LOCK_UN) or
        die "Can't unlock $self->{SEMAPHORE_FILE}: $!";

        unlink $self->{SEMAPHORE_FILE};
        delete $self->{SEMAPHORE_FILE};
        delete $self->{SEMAPHORE};
    };
    if( $@ ) {
        warn $@;
        return;
    }
    else {
        return 1;
    }
}

=end _private

=back

=cut

#------------------------------------------------------------
# Constructor for the tied hash. If filename not specified,
# defaults to '/home/e-smith/db/configuration'.
#------------------------------------------------------------

sub TIEHASH
{
    my $class    = shift;
    my $filename = shift || $ENV{ESMITH_CONFIG_DB} || $Default_Config;

    if ($filename =~ m:^/home/e-smith/\w+$: )
    {
        cluck "*WARNING* esmith::config($filename) called with old " .
              "database path. The following package needs to be updated: ";

        $filename =~ s:e-smith:e-smith/db:;
    }

    my $self =
        {
            FILENAME => $filename,
            CONFIG   => {},
        };
    bless $self, $class;

    $self->{CONFIG} = $self->_readconf($filename);

    return $self;
}

#------------------------------------------------------------
# Look up a configuration parameter.
#------------------------------------------------------------

sub FETCH
{
    my $self = shift;
    my $key  = shift;

    # Trim leading and trailing whitespace from the key.
    $key =~ s/^\s+|\s+$//g;

    return $self->{CONFIG}{$key};
}

#------------------------------------------------------------
# Store a configuration parameter.
#------------------------------------------------------------

sub STORE
{
    my $self  = shift;
    my $key   = shift;
    my $value = shift;

    die "key not defined" unless defined $key;
    die "value not defined for key $key" unless defined $value;

    if( $value =~ /\n/ or $key =~ /\n/ ) {
        &log("$self->{FILENAME}: esmith::config doesn't support newlines in ".
        "keys or values.  Truncating.");
        $key   =~ s/\n.*//s;
        $value =~ s/\n.*//s;
    }

    # Trim leading and trailing whitespace from the key and value.
    $key =~ s/^\s+|\s+$//g;
    $value =~ s/^\s+|\s+$//g;

    # Make sure that the value has a type. Given the format, it should be
    # sufficient to ensure that it does not begin with a pipe char.
    if ($value =~ /^\|/)
    {
        warn "ERROR: You should not set a config record without a type (key was $key).\n";
    }

    # read in config again, just in case it changed
    $self->_lock_write;
    $self->{CONFIG} = $self->_readconf($self->{FILENAME});

    if (exists $self->{CONFIG}{$key} and
    $self->{CONFIG}{$key} eq $value)
    {
        $self->_unlock;
        return undef;
    }

    my $msg = "$self->{FILENAME}: OLD $key=";

    if (exists $self->{CONFIG}{$key})
    {
        $msg .= "$self->{CONFIG}{$key}";
    }
    else
    {
        $msg .= "(undefined)";
    }

    &log($msg);

    $self->{CONFIG} {$key} = $value;
    &log("$self->{FILENAME}: NEW $key=$self->{CONFIG}{$key}");

    $self->_writeconf ($self->{FILENAME}, $self->{CONFIG});
    $self->_unlock;

    return undef;
}

#------------------------------------------------------------
# Delete a configuration parameter.
#------------------------------------------------------------

sub DELETE
{
    my $self = shift;
    my $key = shift;

    # Trim leading and trailing whitespace from the key.
    $key =~ s/^\s+|\s+$//g;

    # read in config again, just in case it changed
    $self->_lock_write;
    $self->{CONFIG} = $self->_readconf($self->{FILENAME});

    my $previous = delete $self->{CONFIG} {$key};
    $self->_writeconf ($self->{FILENAME}, $self->{CONFIG});
    $self->_unlock;

    &log("$self->{FILENAME}: DELETE $key=$previous");

    return $previous;
}

=begin _private

=item CLEAR

tie method: Clear the configuration file

=end _private

=begin testing

my $scratch = 'scratch.conf';
tie %config, 'esmith::config', $scratch;
ok( tied %config,        'tying a non-existant file' );
is( keys %config, 0,    '  and its empty' );
$config{fibble} = 'blah';
isnt( keys %config, 0,  '  and its not empty now' );
%config = ();
is( keys %config, 0,    '  and CLEAR made it empty again' );
unlink $scratch;

=end testing

=cut

sub CLEAR
{
    my $self = shift;

    $self->{CONFIG} = ();
    $self->_writeconf ($self->{FILENAME}, $self->{CONFIG});

    &log("$self->{FILENAME}: CLEAR");

    return undef;
}

#------------------------------------------------------------
# Check whether a particular key exists in the configuration file.
#------------------------------------------------------------

sub EXISTS
{
    my $self = shift;
    my $key = shift;

    # Trim leading and trailing whitespace from the key.
    $key =~ s/^\s+|\s+$//g;

    return exists $self->{CONFIG} {$key};
}

#------------------------------------------------------------
# FIRSTKEY is called whenever we start iterating over the
# configuration table. We cache the configuration table at
# this point to ensure reasonable results if the
# configuration file is changed by another program during
# the iteration.
#------------------------------------------------------------

sub FIRSTKEY
{
    my $self = shift;

    my $discard = keys %{$self->{CONFIG}};    # reset each() iterator

    return each %{$self->{CONFIG}};
}

#------------------------------------------------------------
# NEXTKEY is called for all iterations after the first.  We
# just keep returning results from the cached configuration
# table.  A null array is returned at the end. If the caller
# starts a new iteration, the FIRSTKEY subroutine is called
# again, causing the cache to be reloaded.
#------------------------------------------------------------

sub NEXTKEY
{
    my $self = shift;
    return each %{$self->{CONFIG}};
}


#------------------------------------------------------------
# Log messages to syslog
#------------------------------------------------------------

sub log
{
    # There is a bug in Perl 5.00504 and above. If you are using the unix
    # domain socket, do NOT use ndelay as part of the second argument
    # to openlog().

    my $msg = shift;
    $msg =~ s/[^[:ascii:]]/_/g;
    my $program = $0;

    setlogsock 'unix';
    openlog($program, 'pid', 'local1');
    syslog('info', "%s", $msg);
    closelog();
}

=item _read_binmode

return undef, indicating that by default binmode() need not be called after
file open.

=end _private

=cut

sub _read_binmode
{
    return undef;
}

sub _write_binmode
{
    return undef;
}

=head1 BUGS and CAVEATS

You can't have newlines in keys or values.

While the config values happen to be untainted B<do not depend on this
behavior> as it will change in the future.

=head1 AUTHOR

SME Server Developers <bugs@e-smith.com>

For more information, see http://www.e-smith.org/

=head1 SEE ALSO

esmith::db

=cut

1;