From 60c0ea1747bc8ad95e531d29025f7bcee4fd10c1 Mon Sep 17 00:00:00 2001 From: djk Date: Tue, 16 Jun 1998 21:33:50 +0000 Subject: [PATCH] started to flesh some of it out. added basic message indirection. --- perl/DXChannel.pm | 48 +++++++++++++++++++++++++++ perl/DXM.pm | 28 ++++++++++++++++ perl/DXUser.pm | 77 +++++++++++++++++++++++++++++++++++++++++--- perl/DXVars.pm | 11 ++++--- perl/client.pl | 14 ++++++-- perl/cluster.pl | 71 +++++++++++++++++++--------------------- perl/create_sysop.pl | 45 ++++++++++++++++++++++++++ 7 files changed, 247 insertions(+), 47 deletions(-) create mode 100644 perl/DXM.pm create mode 100755 perl/create_sysop.pl diff --git a/perl/DXChannel.pm b/perl/DXChannel.pm index d4b20a2b..6a867bb9 100644 --- a/perl/DXChannel.pm +++ b/perl/DXChannel.pm @@ -10,6 +10,8 @@ package DXChannel; require Exporter; @ISA = qw(Exporter); +use Msg; + %connects = undef; # create a new connection object [$obj = Connect->new($call, $msg_conn_obj, $user_obj)] @@ -61,5 +63,51 @@ sub del 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 = ; + close(F); + $self->send_later('D', @buf); +} + 1; __END__; diff --git a/perl/DXM.pm b/perl/DXM.pm new file mode 100644 index 00000000..e1579fab --- /dev/null +++ b/perl/DXM.pm @@ -0,0 +1,28 @@ +# +# 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; +} + diff --git a/perl/DXUser.pm b/perl/DXUser.pm index ac06615d..60abaeda 100644 --- a/perl/DXUser.pm +++ b/perl/DXUser.pm @@ -11,13 +11,30 @@ package DXUser; 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 # @@ -46,12 +63,12 @@ sub finish 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; } @@ -61,7 +78,7 @@ sub new sub get { - my ($call) = @_; + my $call = shift; return $u{$call}; } @@ -98,5 +115,57 @@ sub close $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__ diff --git a/perl/DXVars.pm b/perl/DXVars.pm index 23367a14..fced1ffb 100644 --- a/perl/DXVars.pm +++ b/perl/DXVars.pm @@ -12,11 +12,11 @@ package main; 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 ); @@ -27,7 +27,7 @@ $mycall = "GB7TLH"; $myname = "Dirk"; # Your 'normal' callsign -$mynormalcall = "G1TLH"; +$myalias = "G1TLH"; # Your latitude (+)ve = North (-)ve = South in degrees and decimal degrees $mylatitude = +52.68584579; @@ -42,7 +42,7 @@ $mylocator = "JO02LQ"; $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"; @@ -73,3 +73,6 @@ $cmd = "$root/cmd"; # where the user data lives $userfn = "$data/users"; + +# the "message of the day" file +$motd = "$data/motd"; diff --git a/perl/client.pl b/perl/client.pl index 0cdbe9c2..f7912ad7 100755 --- a/perl/client.pl +++ b/perl/client.pl @@ -12,6 +12,11 @@ # $Id$ # +BEGIN { + unshift @INC, "/spider/local"; + unshift @INC, "/spider/perl"; +} + use Msg; use DXVars; @@ -20,6 +25,7 @@ $call = ""; # the callsign being used @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 @@ -48,7 +54,6 @@ sub rec_socket 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; @@ -99,11 +104,16 @@ $call = uc $ARGV[0]; die "client.pl []\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"); diff --git a/perl/cluster.pl b/perl/cluster.pl index 6fded241..fc2a0973 100755 --- a/perl/cluster.pl +++ b/perl/cluster.pl @@ -17,54 +17,46 @@ use DXVars; 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; } @@ -78,9 +70,9 @@ sub login # 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); } } @@ -92,7 +84,7 @@ sub process_inqueue 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?) @@ -101,12 +93,17 @@ sub process_inqueue # 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); } - } ############################################################# diff --git a/perl/create_sysop.pl b/perl/create_sysop.pl new file mode 100755 index 00000000..dcab2f15 --- /dev/null +++ b/perl/create_sysop.pl @@ -0,0 +1,45 @@ +#!/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 = ; + create_it() if ($ans =~ /^[Yy]/); +} else { + create_it(); +} +exit(0); + -- 2.34.1