smeserver-lib/root/usr/share/perl5/vendor_perl/esmith/db.pm

744 lines
15 KiB
Perl
Raw Normal View History

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