added basic message indirection.
require Exporter;
@ISA = qw(Exporter);
+use Msg;
+
%connects = undef;
# create a new connection object [$obj = Connect->new($call, $msg_conn_obj, $user_obj)]
delete $connects{$self->{call}};
}
+
+# handle out going messages
+sub send_now
+{
+ my $self = shift;
+ my $sort = shift;
+ my $call = $self->{call};
+ my $conn = $self->{conn};
+ my $line;
+
+ foreach $line (@_) {
+ print DEBUG "$t > $sort $call $line\n" if defined DEBUG;
+ print "> $sort $call $line\n";
+ $conn->send_now("$sort$call|$line");
+ }
+}
+
+sub send_later
+{
+ my $self = shift;
+ my $sort = shift;
+ my $call = $self->{call};
+ my $conn = $self->{conn};
+ my $line;
+
+ foreach $line (@_) {
+ print DEBUG "$t > $sort $call $line\n" if defined DEBUG;
+ print "> $sort $call $line\n";
+ $conn->send_later("$sort$call|$line");
+ }
+}
+
+# send a file (always later)
+sub send_file
+{
+ my ($self, $fn) = @_;
+ my $call = $self->{call};
+ my $conn = $self->{conn};
+ my @buf;
+
+ open(F, $fn) or die "can't open $fn for sending file ($!)";
+ @buf = <F>;
+ close(F);
+ $self->send_later('D', @buf);
+}
+
1;
__END__;
--- /dev/null
+#
+# DX cluster message strings for output
+#
+# Copyright (c) 1998 - Dirk Koopman G1TLH
+#
+# $Id$
+#
+
+package DXM;
+
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(m);
+
+%msgs = (
+ l1 => "Sorry $a[0], you are already logged on on another channel",
+ l2 => "Hello $a[0], this is $a[1] located in $a[2]",
+);
+
+sub m
+{
+ my $self = shift;
+ local @a = @_;
+ my $s = $msg{$self};
+ return "unknown message '$self'" if !defined $s;
+ return eval $s;
+}
+
require Exporter;
@ISA = qw(Exporter);
-use MLDBM;
+use MLDBM qw(DB_File);
use Fcntl;
%u = undef;
$dbm = undef;
$filename = undef;
+# hash of valid elements and a simple prompt
+%valid = (
+ call => 'Callsign',
+ alias => 'Real Callsign',
+ name => 'Name',
+ qth => 'Home QTH',
+ lat => 'Latitude',
+ long => 'Longtitude',
+ qra => 'Locator',
+ email => 'E-mail Address',
+ priv => 'Privilege Level',
+ sort => 'Type of User',
+ lastin => 'Last Time in',
+ passwd => 'Password',
+ addr => 'Full Address'
+);
+
#
# initialise the system
#
sub new
{
- my ($call) = @_;
+ my ($pkg, $call) = @_;
die "can't create existing call $call in User\n!" if $u{$call};
my $self = {};
$self->{call} = $call;
- bless $self;
+ bless $self, $pkg;
$u{call} = $self;
}
sub get
{
- my ($call) = @_;
+ my $call = shift;
return $u{$call};
}
$self->put();
}
+#
+# return a list of valid elements
+#
+
+sub elements
+{
+ return keys(%valid);
+}
+
+#
+# return a prompt together with the existing value
+#
+
+sub prompt
+{
+ my ($self, $ele) = @_;
+ return "$valid{$ele} [$self->{$ele}]";
+}
+
+#
+# enter an element from input, returns 1 for success
+#
+
+sub enter
+{
+ my ($self, $ele, $value) = @_;
+ return 0 if (!defined $valid{$ele});
+ chomp $value;
+ return 0 if $value eq "";
+ if ($ele eq 'long') {
+ my ($longd, $longm, $longl) = $value =~ /(\d+) (\d+) ([EWew])/;
+ return 0 if (!$longl || $longd < 0 || $longd > 180 || $longm < 0 || $longm > 59);
+ $longd += ($longm/60);
+ $longd = 0-$longd if (uc $longl) eq 'W';
+ $self->{'long'} = $longd;
+ return 1;
+ } elsif ($ele eq 'lat') {
+ my ($latd, $latm, $latl) = $value =~ /(\d+) (\d+) ([NSns])/;
+ return 0 if (!$latl || $latd < 0 || $latd > 90 || $latm < 0 || $latm > 59);
+ $latd += ($latm/60);
+ $latd = 0-$latd if (uc $latl) eq 'S';
+ $self->{'lat'} = $latd;
+ return 1;
+ } elsif ($ele eq 'qra') {
+ $self->{'qra'} = UC $value;
+ return 1;
+ } else {
+ $self->{$ele} = $value; # default action
+ return 1;
+ }
+ return 0;
+}
1;
__END__
require Exporter;
@ISA = qw(Exporter);
-@EXPORT_OK = qw($mycall $myname $mynormalcall $mylatitude $mylongtitude $mylocator
+@EXPORT_OK = qw($mycall $myname $myalias $mylatitude $mylongtitude $mylocator
$myqth $myemail $myprot
$clusterport $clusteraddr $debugfn
$def_hopcount $root $data $system $cmd
- $userfn
+ $userfn $motd
);
$myname = "Dirk";
# Your 'normal' callsign
-$mynormalcall = "G1TLH";
+$myalias = "G1TLH";
# Your latitude (+)ve = North (-)ve = South in degrees and decimal degrees
$mylatitude = +52.68584579;
$myqth = "East Dereham, Norfolk";
# Your e-mail address
-$myemail = "djk@tobit.co.uk";
+$myemail = "djk\@tobit.co.uk";
# the tcp address of the cluster and so does this !!!
$clusteraddr = "dirk1.tobit.co.uk";
# where the user data lives
$userfn = "$data/users";
+
+# the "message of the day" file
+$motd = "$data/motd";
# $Id$
#
+BEGIN {
+ unshift @INC, "/spider/local";
+ unshift @INC, "/spider/perl";
+}
+
use Msg;
use DXVars;
@stdoutq = (); # the queue of stuff to send out to the user
$conn = 0; # the connection object for the cluster
$lastbit = ""; # the last bit of an incomplete input line
+$nl = "\r";
# cease communications
sub cease
my ($sort, $call, $line) = $msg =~ /^(\w)(\S+)|(.*)$/;
if ($sort eq 'D') {
- my $nl = ($mode == 1) ? "\r" : "\n";
$nl = "" if $mode == 0;
$line =~ s/\n/\r/o if $mode == 1;
print $line, $nl;
die "client.pl <call> [<mode>]\r\n" if (!$call);
$mode = $ARGV[1] if (@ARGV > 1);
+if ($mode != 1) {
+ $nl = "\n";
+ $\ = $nl;
+}
+
select STDOUT; $| = 1;
$SIG{'INT'} = \&sig_term;
$SIG{'TERM'} = \&sig_term;
-$SIG{'HUP'} = \&sig_term;
+#$SIG{'HUP'} = \&sig_term;
$conn = Msg->connect("$clusteraddr", $clusterport, \&rec_socket);
$conn->send_now("A$call|start");
use DXUtil;
use DXChannel;
use DXUser;
+use DXM;
package main;
-@inqueue = undef; # the main input queue, an array of hashes
-
-# handle out going messages
-sub send_now
-{
- my ($conn, $sort, $call, $line) = @_;
-
- print DEBUG "$t > $sort $call $line\n" if defined DEBUG;
- print "> $sort $call $line\n";
- $conn->send_now("$sort$call|$line");
-}
-
-sub send_later
-{
- my ($conn, $sort, $call, $line) = @_;
-
- print DEBUG "$t > $sort $call $line\n" if defined DEBUG;
- print "> $sort $call $line\n";
- $conn->send_later("$sort$call|$line");
-}
+@inqueue = (); # the main input queue, an array of hashes
# handle disconnections
sub disconnect
{
- my $dxconn = shift;
- my ($user) = $dxconn->{user};
- my ($conn) = $dxconn->{conn};
+ my $dxchan = shift;
+ return if !defined $dxchan;
+ my ($user) = $dxchan->{user};
+ my ($conn) = $dxchan->{conn};
$user->close() if defined $user;
- $conn->disconnect();
- $dxconn->del();
+ $conn->disconnect() if defined $conn;
+ $dxchan->del();
}
# handle incoming messages
sub rec
{
my ($conn, $msg, $err) = @_;
- my $dxconn = DXChannel->get_by_cnum($conn); # get the dxconnnect object for this message
+ my $dxchan = DXChannel->get_by_cnum($conn); # get the dxconnnect object for this message
if (defined $err && $err) {
- disconnect($dxconn);
+ disconnect($dxchan) if defined $dxchan;
return;
- }
+ }
+
+ # set up the basic channel info
+ if (!defined $dxchan) {
+ my $user = DXUser->get($call);
+ $user = DXUser->new($call) if !defined $user;
+ $dxchan = DXChannel->new($call, $conn, $user);
+ }
+
+ # queue the message and the channel object for later processing
if (defined $msg) {
my $self = bless {}, "inqueue";
- $self->{dxconn} = $dxconn;
+ $self->{dxchan} = $dxchan;
$self->{data} = $msg;
push @inqueue, $self;
}
# cease running this program, close down all the connections nicely
sub cease
{
- my $dxconn;
- foreach $dxconn (DXChannel->get_all()) {
- disconnect($dxconn);
+ my $dxchan;
+ foreach $dxchan (DXChannel->get_all()) {
+ disconnect($dxchan);
}
}
return if !$self;
my $data = $self->{data};
- my $dxconn = $self->{dxconn};
+ my $dxchan = $self->{dxchan};
my ($sort, $call, $line) = $data =~ /^(\w)(\S+)|(.*)$/;
# do the really sexy console interface bit! (Who is going to do the TK interface then?)
# handle A records
if ($sort eq 'A') {
- if ($dxconn) { # there should not be one of these, disconnect
-
+ my $user = $dxchan->{user};
+ $user->{sort} = 'U' if !defined $user->{sort};
+ if ($user->{sort} eq 'U') {
+ $dxchan->send_later('D', m('l2', $call, $mycall, $myqth));
+ $dxchan->send_file($motd) if (-e $motd);
}
- my $user = DXUser->get($call); # see if we have one of these
+ } elsif (sort eq 'D') {
+ ;
+ } elsif ($sort eq 'Z') {
+ disconnect($dxchan);
}
-
}
#############################################################
--- /dev/null
+#!/usr/bin/perl
+#
+# create a NEW user database and the sysop record
+#
+# WARNING - running this will destroy any existing user database
+#
+# Copyright (c) 1998 Dirk Koopman G1TLH
+#
+# $Id$
+#
+
+use DXVars;
+use DXUser;
+
+sub create_it
+{
+ system("rm -f $userfn*");
+ DXUser->init($userfn);
+ my $self = DXUser->new($mycall);
+ $self->{alias} = $myalias;
+ $self->{name} = $myname;
+ $self->{qth} = $myqth;
+ $self->{qra} = $mylocator;
+ $self->{lat} = $mylatitude;
+ $self->{long} = $mylongtitude;
+ $self->{email} = $myemail;
+ $self->{sort} = 'C'; # C - Console user, S - Spider cluster, A - AK1A, U - User, B - BBS
+ $self->{priv} = 9; # 0 - 9 - with 9 being the highest
+ $self->{lastin} = 0;
+
+ # write it away
+ $self->close();
+ DXUser->finish();
+ print "New user database created as $userfn\n";
+}
+
+if (-e "$userfn") {
+ print "This program will destroy your user database!!!!\n\nDo you wish to continue [y/N]: ";
+ $ans = <STDIN>;
+ create_it() if ($ans =~ /^[Yy]/);
+} else {
+ create_it();
+}
+exit(0);
+
projects / spider.git / commitdiff