initial commit of file from CVS for e-smith-lib on Wed 12 Jul 08:58:46 BST 2023
This commit is contained in:
Brian Read
157
root/usr/share/perl5/vendor_perl/esmith/DB/Record.pm
Normal file
157
root/usr/share/perl5/vendor_perl/esmith/DB/Record.pm
Normal file
@@ -0,0 +1,157 @@
|
||||
#----------------------------------------------------------------------
|
||||
# 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::Record;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use esmith::DB;
|
||||
|
||||
our $VERSION = sprintf '%d.%03d', q$Revision: 1.6 $ =~ /: (\d+).(\d+)/;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
esmith::DB::Record - an individual record in an E-Smith database
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
B<DO NOT USE THIS CLASS DIRECTLY!> use via esmith::DB.
|
||||
|
||||
my $key = $record->key;
|
||||
|
||||
my %properties = $record->props;
|
||||
|
||||
my $value = $record->prop($prop_key);
|
||||
$record->set_prop($prop_key, $prop_val);
|
||||
|
||||
my $value = $record->delete_prop($prop_key);
|
||||
|
||||
$record->merge_props(%more_properties);
|
||||
$record->reset_props(%new_properties);
|
||||
|
||||
$record->delete;
|
||||
|
||||
print $record->show;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This class is a general interface to individual records in esmith::DB
|
||||
databases. It should not be used directly, but rather esmith::DBs
|
||||
should hand you esmith::DB::Record objects.
|
||||
|
||||
Each subclass of esmith::DB will also have to subclass and implement
|
||||
an esmith::DB::Record subclass.
|
||||
|
||||
|
||||
=head2 Virtual Methods
|
||||
|
||||
=over 4
|
||||
|
||||
=item B<key>
|
||||
|
||||
my $key = $record->key;
|
||||
|
||||
Returns the $key for this $record;
|
||||
|
||||
=item B<props>
|
||||
|
||||
my %properties = $record->props;
|
||||
my $num_props = $record->props;
|
||||
|
||||
Returns a hash of all the properties for this $record. In scalar
|
||||
context it will return the number of properties this $record has.
|
||||
|
||||
=item B<prop>
|
||||
|
||||
=item B<set_prop>
|
||||
|
||||
my $value = $record->prop($property);
|
||||
$record->set_prop($property, $value);
|
||||
|
||||
Gets/sets the $value of the $property in this $record.
|
||||
|
||||
set_prop() will die if the database is read-only.
|
||||
|
||||
=item B<delete_prop>
|
||||
|
||||
my $value = $record->delete_prop($property);
|
||||
|
||||
Deletes a $property from the $record, returning the old $value.
|
||||
|
||||
delete_prop() will die if the database is read-only.
|
||||
|
||||
=item B<merge_props>
|
||||
|
||||
$record->merge_props(%properties);
|
||||
|
||||
Adds the %properties to the $records existing properties. Any new
|
||||
keys will be added, any existing keys will be overwritten.
|
||||
|
||||
merge_props() will die if the database is read-only.
|
||||
|
||||
=item B<reset_props>
|
||||
|
||||
$record->reset_props(%properties);
|
||||
|
||||
Replaces the $record's properties with the contents of %properties.
|
||||
Any old properties will be deleted.
|
||||
|
||||
reset_props() will die if the database is read-only.
|
||||
|
||||
=item B<delete>
|
||||
|
||||
$record->delete;
|
||||
|
||||
Deletes the $record from its database.
|
||||
|
||||
delete() will die if the database is read-only.
|
||||
|
||||
=back
|
||||
|
||||
|
||||
=head2 Concrete methods
|
||||
|
||||
=over 4
|
||||
|
||||
=item B<show>
|
||||
|
||||
my $formatted = $record->show;
|
||||
|
||||
Returns the $record's key and properties in a nice, human readable
|
||||
format suitable for printing.
|
||||
|
||||
=cut
|
||||
|
||||
sub show {
|
||||
my($self) = shift;
|
||||
|
||||
my $out = $self->key."\n";
|
||||
|
||||
my %props = $self->props;
|
||||
|
||||
# Determine our longest key so we know how to format.
|
||||
my $max_len = 0;
|
||||
foreach (keys %props) { $max_len = length if length > $max_len }
|
||||
|
||||
# But don't go too far.
|
||||
$max_len = 40 if $max_len > 40;
|
||||
|
||||
foreach my $prop (sort { $a cmp $b } keys %props) {
|
||||
$out .= sprintf " %${max_len}s = %s\n", $prop, $props{$prop};
|
||||
}
|
||||
|
||||
return $out;
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<esmith::DB>
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
660
root/usr/share/perl5/vendor_perl/esmith/DB/db.pm
Normal file
660
root/usr/share/perl5/vendor_perl/esmith/DB/db.pm
Normal file
@@ -0,0 +1,660 @@
|
||||
#----------------------------------------------------------------------
|
||||
# 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::db;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp;
|
||||
|
||||
our $VERSION = sprintf '%d.%03d', q$Revision: 1.29 $ =~ /: (\d+).(\d+)/;
|
||||
|
||||
use esmith::db;
|
||||
use esmith::config;
|
||||
use esmith::DB::db::Record;
|
||||
use esmith::DB;
|
||||
our @ISA = qw(esmith::DB);
|
||||
|
||||
=for testing
|
||||
use_ok('esmith::DB::db');
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
esmith::DB::db - interface to esmith::db databases
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
I<Works just like an esmith::DB class except where noted>
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides an abstracted interface to esmith::db flat-file
|
||||
databases. It will read from and write to esmith::db files and can be
|
||||
safely used right along side esmith::db. This follows the esmith::DB
|
||||
interface and will work as documented there unless otherwise stated.
|
||||
|
||||
You should use this instead of esmith::db, and replace any existing
|
||||
esmith::db code with this.
|
||||
|
||||
I<Note for esmith::db users> the old concept of a 'type' is now simply
|
||||
another property.
|
||||
|
||||
my $type = $record->prop('type');
|
||||
|
||||
replaces db_get_type().
|
||||
|
||||
The $record returned by esmith::DB::db subclass is an esmith::DB::db::Record
|
||||
subclass object. See the esmith::DB::db manpage for details on how it is used.
|
||||
|
||||
=head2 Methods
|
||||
|
||||
=over 4
|
||||
|
||||
=item B<create>
|
||||
|
||||
Puts its error on esmith::DB::db->error
|
||||
|
||||
=begin testing
|
||||
|
||||
$Scratch_Conf = '10e-smith-lib/scratch.conf';
|
||||
unlink $Scratch_Conf;
|
||||
$db = esmith::DB::db->create($Scratch_Conf);
|
||||
END { unlink $Scratch_Conf }
|
||||
|
||||
isa_ok( $db, 'esmith::DB::db', 'create()' );
|
||||
ok( -e $Scratch_Conf, 'created a new config file' );
|
||||
ok(! esmith::DB::db->create($Scratch_Conf),
|
||||
'create() wont walk over an existing config' );
|
||||
like( esmith::DB::db->error, qr/^File exists/, ' right error message' );
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub create
|
||||
{
|
||||
my ( $class, $file ) = @_;
|
||||
$file = $class->_file_path($file);
|
||||
my $self;
|
||||
|
||||
eval {
|
||||
$self = $class->_init($file);
|
||||
croak "File exists" if -e $file;
|
||||
|
||||
$self->{config} = $self->_get_config($file)
|
||||
|| croak "Can't get the esmith::config object";
|
||||
|
||||
# touch the config file so it gets created immediately
|
||||
open( FILE, ">>$file" )
|
||||
or die "Failed to open $file for appending: $!\n";
|
||||
close FILE;
|
||||
|
||||
# Migrate, and check for errors, propagating them if they happen.
|
||||
unless ( $self->migrate() )
|
||||
{
|
||||
chomp $@;
|
||||
$self->set_error($@);
|
||||
return;
|
||||
}
|
||||
};
|
||||
if ($@)
|
||||
{
|
||||
chomp $@;
|
||||
$self->set_error($@);
|
||||
return;
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
|
||||
=item B<open>
|
||||
|
||||
=for notes
|
||||
There's currently no way to get the reason why from esmith::config.
|
||||
|
||||
=begin testing
|
||||
|
||||
unlink $Scratch_Conf;
|
||||
ok( !esmith::DB::db->open($Scratch_Conf), 'open() on a non-existent db' );
|
||||
is( esmith::DB::db->error, "File doesn't exist", ' right error' );
|
||||
|
||||
esmith::DB::db->create($Scratch_Conf);
|
||||
$DB = esmith::DB::db->open($Scratch_Conf);
|
||||
isa_ok( $DB, 'esmith::DB::db' );
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub open
|
||||
{
|
||||
my ( $class, $file ) = @_;
|
||||
$file = $class->_file_path($file);
|
||||
my $self = $class->_init($file);
|
||||
|
||||
if ( -e $file && !-w $file )
|
||||
{
|
||||
$self->{ro} = 1;
|
||||
}
|
||||
|
||||
return $self->_open($file) ? $self : undef;
|
||||
}
|
||||
|
||||
=item B<open_local>
|
||||
|
||||
=for notes
|
||||
There's currently no way to get the reason why from esmith::config.
|
||||
|
||||
=begin testing
|
||||
|
||||
unlink $Scratch_Conf;
|
||||
ok( !esmith::DB::db->open_local($Scratch_Conf), 'open() on a non-existent db' );
|
||||
is( esmith::DB::db->error, "File doesn't exist", ' right error' );
|
||||
|
||||
esmith::DB::db->create($Scratch_Conf);
|
||||
$DB = esmith::DB::db->open_local($Scratch_Conf);
|
||||
isa_ok( $DB, 'esmith::DB::db' );
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub open_local
|
||||
{
|
||||
my ( $class, $file ) = @_;
|
||||
$file = $class->_file_path($file);
|
||||
my $self = $class->_init($file);
|
||||
|
||||
if ( -e $file && !-w $file )
|
||||
{
|
||||
$self->{ro} = 1;
|
||||
}
|
||||
|
||||
return $self->_open($file) ? $self : undef;
|
||||
}
|
||||
|
||||
=begin testing
|
||||
|
||||
ok( my $db = esmith::DB::db->open_ro($Scratch_Conf),
|
||||
'open_ro on a non-existent db');
|
||||
eval { $db->new_record('foo', { type => 'bar' }) };
|
||||
like( $@, qr/^This DB is opened read-only/ );
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub open_ro
|
||||
{
|
||||
my ( $class, $file ) = @_;
|
||||
$file = $class->_file_path($file);
|
||||
my $self = $class->_init($file);
|
||||
|
||||
$self->{ro} = 1;
|
||||
|
||||
return $self->_open($file) ? $self : undef;
|
||||
}
|
||||
|
||||
=begin testing
|
||||
|
||||
ok( my $db = esmith::DB::db->open_ro_local($Scratch_Conf),
|
||||
'open_ro on a non-existent db');
|
||||
eval { $db->new_record('foo', { type => 'bar' }) };
|
||||
like( $@, qr/^This DB is opened read-only/ );
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub open_ro_local
|
||||
{
|
||||
my ( $class, $file ) = @_;
|
||||
$file = $class->_file_path($file);
|
||||
my $self = $class->_init($file);
|
||||
|
||||
$self->{ro} = 1;
|
||||
|
||||
return $self->_open($file) ? $self : undef;
|
||||
}
|
||||
|
||||
|
||||
sub is_ro
|
||||
{
|
||||
return $_[0]->{ro} ? 1 : 0;
|
||||
}
|
||||
|
||||
sub _open
|
||||
{
|
||||
my ( $self, $file ) = @_;
|
||||
|
||||
eval {
|
||||
|
||||
# This is unfortunately not atomic, but I don't think
|
||||
# that's a big deal.
|
||||
die "File doesn't exist\n" unless -e $file;
|
||||
die "File isn't readable\n" unless -r $file;
|
||||
|
||||
$self->{config} = $self->_get_config($file)
|
||||
|| die "Can't get the esmith::config object";
|
||||
};
|
||||
if ($@)
|
||||
{
|
||||
chomp $@;
|
||||
$self->set_error($@);
|
||||
return;
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _get_config
|
||||
{
|
||||
my ( $self, $file ) = @_;
|
||||
|
||||
my %config;
|
||||
tie %config, $self->tie_class, $file;
|
||||
|
||||
return \%config;
|
||||
}
|
||||
|
||||
sub _init
|
||||
{
|
||||
my ( $class, $file ) = @_;
|
||||
|
||||
my $self = bless { file => $file }, $class;
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub _file_path
|
||||
{
|
||||
my ( $class, $file ) = @_;
|
||||
|
||||
if ($file =~ m:/:)
|
||||
{
|
||||
use File::Basename;
|
||||
warn "Deprecated pathname $file passed to _file_path()\n"
|
||||
if dirname($file) eq "/home/e-smith";
|
||||
return $file;
|
||||
}
|
||||
|
||||
if (-e "/home/e-smith/db/$file")
|
||||
{
|
||||
return "/home/e-smith/db/$file";
|
||||
} elsif (-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";
|
||||
}
|
||||
}
|
||||
|
||||
=item B<as_hash>
|
||||
|
||||
=begin testing
|
||||
|
||||
use esmith::TestUtils qw(scratch_copy);
|
||||
my $scratch = scratch_copy('10e-smith-lib/db_dummy.conf');
|
||||
my %db = esmith::DB::db->as_hash($scratch);
|
||||
|
||||
my %expect = ( Foo => { type => 'Bar' },
|
||||
Night => { type => 'Day' },
|
||||
Squid => { type => 'cephalopod',
|
||||
arms => 10,
|
||||
species => 'Loligo' },
|
||||
Pipe => { type => 'art',
|
||||
pipe => 'this is not a | got that?',},
|
||||
Haiku => { type => 'poem',
|
||||
words =>
|
||||
"Damian Conway\nGod damn! Damian Conway\nDamian Conway",
|
||||
},
|
||||
Octopus => { type => 'cephalopod',
|
||||
arms => 8,
|
||||
species => '',
|
||||
}
|
||||
);
|
||||
|
||||
is_deeply( \%db, \%expect );
|
||||
|
||||
%db = esmith::DB::db->open($scratch)->as_hash;
|
||||
is_deeply( \%db, \%expect );
|
||||
|
||||
=end testing
|
||||
|
||||
=item B<reload>
|
||||
|
||||
=begin testing
|
||||
|
||||
my $db2 = esmith::DB::db->open($Scratch_Conf);
|
||||
my $something = $DB->new_record('something', { type => "wibble" });
|
||||
isa_ok( $something, 'esmith::DB::db::Record', 'new record in 1st DB' );
|
||||
|
||||
ok( !$db2->get('something'), ' 2nd DB still cant see new record' );
|
||||
ok( $db2->reload, ' reload' );
|
||||
ok( $db2->get('something'), ' 2nd DB can see new record' );
|
||||
|
||||
$something->delete;
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub reload
|
||||
{
|
||||
my ($self) = shift;
|
||||
|
||||
$self->_open( $self->file );
|
||||
}
|
||||
|
||||
=item B<file>
|
||||
|
||||
=for testing
|
||||
is( $db->file, $Scratch_Conf, 'file()' );
|
||||
|
||||
=cut
|
||||
|
||||
sub file
|
||||
{
|
||||
my ($self) = shift;
|
||||
return $self->{file};
|
||||
}
|
||||
|
||||
=item B<new_record>
|
||||
|
||||
=begin testing
|
||||
|
||||
my $record = $DB->new_record('Big Brother', { year => 1984,
|
||||
day => 'night',
|
||||
type => 'Govt',
|
||||
});
|
||||
isa_ok( $record, 'esmith::DB::db::Record', 'new_record' );
|
||||
is( $record->key, 'Big Brother', 'key' );
|
||||
is( $record->prop('type'), 'Govt', 'type' );
|
||||
is_deeply( {$record->props}, {year => 1984, day => 'night', type => 'Govt'},
|
||||
'props' );
|
||||
is( $record->prop('year'), 1984, 'prop() get' );
|
||||
is( $record->prop('day'), 'night', 'prop() get again' );
|
||||
|
||||
|
||||
$record = $DB->new_record('No props');
|
||||
isa_ok( $record, 'esmith::DB::db::Record', 'new_record() w/o props' );
|
||||
is( $record->key, 'No props', ' key' );
|
||||
|
||||
my $db2 = esmith::DB::db->open($DB->file);
|
||||
ok( $db2->get('No props'), ' can be gotten' );
|
||||
|
||||
$record->delete;
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub new_record
|
||||
{
|
||||
my ( $self, $key, $props ) = @_;
|
||||
|
||||
croak "This DB is opened read-only" if $self->is_ro;
|
||||
|
||||
if ( defined db_get( $self->{config}, $key ) )
|
||||
{
|
||||
return;
|
||||
}
|
||||
my $type = exists $props->{type} ? delete $props->{type} : '';
|
||||
db_set( $self->{config}, $key, $type, $props );
|
||||
$self->tie_class->_writeconf($self->{file}, $self->{config});
|
||||
|
||||
return esmith::DB::db::Record->_construct( $self, $key, $self->{config} );
|
||||
}
|
||||
|
||||
=item B<get>
|
||||
|
||||
=begin testing
|
||||
|
||||
my $rec = $DB->get('Big Brother');
|
||||
isa_ok( $rec, 'esmith::DB::db::Record', 'get' );
|
||||
is( $rec->key, 'Big Brother', ' right key' );
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub get
|
||||
{
|
||||
my ( $self, $key ) = @_;
|
||||
|
||||
unless ( defined db_get( $self->{config}, $key ) )
|
||||
{
|
||||
return;
|
||||
}
|
||||
|
||||
return esmith::DB::db::Record->_construct( $self, $key, $self->{config} );
|
||||
}
|
||||
|
||||
=item B<get_all>
|
||||
|
||||
=begin testing
|
||||
|
||||
$DB->new_record('Borg', { type => 'Govt', resistance => 'futile' });
|
||||
my @records = $DB->get_all;
|
||||
is( @records, 2, 'get_all' );
|
||||
ok( !(grep { !$_->isa('esmith::DB::db::Record') } @records),
|
||||
' theyre all records' );
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub get_all
|
||||
{
|
||||
my ($self) = shift;
|
||||
|
||||
return
|
||||
map { esmith::DB::db::Record->_construct( $self, $_, $self->{config} ) }
|
||||
db_get( $self->{config} );
|
||||
}
|
||||
|
||||
=item B<get_all_by_prop>
|
||||
|
||||
=begin testing
|
||||
|
||||
$DB->new_record('Pretz', { type => 'snack', flavor => 'old fashion' });
|
||||
my @records = $DB->get_all_by_prop(type => 'Govt');
|
||||
is( @records, 2, 'get_all_by_prop() type' );
|
||||
ok( !(grep { $_->prop('type') ne 'Govt' } @records),
|
||||
' theyre the right type' );
|
||||
|
||||
$DB->new_record('Pork lips', { type => 'snack', flavor => 'old fashion' });
|
||||
@records = $DB->get_all_by_prop(flavor => 'old fashion');
|
||||
is( @records, 2, 'get_all_by_prop()' );
|
||||
ok( !(grep { $_->prop('flavor') ne 'old fashion' } @records),
|
||||
' they have the right properties' );
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub tie_class
|
||||
{
|
||||
return 'esmith::config';
|
||||
}
|
||||
|
||||
sub close
|
||||
{
|
||||
}
|
||||
|
||||
=begin deprecated
|
||||
|
||||
=item B<list_by_type>
|
||||
|
||||
Given a type of item to look for in the database (eg "service", "ibay"),
|
||||
returns a list of items which are that type. This is the underlying
|
||||
routine behind esmith::AccountsDB::ibays() and similar methods.
|
||||
|
||||
=end deprecated
|
||||
|
||||
=for testing
|
||||
ok($DB->list_by_type("Govt"), "list_by_type *deprecated*");
|
||||
|
||||
=cut
|
||||
|
||||
sub list_by_type
|
||||
{
|
||||
my ( $self, $type ) = @_;
|
||||
|
||||
return map $_->key, $self->get_all_by_prop( type => $type );
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=head1 EXAMPLE
|
||||
|
||||
The full docs can be found in esmith::DB and esmith::DB::Record, but
|
||||
here's a cheat sheet for esmith::config and esmith::db users.
|
||||
|
||||
=over 4
|
||||
|
||||
=item opening the default config
|
||||
|
||||
use esmith::config
|
||||
my %config;
|
||||
tie %config, 'esmith::config;
|
||||
|
||||
Now:
|
||||
|
||||
use esmith::ConfigDB;
|
||||
my $config = esmith::ConfigDB->open;
|
||||
|
||||
=item opening a specific config database
|
||||
|
||||
my %config;
|
||||
tie %config, 'esmith::config', $config_file;
|
||||
|
||||
Now:
|
||||
|
||||
my $config = esmith::ConfigDB->open($config_file);
|
||||
|
||||
=item creating a new config database
|
||||
|
||||
This one's important. Before you could just tie esmith::config to any file
|
||||
and it would create it for you. Now you have to explicitly create it.
|
||||
|
||||
my %config;
|
||||
tie %config, 'esmith::config', $new_config_file;
|
||||
|
||||
Now:
|
||||
|
||||
my $config = esmith::ConfigDB->create($new_config_file);
|
||||
|
||||
=item checking if a record exists
|
||||
|
||||
print "Yep" if exists $config{foo};
|
||||
|
||||
now:
|
||||
|
||||
print "Yep" if $config->get('foo'); # unless of course, 'foo' is zero
|
||||
|
||||
=item creating a new record
|
||||
|
||||
Previously you could just create records on the fly:
|
||||
|
||||
# single value
|
||||
$config{foo} = 'whatever';
|
||||
|
||||
# with properties
|
||||
db_set(\%config, 'whatever', 'sometype', { with => 'properties' });
|
||||
|
||||
Now you have to explicitly create them:
|
||||
|
||||
# single value
|
||||
my $foo = $config->new_record('foo');
|
||||
$foo->set_value('foo');
|
||||
|
||||
# with properties
|
||||
my %defaults = ( 'type' => 'sometype',
|
||||
'linux' => 'stable',
|
||||
'windows' => 'stable?' );
|
||||
my $foo = $config->new_record('foo', \%defaults);
|
||||
|
||||
Note that 'type' is now just another property.
|
||||
|
||||
Here's a handy "create this if it doesn't already exist" idiom.
|
||||
|
||||
my $rec = $config->get($key) ||
|
||||
$config->new_record($key);
|
||||
|
||||
=item getting a value
|
||||
|
||||
Entries in a database should no longer be thought of as values, but as
|
||||
records.
|
||||
|
||||
my $val = $config{foo};
|
||||
|
||||
Now this only works with entries with single value. Things with
|
||||
multiple properties are dealt with differently.
|
||||
|
||||
my $record = $config->get('foo');
|
||||
my $val = $record->value;
|
||||
|
||||
=item setting a value
|
||||
|
||||
$config{foo} = 'something';
|
||||
|
||||
now
|
||||
|
||||
my $record = $config->get('foo');
|
||||
$record->set_value('something');
|
||||
|
||||
=item getting a property
|
||||
|
||||
my $this = db_get_prop(\%config, 'foo', 'this');
|
||||
|
||||
now:
|
||||
|
||||
my $foo = $config->get('foo');
|
||||
my $this = $foo->prop('this');
|
||||
|
||||
=item getting & setting properties
|
||||
|
||||
my $val = db_get_prop(\%config, 'foo', 'some prop');
|
||||
db_set_prop(\%config, 'foo', 'some prop' => $new_val);
|
||||
|
||||
now:
|
||||
|
||||
my $val = $record->prop('some prop');
|
||||
$record->set_prop('some prop' => $new_val);
|
||||
|
||||
=item get/setting the type
|
||||
|
||||
my $type = db_get_type(\%config, 'foo');
|
||||
db_set_type(\%config, 'foo', $new_type);
|
||||
|
||||
type is now just a property
|
||||
|
||||
my $record = $db->get('foo');
|
||||
my $type = $record->prop('type');
|
||||
$record->set_prop('type', $new_type);
|
||||
|
||||
=item getting all the properties
|
||||
|
||||
my %props = db_get_prop(\%config, 'foo');
|
||||
|
||||
now
|
||||
|
||||
my %props = $record->props;
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
SME Server Developers <bugs@e-smith.com>
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<esmith::AccountsDB>, L<esmith::ConfigDB>, L<esmith::DB::db::Record>
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
353
root/usr/share/perl5/vendor_perl/esmith/DB/db/Record.pm
Normal file
353
root/usr/share/perl5/vendor_perl/esmith/DB/db/Record.pm
Normal file
@@ -0,0 +1,353 @@
|
||||
#----------------------------------------------------------------------
|
||||
# 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::db::Record;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp;
|
||||
|
||||
use esmith::db;
|
||||
use esmith::DB::db;
|
||||
|
||||
require esmith::DB::Record;
|
||||
our @ISA = qw(esmith::DB::Record);
|
||||
|
||||
|
||||
=begin testing
|
||||
|
||||
use_ok('esmith::DB::db::Record');
|
||||
use_ok('esmith::DB::db');
|
||||
|
||||
use File::Copy;
|
||||
$Scratch_Conf = '10e-smith-lib/scratch.conf';
|
||||
copy('10e-smith-lib/db_dummy.conf', $Scratch_Conf);
|
||||
END { unlink $Scratch_Conf }
|
||||
|
||||
$DB = esmith::DB::db->open($Scratch_Conf);
|
||||
$Squid = $DB->get('Squid');
|
||||
|
||||
=end testing
|
||||
|
||||
=head1 NAME
|
||||
|
||||
esmith::DB::db::Record - Individual records in an esmith::db database
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Unless otherwise noted, works just like esmith::DB::Record.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This class represents entries in esmith::db flat-file database. A
|
||||
single object is a single line.
|
||||
|
||||
This class is not useful by itself but rather they are handed out
|
||||
via esmith::DB::db objects.
|
||||
|
||||
|
||||
=begin protected
|
||||
|
||||
=head2 Protected Methods
|
||||
|
||||
These methods are only allowed to be called by esmith::DB::db classes.
|
||||
|
||||
=item B<_construct>
|
||||
|
||||
my $record = esmith::DB::db::Record->_construct($db, $key, $config);
|
||||
|
||||
Generates a new esmith::DB::db::Record representing data inside the
|
||||
$db (an esmith::DB::db object).
|
||||
|
||||
This does *not* write anything into $db. This is here so a $db can
|
||||
initialize a new Record from existing data.
|
||||
|
||||
=end protected
|
||||
|
||||
=cut
|
||||
|
||||
sub _construct {
|
||||
my($class, $db, $key, $config) = @_;
|
||||
|
||||
die "_construct may only be called by esmith::DB::db"
|
||||
unless caller->isa('esmith::DB::db');
|
||||
|
||||
my $self = {
|
||||
db => $db,
|
||||
config => $config,
|
||||
key => $key
|
||||
};
|
||||
|
||||
return bless $self, $class;
|
||||
}
|
||||
|
||||
=head2 Methods
|
||||
|
||||
=over 4
|
||||
|
||||
=item B<key>
|
||||
|
||||
=for testing
|
||||
is( $Squid->key, 'Squid', 'key()' );
|
||||
|
||||
=cut
|
||||
|
||||
sub key {
|
||||
my($self) = shift;
|
||||
return $self->{key};
|
||||
}
|
||||
|
||||
=item B<props>
|
||||
|
||||
=for testing
|
||||
is_deeply( {$Squid->props}, {arms => 10, species => 'Loligo',
|
||||
type => 'cephalopod'}, 'props()' );
|
||||
|
||||
=cut
|
||||
|
||||
sub props {
|
||||
my($self) = shift;
|
||||
|
||||
my %props = db_get_prop($self->{config}, $self->{key});
|
||||
$props{type} = db_get_type($self->{config}, $self->{key});
|
||||
foreach my $prop (keys %props) {
|
||||
$props{$prop} =~ s{\\\|}{\|}g if $props{$prop};
|
||||
}
|
||||
return wantarray ? %props : keys %props;
|
||||
}
|
||||
|
||||
=item B<prop>
|
||||
|
||||
=item B<set_prop>
|
||||
|
||||
=begin testing
|
||||
|
||||
is( $Squid->prop('arms'), 10, 'prop()' );
|
||||
$Squid->set_prop('arms', 1000);
|
||||
is( $Squid->prop('arms'), 1000, 'set_prop()' );
|
||||
|
||||
is( $Squid->prop('type'), 'cephalopod', 'prop() type get' );
|
||||
$Squid->set_prop('type', 'tree dweller');
|
||||
is( $Squid->prop('type'), 'tree dweller', 'set_prop() type set' );
|
||||
|
||||
$Squid->set_prop('bar', 'foo | bar');
|
||||
is( $Squid->prop('bar'), 'foo bar', 'prop/set_prop with pipes - pipe stripped' );
|
||||
|
||||
{
|
||||
my $warning = '';
|
||||
local $SIG{__WARN__} = sub { $warning = join '', @_ };
|
||||
$Squid->prop('bar', 'foo');
|
||||
like( $warning, qr/^prop\(\) got extra arguments 'foo'. Maybe you ment set_prop\(\)\?/, 'prop()/set_prop() mixup warns' );
|
||||
|
||||
$warning = '';
|
||||
is( $Squid->prop('I_dont_exist'), undef, 'prop() on non-existent prop' );
|
||||
is( $warning, '', ' no warning' );
|
||||
|
||||
$warning = '';
|
||||
$Squid->set_prop('I_dont_exist', undef);
|
||||
is( $Squid->prop('I_dont_exist'), '', 'set_prop() with undef value' );
|
||||
is( $warning, '', ' no warning' );
|
||||
$Squid->delete_prop('I_dont_exist');
|
||||
}
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub prop {
|
||||
my($self, $property) = splice @_, 0, 2;
|
||||
|
||||
warn sprintf "prop() got extra arguments '%s'. Maybe you ment set_prop()?",
|
||||
"@_" if @_;
|
||||
|
||||
my $value;
|
||||
if( $property eq 'type' ) {
|
||||
$value = db_get_type($self->{config}, $self->{key});
|
||||
}
|
||||
else {
|
||||
$value = db_get_prop($self->{config}, $self->{key}, $property);
|
||||
}
|
||||
|
||||
# Unescape escaped pipes. esmith::db can't do this for us.
|
||||
$value =~ s{\\\|}{\|}g if defined $value;
|
||||
|
||||
return $value;
|
||||
}
|
||||
|
||||
sub set_prop {
|
||||
my($self, $property, $value) = @_;
|
||||
|
||||
croak "The DB is open read-only" if $self->{db}->is_ro;
|
||||
|
||||
# Strip pipes - we can't safely escape them while some code
|
||||
# still expects to split on pipe
|
||||
$value =~ s{\|}{}g if defined $value;
|
||||
|
||||
my $ret;
|
||||
if( $property eq 'type' ) {
|
||||
$ret = db_set_type($self->{config}, $self->{key}, $value);
|
||||
}
|
||||
else {
|
||||
$ret = db_set_prop($self->{config}, $self->{key},
|
||||
$property => $value);
|
||||
}
|
||||
return $ret;
|
||||
}
|
||||
|
||||
|
||||
=item B<delete_prop>
|
||||
|
||||
A special case for esmith::DB::db::Record, you're not allowed to
|
||||
delete the 'type' property.
|
||||
|
||||
=for testing
|
||||
is( $Squid->delete_prop('species'), 'Loligo',
|
||||
'delete_prop() returns the old value' );
|
||||
is_deeply( {$Squid->props}, {arms => 1000, bar => 'foo bar',
|
||||
type => 'tree dweller' },
|
||||
' and deletes' );
|
||||
|
||||
=cut
|
||||
|
||||
sub delete_prop {
|
||||
my($self, $property) = @_;
|
||||
|
||||
croak "The DB is open read-only" if $self->{db}->is_ro;
|
||||
|
||||
croak "You're not allowed to delete a type from an esmith::DB::db::Record"
|
||||
if $property eq 'type';
|
||||
|
||||
my $val = $self->prop($property);
|
||||
db_delete_prop($self->{config}, $self->{key}, $property);
|
||||
|
||||
return $val;
|
||||
}
|
||||
|
||||
=item B<merge_props>
|
||||
|
||||
=begin testing
|
||||
|
||||
my $octopus = $DB->get('Octopus');
|
||||
$octopus->merge_props( arms => '8 + 2i', name => 'Fluffy', pipe => 'not |');
|
||||
is_deeply( {$octopus->props}, { arms => '8 + 2i', type => 'cephalopod',
|
||||
species => '', name => 'Fluffy',
|
||||
pipe => 'not ' }, 'merge_props()' );
|
||||
$octopus->merge_props( type => 'foo' );
|
||||
is_deeply( {$octopus->props}, { arms => '8 + 2i', type => 'foo',
|
||||
species => '', name => 'Fluffy',
|
||||
pipe => 'not ' }, ' with type' );
|
||||
|
||||
$octopus->merge_props( { type => 'foo' } );
|
||||
like( $_STDERR_, qr/^merge_props\(\) was accidentally passed a hash ref/m,
|
||||
' anti-hash ref protection');
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub merge_props {
|
||||
my($self, %new_props) = @_;
|
||||
|
||||
croak "The DB is open read-only" if $self->{db}->is_ro;
|
||||
|
||||
if( ref $_[1] ) {
|
||||
carp("merge_props() was accidentally passed a hash ref");
|
||||
}
|
||||
|
||||
my %props = $self->props;
|
||||
my %merged_props = (%props, %new_props);
|
||||
|
||||
# Strip out pipes.
|
||||
foreach my $prop (keys %merged_props) {
|
||||
$merged_props{$prop} =~ s{\|}{}g
|
||||
if defined $merged_props{$prop};
|
||||
}
|
||||
|
||||
my $type = delete $merged_props{type};
|
||||
db_set($self->{config}, $self->{key}, $type, \%merged_props);
|
||||
}
|
||||
|
||||
=item B<reset_props>
|
||||
|
||||
=begin testing
|
||||
|
||||
my $octopus = $DB->get('Octopus');
|
||||
|
||||
eval { $octopus->reset_props( { type => 'foo' } ); };
|
||||
like( $_STDERR_, qr/^reset_props\(\) was accidentally passed a hash ref/m,
|
||||
' anti-hash ref protection');
|
||||
|
||||
$octopus->reset_props( arms => 8, name => 'Rupert', type => 'foo' );
|
||||
is_deeply( {$octopus->props}, { arms => '8', name => 'Rupert',
|
||||
type => 'foo' }, 'reset_props' );
|
||||
|
||||
eval { $octopus->reset_props( arms => '8 + 2i', name => 'Fluffy',
|
||||
pipe => 'not ') };
|
||||
like( $@, qr/^You must have a type property/, ' you must have a type');
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub reset_props {
|
||||
my($self, %new_props) = @_;
|
||||
|
||||
croak "The DB is open read-only" if $self->{db}->is_ro;
|
||||
|
||||
if( ref $_[1] ) {
|
||||
carp("reset_props() was accidentally passed a hash ref");
|
||||
}
|
||||
|
||||
die "You must have a type property" unless $new_props{type};
|
||||
|
||||
# Strip out pipes
|
||||
foreach my $prop (keys %new_props) {
|
||||
$new_props{$prop} =~ s{\|}{}g
|
||||
if defined $new_props{$prop};
|
||||
}
|
||||
|
||||
my $type = delete $new_props{type} || $self->prop('type');
|
||||
db_set($self->{config}, $self->{key}, $type, \%new_props);
|
||||
}
|
||||
|
||||
|
||||
=item B<delete>
|
||||
|
||||
=for testing
|
||||
my $foo = $DB->get('Foo');
|
||||
$foo->delete;
|
||||
ok( !$DB->get('Foo'), 'delete()' );
|
||||
|
||||
=cut
|
||||
|
||||
sub delete {
|
||||
my($self) = shift;
|
||||
|
||||
croak "The DB is open read-only" if $self->{db}->is_ro;
|
||||
db_delete($self->{config}, $self->{key});
|
||||
}
|
||||
|
||||
=item B<show>
|
||||
|
||||
=begin testing
|
||||
|
||||
is( $Squid->show, <<SQUID, 'show' );
|
||||
Squid
|
||||
arms = 1000
|
||||
bar = foo bar
|
||||
type = tree dweller
|
||||
SQUID
|
||||
|
||||
=end testing
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<esmith::DB::db>
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
Reference in New Issue
Block a user