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
540
root/usr/share/perl5/vendor_perl/esmith/AccountsDB.pm
Normal file
540
root/usr/share/perl5/vendor_perl/esmith/AccountsDB.pm
Normal file
@@ -0,0 +1,540 @@
|
||||
#----------------------------------------------------------------------
|
||||
# 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::AccountsDB;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use esmith::db;
|
||||
|
||||
use vars qw( $AUTOLOAD @ISA );
|
||||
|
||||
use esmith::DB::db;
|
||||
@ISA = qw(esmith::DB::db);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
esmith::AccountsDB - interface to esmith configuration database
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use esmith::AccountsDB;
|
||||
my $a = esmith::AccountsDB->open;
|
||||
|
||||
my @users = $a->users();
|
||||
my @groups = $a->groups();
|
||||
my @ibays = $a->ibays();
|
||||
my @printers = $a->printers();
|
||||
my @pseudonyms = $a->pseudonyms();
|
||||
|
||||
$a->is_user_in_group($user, $group);
|
||||
my @groups = $a->user_group_list($user);
|
||||
$a->add_user_to_groups($user, @groups);
|
||||
$a->remove_user_from_groups($user, @groups);
|
||||
|
||||
$a->create_user_auto_pseudonyms($user);
|
||||
$a->remove_user_auto_pseudonyms($user);
|
||||
$a->remove_all_user_pseudonyms($user);
|
||||
my $dp = $a->dot_pseudonym($user);
|
||||
my $up = $a->underbar_pseudonym($user);
|
||||
my $uid = $a->get_next_uid();
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides an abstracted interface to the esmith accounts
|
||||
database.
|
||||
|
||||
=cut
|
||||
|
||||
our $VERSION = sprintf '%d.%03d', q$Revision: 1.18 $ =~ /: (\d+).(\d+)/;
|
||||
|
||||
=head2 open()
|
||||
|
||||
Loads an existing account database and returns an esmith::AccountsDB
|
||||
object representing it.
|
||||
|
||||
=begin testing
|
||||
|
||||
use esmith::TestUtils qw(scratch_copy);
|
||||
|
||||
use_ok("esmith::AccountsDB");
|
||||
use esmith::db;
|
||||
use vars qw($a);
|
||||
|
||||
my $conf = scratch_copy('10e-smith-lib/accounts.conf');
|
||||
$a = esmith::AccountsDB->open($conf);
|
||||
isa_ok($a, 'esmith::AccountsDB');
|
||||
is( $a->get("global")->prop('type'), "system", "We can get stuff from the db");
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub open {
|
||||
my($class, $file) = @_;
|
||||
$file = $file || $ENV{ESMITH_ACCOUNT_DB} || "accounts";
|
||||
return $class->SUPER::open($file);
|
||||
}
|
||||
|
||||
=head2 open_ro()
|
||||
|
||||
Like esmith::DB->open_ro, but if given no $file it will try to open the
|
||||
file in the ESMITH_ACCOUNT_DB environment variable or accounts.
|
||||
|
||||
=begin testing
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub open_ro {
|
||||
my($class, $file) = @_;
|
||||
$file = $file || $ENV{ESMITH_ACCOUNT_DB} || "accounts";
|
||||
return $class->SUPER::open_ro($file);
|
||||
}
|
||||
|
||||
=head2 users(), groups(), ibays(), printers(), pseudonyms()
|
||||
|
||||
Returns a list of records (esmith::DB::db::Record objects) of the
|
||||
given type.
|
||||
|
||||
=for testing
|
||||
foreach my $t (qw(users groups pseudonyms)) {
|
||||
my @list = $a->$t();
|
||||
ok(@list, "Got a list of $t");
|
||||
isa_ok($list[0], 'esmith::DB::db::Record');
|
||||
}
|
||||
|
||||
=cut
|
||||
|
||||
sub AUTOLOAD {
|
||||
my $self = shift;
|
||||
my ($called_sub_name) = ($AUTOLOAD =~ m/([^:]*)$/);
|
||||
my @types = qw( users groups ibays printers pseudonyms);
|
||||
if (grep /^$called_sub_name$/, @types) {
|
||||
$called_sub_name =~ s/s$//g; # de-pluralize
|
||||
return $self->get_all_by_prop(type => $called_sub_name);
|
||||
}
|
||||
}
|
||||
|
||||
=head1 GROUP MANAGEMENT
|
||||
|
||||
=head2 $a->is_user_in_group($user, $group)
|
||||
|
||||
Returns true if the user is a member of the group, false otherwise. The
|
||||
arguments are a user name and a group name.
|
||||
|
||||
This routine will return undef if there is no such group, false (but
|
||||
defined) if the user is not in the group, and true if the user is in the
|
||||
group.
|
||||
|
||||
=for testing
|
||||
ok($a->is_user_in_group('bart', 'simpsons'), "Bart is in group Simpsons");
|
||||
ok(not($a->is_user_in_group('moe', 'simpsons')), "Moe is not in group Simpsons");
|
||||
ok(not(defined $a->is_user_in_group('moe', 'flanders')), "No such group as Flanders");
|
||||
|
||||
=cut
|
||||
|
||||
sub is_user_in_group {
|
||||
my ($self, $user, $group) = @_;
|
||||
$group = $self->get($group) || return undef;
|
||||
my $members = $group->prop('Members');
|
||||
|
||||
return grep(/^$user$/, split /,/, $members) ? 1 : 0;
|
||||
}
|
||||
|
||||
=head2 $a->user_group_list($user)
|
||||
|
||||
Get a list of groups (by name) of which a user is a member. The $user argument
|
||||
is simply the username.
|
||||
|
||||
=for testing
|
||||
my @groups = $a->user_group_list('bart');
|
||||
is_deeply(\@groups, ['simpsons'], "Bart's group list is 'simpsons'");
|
||||
|
||||
=cut
|
||||
|
||||
sub user_group_list {
|
||||
my ($self, $user) = @_;
|
||||
my @groups = $self->groups();
|
||||
my @user_groups;
|
||||
foreach my $g (@groups) {
|
||||
push(@user_groups, $g->key())
|
||||
if $self->is_user_in_group($user, $g->key());
|
||||
}
|
||||
return @user_groups;
|
||||
}
|
||||
|
||||
=head2 $a->add_user_to_groups($user, @groups)
|
||||
|
||||
Given a list of groups (by name), adds the user to all of them.
|
||||
|
||||
Doesn't signal the group-modify event, just does the DB work.
|
||||
|
||||
Note: the method used here is a bit kludgy. It could result in a user
|
||||
being in the same group twice.
|
||||
|
||||
=for testing
|
||||
my @groups = $a->groups();
|
||||
$a->remove_user_from_groups('maggie', map { $_->key() } @groups);
|
||||
my @mg = $a->user_group_list('maggie');
|
||||
is(scalar @mg, 0, "Maggie has been removed from all groups");
|
||||
$a->add_user_to_groups('maggie', 'simpsons');
|
||||
@mg = $a->user_group_list('maggie');
|
||||
is_deeply(\@mg, ['simpsons'], "Maggie has been added to group 'simpsons'");
|
||||
$a->remove_user_from_groups('maggie', 'simpsons');
|
||||
@mg = $a->user_group_list('maggie');
|
||||
is_deeply(\@mg, [], "Maggie's been removed from all groups again");
|
||||
$a->set_user_groups('maggie', 'simpsons');
|
||||
@mg = $a->user_group_list('maggie');
|
||||
is_deeply(\@mg, ['simpsons'], "Maggie's groups have been set to: 'simpsons'");
|
||||
|
||||
=cut
|
||||
|
||||
sub add_user_to_groups {
|
||||
my ($self, $user, @groups) = @_;
|
||||
GROUP: foreach my $group (@groups) {
|
||||
unless (($group) = ($group =~ /(^[\w.-]+$)/))
|
||||
{
|
||||
warn "Group name doesn't look like a group!\n";
|
||||
next GROUP;
|
||||
}
|
||||
|
||||
my $group_rec = $self->get($group) || next GROUP;
|
||||
my @members = split(/,/, $group_rec->prop('Members'));
|
||||
push @members, $user;
|
||||
# Remove duplicates
|
||||
my %members = map { $_ => 1 } @members;
|
||||
$group_rec->set_prop('Members', join(',', sort keys %members));
|
||||
}
|
||||
}
|
||||
|
||||
=head2 $a->remove_user_from_groups($user, @groups)
|
||||
|
||||
Given a list of groups, removes a user from all of them.
|
||||
Doesn't signal the group-modify event, just does the DB work.
|
||||
|
||||
=cut
|
||||
|
||||
sub remove_user_from_groups {
|
||||
my ($self, $user, @groups) = @_;
|
||||
|
||||
GROUP: foreach my $g (@groups) {
|
||||
my $group_rec = $self->get($g) || next GROUP;
|
||||
my $members = $group_rec->prop('Members');
|
||||
my @members = split (/,/, $members);
|
||||
@members = grep (!/^$user$/, @members);
|
||||
@members = qw(admin) unless @members; # admin *must* be in every group
|
||||
$group_rec->set_prop('Members', join(',', @members));
|
||||
}
|
||||
}
|
||||
|
||||
=head2 $a->set_user_groups($user, @groups)
|
||||
|
||||
Sets the user's groups in one fell swoop. Under the hood, it's removing
|
||||
the user from every group they're in then adding them to the set you give.
|
||||
|
||||
=cut
|
||||
|
||||
sub set_user_groups
|
||||
{
|
||||
my ($self, $user, @groups) = @_;
|
||||
my @old_groups = $self->user_groups_list($user);
|
||||
$self->remove_user_from_groups($user, @old_groups);
|
||||
$self->add_user_to_groups($user, @groups);
|
||||
}
|
||||
|
||||
=head1 PSEUDONYM MANAGEMENT
|
||||
|
||||
=head2 $a->create_user_auto_pseudonyms($user)
|
||||
|
||||
Given a user name, creates standard pseudonyms ("dot" and "underbar" style)
|
||||
for that user.
|
||||
|
||||
=for testing
|
||||
my $user = 'bart';
|
||||
ok($a->pseudonyms(), "There are pseudonyms in the accounts db");
|
||||
$a->remove_user_auto_pseudonyms($user);
|
||||
ok(! $a->get('bart.simpson'), "Removed dot-pseudonym");
|
||||
ok(! $a->get('bart_simpson'), "Removed underbar-pseudonym");
|
||||
$a->create_user_auto_pseudonyms($user);
|
||||
ok($a->get('bart.simpson'), "Created dot-pseudonym");
|
||||
ok($a->get('bart_simpson'), "Created underbar-pseudonym");
|
||||
|
||||
=cut
|
||||
|
||||
sub create_user_auto_pseudonyms {
|
||||
my ($self, $user) = @_;
|
||||
my $user_rec = $self->get($user);
|
||||
my $firstName = $user_rec->prop("FirstName");
|
||||
my $lastName = $user_rec->prop("LastName");
|
||||
|
||||
my $dot_pseudonym = dot_pseudonym($self, $user);
|
||||
my $underbar_pseudonym = underbar_pseudonym($self, $user);
|
||||
|
||||
my $dot_acct = $self->get($dot_pseudonym) ||
|
||||
$self->new_record($dot_pseudonym, { type => 'pseudonym',
|
||||
Account => $user} );
|
||||
|
||||
my $underbar_acct = $self->get($underbar_pseudonym) ||
|
||||
$self->new_record($underbar_pseudonym, { type => 'pseudonym',
|
||||
Account => $user} );
|
||||
}
|
||||
|
||||
|
||||
=head2 $a->remove_all_user_pseudonyms($user)
|
||||
|
||||
Given a username, remove any pseudonyms related to that user from the
|
||||
accounts database. Also removes any pseudonyms related to a pseudonym
|
||||
being removed. Returns the number of pseudonym records deleted.
|
||||
|
||||
=cut
|
||||
|
||||
sub remove_all_user_pseudonyms {
|
||||
my ($self, $user) = @_;
|
||||
my $count = 0;
|
||||
foreach my $p_rec (grep { $_->prop("Account") eq $user } $self->pseudonyms())
|
||||
{
|
||||
foreach my $p_p_rec (grep { $_->prop("Account") eq $p_rec->key } $self->pseudonyms())
|
||||
{
|
||||
$p_p_rec->delete;
|
||||
$count++;
|
||||
}
|
||||
$p_rec->delete;
|
||||
$count++;
|
||||
}
|
||||
return $count;
|
||||
}
|
||||
|
||||
=head2 $a->remove_user_auto_pseudonyms($user)
|
||||
|
||||
Given a username, remove the dot_pseudonym and underbar_pseudonym
|
||||
related to that user from the accounts database. Returns the number
|
||||
of pseudonym records deleted.
|
||||
|
||||
=cut
|
||||
|
||||
sub remove_user_auto_pseudonyms {
|
||||
my ($self, $user) = @_;
|
||||
my $dot_pseudonym = dot_pseudonym($self, $user);
|
||||
my $underbar_pseudonym = underbar_pseudonym($self, $user);
|
||||
my $count = 0;
|
||||
foreach my $p_rec ($self->get($dot_pseudonym),
|
||||
$self->get($underbar_pseudonym))
|
||||
{
|
||||
if (defined $p_rec && $p_rec->prop("type") eq "pseudonym" &&
|
||||
$p_rec->prop("Account") eq $user)
|
||||
{
|
||||
$p_rec->delete;
|
||||
$count++;
|
||||
}
|
||||
}
|
||||
return $count;
|
||||
}
|
||||
|
||||
=head2 $a->dot_pseudonym($user)
|
||||
|
||||
Returns the "dot"-style pseudonym for a user as a string. For instance,
|
||||
dot_pseudonym("bart") might return "bart.simpson".
|
||||
|
||||
=cut
|
||||
|
||||
sub dot_pseudonym {
|
||||
my ($self, $user) = @_;
|
||||
my $user_rec = $self->get($user);
|
||||
my $firstName = $user_rec->prop("FirstName");
|
||||
my $lastName = $user_rec->prop("LastName");
|
||||
|
||||
my $dot_pseudonym = lc("$firstName $lastName");
|
||||
|
||||
$dot_pseudonym =~ s/^\s+//; # Strip leading whitespace
|
||||
$dot_pseudonym =~ s/\s+$//; # Strip trailing whitespace
|
||||
$dot_pseudonym =~ s/\s+/ /g; # Multiple spaces become single spaces
|
||||
$dot_pseudonym =~ s/\s/./g; # Change all spaces to dots
|
||||
return $dot_pseudonym;
|
||||
}
|
||||
|
||||
=head2 $a->underbar_pseudonym($user)
|
||||
|
||||
Returns the "underbar"-style pseudonym for a user as a string. For instance,
|
||||
underbar_pseudonym("bart") might return "bart_simpson".
|
||||
|
||||
=begin testing
|
||||
|
||||
my @users = $a->users();
|
||||
my $user = 'bart';
|
||||
my $rec = $a->get($user);
|
||||
my $firstName = $rec->prop("FirstName");
|
||||
my $lastName = $rec->prop("LastName");
|
||||
my $up = $a->underbar_pseudonym($user);
|
||||
is($up, "bart_simpson", "Underbar pseudonym created correctly");
|
||||
my $dp = $a->dot_pseudonym($user);
|
||||
is($dp, "bart.simpson", "Underbar pseudonym created correctly");
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub underbar_pseudonym {
|
||||
my ($self, $user) = @_;
|
||||
my $user_rec = $self->get($user);
|
||||
my $firstName = $user_rec->prop("FirstName");
|
||||
my $lastName = $user_rec->prop("LastName");
|
||||
|
||||
my $underbar_pseudonym = lc("$firstName $lastName");
|
||||
|
||||
$underbar_pseudonym =~ s/^\s+//; # Strip leading whitespace
|
||||
$underbar_pseudonym =~ s/\s+$//; # Strip trailing whitespace
|
||||
$underbar_pseudonym =~ s/\s+/ /g; # Multiple spaces become single spaces
|
||||
$underbar_pseudonym =~ s/\s/_/g; # Change all spaces to underbars
|
||||
return $underbar_pseudonym;
|
||||
}
|
||||
|
||||
=head2 $a->activeUsers()
|
||||
|
||||
Returns the number of active users, ie, accounts which have passwords set and
|
||||
are of type 'user'.
|
||||
|
||||
=begin testing
|
||||
|
||||
my $numActiveUsers = scalar $a->activeUsers();
|
||||
like($numActiveUsers, qr/[0-9]+/, "active users returns a number");
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub activeUsers()
|
||||
{
|
||||
my $self = shift;
|
||||
my @users = $self->users();
|
||||
|
||||
return unless @users;
|
||||
return grep { $_->prop("PasswordSet") eq 'yes' } @users;
|
||||
}
|
||||
|
||||
=head2 get_next_uid
|
||||
|
||||
Returns the next available UID from /etc/passwd. All UIDs are above the range
|
||||
reserved for 'system' accounts (currently 5000).
|
||||
|
||||
=for testing
|
||||
SKIP: {
|
||||
skip "Must be root to run get_next_uid" if $<;
|
||||
my $u = $a->get_next_uid();
|
||||
ok($u > 5000, "UID should be greater than 5000");
|
||||
ok(! getpwuid($u), "UID should not yet exist");
|
||||
}
|
||||
|
||||
=cut
|
||||
|
||||
sub get_next_uid {
|
||||
use esmith::ConfigDB;
|
||||
|
||||
my $id;
|
||||
my $db = esmith::ConfigDB->open || die "Couldn't open config db";
|
||||
|
||||
if ($id = $db->get('MinUid'))
|
||||
{
|
||||
$id = $id->value();
|
||||
}
|
||||
else
|
||||
{
|
||||
$db->new_record('MinUid');
|
||||
$id = 5000;
|
||||
}
|
||||
|
||||
my $maxid = 1 << 31;
|
||||
setpwent();
|
||||
setgrent();
|
||||
while (getpwuid $id || getgrgid $id)
|
||||
{
|
||||
die "All userids in use" if ($id == $maxid);
|
||||
$id++;
|
||||
}
|
||||
endpwent();
|
||||
endgrent();
|
||||
|
||||
$db->set_value('MinUid', $id + 1);
|
||||
|
||||
return $id;
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 new_record ($key, \%props)
|
||||
|
||||
This method is overridden from esmith::DB::db. We do an additional check
|
||||
for implicit accounts here - accounts that exist in /etc/passwd but not
|
||||
in the db. Otherwise it behaves just like the superclass method.
|
||||
|
||||
=begin testing
|
||||
|
||||
isnt($a->new_record("root", {type=>'system'}), "OK",
|
||||
"can't create existing account");
|
||||
is($a->get("nobody"), undef, "nobody doesn't exist in db");
|
||||
isnt($a->new_record("nobody", {type=>'system'}), "OK",
|
||||
"can't create account in /etc/passwd");
|
||||
isnt($a->new_record("screwy", {type=>'user'}), undef,
|
||||
"created a regular user");
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub new_record
|
||||
{
|
||||
my ($self, $key, $props) = @_;
|
||||
|
||||
if(getpwnam($key) || getgrnam($key))
|
||||
{
|
||||
warn "Attempt to create account '$key' which already exists ",
|
||||
"in passwd";
|
||||
return undef;
|
||||
}
|
||||
return $self->SUPER::new_record($key, $props);
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 validate_account_name ($name)
|
||||
|
||||
Check $name to see if it is a valid account name. Valid account names
|
||||
start with a letter or number and contain only letters, numbers,
|
||||
underscores, dots and dashes.
|
||||
|
||||
=begin testing
|
||||
|
||||
is($a->validate_account_name("root"), "OK", "root is a valid name");
|
||||
is($a->validate_account_name("fred.frog"), "OK", "fred.frog is a valid name");
|
||||
is($a->validate_account_name("jane_doe"), "OK", "jane_doe is a valid name");
|
||||
isnt($a->validate_account_name("^root"), "OK", "^root is not a valid name");
|
||||
is(esmith::AccountsDB::validate_account_name("root"), "OK", "called as a function");
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub validate_account_name
|
||||
{
|
||||
my $self;
|
||||
# Were we called as a method or a function?
|
||||
if($#_ > 0)
|
||||
{
|
||||
$self = shift;
|
||||
}
|
||||
my $name = shift;
|
||||
return ($name =~ /[^0-9a-z\-_\.]/ or $name !~ /^[a-z]/) ? undef : 'OK';
|
||||
}
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
SME Server Developers <bugs@e-smith.com>
|
||||
|
||||
See http://www.e-smith.org/ for more information
|
||||
|
||||
|
||||
|
||||
398
root/usr/share/perl5/vendor_perl/esmith/ConfigDB.pm
Normal file
398
root/usr/share/perl5/vendor_perl/esmith/ConfigDB.pm
Normal file
@@ -0,0 +1,398 @@
|
||||
#----------------------------------------------------------------------
|
||||
# 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::ConfigDB;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use vars qw( $AUTOLOAD @ISA );
|
||||
|
||||
use esmith::DB::db;
|
||||
@ISA = qw( esmith::DB::db );
|
||||
|
||||
use esmith::ConfigDB::Record;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
esmith::ConfigDB - interface to esmith configuration database
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use esmith::ConfigDB;
|
||||
my $db = esmith::ConfigDB->open;
|
||||
my $db = esmith::ConfigDB->open_ro;
|
||||
|
||||
my @services = $db->services();
|
||||
|
||||
# Singleton Records
|
||||
my $record = $db->get($key);
|
||||
my $value = $record->value;
|
||||
$record->set_value($value);
|
||||
|
||||
# BAD!
|
||||
my $value = $db->get($key)->value() # Throws a runtime error if $key
|
||||
# doesn't exist
|
||||
$value = $db->get($key)->prop($p) # Throws a runtime error if $key
|
||||
# doesn't exist
|
||||
|
||||
# GOOD
|
||||
my $record = $db->get($key);
|
||||
my $value;
|
||||
if ($record)
|
||||
{
|
||||
$value = $record->prop($prop);
|
||||
}
|
||||
|
||||
# Typed Records (eventually they all will be)
|
||||
my $prop = $record->prop($p);
|
||||
$record->set_prop($prop, $propvalue);
|
||||
my $value = $db->get_value($key) # Returns undef if record doesn't exist
|
||||
$value = $db->get_prop($key, $p) # Returns undef if record doesn't exist
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides an abstracted interface to the esmith master
|
||||
configuration database.
|
||||
|
||||
Unless otherwise noted, esmith::ConfigDB acts like esmith::DB::db.
|
||||
|
||||
=cut
|
||||
|
||||
our $VERSION = sprintf '%d.%03d', q$Revision: 1.29 $ =~ /: (\d+).(\d+)/;
|
||||
|
||||
=head2 open()
|
||||
|
||||
Like esmith::DB->open, but if given no $file it will try to open the
|
||||
file in the ESMITH_CONFIG_DB environment variable or configuration.
|
||||
|
||||
=begin testing
|
||||
|
||||
use esmith::TestUtils qw(scratch_copy);
|
||||
use_ok("esmith::ConfigDB");
|
||||
|
||||
my $scratch_copy_of_conf = scratch_copy('10e-smith-lib/configuration.conf');
|
||||
$C = esmith::ConfigDB->open($scratch_copy_of_conf);
|
||||
isa_ok($C, 'esmith::ConfigDB');
|
||||
is( $C->get("AccessType")->prop('type'), "dedicated",
|
||||
"We can get stuff from the db");
|
||||
|
||||
is( $C->get_prop("AccessType",'type'), "dedicated",
|
||||
"We can get_prop stuff from the db");
|
||||
|
||||
is( $C->get_value("AccessType"), "dedicated",
|
||||
"We can get_value stuff from the db");
|
||||
|
||||
is( $C->get_value("NoSuchKey"), undef,
|
||||
"We can get_value non-existant keys");
|
||||
|
||||
is( $C->get_prop("diald","status"), "disabled",
|
||||
"We can get_prop stuff from the db");
|
||||
|
||||
is( $C->get_prop("NoSuchKey","NoSuchProp"), undef,
|
||||
"We can get_prop non-existant keys");
|
||||
|
||||
is( $C->get_prop("diald","NoSuchProp"), undef,
|
||||
"We can get_prop non-existant props");
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub open
|
||||
{
|
||||
my ( $class, $file ) = @_;
|
||||
$file = $file || $ENV{ESMITH_CONFIG_DB} || "configuration";
|
||||
return $class->SUPER::open($file);
|
||||
}
|
||||
|
||||
=head2 open_ro()
|
||||
|
||||
Like esmith::DB->open_ro, but if given no $file it will try to open the
|
||||
file in the ESMITH_CONFIG_DB environment variable or configuration.
|
||||
|
||||
=begin testing
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub open_ro
|
||||
{
|
||||
my ( $class, $file ) = @_;
|
||||
$file = $file || $ENV{ESMITH_CONFIG_DB} || "configuration";
|
||||
return $class->SUPER::open_ro($file);
|
||||
}
|
||||
|
||||
=head2 new_record()
|
||||
|
||||
This method creates a new record in the configuration database. As arguments,
|
||||
it expects the key to the record, followed by a hash references with its
|
||||
properties, including the type.
|
||||
|
||||
my $db = esmith::ConfigDB->open;
|
||||
my $record = $db->new_record('zope', { type => 'service',
|
||||
status => 'disabled' });
|
||||
|
||||
my %defaults = qw(
|
||||
type => 'service',
|
||||
status => 'disabled',
|
||||
maintainer => 'admin@domain.com'
|
||||
);
|
||||
my $record = $db->get('zope');
|
||||
unless ($record)
|
||||
{
|
||||
$record = $db->new_record('zope', \%defaults);
|
||||
}
|
||||
|
||||
=head2 get()
|
||||
|
||||
Like their esmith::DB counterparts except they return
|
||||
esmith::ConfigDB::Record objects which have a few extra methods.
|
||||
|
||||
my $record = $db->get('zope');
|
||||
|
||||
=begin testing
|
||||
|
||||
my $rec = eval { $C->get("I_dont_exist"); };
|
||||
ok( !$rec, 'get() on a non-existent key' );
|
||||
is( $@, '', ' doesnt blow up' );
|
||||
|
||||
isa_ok( $C->get("AccessType"), 'esmith::ConfigDB::Record',
|
||||
"get()ened records are ConfigDB::Records" );
|
||||
|
||||
$rec = $C->new_record("I_dont_exist", { type => "foo" });
|
||||
isa_ok( $rec, 'esmith::ConfigDB::Record',
|
||||
"new_record()s are ConfigDB::Records" );
|
||||
$rec->delete("I_dont_exist");
|
||||
ok( !$C->get("I_dont_exist"), 'delete()' );
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub get
|
||||
{
|
||||
my ($self) = shift;
|
||||
|
||||
my $rec = $self->SUPER::get(@_);
|
||||
return $rec ? bless $rec, 'esmith::ConfigDB::Record' : undef;
|
||||
}
|
||||
|
||||
sub new_record
|
||||
{
|
||||
my ($self) = shift;
|
||||
|
||||
my $rec = $self->SUPER::new_record(@_);
|
||||
return $rec ? bless $rec, 'esmith::ConfigDB::Record' : undef;
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 getLocale()
|
||||
|
||||
Retrieves the locale and keyboard settings from the configuration database.
|
||||
Returns ($lang, $kbdtype, $keytable) on success. Returns undef if the record
|
||||
doesn't exist.
|
||||
|
||||
=cut
|
||||
|
||||
sub getLocale
|
||||
{
|
||||
my $self = shift;
|
||||
my $rec = $self->get('sysconfig') or return undef;
|
||||
my $lang = $rec->prop('Language') || 'en_US';
|
||||
my $kbdtype = $rec->prop('KeyboardType') || 'pc';
|
||||
my $keytable = $rec->prop('Keytable') || 'us';
|
||||
return ( $lang, $kbdtype, $keytable );
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 hosts_allow_spec ($service [,$daemon])
|
||||
|
||||
Given a service, return the string suitable for /etc/hosts.allow,
|
||||
checking to see if the service is defined, whether it is enabled and
|
||||
whether access is set to public, private, or localhost.
|
||||
|
||||
An optional argument provides the tag which appears in hosts.allow. If not
|
||||
given, the service name is used.
|
||||
|
||||
For example, one of the following:
|
||||
|
||||
# 'oidentd' is not defined in the configuration database
|
||||
# 'oidentd' is disabled in the configuration database
|
||||
in.identd: 127.0.0.1
|
||||
in.identd: 127.0.0.1 192.168.1.1/255.255.255.0
|
||||
in.identd: ALL
|
||||
|
||||
And here's the hosts.allow fragment:
|
||||
|
||||
{
|
||||
$OUT = $DB->hosts_allow_spec('oidentd', 'in.identd');
|
||||
}
|
||||
|
||||
=cut
|
||||
|
||||
sub hosts_allow_spec
|
||||
{
|
||||
my $self = shift;
|
||||
my $service_name = shift;
|
||||
my $daemon = shift || $service_name;
|
||||
|
||||
my $service = $self->get($service_name)
|
||||
or return
|
||||
"# '$service_name' is not defined in the configuration database";
|
||||
|
||||
my $status = $service->prop('status') || "disabled";
|
||||
return "# '$service_name' is disabled in the configuration database"
|
||||
unless ( $status eq "enabled" );
|
||||
|
||||
my $access = $service->prop('access') || "private";
|
||||
|
||||
use esmith::NetworksDB;
|
||||
my $ndb = esmith::NetworksDB->open_ro;
|
||||
|
||||
my @spec = ( "$daemon:", $ndb->local_access_spec($access) );
|
||||
return "@spec";
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 wins_server
|
||||
|
||||
Return the value of the WINS server from the config db
|
||||
or undef if we don't have a WINS server set and we are
|
||||
not the domain master
|
||||
|
||||
=cut
|
||||
|
||||
sub wins_server
|
||||
{
|
||||
my ($self) = @_;
|
||||
|
||||
my $wins_server = $self->get_prop( 'smb', 'WINSServer' );
|
||||
|
||||
return $wins_server if $wins_server;
|
||||
|
||||
my $server_role = $self->get_prop( 'smb', 'ServerRole' ) || 'WS';
|
||||
|
||||
return $self->get_prop( 'InternalInterface', 'IPAddress' )
|
||||
if $server_role =~ m{^(PDC|ADS)$};
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 services()
|
||||
|
||||
Returns a list of services in the configuration database
|
||||
|
||||
=for testing
|
||||
foreach my $t (qw(services)) {
|
||||
my @list = $C->$t();
|
||||
ok(@list, "Got a list of $t");
|
||||
}
|
||||
|
||||
=cut
|
||||
|
||||
sub AUTOLOAD
|
||||
{
|
||||
my $self = shift;
|
||||
my ($called_sub_name) = ( $AUTOLOAD =~ m/([^:]*)$/ );
|
||||
my @types = qw( services );
|
||||
if ( grep /^$called_sub_name$/, @types )
|
||||
{
|
||||
$called_sub_name =~ s/s$//g; # de-pluralize
|
||||
return $self->list_by_type($called_sub_name);
|
||||
}
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 _loadDefaults ($forceReset)
|
||||
|
||||
Behaves just like the esmith::DB method of the same name. This is a private
|
||||
method used internally.
|
||||
|
||||
=begin testing
|
||||
|
||||
$scratch_copy_of_conf = scratch_copy('10e-smith-lib/configuration.conf', 'configuration.conf.scratch');
|
||||
is ($scratch_copy_of_conf, 'configuration.conf.scratch', 'scratch copy name');
|
||||
$ENV{'ESMITH_CONFIG_DB'} = $scratch_copy_of_conf;
|
||||
$C = esmith::ConfigDB->open();
|
||||
is ($C->{file}, $scratch_copy_of_conf, 'file name');
|
||||
my $accesstype = $C->get("AccessType")->value;
|
||||
ok($C->new_record('foobar', {type=>'service', status=>'disabled'}),
|
||||
"Set up foobar record");
|
||||
is($C->get('foobar')->prop('status'), "disabled", "foobar is disabled");
|
||||
$ENV{'ESMITH_DB_DEFAULTSDIR'} = "10e-smith-lib/db";
|
||||
ok($C->_loadDefaults(), "Loaded defaults");
|
||||
is($C->get('foobar')->prop('status'), 'enabled', "We forced status enabled");
|
||||
is($C->get('bazbar')->prop('status'), 'enabled', "We included a new default");
|
||||
is($C->get('AccessType')->value, $accesstype, "AccessType has not changed");
|
||||
|
||||
=end testing
|
||||
|
||||
=head2 record_has_defaults ($name)
|
||||
|
||||
Behaves just like the esmith::DB method of the same name.
|
||||
|
||||
=begin testing
|
||||
|
||||
$ENV{'ESMITH_DB_DEFAULTSDIR'} = "10e-smith-lib/db";
|
||||
is($C->record_has_defaults('foobar'), 1, "foobar has some defaults");
|
||||
is($C->record_has_defaults('notthisone'), undef, "notthisone does not");
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
# There would normally be a method here, but we inherit _loadDefaults
|
||||
# from esmith::DB. The tests need to go here because the superclass is
|
||||
# all virtual and testing requires concrete open/get/set methods.
|
||||
|
||||
=pod
|
||||
|
||||
=head2 migrate
|
||||
|
||||
Just like the esmith::DB method of the same name.
|
||||
|
||||
=begin testing
|
||||
|
||||
$scratch_copy_of_conf = scratch_copy('10e-smith-lib/configuration.conf', 'configuration.conf.scratch');
|
||||
is ($scratch_copy_of_conf, 'configuration.conf.scratch', 'scratch copy name');
|
||||
$ENV{'ESMITH_CONFIG_DB'} = $scratch_copy_of_conf;
|
||||
$C = esmith::ConfigDB->open();
|
||||
is($C->get('quux'), undef, "No quux here");
|
||||
$ENV{'ESMITH_DB_DEFAULTSDIR'} = "10e-smith-lib/db";
|
||||
ok($C->migrate(), "We can migrate");
|
||||
my $quux = $C->get('quux');
|
||||
ok($quux, "We got quux");
|
||||
is($quux->prop('status'), 'enabled', "We migrated to quux");
|
||||
$quux->delete;
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
# There would normally be a method here, but we inherit migrate
|
||||
# from esmith::DB. The tests need to go here because the superclass is
|
||||
# all virtual and testing requires concrete open/get/set methods.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
SME Server Developers <bugs@e-smith.com>
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<esmith::DB>, L<esmith::DB::db>, L<esmith::AccountsDB>, L<esmith::DomainsDB>,
|
||||
L<esmith::HostsDB>, L<esmith::NetworksDB>, L<esmith::ConfigDB::Record>
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
108
root/usr/share/perl5/vendor_perl/esmith/ConfigDB/Record.pm
Normal file
108
root/usr/share/perl5/vendor_perl/esmith/ConfigDB/Record.pm
Normal file
@@ -0,0 +1,108 @@
|
||||
#----------------------------------------------------------------------
|
||||
# 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::ConfigDB::Record;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use esmith::ConfigDB;
|
||||
require esmith::DB::db::Record;
|
||||
our @ISA = qw(esmith::DB::db::Record);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
esmith::ConfigDB::Record - record in an esmith::ConfigDB database.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Just like esmith::DB::db::Record except...
|
||||
|
||||
my $value = $record->value;
|
||||
$record->set_value($value);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This provides some extra functionality needed by the esmith::ConfigDB
|
||||
databases.
|
||||
|
||||
Unless noted, it works just like esmith::DB::db::Record.
|
||||
|
||||
=head2 New Methods
|
||||
|
||||
|
||||
=over 4
|
||||
|
||||
=item B<value>
|
||||
|
||||
=item B<set_value>
|
||||
|
||||
my $value = $record->value;
|
||||
$record->set_value($value);
|
||||
|
||||
Gets/sets the value of the $record. Some ConfigDB entries don't have
|
||||
a set of properties, but rather a single value.
|
||||
|
||||
It will warn if you use these on $records with properties.
|
||||
|
||||
=begin testing
|
||||
|
||||
use esmith::ConfigDB;
|
||||
$Scratch_Conf = '10e-smith-lib/scratch.conf';
|
||||
unlink $Scratch_Conf;
|
||||
$c = esmith::ConfigDB->create($Scratch_Conf);
|
||||
END { unlink $Scratch_Conf }
|
||||
|
||||
{
|
||||
my $warning = '';
|
||||
local $SIG{__WARN__} = sub { $warning = join '', @_ };
|
||||
|
||||
my $wib = $c->new_record('wibble', { type => 'yar' });
|
||||
$wib->set_value('foo');
|
||||
is( $wib->value, 'foo', 'value/set_value' );
|
||||
is( $warning, '', ' no warning' );
|
||||
|
||||
$wib->set_prop(bar => 42);
|
||||
is( $wib->value, 'foo' );
|
||||
like( $warning, qr/value\(\) should not be used on records with properties, use prop\(\)/, 'value() warns if the record has props');
|
||||
|
||||
$wib->set_value(92);
|
||||
like( $warning, qr/set_value\(\) should not be used on records with properties, use set_prop\(\)/, 'value() warns if the record has props');
|
||||
is( $wib->value, 92 );
|
||||
}
|
||||
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub value {
|
||||
my($self) = shift;
|
||||
|
||||
my %props = $self->props;
|
||||
warn "value() should not be used on records with properties, use prop()" if
|
||||
keys %props > 1;
|
||||
return $self->prop('type');
|
||||
}
|
||||
|
||||
sub set_value {
|
||||
my($self, $value) = @_;
|
||||
|
||||
my %props = $self->props;
|
||||
warn "set_value() should not be used on records with properties, ".
|
||||
"use set_prop()" if keys %props > 1;
|
||||
return $self->set_prop('type', $value);
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<esmith::ConfigDB>, L<esmith::DB::db::Record>
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
22
root/usr/share/perl5/vendor_perl/esmith/ConfigDB/UTF8.pm
Normal file
22
root/usr/share/perl5/vendor_perl/esmith/ConfigDB/UTF8.pm
Normal file
@@ -0,0 +1,22 @@
|
||||
#----------------------------------------------------------------------
|
||||
# Copyright 1999-2008 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::ConfigDB::UTF8;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use esmith::DB::db;
|
||||
use esmith::config::utf8;
|
||||
our @ISA = qw( esmith::DB::db );
|
||||
|
||||
sub tie_class
|
||||
{
|
||||
return 'esmith::config::utf8';
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
705
root/usr/share/perl5/vendor_perl/esmith/DB.pm
Normal file
705
root/usr/share/perl5/vendor_perl/esmith/DB.pm
Normal file
@@ -0,0 +1,705 @@
|
||||
#----------------------------------------------------------------------
|
||||
# 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 strict;
|
||||
use warnings;
|
||||
use Carp;
|
||||
use File::Basename;
|
||||
use esmith::templates;
|
||||
|
||||
use constant TRUE => 1;
|
||||
use constant FALSE => 0;
|
||||
|
||||
our $VERSION = sprintf '%d.%03d', q$Revision: 1.40 $ =~ /: (\d+).(\d+)/;
|
||||
our $Error = undef;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
esmith::DB - virtual interface to E-Smith databases
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# Note: Do not instantiate this class directly. Use a subclass.
|
||||
# Examples in this documentation where you see it being used directly
|
||||
# are merely for consistency. Substitute a subclass in our examples.
|
||||
use esmith::DB;
|
||||
my $db = esmith::DB->create($filename) or
|
||||
die esmith::DB->error;
|
||||
my $db = esmith::DB->open($filename) or
|
||||
die esmith::DB->error;
|
||||
my $db = esmith::DB->open_ro($filename) or
|
||||
die esmith::DB->error;
|
||||
|
||||
my %DB = esmith::DB->as_hash($filename) or
|
||||
die esmith::DB->error;
|
||||
|
||||
$db->reload;
|
||||
|
||||
my $file = $db->file;
|
||||
|
||||
my $record = $db->new_record($key, \%properties);
|
||||
|
||||
my $record = $db->get($key);
|
||||
my @all_records = $db->get_all;
|
||||
my @all_records_by_prop = $db->get_all_by_prop($prop => $val);
|
||||
|
||||
$db->set_prop($key, $prop, $value);
|
||||
$db->set_value($key, $value);
|
||||
|
||||
$db->set_prop($key, $prop, $value, type => $type);
|
||||
$db->set_value($key, $value, create => 0);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module is a general interface to E-Smith's databases of various
|
||||
types and formats. It is not intended to be used directly, but that
|
||||
subclasses will implement the interface presented here to provide a
|
||||
single interface no matter what the underlying format.
|
||||
|
||||
For example, there is esmith::DB::db to interface with esmith::db
|
||||
flatfile databases. There could also be esmith::DB::Berkeley to use
|
||||
Berkeley database files, or even esmith::DB::DBI.
|
||||
|
||||
Most of the methods herein are "virtual". They don't exist. The
|
||||
subclass is responsible for impelmenting them. There are a handful of
|
||||
concrete methods that have been implemented for you that should work
|
||||
with any subclass.
|
||||
|
||||
=head2 Virtual Methods
|
||||
|
||||
This is the esmith::DB interface. Subclassers are expected to
|
||||
implement these methods.
|
||||
|
||||
=over 4
|
||||
|
||||
=item I<create>
|
||||
|
||||
my $db = esmith::DB->create($new_config_file) ||
|
||||
die esmith::DB->error;
|
||||
|
||||
Creates a brand new, empty configuration database and returns a
|
||||
subclass of the esmith::DB object representing it.
|
||||
|
||||
Should the $new_config_file already exist or for some reason you can't
|
||||
write to it, esmith::DB->error will return the reason and
|
||||
create() will return false.
|
||||
|
||||
=item I<open>
|
||||
|
||||
my $db = esmith::DB->open($config_file) ||
|
||||
die esmith::DB->error
|
||||
|
||||
Loads an existing configuration database and returns a
|
||||
subclass of the esmith::DB::db object representing it.
|
||||
|
||||
Should the $config_file not exist or not be openable it will return
|
||||
false and esmith::DB->error will contain the reason.
|
||||
|
||||
=item I<open_ro>
|
||||
|
||||
my $db = esmith::DB->open_ro($config_file) ||
|
||||
die esmith::DB->error;
|
||||
|
||||
Like open(), but the database is read-only. new_record() and all methods
|
||||
which could change a record (set_prop(), merge_props(), delete(), etc...)
|
||||
will both throw exceptions if used.
|
||||
|
||||
=item I<error>
|
||||
|
||||
my $error = esmith::DB->error;
|
||||
|
||||
Returns a string describing the error from the last failing method.
|
||||
|
||||
=item I<reload>
|
||||
|
||||
$db->reload;
|
||||
|
||||
Flushes out the $db's cache (if there is one) and reloads all
|
||||
configuration data from disk.
|
||||
|
||||
=item I<file>
|
||||
|
||||
my $file = $db->file;
|
||||
|
||||
File which this $db represents.
|
||||
|
||||
=item I<new_record>
|
||||
|
||||
my $record = $db->new_record($key, \%properties);
|
||||
|
||||
Adds a new record at $key in the $db setting it to the given
|
||||
%properties. Returns a subclass of the esmith::DB::Record object.
|
||||
|
||||
If a record already exists for the $key it will return false.
|
||||
|
||||
=item I<get>
|
||||
|
||||
my $record = $db->get($key);
|
||||
|
||||
Gets an existing record from the $db with the given $key. Returns an
|
||||
esmith::DB::Record object representing the data in $key.
|
||||
|
||||
If there's no record for the $key it will return false.
|
||||
|
||||
=item I<get_all>
|
||||
|
||||
my @records = $db->get_all;
|
||||
|
||||
Gets all the records out of the given $db as a list of
|
||||
esmith::DB::Record objects.
|
||||
|
||||
=back
|
||||
|
||||
=head2 Concrete methods
|
||||
|
||||
These are all implemented in terms of the esmith::DB interface and
|
||||
its not necessary for a subclass to implement them.
|
||||
|
||||
=over 4
|
||||
|
||||
=item I<as_hash>
|
||||
|
||||
my %db = $db->as_hash;
|
||||
my %db = esmith::DB->as_hash($file);
|
||||
|
||||
Returns the entire database as a hash of hashes. Each key is a key in
|
||||
the database, and the value is a hash of it's properties.
|
||||
|
||||
my $value = $db{some_key}{some_prop};
|
||||
|
||||
When used as an object method it will use the already opened database.
|
||||
When used as a class method it will open the given $file.
|
||||
|
||||
=cut
|
||||
|
||||
sub as_hash
|
||||
{
|
||||
my ( $proto, $file ) = @_;
|
||||
my $class = ref $proto || $proto;
|
||||
|
||||
my $self;
|
||||
if ( ref $proto )
|
||||
{ # object method
|
||||
$self = $proto;
|
||||
}
|
||||
else
|
||||
{ # class method
|
||||
$self = $class->open($file) or return;
|
||||
}
|
||||
my %hash = ();
|
||||
foreach my $rec ( $self->get_all )
|
||||
{
|
||||
my $key = $rec->key;
|
||||
my %props = $rec->props;
|
||||
|
||||
# Setup the hash
|
||||
$hash{$key} = \%props;
|
||||
}
|
||||
|
||||
return %hash;
|
||||
}
|
||||
|
||||
=item I<get_all_by_prop>
|
||||
|
||||
my @records_by_prop = $db->get_all_by_prop($property => $value);
|
||||
|
||||
Like get_all() except it gets only those records whose $property has
|
||||
the given $value. For properties with multiple comma-delimited values
|
||||
(ie: name|val1,val2,val3), only one of the properties needs to match.
|
||||
|
||||
=cut
|
||||
|
||||
sub get_all_by_prop
|
||||
{
|
||||
my ( $self, $prop, @rest ) = @_;
|
||||
my %props;
|
||||
|
||||
if ( ref($prop) eq 'HASH' )
|
||||
{
|
||||
carp "get_all_by_prop called with anonymous hash argument";
|
||||
%props = ( %{$prop} );
|
||||
}
|
||||
else
|
||||
{
|
||||
%props = ($prop, @rest);
|
||||
}
|
||||
my @things = sort { $a->key cmp $b->key } grep
|
||||
{
|
||||
my $found = 1;
|
||||
while ( my ($p, $v) = each (%props) )
|
||||
{
|
||||
$found &= ( defined $_->prop($p) and $_->prop($p) =~ /(?:^|,)$v(?:,|$)/ );
|
||||
}
|
||||
$found;
|
||||
} $self->get_all;
|
||||
@things;
|
||||
}
|
||||
|
||||
=item I<get_value>
|
||||
|
||||
my $value = $db->get_value( $key );
|
||||
|
||||
Shortcut method to get the value from the record defined by the given
|
||||
key. Returns undef if the record does not exist.
|
||||
|
||||
The following code is unsafe if the key doesn't exist:
|
||||
|
||||
my $value = $db->get("foo")->value || 'default';
|
||||
|
||||
and should be:
|
||||
|
||||
my $value = 'default';
|
||||
|
||||
if (my $r = $db->get("foo"))
|
||||
{
|
||||
$value = $r->value;
|
||||
}
|
||||
|
||||
With this method, you can use:
|
||||
|
||||
my $value = $db->get_value("foo") || 'default';
|
||||
|
||||
=cut
|
||||
|
||||
sub get_value
|
||||
{
|
||||
my $self = shift;
|
||||
my $item = $self->get(shift);
|
||||
return undef unless $item;
|
||||
return $item->value;
|
||||
}
|
||||
|
||||
=item I<get_prop>
|
||||
|
||||
my $prop = $db->get_prop( $key, $prop );
|
||||
|
||||
Shortcut method to get a property from the record defined by the given key.
|
||||
|
||||
Returns undef if the record for that key doesn't exist, or the property does
|
||||
not exist.
|
||||
|
||||
The following code is unsafe if either the key or property doesn't exist:
|
||||
|
||||
my $status = $db->get("foo")->prop('status') || 'disabled';
|
||||
|
||||
and should be written as:
|
||||
|
||||
my $status;
|
||||
|
||||
if (my $s = $db->get("foo"))
|
||||
{
|
||||
$status = $s->prop('status');
|
||||
}
|
||||
|
||||
$status ||= "default";
|
||||
|
||||
With this method, you can use:
|
||||
|
||||
my $value = $db->get_prop("foo", "status") || 'default';
|
||||
|
||||
=cut
|
||||
|
||||
sub get_prop
|
||||
{
|
||||
my $self = shift;
|
||||
my $item = $self->get(shift);
|
||||
return undef unless $item;
|
||||
return $item->prop(shift);
|
||||
}
|
||||
|
||||
=item I<set_value>
|
||||
|
||||
$db->set_value($key, $value)[, create => 1]);
|
||||
|
||||
Shortcut method to set a value to a key in the database without extracting the
|
||||
record first.
|
||||
|
||||
If the record is not pre-existing, it will be created, unless the 'create'
|
||||
option is passed with a value of 0.
|
||||
|
||||
Returns 0 for any errors, 1 for success.
|
||||
|
||||
=cut
|
||||
|
||||
sub set_value
|
||||
{
|
||||
my $self = shift;
|
||||
my ($key, $value, %options) = @_;
|
||||
|
||||
my %defaults = (create => 1);
|
||||
%options = (%defaults, %options);
|
||||
|
||||
my $record = $self->get($key);
|
||||
unless ($record)
|
||||
{
|
||||
if ($options{create})
|
||||
{
|
||||
$record = $self->new_record($key, {type => $value})
|
||||
or return 0;
|
||||
}
|
||||
else
|
||||
{
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
$record->set_value($value)
|
||||
or return 0;
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
=item I<set_prop>
|
||||
|
||||
$db->set_prop($key, $prop, $value[, type => $type]);
|
||||
|
||||
Shortcut method to set a property on a record without having to extract the
|
||||
record first.
|
||||
|
||||
If the optional type option is passed, it will be used to create the record if
|
||||
it does not already exist. Otherwise, a non-existent record will cause this
|
||||
method to return an error.
|
||||
|
||||
Returns 0 for any errors, 1 for success.
|
||||
|
||||
=cut
|
||||
|
||||
sub set_prop
|
||||
{
|
||||
my $self = shift;
|
||||
my ($key, $prop, $value, %options) = @_;
|
||||
my %defaults = (type => '');
|
||||
%options = (%defaults, %options);
|
||||
|
||||
my $record = $self->get($key);
|
||||
unless ($record)
|
||||
{
|
||||
if ($options{type})
|
||||
{
|
||||
$record = $self->new_record($key, {type => $options{type}})
|
||||
or return 0;
|
||||
}
|
||||
else
|
||||
{
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
$record->set_prop($prop, $value)
|
||||
or return 0;
|
||||
return 1;
|
||||
}
|
||||
|
||||
=item I<keys>
|
||||
|
||||
foreach my $key ($db->keys)
|
||||
{
|
||||
|
||||
A simple convenience function to prevent having to access the config hash
|
||||
inside the db object (technically private), or calling map across a get_all
|
||||
call, which is what this is going to do. :)
|
||||
|
||||
This method returns a list of keys to the records in the db. It does not sort.
|
||||
|
||||
=cut
|
||||
|
||||
sub keys
|
||||
{
|
||||
my $self = shift;
|
||||
return map { $_->{key} } $self->get_all;
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 migrate
|
||||
|
||||
Process the fragments in the migration queue for this database, using
|
||||
processTemplate.
|
||||
|
||||
The defaults are loaded from /etc/e-smith/db/<dbname>/migrate by default, but
|
||||
the environment variable ESMITH_DB_DEFAULTSDIR can be set to use a different
|
||||
hierarchy if required.
|
||||
|
||||
The entries in "migrate" are perl fragments which will be evaluated and
|
||||
so can munge anything they choose to. But, please be gentle :-)
|
||||
|
||||
So you could have
|
||||
|
||||
/etc/e-smith/db/configuration/migrate/sshd/access
|
||||
|
||||
which is a perl fragment which does something funky to migrate the access
|
||||
property from some old value to some new value.
|
||||
|
||||
After running all the migration scripts, and reloading the DB's data into
|
||||
its local cache, the private method _loadDefaults is called to set any
|
||||
missing default values and any forced settings.
|
||||
|
||||
=cut
|
||||
|
||||
sub migrate
|
||||
{
|
||||
my ($self) = @_;
|
||||
|
||||
my $dbfile = basename( $self->{file} );
|
||||
unless ($dbfile)
|
||||
{
|
||||
carp "migrate can't determine filename";
|
||||
return undef;
|
||||
}
|
||||
|
||||
my $defaults_dir = $ENV{ESMITH_DB_DEFAULTSDIR} || "/etc/e-smith/db";
|
||||
my $dir = "$defaults_dir/$dbfile/migrate";
|
||||
|
||||
eval {
|
||||
if ( -d $dir )
|
||||
{
|
||||
processTemplate(
|
||||
{
|
||||
MORE_DATA => { 'DB_FILENAME' => $dbfile },
|
||||
TEMPLATE_PATH => '',
|
||||
OUTPUT_TYPE => 'string',
|
||||
TEMPLATE_EXPAND_QUEUE =>
|
||||
[ $dir, "/etc/e-smith/templates-default" ]
|
||||
}
|
||||
);
|
||||
$self->reload;
|
||||
}
|
||||
$self->_loadDefaults();
|
||||
};
|
||||
if ($@)
|
||||
{
|
||||
warn "Warning: Migration of $dbfile failed fatally: $@\n";
|
||||
$self->set_error($@);
|
||||
return FALSE;
|
||||
}
|
||||
return TRUE;
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 resetToDefaults
|
||||
|
||||
Reset all entries to their default values, if defaults exist. This calls
|
||||
the internal method _loadDefaults with the forceReset flag set. It should
|
||||
not be used lightly!!
|
||||
|
||||
=cut
|
||||
|
||||
sub resetToDefaults
|
||||
{
|
||||
my ($self) = @_;
|
||||
|
||||
$self->_loadDefaults(1);
|
||||
}
|
||||
|
||||
=head2 record_has_defaults
|
||||
|
||||
Returns true if there are defaults or force directories for the
|
||||
given record name
|
||||
|
||||
=cut
|
||||
|
||||
sub record_has_defaults
|
||||
{
|
||||
my ( $self, $name ) = @_;
|
||||
|
||||
my $dbfile = basename( $self->{file} );
|
||||
|
||||
unless ($dbfile)
|
||||
{
|
||||
carp "record_has_defaults can't determine filename";
|
||||
return undef;
|
||||
}
|
||||
|
||||
unless ($name)
|
||||
{
|
||||
carp "record_has_defaults can't determine record name";
|
||||
return undef;
|
||||
}
|
||||
|
||||
my $defaults_dir = $ENV{ESMITH_DB_DEFAULTSDIR} || "/etc/e-smith/db";
|
||||
my $dir = "$defaults_dir/$dbfile";
|
||||
|
||||
return ( -d "$dir/defaults/$name" ) || ( -d "$dir/force/$name" );
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 _loadDefaults ($forceReset)
|
||||
|
||||
B<This is a private method.>
|
||||
|
||||
Load the default properties for a given database.
|
||||
Caller can provide a flag to force resetting properties that already exist.
|
||||
|
||||
Any forced properties will be evaluated after setting the default properties.
|
||||
|
||||
The defaults are loaded from the following directories in order (the
|
||||
environment variable ESMITH_DB_DEFAULTSDIR can be set to use a different
|
||||
hierarchy if required):
|
||||
|
||||
/etc/e-smith/db/<dbname>/defaults
|
||||
/etc/e-smith/db/<dbname>/force
|
||||
|
||||
Each of these directories is arranged as a set of subdirectories, with the
|
||||
directory name equal to the key for the given database. With these
|
||||
subdirectories are files, which are named by the properties of these
|
||||
database keys.
|
||||
|
||||
The entries in "defaults" will be skipped if the existing key/property
|
||||
already exists (unless the $forceReset argument is provided). These are
|
||||
simple files, whose contents are the value to be used for that property.
|
||||
|
||||
The entries in "force" are always loaded into the given key/property.
|
||||
These are again simple files, like "defaults".
|
||||
|
||||
To make this concrete, you might have:
|
||||
|
||||
/etc/e-smith/db/configuration/defaults/sshd/access
|
||||
|
||||
containing the single word "private", which would be the default. This
|
||||
value would only be used if no "access" property existed, or the
|
||||
$forceReset option is passed.
|
||||
|
||||
You can override both "defaults" and "migrate" with
|
||||
|
||||
/etc/e-smith/db/configuration/force/sshd/access
|
||||
|
||||
containing the single word "public" to force the value of that property.
|
||||
|
||||
=cut
|
||||
|
||||
sub _loadDefaults
|
||||
{
|
||||
my ( $self, $force ) = @_;
|
||||
|
||||
my $dbfile = basename( $self->{file} );
|
||||
unless ($dbfile)
|
||||
{
|
||||
carp "_loadDefaults can't determine filename";
|
||||
return undef;
|
||||
}
|
||||
|
||||
my $defaults_dir = $ENV{ESMITH_DB_DEFAULTSDIR} || "/etc/e-smith/db";
|
||||
|
||||
my @propQueue =
|
||||
( "$defaults_dir/$dbfile/defaults", "$defaults_dir/$dbfile/force", );
|
||||
|
||||
foreach my $dir (@propQueue)
|
||||
{
|
||||
|
||||
# Always process the force dir
|
||||
$force = 1 if ( $dir =~ /\/force$/ );
|
||||
|
||||
next unless opendir DH, $dir;
|
||||
foreach my $key ( grep !/^\./, readdir DH )
|
||||
{
|
||||
if ( -d "$dir/$key" )
|
||||
{
|
||||
my %props = ();
|
||||
|
||||
my $rec = $self->get($key);
|
||||
|
||||
opendir DH2, "$dir/$key";
|
||||
foreach my $prop ( grep !/^\./, readdir DH2 )
|
||||
{
|
||||
unless ($force)
|
||||
{
|
||||
next if ( $rec && defined $rec->prop($prop) );
|
||||
}
|
||||
open FH, "$dir/$key/$prop";
|
||||
my $val = join "", (<FH>);
|
||||
chomp $val;
|
||||
|
||||
$props{$prop} = $val;
|
||||
close FH;
|
||||
}
|
||||
closedir DH2;
|
||||
if ($rec)
|
||||
{
|
||||
$rec->merge_props(%props);
|
||||
}
|
||||
else
|
||||
{
|
||||
$rec = $self->new_record( $key, \%props );
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
warn "Found non-directory $key in $dir\n";
|
||||
}
|
||||
}
|
||||
close DH;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 get_value_and_delete ($key)
|
||||
|
||||
Retrieve the value of the named key, return it, and delete the record.
|
||||
If the key does not exist, it returns undef. This is normally called from
|
||||
migration code.
|
||||
|
||||
=cut
|
||||
|
||||
sub get_value_and_delete
|
||||
{
|
||||
my ( $self, $key ) = @_;
|
||||
my $ret;
|
||||
my $rec = $self->get($key);
|
||||
if ($rec)
|
||||
{
|
||||
$ret = $rec->value;
|
||||
$rec->delete;
|
||||
}
|
||||
return $ret;
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 get_prop_and_delete ($key, $prop)
|
||||
|
||||
Retrieve the named property of the named key, return the value, and delete the
|
||||
property from the record. Returns undef if the property or key does not exist.
|
||||
This is normally called from migration code.
|
||||
|
||||
=cut
|
||||
|
||||
sub get_prop_and_delete
|
||||
{
|
||||
my ( $self, $key, $prop ) = @_;
|
||||
my $ret;
|
||||
my $rec = $self->get($key);
|
||||
if ($rec)
|
||||
{
|
||||
$ret = $rec->prop($prop);
|
||||
$rec->delete_prop($prop);
|
||||
}
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub set_error
|
||||
{
|
||||
my $self = shift;
|
||||
$Error = shift;
|
||||
}
|
||||
|
||||
sub error
|
||||
{
|
||||
return $Error;
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
SME Server Developers <bugs@e-smith.com>
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
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;
|
||||
99
root/usr/share/perl5/vendor_perl/esmith/DomainsDB.pm
Normal file
99
root/usr/share/perl5/vendor_perl/esmith/DomainsDB.pm
Normal file
@@ -0,0 +1,99 @@
|
||||
#----------------------------------------------------------------------
|
||||
# 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::DomainsDB;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use esmith::DB::db;
|
||||
our @ISA = qw( esmith::DB::db );
|
||||
|
||||
=head1 NAME
|
||||
|
||||
esmith::DomainsDB - interface to esmith domains database
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use esmith::DomainsDB;
|
||||
my $c = esmith::DomainsDB->open;
|
||||
|
||||
# everything else works just like esmith::DB::db
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides an abstracted interface to the esmith domain
|
||||
database.
|
||||
|
||||
Unless otherwise noted, esmith::DomainsDB acts like esmith::DB::db.
|
||||
|
||||
=cut
|
||||
|
||||
=head2 open()
|
||||
|
||||
Like esmith::DB->open, but if given no $file it will try to open the
|
||||
file in the ESMITH_DOMAINS_DB environment variable or domains.
|
||||
|
||||
=begin testing
|
||||
|
||||
use_ok("esmith::DomainsDB");
|
||||
|
||||
$C = esmith::DomainsDB->open('10e-smith-lib/domains.conf');
|
||||
isa_ok($C, 'esmith::DomainsDB');
|
||||
is( $C->get("test")->prop('foo'), "bar",
|
||||
"We can get stuff from the db");
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub open {
|
||||
my ($self, $file) = @_;
|
||||
$file = $file || $ENV{ESMITH_DOMAINS_DB} || "domains";
|
||||
return $self->SUPER::open($file);
|
||||
}
|
||||
|
||||
=head2 open_ro()
|
||||
|
||||
Like esmith::DB->open_ro, but if given no $file it will try to open the
|
||||
file in the ESMITH_DOMAINS_DB environment variable or domains.
|
||||
|
||||
=begin testing
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub open_ro {
|
||||
my($class, $file) = @_;
|
||||
$file = $file || $ENV{ESMITH_DOMAINS_DB} || "domains";
|
||||
return $class->SUPER::open_ro($file);
|
||||
}
|
||||
=for testing
|
||||
$C = esmith::DomainsDB->open('10e-smith-lib/domains.conf');
|
||||
isa_ok($C, 'esmith::DomainsDB');
|
||||
can_ok($C, 'domains');
|
||||
can_ok($C, 'get_all_by_prop');
|
||||
is(scalar($C->domains()), 2, "Found 2 domains with domains()");
|
||||
|
||||
=cut
|
||||
|
||||
sub domains {
|
||||
my ($self) = @_;
|
||||
return $self->get_all_by_prop(type => 'domain');
|
||||
}
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
SME Server Developers <bugs@e-smith.com>
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<esmith::ConfigDB>
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
230
root/usr/share/perl5/vendor_perl/esmith/HostsDB.pm
Normal file
230
root/usr/share/perl5/vendor_perl/esmith/HostsDB.pm
Normal file
@@ -0,0 +1,230 @@
|
||||
#----------------------------------------------------------------------
|
||||
# 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::HostsDB;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use esmith::DB::db;
|
||||
our @ISA = qw( esmith::DB::db );
|
||||
|
||||
=head1 NAME
|
||||
|
||||
esmith::HostsDB - interface to esmith hostnames/addresses database
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use esmith::HostsDB;
|
||||
my $hosts = esmith::HostsDB->open;
|
||||
|
||||
# everything else works just like esmith::DB::db
|
||||
|
||||
# these methods are added
|
||||
my @hosts = $hosts->hosts;
|
||||
my @new_hosts = $hosts->propogate_hosts;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides an abstracted interface to the esmith hosts
|
||||
database.
|
||||
|
||||
Unless otherwise noted, esmith::HostsDB acts like esmith::DB::db.
|
||||
|
||||
=cut
|
||||
|
||||
=head2 Overridden methods
|
||||
|
||||
=over 4
|
||||
|
||||
=item I<open>
|
||||
|
||||
Like esmith::DB->open, but if given no $file it will try to open the
|
||||
file in the ESMITH_HOSTS_DB environment variable or hosts.
|
||||
|
||||
=begin testing
|
||||
|
||||
use_ok("esmith::HostsDB");
|
||||
|
||||
$H = esmith::HostsDB->open('10e-smith-lib/hosts.conf');
|
||||
isa_ok($H, 'esmith::HostsDB');
|
||||
is( $H->get("otherhost.mydomain.xxx")->prop('InternalIP'), "192.168.1.3",
|
||||
"We can get stuff from the db");
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub open {
|
||||
my($class, $file) = @_;
|
||||
$file = $file || $ENV{ESMITH_HOSTS_DB} || "hosts";
|
||||
return $class->SUPER::open($file);
|
||||
}
|
||||
|
||||
=head2 open_ro()
|
||||
|
||||
Like esmith::DB->open_ro, but if given no $file it will try to open the
|
||||
file in the ESMITH_HOSTS_DB environment variable or hosts.
|
||||
|
||||
=begin testing
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub open_ro {
|
||||
my($class, $file) = @_;
|
||||
$file = $file || $ENV{ESMITH_HOSTS_DB} || "hosts";
|
||||
return $class->SUPER::open_ro($file);
|
||||
}
|
||||
=back
|
||||
|
||||
=head2 Additional Methods
|
||||
|
||||
These methods are added be esmith::HostsDB
|
||||
|
||||
=over 4
|
||||
|
||||
=item I<hosts>
|
||||
|
||||
my @hosts = $hosts->hosts;
|
||||
|
||||
Returns a list of all host records in the database.
|
||||
|
||||
=begin testing
|
||||
|
||||
$db = esmith::HostsDB->open('10e-smith-lib/hosts.conf');
|
||||
isa_ok($db, 'esmith::HostsDB');
|
||||
can_ok($db, 'hosts');
|
||||
my @hosts = $db->hosts();
|
||||
isnt( @hosts, 0 );
|
||||
is_deeply(\@hosts, [$db->get_all_by_prop('type' => 'host')]);
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub hosts {
|
||||
my ($self) = @_;
|
||||
return $self->get_all_by_prop('type' => 'host');
|
||||
}
|
||||
|
||||
=item I<propogate_hosts>
|
||||
|
||||
my @new_hosts = $hosts->propogate_hosts($old_name, $new_name);
|
||||
|
||||
When the name of your e-smith machine changes, this will change the
|
||||
name of any hosts which also started with $old_name to use the
|
||||
$new_name.
|
||||
|
||||
Returns a list of the newly tranlsated host records.
|
||||
|
||||
=begin testing
|
||||
|
||||
use esmith::ConfigDB;
|
||||
|
||||
my $hosts_file = '10e-smith-lib/propogate_hosts.conf';
|
||||
END { unlink $hosts_file }
|
||||
|
||||
my $db = esmith::HostsDB->create($hosts_file);
|
||||
|
||||
use esmith::TestUtils qw(scratch_copy);
|
||||
my $c_scratch = scratch_copy('10e-smith-lib/configuration.conf');
|
||||
my $config = esmith::ConfigDB->open($c_scratch);
|
||||
isa_ok($config, 'esmith::ConfigDB');
|
||||
|
||||
my $name = $config->get('SystemName')->value;
|
||||
|
||||
# setup some dummy hosts to propogate.
|
||||
foreach my $host ( "$name.tofu-dog.com", "$name.wibble.org",
|
||||
"wibble.$name.org", "yarrow.hack" )
|
||||
{
|
||||
$db->new_record($host, { type => 'host', HostType => 'Self',
|
||||
ExternalIP => '', InternalIP => ''
|
||||
});
|
||||
}
|
||||
|
||||
$db->reload;
|
||||
my @new_hosts = $db->propogate_hosts($name, "armondo");
|
||||
my @hosts = $db->hosts;
|
||||
is( @hosts, 4 );
|
||||
is_deeply( [sort map { $_->key } @hosts],
|
||||
[sort +('armondo.tofu-dog.com',
|
||||
'armondo.wibble.org',
|
||||
"wibble.$name.org",
|
||||
'yarrow.hack',
|
||||
)]
|
||||
);
|
||||
|
||||
is( @new_hosts, 2 );
|
||||
is_deeply( [sort map { $_->key } @new_hosts],
|
||||
[sort qw(armondo.tofu-dog.com armondo.wibble.org)]
|
||||
);
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub propogate_hosts
|
||||
{
|
||||
my($self, $old_name, $new_name) = @_;
|
||||
|
||||
my @new_hosts = ();
|
||||
foreach my $host ($self->hosts)
|
||||
{
|
||||
my $new_host = $host->key;
|
||||
if( $new_host =~ s/^\Q$old_name.\E/$new_name./ )
|
||||
{
|
||||
push @new_hosts, $self->new_record($new_host,
|
||||
{ $host->props }
|
||||
);
|
||||
$host->delete;
|
||||
}
|
||||
}
|
||||
|
||||
return @new_hosts;
|
||||
}
|
||||
|
||||
|
||||
=head2 $db->get_hosts_by_domain
|
||||
|
||||
Given a domain name (as a string), finds any hosts which match it and
|
||||
return them as a list of record objects.
|
||||
|
||||
=begin testing
|
||||
|
||||
my $h = esmith::HostsDB->open('10e-smith-lib/hosts.conf');
|
||||
my @hosts = $h->get_hosts_by_domain('otherdomain.xxx');
|
||||
is(scalar(@hosts), 2, "Found two hosts in otherdomain.xxx");
|
||||
isa_ok($hosts[0], 'esmith::DB::Record');
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub get_hosts_by_domain {
|
||||
my ($self, $domain) = @_;
|
||||
my @all = $self->get_all();
|
||||
my @return;
|
||||
foreach my $h (@all) {
|
||||
push @return, $h if $h->key() =~ /^[^\.]+\.$domain$/;
|
||||
}
|
||||
return @return;
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
SME Server Developers <bugs@e-smith.com>
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<esmith::ConfigDB>
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
331
root/usr/share/perl5/vendor_perl/esmith/I18N.pm
Normal file
331
root/usr/share/perl5/vendor_perl/esmith/I18N.pm
Normal file
@@ -0,0 +1,331 @@
|
||||
#----------------------------------------------------------------------
|
||||
# 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::I18N;
|
||||
|
||||
use strict;
|
||||
|
||||
use esmith::ConfigDB;
|
||||
use POSIX qw(setlocale LC_ALL LC_CTYPE);
|
||||
use Locale::gettext;
|
||||
use I18N::AcceptLanguage;
|
||||
use I18N::LangTags qw(is_language_tag locale2language_tag);
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
esmith::I18N - Internationalization utilities Mitel Network SME Server
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
This file documents C<esmith::I18N> version B<1.4.0>
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use esmith::I18N;
|
||||
|
||||
my $i18n = new esmith::I18N;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides general internationalization and localisation
|
||||
utilities for developers of the Mitel Networks SME Server.
|
||||
|
||||
=begin testing
|
||||
|
||||
use I18N::LangTags qw(is_language_tag locale2language_tag language_tag2locale);
|
||||
use_ok('esmith::I18N');
|
||||
|
||||
=end testing
|
||||
|
||||
=head1 GENERAL UTILITIES
|
||||
|
||||
=cut
|
||||
|
||||
sub new
|
||||
{
|
||||
my $self = shift;
|
||||
my $class = ref($self) || $self;
|
||||
|
||||
my %args = @_;
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
=head2 availableLocales()
|
||||
|
||||
Returns an array containing the available locales supported by the
|
||||
server.
|
||||
|
||||
=begin testing
|
||||
|
||||
$ENV{ESMITH_CONFIG_DB}="10e-smith-lib/sysconfig-en_US.conf";
|
||||
$ENV{ESMITH_I18N_USRSHARELOCALE}="10e-smith-lib/usr/share/locale";
|
||||
|
||||
my $i18n = new esmith::I18N;
|
||||
my @locales = grep !/CVS/, sort $i18n->availableLocales;
|
||||
|
||||
# NOTE: de is not a valid locale for the test - no server-console file
|
||||
is_deeply(\@locales, [('en_US', 'fr_CA', 'wx_YZ')], "Locales match" );
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub availableLocales()
|
||||
{
|
||||
my ($self) = shift;
|
||||
|
||||
my $localedir = $ENV{ESMITH_I18N_USRSHARELOCALE} || '/usr/share/locale';
|
||||
|
||||
return () unless opendir LOCALE, $localedir;
|
||||
|
||||
my @locales;
|
||||
|
||||
foreach my $locale ( grep(!/\./, readdir LOCALE) )
|
||||
{
|
||||
push @locales, $locale if
|
||||
(-f "$localedir/$locale/LC_MESSAGES/server-console.mo" or
|
||||
-f "$localedir/$locale/LC_MESSAGES/server-console.po");
|
||||
}
|
||||
|
||||
closedir LOCALE;
|
||||
return @locales;
|
||||
}
|
||||
|
||||
=head2 fallbackLocale()
|
||||
|
||||
Return system fallback locale
|
||||
|
||||
=cut
|
||||
|
||||
sub fallbackLocale()
|
||||
{
|
||||
return "en_US.utf8";
|
||||
}
|
||||
|
||||
=head2 preferredLocale()
|
||||
|
||||
Retrieves the preferred locale for this server.
|
||||
|
||||
=begin testing
|
||||
|
||||
$ENV{ESMITH_CONFIG_DB}="10e-smith-lib/sysconfig-en_US.conf";
|
||||
|
||||
my $i18n = new esmith::I18N;
|
||||
is($i18n->preferredLocale, 'en_US', "en_US.conf: Preferred locale is en_US");
|
||||
|
||||
$ENV{ESMITH_CONFIG_DB}="10e-smith-lib/sysconfig-fr_CA.conf";
|
||||
|
||||
$i18n = new esmith::I18N;
|
||||
is($i18n->preferredLocale, 'fr_CA', "fr_CA.conf: Preferred locale is fr_CA");
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub preferredLocale()
|
||||
{
|
||||
my ($self) = shift;
|
||||
|
||||
my $db = esmith::ConfigDB->open_ro || return $self->fallbackLocale;
|
||||
|
||||
my ($locale, @rest) = $db->getLocale();
|
||||
|
||||
return $locale || $self->fallbackLocale;
|
||||
}
|
||||
|
||||
=head2 setLocale()
|
||||
|
||||
Configure the locale for gettext() for the supplied text domain.
|
||||
|
||||
The method takes two arguments, the text domain, and an optional argument
|
||||
which can be either a language tag or a locale.
|
||||
|
||||
=cut
|
||||
|
||||
sub setLocale()
|
||||
{
|
||||
my ($self, $text_domain, $opt) = @_;
|
||||
my $locale;
|
||||
|
||||
$locale = $self->langtag2locale($opt) if ($opt);
|
||||
$locale ||= $self->preferredLocale;
|
||||
$locale =~ s{(?:\..*)?$}{.utf8};
|
||||
|
||||
$ENV{'LANGUAGE'} = $locale;
|
||||
$ENV{'LANG'} = $ENV{'LANGUAGE'};
|
||||
|
||||
setlocale(LC_MESSAGES, $locale);
|
||||
setlocale(LC_MESSAGES, $locale);
|
||||
setlocale(LC_ALL, $locale);
|
||||
setlocale(LC_ALL, $locale);
|
||||
|
||||
bindtextdomain ($text_domain, "/usr/share/locale");
|
||||
textdomain ($text_domain);
|
||||
}
|
||||
|
||||
|
||||
=head2 langtag2locale
|
||||
|
||||
Even though the directories appear in /usr/share/locale, they also need
|
||||
to appear in /usr/lib/locale to actually be treated as locales. Read the
|
||||
Perl locale docs for details of how horrid this is. For now, we're just
|
||||
going to force things for supported languages.
|
||||
|
||||
=begin testing
|
||||
my $i18n = new esmith::I18N;
|
||||
|
||||
is($i18n->langtag2locale("en"), "en_US", "en langtag is en_US locale");
|
||||
is($i18n->langtag2locale("en-us"), "en_US", "en-us langtag is en_US locale");
|
||||
is($i18n->langtag2locale("en-au"), "en_AU", "en-au langtag is en_AU locale");
|
||||
|
||||
is($i18n->langtag2locale("es"), "es_ES", "es langtag is es_ES locale");
|
||||
is($i18n->langtag2locale("es-es"), "es_ES", "es-es langtag is es_ES locale");
|
||||
is($i18n->langtag2locale("es-ar"), "es_AR", "es-ar langtag is es_AR locale");
|
||||
|
||||
is($i18n->langtag2locale("fr"), "fr_CA", "fr langtag is fr_CA locale");
|
||||
is($i18n->langtag2locale("fr-ca"), "fr_CA", "fr-ca langtag is fr_CA locale");
|
||||
is($i18n->langtag2locale("fr-fr"), "fr_FR", "fr-fr langtag is fr_FR locale");
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub langtag2locale
|
||||
{
|
||||
my ($self, $opt) = @_;
|
||||
|
||||
my $locale;
|
||||
|
||||
if (is_language_tag($opt))
|
||||
{
|
||||
$locale = _language_tag2locale($opt) || $self->fallbackLocale;
|
||||
|
||||
unless (-d "/usr/lib/locale/$locale")
|
||||
{
|
||||
$locale = "da_DK" if ($opt =~ /^da(-.*)?/);
|
||||
$locale = "de_DE" if ($opt =~ /^de(-.*)?/);
|
||||
$locale = "el_GR" if ($opt =~ /^el(-.*)?/);
|
||||
$locale = "en_US" if ($opt =~ /^en(-.*)?/);
|
||||
$locale = "es_ES" if ($opt =~ /^es(-.*)?/);
|
||||
$locale = "fr_CA" if ($opt =~ /^fr(-.*)?/);
|
||||
$locale = "hu_HU" if ($opt =~ /^hu(-.*)?/);
|
||||
$locale = "id_ID" if ($opt =~ /^id(-.*)?/);
|
||||
$locale = "it_IT" if ($opt =~ /^it(-.*)?/);
|
||||
$locale = "nl_NL" if ($opt =~ /^nl(-.*)?/);
|
||||
$locale = "pt_BR" if ($opt =~ /^pt(-.*)?/);
|
||||
$locale = "sl_SL" if ($opt =~ /^sl(-.*)?/);
|
||||
$locale = "sv_SE" if ($opt =~ /^sv(-.*)?/);
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
$locale = $opt;
|
||||
}
|
||||
|
||||
return $locale;
|
||||
}
|
||||
|
||||
sub _language_tag2locale
|
||||
{
|
||||
my $langtags = $_[0];
|
||||
my @locales;
|
||||
foreach my $maybe (split /[\n\r\t ,]+/, $langtags)
|
||||
{
|
||||
push @locales,
|
||||
lc($1) . ( $2 ? ('_' . uc($2)) : '' )
|
||||
if $maybe =~ m/^([a-zA-Z]{2})(?:-([a-zA-Z]{2}))?$/s;
|
||||
}
|
||||
return $locales[0] unless wantarray; # might be undef!
|
||||
return @locales; # might be empty!
|
||||
}
|
||||
|
||||
=head2 availableLanguages()
|
||||
|
||||
Returns an array containing the available languages supported by the
|
||||
server.
|
||||
|
||||
=begin testing
|
||||
|
||||
$ENV{ESMITH_CONFIG_DB}="10e-smith-lib/sysconfig-en_US.conf";
|
||||
$ENV{ESMITH_I18N_ESMITHLOCALEDIR}="10e-smith-lib/etc/e-smith/locale";
|
||||
|
||||
my $i18n = new esmith::I18N;
|
||||
my @locales = grep !/CVS/, sort $i18n->availableLanguages;
|
||||
|
||||
is_deeply(\@locales, [('en-us', 'es', 'fr-ca', 'jk', 'wx-yz')], "Locales match" );
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub availableLanguages
|
||||
{
|
||||
my ($self) = shift;
|
||||
|
||||
my $localedir = $ENV{ESMITH_I18N_ESMITHLOCALEDIR} || '/etc/e-smith/locale';
|
||||
|
||||
return () unless opendir LOCALE, $localedir;
|
||||
|
||||
my @locales = grep(!/\./, readdir LOCALE);
|
||||
closedir LOCALE;
|
||||
return @locales;
|
||||
}
|
||||
|
||||
=head2 fallbackLanguage()
|
||||
|
||||
Return system fallback language
|
||||
|
||||
=cut
|
||||
|
||||
sub fallbackLanguage()
|
||||
{
|
||||
return "en-us";
|
||||
}
|
||||
|
||||
=head2 preferredLanguage()
|
||||
|
||||
Returns the preferred language, determined by the HTTP_ACCEPT_LANGUAGE
|
||||
setting from the browser and the available languages on the server.
|
||||
|
||||
=begin testing
|
||||
|
||||
my $i18n = new esmith::I18N;
|
||||
delete $ENV{HTTP_ACCEPT_LANGUAGE};
|
||||
|
||||
is( $i18n->preferredLanguage(), "en-us", "Preferred language is en-us");
|
||||
is( $i18n->preferredLanguage("en-us"), "en-us", "Preferred language is en-us");
|
||||
is( $i18n->preferredLanguage("en-us, fr-ca"), "en-us", "Preferred language is en-us");
|
||||
is( $i18n->preferredLanguage("fr-ca, en-us"), "fr-ca", "Preferred language is fr-ca");
|
||||
|
||||
$ENV{HTTP_ACCEPT_LANGUAGE} = "de, es";
|
||||
is( $i18n->preferredLanguage(), "es", "Preferred language is es");
|
||||
|
||||
$ENV{HTTP_ACCEPT_LANGUAGE} = "de, fr-ca, es, en-us";
|
||||
is( $i18n->preferredLanguage(), "fr-ca", "Preferred language is fr-ca");
|
||||
|
||||
$ENV{HTTP_ACCEPT_LANGUAGE} = "de, es, fr-ca, en-us";
|
||||
is( $i18n->preferredLanguage(), "es", "Preferred language is es");
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub preferredLanguage
|
||||
{
|
||||
my ($self, $browser_languages) = @_;
|
||||
|
||||
$browser_languages ||= $ENV{HTTP_ACCEPT_LANGUAGE}
|
||||
||= $self->fallbackLanguage;
|
||||
|
||||
my @availableLanguages = $self->availableLanguages;
|
||||
|
||||
my $acceptor = I18N::AcceptLanguage->new();
|
||||
my $language = $acceptor->accepts($browser_languages, \@availableLanguages)
|
||||
|| $self->fallbackLanguage;
|
||||
}
|
||||
|
||||
1;
|
||||
77
root/usr/share/perl5/vendor_perl/esmith/Logger.pm
Normal file
77
root/usr/share/perl5/vendor_perl/esmith/Logger.pm
Normal file
@@ -0,0 +1,77 @@
|
||||
#----------------------------------------------------------------------
|
||||
# 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::Logger;
|
||||
|
||||
use Sys::Syslog qw(:DEFAULT setlogsock);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
esmith::Logger - A filehandle abstraction around Syslog.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use esmith::Logger;
|
||||
|
||||
tie *FH, 'esmith::Logger';
|
||||
print FH "log message";
|
||||
close FH;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
=cut
|
||||
|
||||
our $VERSION = sprintf '%d.%03d', q$Revision: 1.100 $ =~ /: (\d+).(\d+)/;
|
||||
|
||||
sub TIEHANDLE
|
||||
{
|
||||
my $class = ref($_[0]) || $_[0]; shift;
|
||||
my $self;
|
||||
my $title = shift || 'e-smith';
|
||||
setlogsock 'unix';
|
||||
openlog($title, 'pid', 'local1');
|
||||
return bless \$self, $class;
|
||||
}
|
||||
|
||||
sub PRINT
|
||||
{
|
||||
my $self = shift;
|
||||
syslog('info', "%s", "@_");
|
||||
}
|
||||
|
||||
sub PRINTF
|
||||
{
|
||||
my $self = shift;
|
||||
my $fmt = shift;
|
||||
syslog('info', $fmt, @_);
|
||||
}
|
||||
|
||||
sub WRITE
|
||||
{
|
||||
die "Sorry, WRITE unimplemented.\n";
|
||||
}
|
||||
|
||||
sub READ
|
||||
{
|
||||
die "Can't read from logger.\n";
|
||||
}
|
||||
|
||||
sub READLINE
|
||||
{
|
||||
die "Can't read from logger.\n";
|
||||
}
|
||||
|
||||
sub GETC
|
||||
{
|
||||
die "Can't read from logger.\n";
|
||||
}
|
||||
|
||||
sub CLOSE
|
||||
{
|
||||
closelog();
|
||||
}
|
||||
|
||||
1;
|
||||
16
root/usr/share/perl5/vendor_perl/esmith/NavigationDB.pm
Normal file
16
root/usr/share/perl5/vendor_perl/esmith/NavigationDB.pm
Normal file
@@ -0,0 +1,16 @@
|
||||
#----------------------------------------------------------------------
|
||||
# Copyright 1999-2008 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::NavigationDB;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use esmith::ConfigDB::UTF8;
|
||||
our @ISA = qw( esmith::ConfigDB::UTF8 );
|
||||
|
||||
1;
|
||||
|
||||
157
root/usr/share/perl5/vendor_perl/esmith/NetworksDB.pm
Normal file
157
root/usr/share/perl5/vendor_perl/esmith/NetworksDB.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::NetworksDB;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use esmith::DB::db;
|
||||
our @ISA = qw( esmith::DB::db );
|
||||
|
||||
=head1 NAME
|
||||
|
||||
esmith::NetworksDB - interface to esmith networks database
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use esmith::NetworksDB;
|
||||
my $c = esmith::NetworksDB->open;
|
||||
|
||||
# everything else works just like esmith::DB::db
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides an abstracted interface to the esmith master
|
||||
configuration database.
|
||||
|
||||
Unless otherwise noted, esmith::NetworksDB acts like esmith::DB::db.
|
||||
|
||||
=cut
|
||||
|
||||
=head2 open()
|
||||
|
||||
Like esmith::DB->open, but if given no $file it will try to open the
|
||||
file in the ESMITH_NETWORKS_DB environment variable or networks.
|
||||
|
||||
=begin testing
|
||||
|
||||
use_ok("esmith::NetworksDB");
|
||||
|
||||
$C = esmith::NetworksDB->open('10e-smith-lib/networks.conf');
|
||||
isa_ok($C, 'esmith::NetworksDB');
|
||||
is( $C->get("10.0.0.0")->prop('Mask'), "255.255.255.0",
|
||||
"We can get stuff from the db");
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub open
|
||||
{
|
||||
my ( $class, $file ) = @_;
|
||||
$file = $file || $ENV{ESMITH_NETWORKS_DB} || "networks";
|
||||
return $class->SUPER::open($file);
|
||||
}
|
||||
|
||||
=head2 open_ro()
|
||||
|
||||
Like esmith::DB->open_ro, but if given no $file it will try to open the
|
||||
file in the ESMITH_NETWORKS_DB environment variable or networks.
|
||||
|
||||
=begin testing
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub open_ro
|
||||
{
|
||||
my ( $class, $file ) = @_;
|
||||
$file = $file || $ENV{ESMITH_NETWORKS_DB} || "networks";
|
||||
return $class->SUPER::open_ro($file);
|
||||
}
|
||||
|
||||
=head2 networks
|
||||
|
||||
Return a list of all objects of type "network".
|
||||
|
||||
=cut
|
||||
|
||||
sub networks {
|
||||
my ($self) = @_;
|
||||
return $self->get_all_by_prop(type => 'network');
|
||||
}
|
||||
|
||||
=head2 local_access_spec ([$access])
|
||||
|
||||
Compute the network/netmask entries which are to treated as local access.
|
||||
|
||||
There is also an optional access parameter which can further restrict
|
||||
the values returned. If C<access> is C<localhost>, this routine will only
|
||||
return a single value, equating to access from localhost only.
|
||||
|
||||
If called in scalar context, the returned string is suitable for
|
||||
use in /etc/hosts.allow, smb.conf and httpd.conf, for example:
|
||||
|
||||
127.0.0.1 192.168.1.1/255.255.255.0
|
||||
|
||||
Note: The elements are space separated, which is suitable for use in
|
||||
hosts.allow, smb.conf and httpd.conf. httpd.conf does not permit
|
||||
comma separated lists in C<allow from> directives. Each element is either
|
||||
an IP address, or a network/netmask string.
|
||||
|
||||
If called in list context, returns the array of addresses and network/netmask
|
||||
strings. It's trivial, of course, to convert an array to a comma separated
|
||||
list :-)
|
||||
|
||||
=cut
|
||||
|
||||
sub local_access_spec
|
||||
{
|
||||
my $self = shift;
|
||||
my $access = shift || "private";
|
||||
|
||||
my @localAccess = ("127.0.0.1");
|
||||
|
||||
if ( $access eq "localhost" )
|
||||
{
|
||||
# Nothing more to do
|
||||
}
|
||||
elsif ( $access eq "private" )
|
||||
{
|
||||
foreach my $network ( $self->networks )
|
||||
{
|
||||
my $element = $network->key;
|
||||
my $mask = $network->prop('Mask');
|
||||
$element .= "/$mask" unless ($mask eq "255.255.255.255");
|
||||
push @localAccess, $element;
|
||||
}
|
||||
}
|
||||
elsif ( $access eq "public" )
|
||||
{
|
||||
@localAccess = ("ALL");
|
||||
}
|
||||
else
|
||||
{
|
||||
warn "local_access_spec: unknown access value $access\n";
|
||||
}
|
||||
return wantarray ? @localAccess : "@localAccess";
|
||||
}
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
SME Server Developers <bugs@e-smith.com>
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<esmith::DB::db>
|
||||
|
||||
L<esmith::DB::Record>
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
480
root/usr/share/perl5/vendor_perl/esmith/cgi.pm
Normal file
480
root/usr/share/perl5/vendor_perl/esmith/cgi.pm
Normal file
@@ -0,0 +1,480 @@
|
||||
#----------------------------------------------------------------------
|
||||
# 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::cgi;
|
||||
|
||||
use strict;
|
||||
use esmith::config;
|
||||
use esmith::db;
|
||||
use esmith::util;
|
||||
|
||||
BEGIN
|
||||
{
|
||||
}
|
||||
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
esmith::cgi - Useful CGI routines for e-smith server and gateway
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
This file documents C<esmith::cgi> version B<1.4.0>
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use esmith::cgi;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module contains a collection of useful routines for working with
|
||||
the e-smith manager's CGI interface.
|
||||
=head1 WEB PAGE HEADER GENERATION ROUTINES
|
||||
|
||||
=head2 genHeaderNonCacheable($q, $confref, $title)
|
||||
|
||||
=cut
|
||||
|
||||
sub genHeaderNonCacheable
|
||||
{
|
||||
my ($q, $confref, $title) = @_;
|
||||
genHeader ($q, $confref, $title, '-20y', 1);
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 genHeaderCacheableNoPasswordCheck($q, $confref, $title)
|
||||
|
||||
=cut
|
||||
|
||||
sub genHeaderCacheableNoPasswordCheck
|
||||
{
|
||||
my ($q, $confref, $title) = @_;
|
||||
genHeader ($q, $confref, $title, '+1d', 0);
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 genHeaderCacheableNoPasswordCheck($q, $confref, $title)
|
||||
|
||||
=cut
|
||||
|
||||
sub genHeaderNonCacheableNoPasswordCheck
|
||||
{
|
||||
my ($q, $confref, $title) = @_;
|
||||
genHeader ($q, $confref, $title, '-20y', 0);
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 genHeader($q, $confref, $title, $expiry, $checkpassword)
|
||||
|
||||
=cut
|
||||
|
||||
sub genHeader
|
||||
{
|
||||
my ($q, $confref, $title, $expiry, $checkpassword) = @_;
|
||||
|
||||
print $q->header (-EXPIRES => $expiry, charset => 'UTF-8');
|
||||
|
||||
genHeaderStartHTML ($q, "panel_main");
|
||||
|
||||
print $q->h1 ($title);
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 genNavigationHeader($q)
|
||||
|
||||
=cut
|
||||
|
||||
sub genNavigationHeader
|
||||
{
|
||||
my ($q, $num) = @_;
|
||||
|
||||
print $q->header (-EXPIRES => '-20y', charset => 'UTF-8');
|
||||
|
||||
genHeaderStartHTML ($q, "panel_nav", $num);
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 genNoframesHeader($q)
|
||||
|
||||
=cut
|
||||
|
||||
sub genNoframesHeader
|
||||
{
|
||||
my ($q) = @_;
|
||||
|
||||
print $q->header (-EXPIRES => '-20y', charset => 'UTF-8');
|
||||
genHeaderStartHTML ($q, "panel_main");
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 genHeaderStartHTML($q)
|
||||
|
||||
=cut
|
||||
|
||||
sub genHeaderStartHTML
|
||||
{
|
||||
my ($q, $page_type, $num) = @_;
|
||||
my ($cssFile);
|
||||
my ($bodyStyle);
|
||||
my ($script) = "//This swaps the class of the selected item.\n"
|
||||
."function swapClass(){\n"
|
||||
."var i,x,tB,j=0,tA=new Array(),arg=swapClass.arguments;\n"
|
||||
."if(document.getElementsByTagName){for(i=4;i<arg.length;i++){tB=document.getElementsByTagName(arg[i]);\n"
|
||||
."for(x=0;x<tB.length;x++){tA[j]=tB[x];j++;}}for(i=0;i<tA.length;i++){\n"
|
||||
."if(tA[i].className){if(tA[i].id==arg[1]){if(arg[0]==1){\n"
|
||||
."tA[i].className=(tA[i].className==arg[3])?arg[2]:arg[3];}else{tA[i].className=arg[2];}\n"
|
||||
."}else if(arg[0]==1 && arg[1]=='none'){if(tA[i].className==arg[2] || tA[i].className==arg[3]){\n"
|
||||
."tA[i].className=(tA[i].className==arg[3])?arg[2]:arg[3];}\n"
|
||||
."}else if(tA[i].className==arg[2]){tA[i].className=arg[3];}}}}}\n";
|
||||
|
||||
if ($page_type eq "panel_nav") {
|
||||
$cssFile = "sme_menu.css";
|
||||
$bodyStyle = "menu"
|
||||
}
|
||||
elsif ($page_type eq "panel_main") {
|
||||
$cssFile = "sme_main.css";
|
||||
$bodyStyle = "main"
|
||||
}
|
||||
# the -CLASS thing gets sent as a body class, not in the header
|
||||
print $q->start_html (-TITLE => 'SME Server server manager',
|
||||
-META => {'copyright' => 'Copyright 1999-2006 Mitel Networks Corporation, Copyright (C) ____COPYYEARS____ Koozali Foundation, Inc.'},
|
||||
-SCRIPT => "$script",
|
||||
-CLASS => "$bodyStyle",
|
||||
-STYLE => {
|
||||
-code => '@import url("/server-common/css/'.$cssFile.'");',
|
||||
-src => '/server-common/css/sme_core.css'
|
||||
});
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head1 WEB PAGE FOOTER GENERATION ROUTINES
|
||||
|
||||
=head2 genFooter($q)
|
||||
|
||||
=cut
|
||||
|
||||
sub genFooter
|
||||
{
|
||||
my ($q) = @_;
|
||||
|
||||
if ($q->isa('CGI::FormMagick'))
|
||||
{
|
||||
print $q->parse_template("/etc/e-smith/web/common/foot.tmpl");
|
||||
return;
|
||||
}
|
||||
|
||||
my $release = esmith::util::determineRelease();
|
||||
|
||||
print $q->p
|
||||
($q->hr ({-CLASS => "sme-copyrightbar"}),
|
||||
$q->div ({-CLASS => "sme-copyright"},
|
||||
"SME Server server ${release}<BR>" .
|
||||
"Copyright 1999-2006 Mitel Networks Corporation, Copyright (C) ____COPYYEARS____ Koozali Foundation, Inc..<BR>" .
|
||||
"All rights reserved.")
|
||||
);
|
||||
|
||||
print '</DIV>';
|
||||
print $q->end_html;
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 genFooterNoCopyright($q)
|
||||
|
||||
=cut
|
||||
|
||||
sub genFooterNoCopyright
|
||||
{
|
||||
my ($q) = @_;
|
||||
print $q->p ($q->hr);
|
||||
print $q->end_html;
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 genNavigationFooter($q)
|
||||
|
||||
=cut
|
||||
|
||||
sub genNavigationFooter
|
||||
{
|
||||
my ($q) = @_;
|
||||
print $q->end_html;
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 genNoframesFooter($q)
|
||||
|
||||
=cut
|
||||
|
||||
sub genNoframesFooter
|
||||
{
|
||||
my ($q) = @_;
|
||||
print $q->end_html;
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head1 FONT ROUTINES
|
||||
|
||||
=head2 curFont()
|
||||
|
||||
Returns the preferred font faces eg. "Verdana, Arial, Helvetica, sans-serif".
|
||||
This should be done by CSS now, so if you're calling this, you shouldn't be.
|
||||
|
||||
=cut
|
||||
|
||||
sub curFont
|
||||
{
|
||||
return "Verdana, Arial, Helvetica, sans-serif";
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head1 TABLE GENERATION ROUTINES
|
||||
|
||||
=head2 genCell($q, $text)
|
||||
|
||||
=cut
|
||||
|
||||
sub genCell
|
||||
{
|
||||
my ($q, $text, $class) = @_;
|
||||
|
||||
if ($text =~ /^\s*$/){$text = " "}
|
||||
if ($class) { return $q->td({-class => "$class"}, $text),"\n";}
|
||||
else { return $q->td ($text),"\n";}
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 genDoubleCell($q, $text);
|
||||
|
||||
Generates a cell which spans two columns, containing the text specified.
|
||||
|
||||
=cut
|
||||
|
||||
sub genDoubleCell
|
||||
{
|
||||
my ($q, $text) = @_;
|
||||
if ($text =~ /^\s*$/){ $text = " " }
|
||||
return $q->td ({colspan => 2}, $text),"\n";
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 genSmallCell($q, $text, $type, $colspan)
|
||||
|
||||
Generates a cell with "small" text (font size is 80%).
|
||||
"$type" can be one of:
|
||||
"normal" : creates <td class="sme-border"> cell
|
||||
"header" : creates <th class="sme-border"> cell
|
||||
|
||||
=cut
|
||||
|
||||
sub genSmallCell
|
||||
{
|
||||
my ($q, $text, $type, $colspan) = @_;
|
||||
$text = '' unless defined $text;
|
||||
$type ||= 'normal';
|
||||
$colspan ||= 1;
|
||||
if ($text =~ /^\s*$/){ $text = " " }
|
||||
if ("$type" eq "header") {
|
||||
return $q->th ({class=>"sme-border", colspan=>$colspan}, $text)."\n";
|
||||
} else {
|
||||
return $q->td ({class=>"sme-border", colspan=>$colspan}, $text)."\n";
|
||||
}
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 genSmallCellCentered($q, $text)
|
||||
|
||||
Generates a cell with "small" text (font size is 80%), centered.
|
||||
creates <td class="sme-border-center"> cell
|
||||
|
||||
=cut
|
||||
|
||||
sub genSmallCellCentered
|
||||
{
|
||||
my ($q, $text) = @_;
|
||||
if ($text =~ /^\s*$/){ $text = " " }
|
||||
return $q->td ({class => "sme-border-center"}, $text)."\n";
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 genSmallCellRightJustified($q, $text)
|
||||
|
||||
=head2 genSmallCellCentered($q, $text)
|
||||
|
||||
Generates a cell with "small" text (font size is 80%), right justified.
|
||||
creates <td class="sme-border-right"> cell
|
||||
|
||||
=cut
|
||||
|
||||
sub genSmallCellRightJustified
|
||||
{
|
||||
my ($q, $text) = @_;
|
||||
if ($text =~ /^\s*$/){ $text = " " }
|
||||
return $q->td ({class => "sme-border-right"}, $text)."\n";
|
||||
}
|
||||
|
||||
|
||||
=pod
|
||||
|
||||
=head2 genSmallRedCell($q, $text)
|
||||
|
||||
Generates a cell with "small" text (font size is 80%), left justified.
|
||||
creates <td class="sme-border-warning"> cell
|
||||
|
||||
=cut
|
||||
|
||||
sub genSmallRedCell
|
||||
{
|
||||
my ($q, $text) = @_;
|
||||
if ($text =~ /^\s*$/){ $text = " " }
|
||||
return $q->td ({class => "sme-border-warning"}, $text)."\n";
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 genTextRow($q, $text)
|
||||
|
||||
Returns a table row containing a two-column cell containing $text.
|
||||
|
||||
=cut
|
||||
|
||||
sub genTextRow
|
||||
{
|
||||
my ($q, $text) = @_;
|
||||
if ($text =~ /^\s*$/){ $text = " " }
|
||||
return "\n",$q->Tr ($q->td ({colspan => 2}, $text)),"\n";
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 genButtonRow($q, $button)
|
||||
|
||||
Returns a table row containing an empty first cell and a second cell
|
||||
containing a button with the value $button.
|
||||
|
||||
=cut
|
||||
|
||||
sub genButtonRow
|
||||
{
|
||||
my ($q, $button) = @_;
|
||||
|
||||
# return $q->Tr ($q->td ({-class => "sme-submitbutton", -colspan => "2"},$q->b ($button))),"\n";
|
||||
# return $q->Tr ($q->td (' '),
|
||||
# $q->td ({-class => "sme-submitbutton"},$q->b ($button))),"\n";
|
||||
return $q->Tr ({-class => "sme-layout"}, $q->th ({-class => "sme-layout", colspan => "2"},$q->b ($button))),"\n";
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 genNameValueRow($q, $fieldlabel, $fieldname, $fieldvalue)
|
||||
|
||||
Returns a table row with two cells. The first has the text
|
||||
"$fieldlabel:" in it, and the second has a text field with the default
|
||||
value $fieldvalue and the name $fieldname.
|
||||
|
||||
=cut
|
||||
|
||||
sub genNameValueRow
|
||||
{
|
||||
my ($q, $fieldlabel, $fieldname, $fieldvalue) = @_;
|
||||
|
||||
return $q->Tr (
|
||||
$q->td ({-class => "sme-noborders-label"},
|
||||
"$fieldlabel:"),"\n",
|
||||
$q->td ({-class => "sme-noborders-content"},
|
||||
$q->textfield (
|
||||
-name => $fieldname,
|
||||
-override => 1,
|
||||
-default => $fieldvalue,
|
||||
-size => 32))),"\n";
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
sub genWidgetRow($q, $fieldlabel, $popup)
|
||||
|
||||
=cut
|
||||
|
||||
# used only by backup panel as far as I can see
|
||||
sub genWidgetRow
|
||||
{
|
||||
my ($q, $fieldlabel, $popup) = @_;
|
||||
|
||||
return $q->Tr ($q->td ("$fieldlabel:"),
|
||||
$q->td ($popup));
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head1 STATUS AND ERROR REPORT GENERATION ROUTINES
|
||||
|
||||
=head2 genResult($q, $msg)
|
||||
|
||||
Generates a "status report" page, including the footer
|
||||
|
||||
=cut
|
||||
|
||||
sub genResult
|
||||
{
|
||||
my ($q, $msg) = @_;
|
||||
|
||||
print $q->p ($msg);
|
||||
genFooter ($q);
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 genStateError($q, $confref)
|
||||
|
||||
Subroutine to generate "unknown state" error message.
|
||||
|
||||
=cut
|
||||
|
||||
sub genStateError
|
||||
{
|
||||
my ($q, $confref) = @_;
|
||||
|
||||
genHeaderNonCacheable ($q, $confref, "Internal error");
|
||||
genResult ($q, "Internal error! Unknown state: " . $q->param ("state") . ".");
|
||||
}
|
||||
|
||||
END
|
||||
{
|
||||
}
|
||||
|
||||
#------------------------------------------------------------
|
||||
# return "1" to make the import process return success
|
||||
#------------------------------------------------------------
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Mitel Networks Corporation
|
||||
|
||||
For more information, see http://e-smith.org/
|
||||
|
||||
=cut
|
||||
|
||||
640
root/usr/share/perl5/vendor_perl/esmith/config.pm
Normal file
640
root/usr/share/perl5/vendor_perl/esmith/config.pm
Normal file
@@ -0,0 +1,640 @@
|
||||
#----------------------------------------------------------------------
|
||||
# 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;
|
||||
25
root/usr/share/perl5/vendor_perl/esmith/config/utf8.pm
Normal file
25
root/usr/share/perl5/vendor_perl/esmith/config/utf8.pm
Normal file
@@ -0,0 +1,25 @@
|
||||
#----------------------------------------------------------------------
|
||||
# Copyright 1999-2008 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::utf8;
|
||||
use warnings;
|
||||
use strict;
|
||||
|
||||
use vars qw(@ISA);
|
||||
@ISA = qw(esmith::config);
|
||||
|
||||
sub _read_binmode
|
||||
{
|
||||
return ":encoding(UTF-8)";
|
||||
}
|
||||
|
||||
sub _write_binmode
|
||||
{
|
||||
return ":utf8";
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
603
root/usr/share/perl5/vendor_perl/esmith/console.pm
Executable file
603
root/usr/share/perl5/vendor_perl/esmith/console.pm
Executable file
@@ -0,0 +1,603 @@
|
||||
#----------------------------------------------------------------------
|
||||
# Copyright 1999-2006 Mitel Corporation
|
||||
# This program is free software; you can redistribute it and/or
|
||||
# modify it under the same terms as Perl itself.
|
||||
#----------------------------------------------------------------------
|
||||
|
||||
=head1 NAME
|
||||
|
||||
esmith::console - A class to provide a backend library to the server console.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use esmith::console;
|
||||
|
||||
my $console = esmith::console->new();
|
||||
|
||||
($rc, $choice) = $console->message_page
|
||||
(
|
||||
title => gettext("Administrator password not set"),
|
||||
text => gettext("Sorry, you must set the administrator password."),
|
||||
);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This class provides a backend library of methods for the frontend console on
|
||||
the server. The intent is that all of the whiptail code is hidden in this
|
||||
library, and the frontend can just concern itself with the logical progression
|
||||
through any and all applicable screens.
|
||||
|
||||
=head1 Methods
|
||||
|
||||
=cut
|
||||
|
||||
package esmith::console;
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION @ISA @EXPORT_OK);
|
||||
use esmith::util;
|
||||
use Locale::gettext;
|
||||
use esmith::ConfigDB;
|
||||
use esmith::I18N;
|
||||
|
||||
@ISA = qw(Exporter);
|
||||
|
||||
use constant SCREEN_ROWS => 22;
|
||||
use constant SCREEN_COLUMNS => 76;
|
||||
use constant CONSOLE_SCREENS => "/sbin/e-smith/console-screens";
|
||||
|
||||
BEGIN
|
||||
{
|
||||
# disable CTRL-C
|
||||
$SIG{INT} = 'IGNORE';
|
||||
|
||||
# Set PATH explicitly and clear related environment variables so that calls
|
||||
# to external programs do not cause results to be tainted. See
|
||||
# "perlsec" manual page for details.
|
||||
|
||||
$ENV {'PATH'} = '/sbin:/bin:/usr/sbin:/usr/bin:/usr/local/sbin:/usr/local/bin';
|
||||
$ENV {'SHELL'} = '/bin/bash';
|
||||
delete $ENV {'ENV'};
|
||||
delete $ENV {'BASH_ENV'};
|
||||
}
|
||||
|
||||
=head2 new
|
||||
|
||||
This is the class constructor.
|
||||
|
||||
=cut
|
||||
|
||||
sub new
|
||||
{
|
||||
my $class = ref($_[0]) || $_[0];
|
||||
my $self = {};
|
||||
esmith::util::setRealToEffective ();
|
||||
|
||||
my $i18n = new esmith::I18N;
|
||||
$i18n->setLocale("server-console");
|
||||
|
||||
#------------------------------------------------------------
|
||||
# Set stdin, stdout and stderr to console
|
||||
#------------------------------------------------------------
|
||||
|
||||
if (defined $ARGV [0])
|
||||
{
|
||||
$ARGV[0] =~ /(console|tty\d*)/ && -c "/dev/$1"
|
||||
or die gettext("Bad ttyname:"), " ", $ARGV[0], "\n";
|
||||
my $tty = $1;
|
||||
|
||||
open (STDIN, "</dev/$tty") or die gettext("Can't redirect stdin"), ": $!\n";
|
||||
open (STDOUT, ">/dev/$tty") or die gettext("Can't redirect stdout"), ": $!\n";
|
||||
|
||||
my $pid = open(STDERR, "|-");
|
||||
die gettext("Can't fork"), ": $!\n" unless defined $pid;
|
||||
|
||||
unless ($pid)
|
||||
{
|
||||
exec qw(/usr/bin/logger -p local1.info -t console);
|
||||
}
|
||||
}
|
||||
|
||||
$self = bless $self, $class;
|
||||
return $self;
|
||||
}
|
||||
|
||||
=head2 screen and dialog
|
||||
|
||||
These method are wrappers around whiptail and dialog, and permit the creation
|
||||
of custom screens depending on the arguments passed. They are typically not
|
||||
called directly, but are used by all of the other page methods that
|
||||
follow. You should only call these method directly if none of the other
|
||||
methods apply.
|
||||
|
||||
=cut
|
||||
|
||||
sub screen
|
||||
{
|
||||
_screen(shift, "/usr/bin/dialog", @_);
|
||||
}
|
||||
|
||||
sub dialog
|
||||
{
|
||||
_screen(shift, "/usr/bin/dialog", @_);
|
||||
}
|
||||
|
||||
sub whiptail
|
||||
{
|
||||
_screen(shift, "/usr/bin/whiptail", @_);
|
||||
}
|
||||
|
||||
sub _screen
|
||||
{
|
||||
my $self = shift;
|
||||
my $whiptail = shift;
|
||||
my @whiptailArgs = @_;
|
||||
|
||||
# now would be a good time to flush output buffers, so the partial
|
||||
# buffers don't get copied:
|
||||
|
||||
$| = 1;
|
||||
print "";
|
||||
|
||||
pipe (READER, WRITER)
|
||||
or die gettext("Couldn't create pipe") . ": $!\n";
|
||||
|
||||
my $pid = fork;
|
||||
|
||||
if (! defined $pid)
|
||||
{
|
||||
die gettext("Couldn't fork") . ": $!\n";
|
||||
}
|
||||
|
||||
elsif ($pid == 0)
|
||||
{
|
||||
#----------------------------------------
|
||||
# Child
|
||||
#----------------------------------------
|
||||
|
||||
# Attach child's STDIN to the reading end of the pipe
|
||||
close READER
|
||||
or die gettext("Couldn't close reading end of pipe") , ": $!\n";
|
||||
|
||||
if ($whiptail =~ m{\bwhiptail$} ) {
|
||||
# whiptail sends its output via STDERR. We temporarily
|
||||
# shut off warnings so they don't interfere with that.
|
||||
local $^W = 0;
|
||||
|
||||
open STDERR, ">& WRITER"
|
||||
or die gettext("Couldn't connect STDERR to pipe"), ": $!\n";
|
||||
|
||||
close WRITER
|
||||
or die gettext("Couldn't close writing end of pipe"), ": $!\n";
|
||||
|
||||
unshift @whiptailArgs, $whiptail,
|
||||
'--backtitle', $self->backtitle;
|
||||
} else {
|
||||
use Fcntl qw/F_SETFD/;
|
||||
|
||||
# Clear close-on-exec on WRITER so that it stays open for dialog to use
|
||||
fcntl(WRITER, F_SETFD, 0);
|
||||
|
||||
unshift @whiptailArgs, $whiptail,
|
||||
'--backtitle', $self->backtitle, "--output-fd", fileno(WRITER);
|
||||
}
|
||||
exec @whiptailArgs;
|
||||
die gettext("Couldn't exec:"), ": $!\n";
|
||||
}
|
||||
|
||||
#----------------------------------------
|
||||
# Parent
|
||||
#----------------------------------------
|
||||
|
||||
close WRITER;
|
||||
|
||||
my $choice = <READER>;
|
||||
close READER;
|
||||
|
||||
waitpid ($pid, 0);
|
||||
my $rc = $?;
|
||||
|
||||
return ($rc, $choice);
|
||||
}
|
||||
|
||||
=head2 backtitle
|
||||
|
||||
Console header line for each page
|
||||
|
||||
=cut
|
||||
|
||||
sub backtitle
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
my $db = esmith::ConfigDB->open_ro or die "Couldn't open ConfigDB\n";
|
||||
|
||||
sprintf("%-33s%45s",
|
||||
($db->get_prop('sysconfig', 'ProductName') || "SME Server") . " " .
|
||||
($db->get_prop('sysconfig', 'ReleaseVersion') || "UNKNOWN"),
|
||||
"Copyright (C) 1999-2006 Mitel Corporation, Copyright (C) ____COPYYEARS____ Koozali Foundation, Inc."
|
||||
);
|
||||
}
|
||||
|
||||
=head2 message_page
|
||||
|
||||
This method should be used whenever a screen that displays a simple message
|
||||
is required.
|
||||
|
||||
=cut
|
||||
|
||||
sub message_page
|
||||
{
|
||||
my $self = shift;
|
||||
my %params = @_;
|
||||
|
||||
my $title = $params{title};
|
||||
my $message_box = $params{text};
|
||||
|
||||
my $left = defined $params{left} ? $params{left} : gettext("Back");
|
||||
my $right = defined $params{right} ? $params{right} : gettext("Next");
|
||||
|
||||
$self->screen ("--title", $title,
|
||||
"--cancel-label", $left,
|
||||
"--ok-label", $right,
|
||||
"--clear",
|
||||
"--msgbox", $message_box,
|
||||
SCREEN_ROWS,
|
||||
SCREEN_COLUMNS,
|
||||
);
|
||||
}
|
||||
|
||||
=head2 tryagain_page
|
||||
|
||||
This method displays a simple "try again" screen.
|
||||
|
||||
=cut
|
||||
|
||||
sub tryagain_page
|
||||
{
|
||||
my $self = shift;
|
||||
my %params = @_;
|
||||
|
||||
my $title = $params{title};
|
||||
my $choice = $params{choice};
|
||||
|
||||
my $try_again = "; " . gettext("please try again");
|
||||
|
||||
my $message_box = $title . ":'${choice}'" . $try_again;
|
||||
|
||||
$self->screen ("--title", $title,
|
||||
"--cancel-label", gettext("Back"),
|
||||
"--ok-label", gettext("Next"),
|
||||
"--clear",
|
||||
"--msgbox", $message_box,
|
||||
SCREEN_ROWS,
|
||||
SCREEN_COLUMNS,
|
||||
);
|
||||
}
|
||||
|
||||
=head2 password_page
|
||||
|
||||
This method displays a screen suitable for entering a password.
|
||||
|
||||
=cut
|
||||
|
||||
sub password_page
|
||||
{
|
||||
my $self = shift;
|
||||
my %params = @_;
|
||||
|
||||
my $title = $params{title};
|
||||
my $message_box = $params{text};
|
||||
|
||||
my $left = defined $params{left} ? $params{left} : gettext("Back");
|
||||
my $right = defined $params{right} ? $params{right} : gettext("Next");
|
||||
|
||||
$self->dialog ("--title", $title,
|
||||
"--insecure",
|
||||
"--cancel-label", $left,
|
||||
"--ok-label", $right,
|
||||
"--clear",
|
||||
"--passwordbox", "\n" . $message_box,
|
||||
SCREEN_ROWS,
|
||||
SCREEN_COLUMNS,
|
||||
);
|
||||
}
|
||||
|
||||
=head2 yesno_page
|
||||
|
||||
This method displays a simple yes/no screen, so the user can make a
|
||||
simple binary selection.
|
||||
|
||||
=cut
|
||||
|
||||
sub yesno_page
|
||||
{
|
||||
my $self = shift;
|
||||
my %params = @_;
|
||||
|
||||
my $title = $params{title};
|
||||
my $text = $params{text};
|
||||
|
||||
my $left = defined $params{left} ? $params{left} : gettext("Yes");
|
||||
my $right = defined $params{right} ? $params{right} : gettext("No");
|
||||
my @args = (
|
||||
"--title" => $title,
|
||||
"--yes-label" => $left,
|
||||
"--no-label" => $right,
|
||||
);
|
||||
push @args, "--defaultno" if defined $params{defaultno};
|
||||
push @args, "--clear";
|
||||
|
||||
$self->screen (@args,
|
||||
"--yesno", $text,
|
||||
SCREEN_ROWS,
|
||||
SCREEN_COLUMNS,
|
||||
);
|
||||
}
|
||||
|
||||
=head2 input_page
|
||||
|
||||
This method displays a simple input screen with an input box.
|
||||
|
||||
=cut
|
||||
|
||||
sub input_page
|
||||
{
|
||||
my $self = shift;
|
||||
my %params = @_;
|
||||
|
||||
my $title = $params{title};
|
||||
my $text = $params{text};
|
||||
my $value = $params{value};
|
||||
|
||||
my $left = defined $params{left} ? $params{left} : gettext("Back");
|
||||
my $right = defined $params{right} ? $params{right} : gettext("Next");
|
||||
|
||||
$self->screen("--title", $title,
|
||||
"--cancel-label", $left,
|
||||
"--ok-label", $right,
|
||||
"--clear",
|
||||
"--inputbox", $text,
|
||||
SCREEN_ROWS,
|
||||
SCREEN_COLUMNS,
|
||||
$value
|
||||
);
|
||||
}
|
||||
|
||||
=head2 infobox
|
||||
|
||||
This method is similar to a messagebox, but exits immediately, without clearing the screen.
|
||||
|
||||
=cut
|
||||
|
||||
sub infobox
|
||||
{
|
||||
my $self = shift;
|
||||
my %params = @_;
|
||||
my $title = $params{title};
|
||||
my $text = $params{text};
|
||||
my $height = $params{height} || "8";
|
||||
my $width = $params{width} || SCREEN_COLUMNS;
|
||||
$self->screen("--title", $title,
|
||||
"--infobox", $text,
|
||||
$height,
|
||||
$width,
|
||||
);
|
||||
}
|
||||
|
||||
|
||||
=head2 textbox
|
||||
|
||||
A text box lets you display the contents of a text file in a dialog box.
|
||||
It is like a simple text file viewer.
|
||||
|
||||
=cut
|
||||
|
||||
sub textbox
|
||||
{
|
||||
my $self = shift;
|
||||
my %params = @_;
|
||||
my $title = $params{title};
|
||||
my $file = $params{file};
|
||||
my $height = $params{height} || '20';
|
||||
my $width = $params{width} || SCREEN_COLUMNS;
|
||||
$self->screen("--title", $title,
|
||||
"--textbox", $file,
|
||||
$height,
|
||||
$width,
|
||||
);
|
||||
}
|
||||
|
||||
=head2 menu_page
|
||||
|
||||
This method displays a screen with a menu.
|
||||
|
||||
=cut
|
||||
|
||||
sub menu_page
|
||||
{
|
||||
my $self = shift;
|
||||
my %params = @_;
|
||||
|
||||
my $title = $params{title};
|
||||
my $text = $params{text};
|
||||
my @args = ("--clear", "--title", $title);
|
||||
if ($params{default})
|
||||
{
|
||||
push @args, "--default-item", $params{default};
|
||||
}
|
||||
|
||||
my $value = $params{value};
|
||||
my $argsref = $params{argsref};
|
||||
|
||||
my $menu_rows = scalar @$argsref / 2;
|
||||
|
||||
$menu_rows = 10 if ($menu_rows > 10);
|
||||
|
||||
my $left = defined $params{left} ? $params{left} : gettext("Back");
|
||||
my $right = defined $params{right} ? $params{right} : gettext("Next");
|
||||
|
||||
$self->dialog(@args,
|
||||
"--cancel-label", $left,
|
||||
"--ok-label", $right,
|
||||
"--menu", $text,
|
||||
SCREEN_ROWS,
|
||||
SCREEN_COLUMNS,
|
||||
$menu_rows,
|
||||
@$argsref,
|
||||
);
|
||||
}
|
||||
|
||||
=head2 keep_option
|
||||
|
||||
??
|
||||
|
||||
=cut
|
||||
|
||||
sub keep_option
|
||||
{
|
||||
my $self = shift;
|
||||
my ($value) = @_;
|
||||
|
||||
my $keep_phrase = gettext("Keep the current setting");
|
||||
|
||||
return ( gettext("keep"), "${keep_phrase}: $value" );
|
||||
}
|
||||
|
||||
=head2 gauge
|
||||
|
||||
This method displays a progress bar. It takes a coderef as parameter, and uses
|
||||
the coderef to drive the --gauge widget of the dialog program, as well as to
|
||||
perform whatever actions are being reported by the progress bar. The coderef
|
||||
should take one parameter, which is the file handle to write the controlling
|
||||
text to. If the return value of the coderef is defined, it is displayed by a
|
||||
message_page after the progress bar terminates.
|
||||
|
||||
All text used to update the progress bar should either be numbers between 0
|
||||
and 100, or arbitrary text sandwiched between leading and training lines
|
||||
of 'XXX' followed by newline. The numbers will update the percentage complete
|
||||
of the display, and the text will update the displayed text. Updating the
|
||||
displayed text will reset the precentage complete to 0, so text should always
|
||||
be followed by number.
|
||||
|
||||
=cut
|
||||
|
||||
sub gauge
|
||||
{
|
||||
my $self = shift;
|
||||
my $sub = shift;
|
||||
my %params = @_;
|
||||
my $title = $params{title} || 'Progress';
|
||||
my $feedback_title = $params{feedback_title} || 'Status';
|
||||
my $init_text = $params{text} || 'Progress';
|
||||
my @args = (
|
||||
'--backtitle', $self->backtitle,
|
||||
'--title', gettext($title),
|
||||
);
|
||||
push @args, "--clear" if $params{clear};
|
||||
push @args, "--colors" if $params{colors};
|
||||
push @args, "--no-collapse" if $params{no_collapse};
|
||||
|
||||
use FileHandle;
|
||||
|
||||
unless (open(WR, '|-'))
|
||||
{
|
||||
exec('/usr/bin/dialog',
|
||||
@args,
|
||||
'--gauge',
|
||||
gettext($init_text),
|
||||
SCREEN_ROWS,
|
||||
SCREEN_COLUMNS,
|
||||
);
|
||||
}
|
||||
WR->autoflush(1);
|
||||
my $text = &$sub(*WR);
|
||||
close(WR);
|
||||
$self->message_page('title' => $feedback_title, 'text' => $text)
|
||||
if defined $text;
|
||||
}
|
||||
|
||||
=head2 run_screens
|
||||
|
||||
This method takes a directory of screens to run, and runs them in order.
|
||||
To support navigation between screens, this method respects an integer
|
||||
return value from the screens.
|
||||
|
||||
0 = all is well, continue to the next screen
|
||||
1 = all is not well, go back to the previous screen
|
||||
2 = catastrophic failure - return from run_screen
|
||||
|
||||
=cut
|
||||
|
||||
sub run_screens
|
||||
{
|
||||
my $self = shift;
|
||||
my ($subdir) = @_;
|
||||
|
||||
my $dir = CONSOLE_SCREENS . "/$subdir";
|
||||
|
||||
# This is fine. Noop if the directory isn't there.
|
||||
unless (-d $dir)
|
||||
{
|
||||
return 1;
|
||||
}
|
||||
|
||||
# This is not fine. If it's there, we should be able to open it.
|
||||
unless ( opendir(SCREENS, $dir) )
|
||||
{
|
||||
warn "Failed to open directory $dir: $!\n";
|
||||
return 0;
|
||||
}
|
||||
|
||||
my @screens = sort grep (!/^(\.\.?)$/, readdir (SCREENS));
|
||||
|
||||
my @previous_screens = ();
|
||||
while (@screens)
|
||||
{
|
||||
my $screen = shift @screens;
|
||||
unless ( $screen =~ /(S\d\d[\d\w]+)/ )
|
||||
{
|
||||
warn "Unknown screen type $dir/$screen\n";
|
||||
next;
|
||||
}
|
||||
|
||||
$screen = $1;
|
||||
my $rv = system( "$dir/$screen" );
|
||||
$rv >>= 8;
|
||||
if ($rv == 0)
|
||||
{
|
||||
# Success, move to next screen.
|
||||
push @previous_screens, $screen;
|
||||
}
|
||||
elsif ($rv == 1)
|
||||
{
|
||||
# Failure, go back one screen.
|
||||
unshift @screens, $screen;
|
||||
if (@previous_screens)
|
||||
{
|
||||
unshift @screens, pop @previous_screens;
|
||||
}
|
||||
else
|
||||
{
|
||||
# We're at the beginning of the stack. Just return.
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
# Catastrophic failure, return. While 2 is the agreed-upon
|
||||
# return code for this, consider it a catastrophic failure
|
||||
# if we don't get a valid return code.
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
SME Server Developers <smebugs@mitel.com>
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
743
root/usr/share/perl5/vendor_perl/esmith/db.pm
Normal file
743
root/usr/share/perl5/vendor_perl/esmith/db.pm
Normal file
@@ -0,0 +1,743 @@
|
||||
#----------------------------------------------------------------------
|
||||
# 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;
|
||||
133
root/usr/share/perl5/vendor_perl/esmith/ethernet.pm
Normal file
133
root/usr/share/perl5/vendor_perl/esmith/ethernet.pm
Normal file
@@ -0,0 +1,133 @@
|
||||
#----------------------------------------------------------------------
|
||||
# Copyright 1999-2005 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::ethernet;
|
||||
|
||||
#----------------------------------------------------------------------
|
||||
|
||||
use strict;
|
||||
use File::Basename;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
esmith::ethernet - Ethernet-related utility routines for e-smith
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
This file documents C<esmith::ethernet> version B<1.4.0>
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use esmith::ethernet;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module contains routines for
|
||||
|
||||
|
||||
=pod
|
||||
|
||||
=head2 probeAdapters()
|
||||
|
||||
Probe for any recognised adapters
|
||||
|
||||
=cut
|
||||
|
||||
sub probeAdapters ()
|
||||
{
|
||||
opendir(my $dh, "/sys/class/net") or die "Couldn't open /sys/class/net: $!";
|
||||
my @nics = grep { $_ !~ m/^\./ } readdir($dh);
|
||||
closedir($dh);
|
||||
my $adapters = '';
|
||||
my $index = 1;
|
||||
foreach my $nic (@nics){
|
||||
# Untaint $nic and makes sure the name looks OK
|
||||
next unless ($nic =~ m/^(\w+[\.:]?\d+)$/);
|
||||
$nic = $1;
|
||||
next if (
|
||||
# skip loopback
|
||||
$nic eq 'lo' ||
|
||||
# skip non links
|
||||
!-l "/sys/class/net/$nic" ||
|
||||
# skip wireless nics
|
||||
-d "/sys/class/net/$nic/wireless" ||
|
||||
-l "/sys/class/net/$nic/phy80211" ||
|
||||
# skip bridges
|
||||
-d "/sys/class/net/$nic/bridge" ||
|
||||
# skip vlans
|
||||
-f "/proc/net/vlan/$nic" ||
|
||||
# skip bonds
|
||||
-d "/sys/class/net/$nic/bonding" ||
|
||||
# skip tun/tap
|
||||
-f "/sys/class/net/$nic/tun_flags" ||
|
||||
# skip dummy
|
||||
-d "/sys/devices/virtual/net/$nic"
|
||||
);
|
||||
# Now we should be left only wth ethernet adapters
|
||||
open HW, "/sys/class/net/$nic/address";
|
||||
my $mac = join("", <HW>);
|
||||
close HW;
|
||||
# Check MAC Addr and untaint it
|
||||
next unless ($mac =~ m/^(([\da-f]{2}:){5}[\da-f]{2})$/i);
|
||||
$mac = $1;
|
||||
# If the device is a slave of a bridge, it's real MAC
|
||||
# address can be found in /proc/net/bonding/bondX
|
||||
if (-l "/sys/class/net/$nic/master"){
|
||||
my $bond = basename (readlink "/sys/class/net/$nic/master");
|
||||
local $/ = '';
|
||||
open SLAVES, "/proc/net/bonding/$bond";
|
||||
my @slaves = <SLAVES>;
|
||||
close SLAVES;
|
||||
my @slaveInfo = grep { /^Slave\ Interface:\ $nic/m } @slaves;
|
||||
foreach (split /\n+/, (join "", @slaveInfo)){
|
||||
$mac = $1 if (/^Permanent\ HW\ addr:\ (.*)$/);
|
||||
}
|
||||
}
|
||||
chomp($mac);
|
||||
my $driver = basename (readlink "/sys/class/net/$nic/device/driver");
|
||||
# Untaint driver name
|
||||
next unless ($driver =~ m/^([\w\-]+)$/);
|
||||
$driver = $1;
|
||||
my $bus = basename (readlink "/sys/class/net/$nic/device/subsystem");
|
||||
my $desc = $nic;
|
||||
if ($bus eq 'pci'){
|
||||
my $dev = basename (readlink "/sys/class/net/$nic/device");
|
||||
# Untaint $dev
|
||||
if ($dev =~ m/^(\d+:\d+:\d+\.\d+)$/){
|
||||
$dev = $1;
|
||||
$desc = `/sbin/lspci -s $dev`;
|
||||
# Extract only description
|
||||
$desc =~ m/^.*:.*:\s+(.*)\s*/;
|
||||
$desc = $1;
|
||||
}
|
||||
}
|
||||
elsif ($bus eq 'virtio'){
|
||||
$desc = 'Virtio Network Device';
|
||||
}
|
||||
# TODO: we should also try to get the description of USB devices
|
||||
$adapters .= "EthernetDriver" . $index++ . "\t" . $driver . "\t" .
|
||||
$mac . "\t" . "\"$desc\"" . "\t" . $nic ."\n";
|
||||
}
|
||||
return $adapters;
|
||||
}
|
||||
|
||||
|
||||
#----------------------------------------------------------------------
|
||||
# Return one to make the import process return success.
|
||||
#----------------------------------------------------------------------
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=AUTHOR
|
||||
|
||||
SME Server Developers <bugs@e-smith.com>
|
||||
|
||||
For more information see http://www.e-smith.org/
|
||||
|
||||
=cut
|
||||
|
||||
220
root/usr/share/perl5/vendor_perl/esmith/event.pm
Normal file
220
root/usr/share/perl5/vendor_perl/esmith/event.pm
Normal file
@@ -0,0 +1,220 @@
|
||||
#----------------------------------------------------------------------
|
||||
# Copyright 1999-2005 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::event;
|
||||
|
||||
use strict;
|
||||
use Exporter;
|
||||
use Time::HiRes qw( usleep ualarm gettimeofday tv_interval );
|
||||
use esmith::Logger;
|
||||
use File::Basename;
|
||||
use File::Temp qw/ :mktemp /;
|
||||
use esmith::ConfigDB;
|
||||
use POSIX;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
esmith::event - Routines for handling e-smith events
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use esmith::event;
|
||||
|
||||
my $exitcode = event_signal($event, @args);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
=cut
|
||||
|
||||
our $VERSION = sprintf '%d.%03d', q$Revision: 1.16 $ =~ /: (\d+).(\d+)/;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT = qw(event_signal);
|
||||
|
||||
our @EXPORT_OK = ();
|
||||
our %EXPORT_TAGS = ();
|
||||
our $return_value = undef;
|
||||
|
||||
tie *LOG, 'esmith::Logger', 'esmith::event';
|
||||
|
||||
sub event_signal
|
||||
{
|
||||
my ($event, @args) = @_;
|
||||
if ($event eq "actions")
|
||||
{
|
||||
warn("'actions' is not a valid event name.\n");
|
||||
return;
|
||||
}
|
||||
|
||||
my $events = "/etc/e-smith/events";
|
||||
my $handlerDir = "$events/$event";
|
||||
|
||||
#------------------------------------------------------------
|
||||
# get event handler filenames
|
||||
#------------------------------------------------------------
|
||||
opendir (DIR, $handlerDir)
|
||||
|| die "Can't open directory $handlerDir\n";
|
||||
|
||||
# Create a hash of handlers (ignore directories),
|
||||
# with value of basename(handler)
|
||||
my %handlers = ();
|
||||
foreach (grep {! -d "$handlerDir/$_"} readdir (DIR))
|
||||
{
|
||||
$handlers{"$handlerDir/$_"} = $_;
|
||||
}
|
||||
|
||||
closedir (DIR);
|
||||
|
||||
# Add generic handlers to list, if their metadata directories
|
||||
# exist
|
||||
$handlers{"$events/actions/generic_template_expand"} = "S05generic_template_expand"
|
||||
if ( -d "$handlerDir/templates2expand");
|
||||
$handlers{"$events/actions/adjust-services"} = "S90adjust-services"
|
||||
if ( -d "$handlerDir/services2adjust");
|
||||
|
||||
#------------------------------------------------------------
|
||||
# Execute all handlers, sending any output to the system log.
|
||||
#
|
||||
# Event handlers are not supposed to generate error messages
|
||||
# under normal conditions, so we do not provide a mechanism
|
||||
# for event handlers to signal errors to the user. Errors can
|
||||
# only be written to the log file.
|
||||
#------------------------------------------------------------
|
||||
print LOG "Processing event: $event @args";
|
||||
|
||||
#------------------------------------------------------------
|
||||
# Run handlers, logging all output.
|
||||
#------------------------------------------------------------
|
||||
|
||||
# assume success
|
||||
my $exitcode = 1;
|
||||
|
||||
foreach my $filename
|
||||
(sort { $handlers{$a} cmp $handlers{$b} } keys %handlers)
|
||||
{
|
||||
my $handler = basename $filename;
|
||||
my $startTime = [gettimeofday];
|
||||
|
||||
my $status = -1;
|
||||
if (-x $filename)
|
||||
{
|
||||
print LOG "Running event handler: $filename";
|
||||
|
||||
unless (($status = _mysystem(\*LOG, $filename, $event, @args)) == 0)
|
||||
{
|
||||
# if any handler fails, the entire event fails
|
||||
$exitcode = 0;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
print LOG "Skipping non-executable event handler: $filename";
|
||||
next;
|
||||
}
|
||||
|
||||
my $endTime = [gettimeofday];
|
||||
my $elapsedTime = tv_interval($startTime, $endTime);
|
||||
my $log = "$handler=action|Event|$event|Action|$handler";
|
||||
$log .= "|Start|@$startTime|End|@$endTime|Elapsed|$elapsedTime";
|
||||
$log .= "|Status|$status" if $status;
|
||||
print LOG $log;
|
||||
}
|
||||
|
||||
# Implement event queuing for clustered systems.
|
||||
my $qfifo = "/var/spool/eventq";
|
||||
return $exitcode unless (-e $qfifo);
|
||||
|
||||
# Ensure we aren't called by a cascaded event. We only need to
|
||||
# queue the top-level of such a beast.
|
||||
my $ppid = getppid();
|
||||
open F, "/proc/$ppid/cmdline";
|
||||
my $cmd = <F>;
|
||||
close F;
|
||||
|
||||
unless($cmd =~ "/etc/e-smith/event")
|
||||
{
|
||||
my $fd = POSIX::open($qfifo, &POSIX::O_WRONLY) or return $exitcode;
|
||||
my $argstr = join(" ",$event,@args);
|
||||
$argstr .= "\n";
|
||||
POSIX::write($fd, $argstr, length($argstr));
|
||||
POSIX::close($fd);
|
||||
}
|
||||
|
||||
return $exitcode;
|
||||
}
|
||||
|
||||
sub _mysystem
|
||||
{
|
||||
my ($logger, $filename, $event, @args) = @_;
|
||||
|
||||
my $pid = open(PIPE, "-|");
|
||||
die "Failed to fork: $!\n" unless defined $pid;
|
||||
|
||||
if ($pid)
|
||||
{
|
||||
# Parent
|
||||
while (my $line = <PIPE>)
|
||||
{
|
||||
print $logger $line;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
# Child
|
||||
open(STDERR, ">&STDOUT");
|
||||
exec($filename, $event, @args);
|
||||
}
|
||||
close(PIPE);
|
||||
return $?;
|
||||
}
|
||||
|
||||
#------------------------------------------------------------
|
||||
# Attempt to eval perl handlers for efficiency - not currently used
|
||||
# return 1 on success; 0 on error
|
||||
#------------------------------------------------------------
|
||||
sub _runHandler($)
|
||||
{
|
||||
my ($filename) = @_;
|
||||
|
||||
open(FILE, $filename) || die "Couldn't open $filename: $!";
|
||||
my @lines = <FILE>;
|
||||
close FILE;
|
||||
|
||||
my $string = "";
|
||||
|
||||
unless ( $lines[0] =~ /^#!.*perl/ )
|
||||
{
|
||||
# STDOUT and STDERR are both redirected going to LOG
|
||||
return (system($filename, @ARGV) == 0) ? 1 : 0;
|
||||
}
|
||||
|
||||
map { $string .= $_ } @lines;
|
||||
|
||||
print "Eval of $filename...";
|
||||
|
||||
# Override 'exit' in symbol table for handlers
|
||||
sub exit { die "$_[0]\n" };
|
||||
*CORE::GLOBAL::exit = \&esmith::event::exit;
|
||||
|
||||
my $status = eval $string;
|
||||
chomp $@;
|
||||
|
||||
# if $@ is defined, then die or exit was called - use that status
|
||||
$status = $@ if defined $@;
|
||||
|
||||
# for all exit values except 0, assume failure
|
||||
if ($@)
|
||||
{
|
||||
print "Eval of $filename failed: $status\n";
|
||||
return 0;
|
||||
}
|
||||
|
||||
print "$status\n";
|
||||
return 1;
|
||||
}
|
||||
|
||||
1;
|
||||
61
root/usr/share/perl5/vendor_perl/esmith/lockfile.pm
Normal file
61
root/usr/share/perl5/vendor_perl/esmith/lockfile.pm
Normal file
@@ -0,0 +1,61 @@
|
||||
#----------------------------------------------------------------------
|
||||
# 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::lockfile;
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION @ISA @EXPORT_OK);
|
||||
use Exporter;
|
||||
use Fcntl ":flock";
|
||||
use FileHandle;
|
||||
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT_OK = qw(
|
||||
LockFileOrReturn LockFileOrWait UnlockFile
|
||||
);
|
||||
|
||||
|
||||
sub LockFileOrReturn ($)
|
||||
{
|
||||
# Attempt to lock a file. If the lock fails, return immediately.
|
||||
|
||||
my $lock_file = shift;
|
||||
|
||||
my $FH = new FileHandle;
|
||||
|
||||
$FH->open(">> $lock_file")
|
||||
or die "Cannot open lock file $lock_file for writing: $!.\n";
|
||||
|
||||
flock($FH, LOCK_EX | LOCK_NB) or return 0;
|
||||
|
||||
return $FH;
|
||||
}
|
||||
|
||||
sub LockFileOrWait ($)
|
||||
{
|
||||
# Attempt to lock a file. Wait until the file is available.
|
||||
|
||||
my $lock_file = shift;
|
||||
|
||||
my $FH = new FileHandle;
|
||||
|
||||
$FH->open(">> $lock_file")
|
||||
or die "Cannot open lock file $lock_file for writing: $!.\n";
|
||||
|
||||
flock($FH, LOCK_EX) or return 0;
|
||||
|
||||
return $FH;
|
||||
}
|
||||
|
||||
sub UnlockFile ($)
|
||||
{
|
||||
my $FH = shift;
|
||||
|
||||
flock($FH, LOCK_UN);
|
||||
$FH->close;
|
||||
}
|
||||
|
||||
1;
|
||||
76
root/usr/share/perl5/vendor_perl/esmith/logrotate.pm
Normal file
76
root/usr/share/perl5/vendor_perl/esmith/logrotate.pm
Normal file
@@ -0,0 +1,76 @@
|
||||
#----------------------------------------------------------------------
|
||||
# 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::event;
|
||||
|
||||
use strict;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
esmith::logrotate - Routines for handling rotation of log files
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use esmith::logrotate;
|
||||
|
||||
NewLogFileSymlink($file);
|
||||
MakeFilenameFromSymlink($file);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
=cut
|
||||
|
||||
BEGIN
|
||||
{
|
||||
}
|
||||
|
||||
sub NewLogFileSymlink
|
||||
{
|
||||
my $file = shift;
|
||||
unless (defined $file)
|
||||
{
|
||||
warn("newlogfilesymlink called with no argument");
|
||||
return;
|
||||
}
|
||||
|
||||
my $time = time();
|
||||
|
||||
if (-f "/var/log/${file}")
|
||||
{
|
||||
my ($sec,$min,$hour,$mday,$mon,$year) = localtime($time - 1);
|
||||
my $target = sprintf("%s%04d%02d%02d%02d%02d%02d",
|
||||
$file, $year+1900, $mon, $mday, $hour, $min, $sec);
|
||||
move("/var/log/${file}", "/var/log/${target}") or
|
||||
die "Could not move /var/log/${file} to /var/log/${target}";
|
||||
}
|
||||
|
||||
my ($sec,$min,$hour,$mday,$mon,$year) = localtime($time);
|
||||
my $target = sprintf("%s%04d%02d%02d%02d%02d%02d",
|
||||
$file, $year+1900, $mon, $mday, $hour, $min, $sec);
|
||||
unlink("/var/log/${file}") or
|
||||
warn "Could not unlink /var/log/${file}";
|
||||
symlink("/var/log/${target}", "/var/log/${file}") or
|
||||
warn "Could not symlink /var/log/${target} to /var/log/${file}";
|
||||
}
|
||||
|
||||
sub MakeFilenameFromSymlink
|
||||
{
|
||||
use File::Basename;
|
||||
my $filename = shift;
|
||||
|
||||
return $filename unless (-l $filename);
|
||||
my $link = readlink $filename;
|
||||
my $directory = dirname($filename);
|
||||
return "${directory}/${link}";
|
||||
}
|
||||
|
||||
END
|
||||
{
|
||||
}
|
||||
|
||||
1;
|
||||
140
root/usr/share/perl5/vendor_perl/esmith/tcpsvd.pm
Normal file
140
root/usr/share/perl5/vendor_perl/esmith/tcpsvd.pm
Normal file
@@ -0,0 +1,140 @@
|
||||
#----------------------------------------------------------------------
|
||||
# Copyright 2005-2006 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::tcpsvd;
|
||||
use strict;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
esmith::tcpsvd - Manage tcpsvd "peers" directory
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use esmith::tcpsvd;
|
||||
|
||||
esmith::tcpsvd::configure_peers($service)
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides utility functions for use with tcpsvd from Gerrit
|
||||
Pape's ipsvd package - see http://smarden.org/ipsvd/.
|
||||
|
||||
=cut
|
||||
|
||||
use esmith::NetworksDB;
|
||||
use esmith::ConfigDB;
|
||||
use esmith::util;
|
||||
use esmith::lockfile;
|
||||
use Carp;
|
||||
|
||||
=head2 configure_peers($service [, $peers_directory] )
|
||||
|
||||
configure_peers() configures the "peers" direectory used by tcpsvd for
|
||||
access control and environment maipulation. $service identifies the name
|
||||
of the service managed by supervise or runit. The peers directory (as
|
||||
specified by the optional $peers_directory argument, defaulting to
|
||||
"/var/service/$service/peers") is expected to contain files "0" defining
|
||||
access conditions for public (default) accesss, and "local", defining
|
||||
access conditions for local access. configure_peers() creates a set of
|
||||
symlinks so that tcpsvd uses "local" for all local network access to
|
||||
the service.
|
||||
|
||||
See http://smarden.org/ipsvd/ipsvd-instruct.5.html for all details of
|
||||
the contents of the peers directory.
|
||||
|
||||
=cut
|
||||
|
||||
sub configure_peers
|
||||
{
|
||||
my $service = shift;
|
||||
my $peers = shift || "/var/service/$service/peers";
|
||||
|
||||
unless (opendir(PEERS, $peers))
|
||||
{
|
||||
carp "Cannot read peers directory: $!";
|
||||
return;
|
||||
}
|
||||
|
||||
my $config = esmith::ConfigDB->open;
|
||||
unless ($config)
|
||||
{
|
||||
carp "Could not open config db.";
|
||||
return;
|
||||
}
|
||||
$service = $config->get($service);
|
||||
unless ($service)
|
||||
{
|
||||
carp "No service record for $service";
|
||||
return;
|
||||
}
|
||||
my $access = $service->prop('access') || "localhost";
|
||||
my $nets = esmith::NetworksDB->open;
|
||||
unless ($nets)
|
||||
{
|
||||
carp "Could not open networks db.";
|
||||
return;
|
||||
}
|
||||
|
||||
my $gw = $config->get('GatewayIP');
|
||||
|
||||
# Make a list of local networks, in prefix format
|
||||
my %nets = ($access eq "localhost") ? () :
|
||||
map
|
||||
{
|
||||
$_ => 1,
|
||||
}
|
||||
map
|
||||
{
|
||||
esmith::util::computeAllLocalNetworkPrefixes($_->key, $_->prop('Mask'));
|
||||
}
|
||||
($nets->get_all_by_prop('type', 'network'));
|
||||
|
||||
$nets{'127.0.0.1'} = 1;
|
||||
|
||||
# Setup lock on peers directory while we manipulate it
|
||||
my $lock = esmith::lockfile::LockFileOrWait("$peers/local");
|
||||
|
||||
# Now manage a set of symlinks to the "local" instructions file
|
||||
foreach my $insfile (readdir (PEERS))
|
||||
{
|
||||
next unless -l "$peers/$insfile";
|
||||
if (exists $nets{$insfile})
|
||||
{
|
||||
# Cross this one off the list so that we don't bother creating it
|
||||
delete $nets{$insfile};
|
||||
}
|
||||
else
|
||||
{
|
||||
# We no longer need this entry
|
||||
unlink "$peers/$insfile" or
|
||||
warn "Could not delete access control file $peers/$insfile: $!\n";
|
||||
}
|
||||
}
|
||||
closedir(PEERS);
|
||||
|
||||
foreach my $insfile (keys %nets)
|
||||
{
|
||||
symlink "local", "$peers/$insfile" or
|
||||
warn "Cannot add instructions file for $peers/$insfile: $!\n";
|
||||
}
|
||||
|
||||
if (defined $gw)
|
||||
{
|
||||
# We have a defined gateway address - make sure that the router doesn't have
|
||||
# relay privileges
|
||||
my $gw_ip = $gw->value;
|
||||
unlink "$peers/$gw_ip";
|
||||
symlink "0", "$peers/$gw_ip" or
|
||||
warn "Cannot add instructions file for $peers/$gw_ip: $!\n";
|
||||
}
|
||||
|
||||
# Unlock peers directory
|
||||
$lock && esmith::lockfile::UnlockFile($lock);
|
||||
}
|
||||
|
||||
1;
|
||||
1091
root/usr/share/perl5/vendor_perl/esmith/templates.pm
Normal file
1091
root/usr/share/perl5/vendor_perl/esmith/templates.pm
Normal file
File diff suppressed because it is too large
Load Diff
1413
root/usr/share/perl5/vendor_perl/esmith/util.pm
Normal file
1413
root/usr/share/perl5/vendor_perl/esmith/util.pm
Normal file
File diff suppressed because it is too large
Load Diff
201
root/usr/share/perl5/vendor_perl/esmith/util/link.pm
Normal file
201
root/usr/share/perl5/vendor_perl/esmith/util/link.pm
Normal file
@@ -0,0 +1,201 @@
|
||||
#----------------------------------------------------------------------
|
||||
# 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::util::link;
|
||||
|
||||
use strict;
|
||||
use esmith::ConfigDB;
|
||||
require Exporter;
|
||||
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(getExternalLink);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
esmith::util::link - utilities for manipulating network links
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use esmith::util::link qw(getExternalLink);
|
||||
|
||||
# wait at most 60 seconds for the link to come up
|
||||
my $timeout = 60;
|
||||
|
||||
# now just get the link
|
||||
if (getExternalLink($timeout))
|
||||
{
|
||||
# the link is up
|
||||
}
|
||||
else
|
||||
{
|
||||
# the link didn't come up
|
||||
}
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is a collection of generally useful functions for manipulating network
|
||||
links.
|
||||
|
||||
Functions are exported only on request.
|
||||
|
||||
=head2 Functions
|
||||
|
||||
=over 4
|
||||
|
||||
=item I<getExternalLink($timeout)>
|
||||
|
||||
Bring up the external link if it is not already up, waiting at most $timeout
|
||||
seconds. If a $timeout is not specified, it defaults to 300 (5 minutes) for
|
||||
dialup connections. This function can be used for both dialup and dedicated
|
||||
connections, but dedicated connections will always return 1 (true).
|
||||
|
||||
Returns 1 if the external link is already up, or if it comes up within the
|
||||
specfied $timeout period.
|
||||
|
||||
Returns 0 if the external link does not come up within the specified $timeout
|
||||
period.
|
||||
|
||||
=cut
|
||||
|
||||
sub getExternalLink
|
||||
{
|
||||
my $timeout = shift;
|
||||
|
||||
my $configdb = esmith::ConfigDB->open;
|
||||
my $rec = $configdb->get("AccessType");
|
||||
my $accessType = $rec->value;
|
||||
if ($accessType eq "dialup")
|
||||
{
|
||||
return _getDialupLink($timeout);
|
||||
}
|
||||
elsif ($accessType eq "dedicated")
|
||||
{
|
||||
# assume we are up
|
||||
return 1;
|
||||
}
|
||||
else
|
||||
{
|
||||
# unknown access type
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
|
||||
=begin _private
|
||||
|
||||
=item I<getDialupLink($timeout)>
|
||||
|
||||
Bring up the ppp0 link, waiting at most $timeout seconds.
|
||||
|
||||
Returns 1 if the link comes up within the timeout period.
|
||||
|
||||
Returns 0 if the link does not come up within the timeout period.
|
||||
|
||||
The default timeout is 300 seconds.
|
||||
|
||||
=end _private
|
||||
=cut
|
||||
|
||||
sub _getDialupLink
|
||||
{
|
||||
local $|=1;
|
||||
my $timeout = shift(@_) || 300;
|
||||
|
||||
# check for existing ppp link
|
||||
if (-f "/var/run/ppp0.pid")
|
||||
{
|
||||
# already up - return 1
|
||||
return 1;
|
||||
}
|
||||
|
||||
# create a diald monitor channel
|
||||
my $ctlFile = "/etc/diald/diald.ctl";
|
||||
my $monFile = "/tmp/diald.monitor.$$";
|
||||
system('/bin/mknod', $monFile, 'p') == 0
|
||||
or die "Can't mknod $monFile: $!\n";
|
||||
|
||||
# open control channel to diald
|
||||
open (CTL, ">$ctlFile") or die "Can't open $ctlFile: $!\n";
|
||||
|
||||
# set up a child process to monitor the channel
|
||||
|
||||
my $pid = fork;
|
||||
die "Can't fork: $!" unless defined $pid;
|
||||
if ($pid)
|
||||
{
|
||||
# parent
|
||||
|
||||
# if the pipe reader isn't up first, diald will bail, so we open
|
||||
# another pipe writer just to wait for the pipe reader
|
||||
open (MON_W, ">$monFile") or die "can't open $monFile: $!\n";
|
||||
|
||||
# begin monitoring diald status via monitor fifo
|
||||
print CTL "monitor $monFile\n";
|
||||
close CTL;
|
||||
|
||||
# ok, everything is up and ready - send USR1 to diald
|
||||
open (PID, "</var/run/diald.pid")
|
||||
or die "can't open diald pidfile: $!\n";
|
||||
my $dialdPid = <PID>;
|
||||
close PID;
|
||||
kill 'USR1', $dialdPid;
|
||||
|
||||
# Wait for the child to exit, then check for link again
|
||||
waitpid($pid, 0);
|
||||
close MON_W;
|
||||
}
|
||||
else
|
||||
{
|
||||
# child
|
||||
|
||||
open (MON, "<$monFile") or die "Can't open $monFile: $!\n";
|
||||
|
||||
# Parse the diald monitor stream for state information
|
||||
my $state = "";
|
||||
my $elapsed = 0;
|
||||
while (<MON>)
|
||||
{
|
||||
# lucky us; diald sends a STATUS msg every second
|
||||
if (/^STATUS/)
|
||||
{
|
||||
$elapsed++;
|
||||
if ($elapsed >= $timeout)
|
||||
{
|
||||
# time is up - exit with failure code
|
||||
exit 1;
|
||||
}
|
||||
}
|
||||
elsif (/^STATE/)
|
||||
{
|
||||
$state = $_;
|
||||
}
|
||||
elsif ($state eq 'UP')
|
||||
{
|
||||
# the link is up - exit with success code
|
||||
exit 0;
|
||||
}
|
||||
next;
|
||||
}
|
||||
close MON;
|
||||
# end child
|
||||
}
|
||||
|
||||
# parent (cont)
|
||||
|
||||
unlink $monFile;
|
||||
|
||||
if ($? == 0 || -f "/var/run/ppp0.pid")
|
||||
{
|
||||
# ok we're up - return 1 (true)
|
||||
return 1;
|
||||
}
|
||||
else
|
||||
{
|
||||
# out of time - return 0 (false)
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
312
root/usr/share/perl5/vendor_perl/esmith/util/network.pm
Normal file
312
root/usr/share/perl5/vendor_perl/esmith/util/network.pm
Normal file
@@ -0,0 +1,312 @@
|
||||
#----------------------------------------------------------------------
|
||||
# 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::util::network;
|
||||
|
||||
use strict;
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(isValidIP cleanIP isValidPort cmpIP);
|
||||
our %EXPORT_TAGS = (
|
||||
all => [qw(isValidIP cleanIP isValidPort cmpIP)]
|
||||
);
|
||||
|
||||
use Net::IPv4Addr qw(:all);
|
||||
use Mail::RFC822::Address;
|
||||
use esmith::AccountsDB;
|
||||
|
||||
use constant TRUE => 1;
|
||||
use constant FALSE => 0;
|
||||
|
||||
=for testing
|
||||
use_ok('esmith::util::network');
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
esmith::util::network - miscellaneous network utilities
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use esmith::util::network qw(the functions you want);
|
||||
|
||||
my $ip = cleanIP($orig_ip);
|
||||
my $is_valid = isValidIP($ip);
|
||||
my $is_valid = isValidPort($port);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is a collection of generally useful functions for working with IP
|
||||
addresses.
|
||||
|
||||
Functions are exported only on request.
|
||||
|
||||
=head2 Functions
|
||||
|
||||
=over 4
|
||||
|
||||
=item I<cleanIP>
|
||||
|
||||
my $ip = cleanIP($orig_ip);
|
||||
|
||||
If the $orig_ip is valid it will be cleaned up into a cannonical form,
|
||||
stripping any padding zeros and such.
|
||||
|
||||
=begin testing
|
||||
|
||||
use esmith::util::network qw(cleanIP);
|
||||
|
||||
my %ips = (
|
||||
'000.000.000.000' => '0.0.0.0',
|
||||
'0.0.0.0' => '0.0.0.0',
|
||||
'001.2.003.4' => '1.2.3.4',
|
||||
'100.2.3.4' => '100.2.3.4',
|
||||
'10.13.14.015' => '10.13.14.15',
|
||||
'10.33.15.109' => '10.33.15.109',
|
||||
'1.2.3.4.5' => ''
|
||||
);
|
||||
|
||||
while( my($ip, $cleanip) = each %ips ) {
|
||||
is( cleanIP($ip), $cleanip, "cleanIP($ip)" );
|
||||
}
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub cleanIP {
|
||||
my $ip = shift;
|
||||
|
||||
return '' unless isValidIP($ip);
|
||||
$ip =~ s/\b0+(\d+)/$1/g;
|
||||
|
||||
return isValidIP($ip) ? $ip : '';
|
||||
}
|
||||
|
||||
=item I<isValidIP>
|
||||
|
||||
my $is_valid = isValidIP($ip);
|
||||
|
||||
Returns the IP given if $ip is a properly formatted IP address, undef otherwise.
|
||||
|
||||
=begin testing
|
||||
|
||||
use esmith::util::network qw(isValidIP);
|
||||
|
||||
my @goodIPs = qw(1.2.3.4
|
||||
0.0.0.0
|
||||
255.255.255.255
|
||||
001.002.003.004
|
||||
1.32.123.213
|
||||
192.168.0.3
|
||||
02.19.090.19
|
||||
);
|
||||
foreach my $ip (@goodIPs) {
|
||||
ok( isValidIP($ip), "valid $ip");
|
||||
}
|
||||
|
||||
my @badIPs = qw(256.3.2.4
|
||||
-1.39.9.23
|
||||
0
|
||||
1
|
||||
255.255.255.255.0
|
||||
239..19.23.12
|
||||
1.2.3.4.
|
||||
foo.bar.com
|
||||
);
|
||||
|
||||
foreach my $ip (@badIPs) {
|
||||
ok( !isValidIP($ip), "invalid $ip");
|
||||
}
|
||||
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub isValidIP($)
|
||||
{
|
||||
my ($string) = @_;
|
||||
return unless defined ipv4_chkip($string);
|
||||
return $string eq ipv4_chkip($string);
|
||||
}
|
||||
|
||||
=item I<isValidPort>
|
||||
|
||||
my $is_valid = isValidPort($port);
|
||||
|
||||
Returns true if $port is a properly formatted port, false otherwise.
|
||||
|
||||
=begin testing
|
||||
|
||||
@badports = (98765434, -183, 0, 'bad port', 'a');
|
||||
@goodports = (67, 23, 1, 54736);
|
||||
|
||||
foreach $port (@badports) {
|
||||
isnt(esmith::util::network::isValidPort($port), 1);
|
||||
}
|
||||
foreach $port (@goodports) {
|
||||
is(esmith::util::network::isValidPort($port), 1);
|
||||
}
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub isValidPort($)
|
||||
{
|
||||
my $port = shift;
|
||||
|
||||
return FALSE unless defined $port;
|
||||
|
||||
if (($port =~ /^\d+$/) &&
|
||||
($port > 0) &&
|
||||
($port < 65536))
|
||||
{
|
||||
return TRUE;
|
||||
}
|
||||
else {
|
||||
return FALSE;
|
||||
}
|
||||
}
|
||||
|
||||
=item I<cmpIP>
|
||||
|
||||
Performs a cmp operation on two IP addresses.
|
||||
|
||||
=begin testing
|
||||
|
||||
$ip1 = '24.123.212.87';
|
||||
$ip2 = '240.34.216.12';
|
||||
|
||||
is(esmith::util::network::cmpIP($ip1, $ip2), -1);
|
||||
is(esmith::util::network::cmpIP($ip2, $ip1), 1);
|
||||
is(esmith::util::network::cmpIP($ip1, $ip1), 0);
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub cmpIP($$)
|
||||
{
|
||||
my $ip1 = ipv4_chkip(shift);
|
||||
my $ip2 = ipv4_chkip(shift);
|
||||
|
||||
die "The first argument is not a valid IP address.\n" if not $ip1;
|
||||
die "The second argument is not a valid IP address.\n" if not $ip2;
|
||||
|
||||
my @ip1cmps = split /\./, $ip1;
|
||||
my @ip2cmps = split /\./, $ip2;
|
||||
|
||||
while (@ip1cmps)
|
||||
{
|
||||
my $cmp1 = shift @ip1cmps;
|
||||
my $cmp2 = shift @ip2cmps;
|
||||
|
||||
my $cmp = $cmp1 <=> $cmp2;
|
||||
return $cmp if $cmp;
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
=item I<isValidHostname>
|
||||
|
||||
This function returns true if it is passed a valid RFC 921 hostname,
|
||||
false otherwise.
|
||||
|
||||
=cut
|
||||
|
||||
sub isValidHostname
|
||||
{
|
||||
my $host_or_ip = shift;
|
||||
|
||||
unless (isValidIP($host_or_ip))
|
||||
{
|
||||
# It's not an IP address. Does it look like a hostname?
|
||||
# FIXME: We could do a DNS lookup to be sure.
|
||||
# (See RFC 921, "Domain Name System Implementation Schedule,"
|
||||
# FIXME: Put this in a library.
|
||||
unless ($host_or_ip =~ m{
|
||||
# Must begin with an alphabetical character...
|
||||
^[a-z]
|
||||
# optionally followed by zero or more alphabetic characters,
|
||||
# hyphens, periods and numbers...
|
||||
[-a-z.0-9]*
|
||||
(
|
||||
# followed by one period...
|
||||
\.
|
||||
# and a repeat of the first pattern
|
||||
[a-z]
|
||||
[-a-z.0-9]*
|
||||
)+
|
||||
# which we can repeat one or more times, to the end of the
|
||||
# string.
|
||||
$
|
||||
# Case insensitive.
|
||||
}ix)
|
||||
{
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
=item I<isValidEmail>
|
||||
|
||||
This validation function validates an email address, using the
|
||||
Mail::RFC822::Address module. Additionally, by default, it permits a local
|
||||
address instead of a fully-qualified remote address, even checking the
|
||||
existence of said user in the accounts db.
|
||||
|
||||
If you don't wish to permit local addresses, pass the permitlocal option as
|
||||
false.
|
||||
|
||||
ie. esmith::util::isValidEmail($address, { permitlocal => 0 })
|
||||
|
||||
=cut
|
||||
|
||||
sub isValidEmail
|
||||
{
|
||||
my $address = shift;
|
||||
my $hashref = shift || {};
|
||||
my %defaults = ( permitlocal => 1 );
|
||||
my %options = (%defaults, %$hashref);
|
||||
|
||||
if (Mail::RFC822::Address::valid($address))
|
||||
{
|
||||
return TRUE;
|
||||
}
|
||||
# Permit a local address.
|
||||
if ($address =~ /^[a-zA-Z][a-zA-Z0-9\._\-]*$/)
|
||||
{
|
||||
# Exception for 'admin' user. FIXME - I'd rather not hardcode this,
|
||||
# but we can't permit email to all system users.
|
||||
return TRUE if $address eq 'admin';
|
||||
# Make sure the user exists.
|
||||
my $accountsdb = esmith::AccountsDB->open_ro;
|
||||
my $user = $accountsdb->get($address) || '';
|
||||
unless (($user) && ($user->prop('type') eq 'user'))
|
||||
{
|
||||
return FALSE;
|
||||
}
|
||||
else
|
||||
{
|
||||
return TRUE;
|
||||
}
|
||||
}
|
||||
return FALSE;
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Mitel Networks Corp.
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
215
root/usr/share/perl5/vendor_perl/esmith/util/system.pm
Normal file
215
root/usr/share/perl5/vendor_perl/esmith/util/system.pm
Normal file
@@ -0,0 +1,215 @@
|
||||
#----------------------------------------------------------------------
|
||||
# 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::util::system;
|
||||
|
||||
use strict;
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
|
||||
our @EXPORT_OK = qw(killall rsync rsync_ssh);
|
||||
|
||||
=for testing
|
||||
use_ok('esmith::util::system', 'killall', 'rsync', 'rsync_ssh');
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
esmith::util::system - replacements/wrappers for system() commands
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use esmith::util::system qw(killall rsync rsync_ssh);
|
||||
|
||||
killall($signal, @commands);
|
||||
rsync($src, $dest, @options);
|
||||
rsync_ssh($src, $dest, $user, $ident, \@rsync_opts, \@ssh_opts);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is for common functions that would normally require a system(...)
|
||||
command. Makes things easier to document, test and upgrade.
|
||||
|
||||
If you find yourself writing a system() command, consider putting it
|
||||
in here.
|
||||
|
||||
|
||||
=head2 Functions
|
||||
|
||||
These may be pure Perl functions or they may well just be wrappers
|
||||
around system() commands.
|
||||
|
||||
Each can be imported on request.
|
||||
|
||||
=over 4
|
||||
|
||||
=item B<killall>
|
||||
|
||||
my $killed_something = killall($signal, @commands);
|
||||
|
||||
Sends a $signal to all of the named @commands. $signal can be
|
||||
specified by name or number (so 1 or HUP for example, names are
|
||||
prefered).
|
||||
|
||||
Returns true if something was killed, false otherwise.
|
||||
|
||||
=begin testing
|
||||
|
||||
open(SCRATCH, ">scratch.exe") || die $!;
|
||||
|
||||
# XXX Irritating perl bug ends POD processing if it sees /^#!.*perl/
|
||||
print SCRATCH sprintf <<'ENDING', '/usr/bin/perl';
|
||||
#!%s -w
|
||||
|
||||
sleep 99;
|
||||
ENDING
|
||||
|
||||
close SCRATCH;
|
||||
|
||||
END { unlink 'scratch.exe', 'scratch.out' }
|
||||
|
||||
chmod 0755, 'scratch.exe' || die $!;
|
||||
my $pid = open(SCRATCH, "./scratch.exe |");
|
||||
ok( $pid, 'scratch program started ok' );
|
||||
|
||||
ok( killall('USR1', 'scratch.exe'), 'killall returned properly' );
|
||||
close SCRATCH; # so scratch.exe responds to the signal and exits
|
||||
|
||||
is( kill(9, $pid), 0, 'killall worked' );
|
||||
|
||||
# I can't actually think of a way to explicitly check this but it
|
||||
# will make noise if it doesn't work.
|
||||
ok( !killall('USR1', 'I_dont_exist_nope'),
|
||||
'returned properly for killing nothing' );
|
||||
ok( 1, 'killall is quiet when nothing is killed' );
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub killall {
|
||||
my($signal, @commands) = @_;
|
||||
|
||||
warn "You don't need a - on the signal" if $signal =~ /^-/;
|
||||
|
||||
my $killed_something =
|
||||
system('/usr/bin/killall', '-q', "-$signal", @commands);
|
||||
|
||||
return !$killed_something;
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=item B<rsync>
|
||||
|
||||
my $success = rsync($source, $destination, @options);
|
||||
|
||||
rsyncs the $source file or directory to the $destination. Any
|
||||
@options are direct options to the rsync command.
|
||||
|
||||
rsync will be run --quiet by default.
|
||||
|
||||
Returns true if the rsync succeeds, false otherwise.
|
||||
|
||||
=begin testing
|
||||
|
||||
use File::Compare;
|
||||
my $src = '10e-smith-lib/db.t';
|
||||
my $dest = '10e-smith-lib/db.t.copy';
|
||||
rsync($src, $dest);
|
||||
END { unlink $dest }
|
||||
|
||||
ok( -e $dest );
|
||||
ok( compare($src, $dest) == 0, 'basic rsync copy' );
|
||||
|
||||
open(DEST, ">$dest" ) || die $!;
|
||||
print DEST "Fooble\n";
|
||||
close DEST;
|
||||
|
||||
# rsync in update-only mode. $dest is newer than $src and shouldn't
|
||||
# be updated.
|
||||
rsync($src, $dest, qw(--update));
|
||||
|
||||
ok( compare($src, $dest) == 1, 'rsync, update only' );
|
||||
|
||||
open(DEST, "$dest") || die $!;
|
||||
my $data = join '', <DEST>;
|
||||
close DEST;
|
||||
|
||||
is( $data, "Fooble\n" );
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
our $RSYNC_CMD = '/usr/bin/rsync';
|
||||
sub rsync {
|
||||
my($src, $dest, @options) = @_;
|
||||
|
||||
push @options, '--quiet';
|
||||
return !system($RSYNC_CMD, @options, $src, $dest);
|
||||
}
|
||||
|
||||
=item B<rsync_ssh>
|
||||
|
||||
my $success = rsync_ssh($src, $dest, $user, $ident, \@rsync_opts,
|
||||
\@ssh_opts);
|
||||
|
||||
Like rsync() except it uses ssh. A typical call might be:
|
||||
|
||||
rsync_ssh('some.host:', 'some/file', 'someuser', 'some/.ssh/identity',
|
||||
[qw(--archive --delete)]);
|
||||
|
||||
=begin testing
|
||||
|
||||
use File::Compare;
|
||||
my $src = '10e-smith-lib/db.t';
|
||||
my $dest = '10e-smith-lib/db.t.copy';
|
||||
|
||||
unlink $dest;
|
||||
END { unlink $dest }
|
||||
|
||||
no warnings 'once';
|
||||
my @args;
|
||||
my $real_rsync = \&esmith::util::system::rsync;
|
||||
local *esmith::util::system::rsync = sub {
|
||||
@args = @_;
|
||||
|
||||
pop @_;
|
||||
$real_rsync->(@_);
|
||||
};
|
||||
|
||||
rsync_ssh($src, $dest, 'someone', 'some/ident', [qw(--update)], [qw(-C)]);
|
||||
ok( -e $dest );
|
||||
ok( compare($src, $dest) == 0 );
|
||||
|
||||
is($args[0], $src );
|
||||
is($args[1], $dest );
|
||||
is($args[2], '--update' );
|
||||
is($args[3], "-e $esmith::util::system::SSH_CMD -l someone -i some/ident -C");
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
our $SSH_CMD = '/usr/bin/ssh';
|
||||
sub rsync_ssh {
|
||||
my($src, $dest, $user, $ident, $rsync_opts, $ssh_opts) = @_;
|
||||
|
||||
$ssh_opts ||= [];
|
||||
my $ssh_opt = join ' ', ('-e', $SSH_CMD, '-l', $user, '-i', $ident,
|
||||
@$ssh_opts);
|
||||
|
||||
return rsync($src, $dest, @$rsync_opts, $ssh_opt);
|
||||
}
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Mitel Networks Corporation
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
Reference in New Issue
Block a user