744 lines
15 KiB
Perl
744 lines
15 KiB
Perl
#----------------------------------------------------------------------
|
|
# 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::db;
|
|
|
|
use esmith::config;
|
|
use strict;
|
|
|
|
|
|
=head1 NAME
|
|
|
|
esmith::db - Routines for handling the e-smith configuration database
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
B<THIS MODULE HAS BEEN DEPRECATED>
|
|
|
|
use esmith::db;
|
|
use esmith::config;
|
|
|
|
my %config;
|
|
tie %config, 'esmith::config', $config_file;
|
|
|
|
db_set(\%config, $key, $type, \%properties);
|
|
db_set_type(\%config, $key, $type);
|
|
db_set_prop(\%config, $key, $property => $new_value);
|
|
|
|
my($type, %properties) = db_get(\%config, $key);
|
|
my $type = db_get_type(\%config, $key);
|
|
my %properties = db_get_prop(\%config, $key);
|
|
my $value = db_get_prop(\%config, $key, $property);
|
|
|
|
db_delete(\%config, $key);
|
|
db_delete_prop(\%config, $key, $property);
|
|
|
|
db_print(\%config, $key);
|
|
db_show(\%config, $key);
|
|
db_print_type(\%config, $key);
|
|
db_print_prop(\%config, $key, $prop);
|
|
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
B<THIS MODULE HAS BEEN DEPRECATED>. Please use a subclass of
|
|
esmith::DB::db instead, such as esmith::AccountsDB or esmith::ConfigDB.
|
|
|
|
I<Do not try to change this module>. Much code depends on subtle
|
|
nuances and bugs and you will break things if you try to fix it.
|
|
Instead, move any existing code away from esmith::db and towards
|
|
esmith::DB::db.
|
|
|
|
|
|
This module provides utility routines for manipulating e-smith
|
|
configuration data. OO and non-OO versions of the routines are provided.
|
|
For example, db_set() is the non-OO while set() can be called with an
|
|
object reference.
|
|
|
|
E-Smith DB entries have three parts. A key, a type and a hash of
|
|
properties.
|
|
|
|
key squid
|
|
type cephalopod
|
|
properties arms => 10
|
|
species => Loligo
|
|
|
|
=cut
|
|
|
|
use vars qw($VERSION @ISA @EXPORT);
|
|
$VERSION = sprintf "%d.%03d", q$Revision: 1.16 $ =~ /(\d+)\.(\d+)/;
|
|
|
|
use Exporter;
|
|
@ISA = qw(Exporter);
|
|
@EXPORT = qw(
|
|
db_set
|
|
db_get
|
|
db_delete
|
|
|
|
db_set_type
|
|
db_get_type
|
|
|
|
db_get_prop
|
|
db_set_prop
|
|
db_delete_prop
|
|
|
|
db_print
|
|
db_show
|
|
|
|
db_print_type
|
|
db_print_prop
|
|
);
|
|
|
|
=head2 Functions
|
|
|
|
=over 4
|
|
|
|
=item B<db_set>
|
|
|
|
my $success = db_set(\%config, $key, $raw_value);
|
|
my $success = db_set(\%config, $key, $type);
|
|
my $success = db_set(\%config, $key, $type, \%properties);
|
|
|
|
Enters a new $key into the %config or replaces an existing $key. It
|
|
sets the $type and optionally %properties.
|
|
|
|
As a "bug which has become a feature" you can feed db_set() the
|
|
$raw_value for a $key (ie. 'type|prop1|val1|prop2|val2') and it will
|
|
setup the types and properties properly. I<Do not depend on this> but
|
|
don't change it either. There's code that depends on this behavior.
|
|
|
|
It returns true on success, false on failure.
|
|
|
|
If the $key contains a newline it will fail.
|
|
|
|
=cut
|
|
|
|
sub db_set
|
|
{
|
|
my ($hash, $key, $new_value, $hashref) = @_;
|
|
|
|
return undef if ($key =~ /\n/);
|
|
if (defined $hashref)
|
|
{
|
|
my $properties = _db_hash_to_string($hashref);
|
|
if (defined $properties && $properties ne '')
|
|
{
|
|
$new_value .= "|$properties";
|
|
}
|
|
}
|
|
$new_value and $new_value =~ s/\n/\\n/g;
|
|
$$hash{$key} = $new_value;
|
|
return undef unless defined db_get($hash, $key);
|
|
return 1;
|
|
}
|
|
|
|
=head2 B<db_get>
|
|
|
|
my($type, %properties) = db_get(\%config, $key);
|
|
my $raw_value = db_get(\%config, $key);
|
|
my @keys = db_get(\%config);
|
|
|
|
Reads the $type and %properties for the given $key in %config.
|
|
|
|
In scalar context it returns the raw value of $config{$key} B<NOT> the
|
|
type! But it unescapes newlines. I<Use db_get_type() instead>.
|
|
|
|
If a $key is not given it returns all the @keys in the %config.
|
|
|
|
=cut
|
|
|
|
sub db_get
|
|
{
|
|
my ($hash, $key) = @_;
|
|
|
|
return sort keys %$hash unless defined $key;
|
|
return undef unless exists $$hash{$key};
|
|
|
|
my $value = $$hash{$key};
|
|
$value and $value =~ s/\\n/\n/g;
|
|
return wantarray() ? _db_string_to_type_and_hash($value) : $value;
|
|
}
|
|
|
|
=item B<db_delete>
|
|
|
|
db_delete(\%config, $key)
|
|
|
|
Deletes the $key from %config.
|
|
|
|
=cut
|
|
|
|
sub db_delete
|
|
{
|
|
my ($hash, $key) = @_;
|
|
|
|
return undef unless defined db_get($hash, $key);
|
|
|
|
delete $$hash{$key};
|
|
return 1;
|
|
}
|
|
|
|
|
|
=item B<db_set_type>
|
|
|
|
my $success = db_set_type(\%config, $key, $type)
|
|
|
|
Sets the $type for $config{$key}.
|
|
|
|
Returns true if the set succeeded, false otherwise.
|
|
|
|
=cut
|
|
|
|
sub db_set_type
|
|
{
|
|
my ($hash, $key, $type) = @_;
|
|
|
|
return undef unless defined db_get($hash, $key);
|
|
|
|
my %properties = db_get_prop($hash, $key);
|
|
|
|
return db_set($hash, $key, $type, \%properties);
|
|
}
|
|
|
|
|
|
=item B<db_get_type>
|
|
|
|
my $type = db_get_type(\%config, $key);
|
|
|
|
Returns the $type associated with the $key in the %config database.
|
|
|
|
Will return undef if the $key doesn't exist.
|
|
|
|
=cut
|
|
|
|
sub db_get_type
|
|
{
|
|
my ($hash, $key) = @_;
|
|
|
|
return undef unless defined db_get($hash, $key);
|
|
|
|
my ($type) =
|
|
_db_string_to_type_and_hash(db_get($hash, $key));
|
|
return $type;
|
|
}
|
|
|
|
|
|
=item B<db_set_prop>
|
|
|
|
my $success = db_set_prop(\%config, $key, $property => $new_value)
|
|
|
|
Sets the given $property of the $key in the %config database to the
|
|
$new_value. If the $property didn't exist, it will be added.
|
|
|
|
Returns true/value if it succeeded/failed.
|
|
|
|
=cut
|
|
|
|
sub db_set_prop
|
|
{
|
|
my ($hash, $key, $prop, $new_value) = @_;
|
|
|
|
return undef unless defined db_get($hash, $key);
|
|
|
|
my $type = db_get_type($hash, $key);
|
|
my %properties = db_get_prop($hash, $key);
|
|
$properties{$prop} = $new_value;
|
|
return db_set($hash, $key, $type, \%properties);
|
|
}
|
|
|
|
|
|
=item B<db_get_prop>
|
|
|
|
my %properties = db_get_prop(\%config, $key);
|
|
my $value = db_get_prop(\%config, $key, $property);
|
|
|
|
Returns the %properties for a $key in the %config database. If you
|
|
ask for a specific $property you'll get the $value for that $property.
|
|
|
|
Returns undef if the $key or $property doesn't exist.
|
|
|
|
=cut
|
|
|
|
sub db_get_prop
|
|
{
|
|
my ($hash, $key, $prop) = @_;
|
|
|
|
my $val = db_get($hash, $key);
|
|
return (defined $prop ? undef : ()) unless defined $val;
|
|
|
|
my($type, %properties) = _db_string_to_type_and_hash($val);
|
|
|
|
return %properties unless defined $prop;
|
|
return undef unless exists $properties{$prop};
|
|
return $properties{$prop};
|
|
}
|
|
|
|
|
|
=item B<db_delete_prop>
|
|
|
|
db_delete_prop(\%config, $key, $property)
|
|
|
|
Deletes a $property from the $key in the %config.
|
|
|
|
Returns undef if the $key doesn't exist.
|
|
|
|
=cut
|
|
|
|
sub db_delete_prop
|
|
{
|
|
my ($hash, $key, $prop) = @_;
|
|
|
|
return undef unless defined db_get($hash, $key);
|
|
|
|
my $type = db_get_type($hash, $key);
|
|
my %properties = db_get_prop($hash, $key);
|
|
delete $properties{$prop};
|
|
return db_set($hash, $key, $type, \%properties);
|
|
}
|
|
|
|
=back
|
|
|
|
=head2 Debugging Functions
|
|
|
|
These functions are useful for debugging.
|
|
|
|
=over 4
|
|
|
|
=item B<db_print>
|
|
|
|
db_print(\%config);
|
|
db_print(\%config, $key);
|
|
|
|
Prints out keys and raw values in the %config database. If $key is
|
|
given it prints the $key and its raw value. If no $key is given it
|
|
prints out all the keys and their raw values.
|
|
|
|
=cut
|
|
|
|
sub db_print
|
|
{
|
|
my ($hash, $key) = @_;
|
|
|
|
my @list;
|
|
|
|
if (defined $key)
|
|
{
|
|
return undef unless defined db_get($hash, $key);
|
|
@list = ($key);
|
|
}
|
|
else
|
|
{
|
|
@list = db_get($hash);
|
|
}
|
|
|
|
return undef unless scalar @list;
|
|
|
|
foreach (@list)
|
|
{
|
|
print "$_=", scalar db_get($hash, $_),"\n";
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
|
|
=item B<db_show>
|
|
|
|
db_show(\%config);
|
|
db_show(\%config, $key);
|
|
|
|
Prints out keys and their values in a human readable format.
|
|
|
|
If $key is given it prints out the $key, type and properties of that
|
|
$key. Otherwise it prints out the key, type and properties for all
|
|
keys.
|
|
|
|
=cut
|
|
|
|
sub db_show
|
|
{
|
|
my ($hash, $key) = @_;
|
|
|
|
my @list;
|
|
|
|
if (defined $key)
|
|
{
|
|
return undef unless defined db_get($hash, $key);
|
|
@list = ($key);
|
|
}
|
|
else
|
|
{
|
|
@list = db_get($hash) unless defined $key;
|
|
}
|
|
|
|
return undef unless scalar @list;
|
|
|
|
foreach (@list)
|
|
{
|
|
print "$_=";
|
|
|
|
my $type = db_get_type($hash, $_);
|
|
|
|
if (defined $type)
|
|
{
|
|
print "$type\n";
|
|
}
|
|
else
|
|
{
|
|
print "\n";
|
|
next;
|
|
}
|
|
|
|
my %properties = db_get_prop($hash, $_);
|
|
next unless scalar keys %properties;
|
|
|
|
foreach my $property (sort keys %properties)
|
|
{
|
|
print " $property=$properties{$property}\n";
|
|
}
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
|
|
=item B<db_print_type>
|
|
|
|
db_print_type(\%config);
|
|
db_print_type(\%config, $key);
|
|
|
|
Prints out keys and their types in the %config database.
|
|
|
|
If $key is given, it prints out just that $key and its type.
|
|
Otherwise it prints out all the keys and their types.
|
|
|
|
=cut
|
|
|
|
sub db_print_type
|
|
{
|
|
my ($hash, $key) = @_;
|
|
|
|
my @list;
|
|
|
|
if (defined $key)
|
|
{
|
|
return undef unless defined db_get($hash, $key);
|
|
@list = $key;
|
|
}
|
|
else
|
|
{
|
|
@list = db_get($hash);
|
|
}
|
|
|
|
return undef unless scalar @list;
|
|
|
|
foreach (@list)
|
|
{
|
|
print "$_=";
|
|
|
|
my $type = db_get_type($hash, $_);
|
|
|
|
print db_get_type($hash, $_),"\n" if defined $type;
|
|
print "\n" unless defined $type;
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
|
|
=item B<db_print_prop>
|
|
|
|
db_print_prop(\%config, $key);
|
|
db_print_prop(\%config, $key, $property);
|
|
|
|
Prints out the properties (or a single $property) of the given $key in
|
|
the %config.
|
|
|
|
=cut
|
|
|
|
sub db_print_prop
|
|
{
|
|
my ($hash, $key, $prop) = @_;
|
|
|
|
my @list;
|
|
my %list;
|
|
|
|
return undef unless defined db_get($hash, $key);
|
|
|
|
if (defined $prop)
|
|
{
|
|
my $value = db_get_prop($hash, $key, $prop);
|
|
return undef unless defined $value;
|
|
|
|
%list = ($prop => $value);
|
|
}
|
|
else
|
|
{
|
|
%list = db_get_prop($hash, $key);
|
|
}
|
|
|
|
return undef unless scalar keys %list;
|
|
|
|
foreach (sort keys %list)
|
|
{
|
|
print "$_=$list{$_}\n";
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
|
|
=head2 OO Interface
|
|
|
|
To add to the confusion, esmith::db has a vestigal object-oriented
|
|
interface. Use esmith::DB::db instead.
|
|
|
|
=over 4
|
|
|
|
=item B<new>
|
|
|
|
my $db = esmith::db->new($db_file)
|
|
|
|
Generates a new esmith::db object from the given $db_file
|
|
|
|
=cut
|
|
|
|
sub new
|
|
{
|
|
my($class,$dbname) = @_;
|
|
|
|
return $class->open($dbname);
|
|
}
|
|
|
|
|
|
=item B<open>
|
|
|
|
my $db = esmith::db->open($db_name);
|
|
my $db = esmith::db->open($db_file);
|
|
|
|
Takes a database name (or pathname) and opens the named database.
|
|
The database name form is preferred over the explicit pathname.
|
|
|
|
For example
|
|
|
|
$db->open( 'configuration' );
|
|
or
|
|
$db->open( '/path/to/configuration' );
|
|
|
|
=cut
|
|
|
|
sub open
|
|
{
|
|
my $self = shift;
|
|
my $dbName = shift;
|
|
my $class = ref($self) || $self;
|
|
|
|
my $dataFile = _db_path($dbName);
|
|
|
|
unless ( $esmith::db::REFCOUNT{$dataFile} )
|
|
{
|
|
warn "Reading $dataFile into cache\n" if ($esmith::db::DEBUG);
|
|
|
|
my %db;
|
|
tie %db, 'esmith::config', $dataFile;
|
|
|
|
$esmith::db::CACHE{$dataFile} = \%db;
|
|
}
|
|
|
|
$self = bless {
|
|
DBNAME => $dataFile,
|
|
CACHE => $esmith::db::CACHE{$dataFile}
|
|
}, $class;
|
|
|
|
$esmith::db::REFCOUNT{$dataFile}++;
|
|
|
|
return $self;
|
|
}
|
|
|
|
sub DESTROY
|
|
{
|
|
my $self = shift;
|
|
return $self->close();
|
|
}
|
|
|
|
|
|
=item B<close>
|
|
|
|
$db->close;
|
|
|
|
Closes this database.
|
|
|
|
=cut
|
|
|
|
sub close
|
|
{
|
|
my $self = shift;
|
|
|
|
my $dataFile = $self->{'DBNAME'};
|
|
|
|
$esmith::db::REFCOUNT{$dataFile}--;
|
|
|
|
if ( $esmith::db::REFCOUNT{$dataFile} == 0 )
|
|
{
|
|
delete $esmith::db::CACHE{$dataFile};
|
|
warn "esmith::db::close Closing $dataFile\n" if ($esmith::db::DEBUG);
|
|
}
|
|
elsif ( $esmith::db::REFCOUNT{$dataFile} > 0 )
|
|
{
|
|
warn "esmith::db::close Not closing $dataFile, references ",
|
|
$esmith::db::REFCOUNT{$dataFile}, "\n" if ($esmith::db::DEBUG);
|
|
}
|
|
else
|
|
{
|
|
$esmith::db::REFCOUNT{$dataFile} = 0;
|
|
warn "esmith::db::close Not closing $dataFile, zero references\n"
|
|
if ($esmith::db::DEBUG);
|
|
}
|
|
}
|
|
|
|
|
|
=item B<set>
|
|
|
|
=item B<set_type>
|
|
|
|
=item B<set_prop>
|
|
|
|
=item B<get>
|
|
|
|
=item B<get_type>
|
|
|
|
=item B<get_prop>
|
|
|
|
=item B<delete>
|
|
|
|
=item B<delete_prop>
|
|
|
|
These all work like their functional versions (ie. set() == db_set())
|
|
except it is not necessary to input the %config database.
|
|
|
|
=cut
|
|
|
|
sub AUTOLOAD
|
|
{
|
|
no strict 'refs';
|
|
|
|
# fully qualified sub-name stored in $AUTOLOAD package variable
|
|
$esmith::db::AUTOLOAD =~ /^(.*::)(.*)$/;
|
|
my ($pkg, $sub) = ($1, $2);
|
|
|
|
# use *foo{THING} syntax to check if sub is defined (see perlref)
|
|
if (defined *{"${pkg}db_${sub}"}{CODE})
|
|
{
|
|
my $self = shift;
|
|
my $cache = $esmith::db::CACHE{$self->{DBNAME}};
|
|
wantarray ? return (my @p = &{"${pkg}db_${sub}"}($cache, @_))
|
|
: return (my $p = &{"${pkg}db_${sub}"}($cache, @_));
|
|
}
|
|
}
|
|
|
|
=begin private
|
|
|
|
=head2 Private functions
|
|
|
|
=over4
|
|
|
|
=item B<_db_hash_to_string>
|
|
|
|
my $raw_value = _db_hash_to_string($hashref);
|
|
|
|
Takes a reference to a hash and returns a string of pipe "|" delimited
|
|
pairs suitable for being stored.
|
|
|
|
=cut
|
|
|
|
sub _db_hash_to_string
|
|
{
|
|
my ($hash) = @_;
|
|
my $string = '';
|
|
|
|
foreach (sort keys %$hash)
|
|
{
|
|
$string .= '|' if length($string);
|
|
$string .= "$_|";
|
|
$string .= $$hash{$_} if defined $$hash{$_};
|
|
}
|
|
|
|
return $string;
|
|
}
|
|
|
|
=pod
|
|
|
|
=item B<_db_string_to_type_and_hash>
|
|
|
|
my($type, %properties) = _db_string_to_type_and_hash($raw_value);
|
|
|
|
Takes the $raw_value, which is a | delimited string, and spits it up
|
|
into the $type (the first field) and its %properties (the rest).
|
|
|
|
Escaped pipes (\|) are properly ignored as a delimiter.
|
|
|
|
=cut
|
|
|
|
sub _db_string_to_type_and_hash ($)
|
|
{
|
|
my ($arg) = @_;
|
|
return ('', ()) unless defined $arg;
|
|
|
|
# The funky regex is to avoid escaped pipes.
|
|
# If you specify a negative limit empty trailing fields are omitted.
|
|
return split(/(?<!\\)\|/, $arg, -1);
|
|
}
|
|
|
|
=item B<_db_path>
|
|
|
|
my $dfile = _db_path($database_name);
|
|
|
|
Takes a $database_name and returns the $file where it lives.
|
|
|
|
=cut
|
|
|
|
sub _db_path($)
|
|
{
|
|
my ($file) = @_;
|
|
|
|
if ($file =~ m:^/:)
|
|
{
|
|
return $file;
|
|
}
|
|
return "/home/e-smith/db/$file" if (-e "/home/e-smith/db/$file");
|
|
|
|
if (-e "/home/e-smith/$file")
|
|
{
|
|
warn "Database found in old location /home/e-smith/$file";
|
|
return "/home/e-smith/$file";
|
|
}
|
|
else
|
|
{
|
|
return "/home/e-smith/db/$file";
|
|
}
|
|
}
|
|
|
|
=back
|
|
|
|
=end private
|
|
|
|
|
|
=head1 BUGS and CAVEATS
|
|
|
|
keys cannot contain newlines or pipes.
|
|
|
|
types and properties cannot contain pipes.
|
|
|
|
|
|
=head1 AUTHOR
|
|
|
|
Mitel Networks Corporation
|
|
|
|
For more information, see http://www.e-smith.org/
|
|
|
|
=cut
|
|
|
|
1;
|