smeserver/smeserver-lib
6
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

initial commit of file from CVS for e-smith-lib on Wed 12 Jul 08:58:46 BST 2023

Browse Source
This commit is contained in:
Brian Read
2023-07-12 08:58:46 +01:00
parent 6d7e97ea37
commit a527984040
98 changed files with 14369 additions and 2 deletions
Download Patch File Download Diff File Expand all files Collapse all files

201
root/usr/share/perl5/vendor_perl/esmith/util/link.pm Normal file
View 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
View 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
View 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;