From 1cf4bd14be226274d5deb05da8480ab91a5dac52 Mon Sep 17 00:00:00 2001 From: djk Date: Mon, 22 Jun 1998 20:05:22 +0000 Subject: [PATCH] We have lift off, we are CONNECTED. We aren't doing much but we can get on and we have a structure in place which is workable. It now needs fleshing out. --- cmd/set/address.pl | 27 +++++ cmd/set/announce.pl | 6 +- cmd/set/dx.pl | 6 +- cmd/set/here.pl | 6 +- cmd/set/node.pl | 35 ++++++ cmd/set/talk.pl | 6 +- cmd/set/wwv.pl | 6 +- cmd/show/user.pl | 2 +- perl/DXChannel.pm | 29 ++++- perl/DXCluster.pm | 48 ++++---- perl/DXCommandmode.pm | 53 ++++++++- perl/DXM.pm | 2 + perl/DXProt.pm | 264 +++++++++++++++++++++++++++++++++++++++--- perl/DXProtVars.pm | 38 ++++++ perl/DXUser.pm | 33 ++++-- perl/DXVars.pm | 9 -- perl/client.pl | 6 +- perl/cluster.pl | 27 ++--- perl/create_sysop.pl | 4 + 19 files changed, 514 insertions(+), 93 deletions(-) create mode 100644 cmd/set/node.pl create mode 100644 perl/DXProtVars.pm diff --git a/cmd/set/address.pl b/cmd/set/address.pl index e69de29b..f5922d9c 100644 --- a/cmd/set/address.pl +++ b/cmd/set/address.pl @@ -0,0 +1,27 @@ +# +# set the address field +# +# Copyright (c) 1998 - Dirk Koopman +# +# $Id$ +# + +my ($self, $line) = @_; +my $call; +my @out; +my $user; + +if ($self->priv >= 5) { # allow a callsign as first arg + my @args = split /\s+/, $line; + $call = UC $args[0]; + $user = DXUser->get_current($call); + shift @args if $user; + $line = join ' ', @args; +} else { + $user = $self->user; +} + +$user->addr($line); +push @out, DXM::msg('addr', $call); + +return (1, @out); diff --git a/cmd/set/announce.pl b/cmd/set/announce.pl index 8fce45ca..8a77f1ea 100644 --- a/cmd/set/announce.pl +++ b/cmd/set/announce.pl @@ -15,9 +15,9 @@ my @out; foreach $call (@args) { $call = uc $call; - my $user = ($call eq $self->call) ? $self->user : DXUser->get($call); - if ($user) { - $user->ann(1); + my $chan = DXChannel->get($call); + if ($chan) { + $chan->ann(1); push @out, DXM::msg('anns', $call); } else { push @out, DXM::msg('e3', "Set Announce", $call); diff --git a/cmd/set/dx.pl b/cmd/set/dx.pl index 00ea0328..0acb39db 100644 --- a/cmd/set/dx.pl +++ b/cmd/set/dx.pl @@ -15,9 +15,9 @@ my @out; foreach $call (@args) { $call = uc $call; - my $user = ($call eq $self->call) ? $self->user : DXUser->get($call); - if ($user) { - $user->dx(1); + my $chan = DXChannel->get($call); + if ($chan) { + $chan->dx(1); push @out, DXM::msg('dxs', $call); } else { push @out, DXM::msg('e3', "Set DX Spots", $call); diff --git a/cmd/set/here.pl b/cmd/set/here.pl index acccbcc4..b89d47d7 100644 --- a/cmd/set/here.pl +++ b/cmd/set/here.pl @@ -15,9 +15,9 @@ my @out; foreach $call (@args) { $call = uc $call; - my $user = ($call eq $self->call) ? $self->user : DXUser->get($call); - if ($user) { - $user->here(1); + my $chan = DXChannel->get($call); + if ($chan) { + $chan->here(1); push @out, DXM::msg('heres', $call); } else { push @out, DXM::msg('e3', "Set Here", $call); diff --git a/cmd/set/node.pl b/cmd/set/node.pl new file mode 100644 index 00000000..78baa189 --- /dev/null +++ b/cmd/set/node.pl @@ -0,0 +1,35 @@ +# +# set user type to 'A' for AK1A node +# +# Please note that this is only effective if the user is not on-line +# +# Copyright (c) 1998 - Dirk Koopman +# +# $Id$ +# + +my ($self, $line) = @_; +my @args = split /\s+/, $line; +my $call; +my @out; +my $user; + +return (0) if $self->priv < 5; + +foreach $call (@args) { + $call = uc $call; + my $chan = DXChannel->get($call); + if ($chan) { + push @out, DXM::msg('nodee1', $call); + } else { + $user = DXUser->get($call); + if ($user) { + $user->sort('A'); + $user->close(); + push @out, DXM::msg('node', $call); + } else { + push @out, DXM::msg('e3', "Set Node", $call); + } + } +} +return (1, @out); diff --git a/cmd/set/talk.pl b/cmd/set/talk.pl index 8c4d3ac4..85b66c04 100644 --- a/cmd/set/talk.pl +++ b/cmd/set/talk.pl @@ -15,9 +15,9 @@ my @out; foreach $call (@args) { $call = uc $call; - my $user = ($call eq $self->call) ? $self->user : DXUser->get($call); - if ($user) { - $user->talk(1); + my $chan = DXChannel->get($call); + if ($chan) { + $chan->talk(1); push @out, DXM::msg('talks', $call); } else { push @out, DXM::msg('e3', "Set Talk", $call); diff --git a/cmd/set/wwv.pl b/cmd/set/wwv.pl index 2e403cec..bfa04f25 100644 --- a/cmd/set/wwv.pl +++ b/cmd/set/wwv.pl @@ -15,9 +15,9 @@ my @out; foreach $call (@args) { $call = uc $call; - my $user = ($call eq $self->call) ? $self->user : DXUser->get($call); - if ($user) { - $user->wwv(1); + my $chan = DXChannel->get($call); + if ($chan) { + $chan->wwv(1); push @out, DXM::msg('wwvs', $call); } else { push @out, DXM::msg('e3', "Set WWV", $call); diff --git a/cmd/show/user.pl b/cmd/show/user.pl index 3b277774..997ae542 100644 --- a/cmd/show/user.pl +++ b/cmd/show/user.pl @@ -12,7 +12,7 @@ my $call; my @out; foreach $call (@list) { $call = uc $call; - my $ref = DXUser->get($call); + my $ref = DXUser->get_current($call); if ($ref) { @out = print_all_fields($self, $ref, "User Information $call"); } else { diff --git a/perl/DXChannel.pm b/perl/DXChannel.pm index 24b87566..fc0305a7 100644 --- a/perl/DXChannel.pm +++ b/perl/DXChannel.pm @@ -30,9 +30,11 @@ use DXUtil; use DXM; use DXDebug; -%channels = undef; +use strict; -%valid = ( +my %channels = undef; + +my %valid = ( call => '0,Callsign', conn => '9,Msg Conn ref', user => '9,DXUser ref', @@ -45,11 +47,17 @@ use DXDebug; name => '0,User Name', consort => '9,Connection Type', sort => '9,Type of Channel', + wwv => '0,Want WWV,yesno', + talk => '0,Want Talk,yesno', + ann => '0,Want Announce,yesno', + here => '0,Here?,yesno', + confmode => '0,In Conference?,yesno', + dx => '0,DX Spots,yesno', ); # create a new channel object [$obj = DXChannel->new($call, $msg_conn_obj, $user_obj)] -sub new +sub alloc { my ($pkg, $call, $conn, $user) = @_; my $self = {}; @@ -98,6 +106,19 @@ sub del delete $channels{$self->{call}}; } +# is it an ak1a cluster ? +sub is_ak1a +{ + my $self = shift; + return $self->{sort} eq 'A'; +} + +# is it a user? +sub is_user +{ + my $self = shift; + return $self->{sort} eq 'U'; +} # handle out going messages, immediately without waiting for the select to drop # this could, in theory, block @@ -186,11 +207,11 @@ sub field_prompt return $valid{$ele}; } +no strict; sub AUTOLOAD { my $self = shift; my $name = $AUTOLOAD; - return if $name =~ /::DESTROY$/; $name =~ s/.*:://o; diff --git a/perl/DXCluster.pm b/perl/DXCluster.pm index 2dad1cb6..920a33fb 100644 --- a/perl/DXCluster.pm +++ b/perl/DXCluster.pm @@ -17,17 +17,28 @@ package DXCluster; use Exporter; @ISA = qw(Exporter); -%cluster = (); # this is where we store the dxcluster database +use strict; + +my %cluster = (); # this is where we store the dxcluster database + +my %valid = ( + mynode => '0,Parent Node', + call => '0,Callsign', + confmode => '0,Conference Mode,yesno', + here => '0,Here?,yesno', + dxchan => '5,Channel ref', + pcversion => '5,Node Version', +); sub alloc { - my ($pkg, $call, $confmode, $here, $dxprot) = @_; + my ($pkg, $call, $confmode, $here, $dxchan) = @_; die "$call is already alloced" if $cluster{$call}; my $self = {}; $self->{call} = $call; $self->{confmode} = $confmode; $self->{here} = $here; - $self->{dxprot} = $dxprot; + $self->{dxchan} = $dxchan; $cluster{$call} = bless $self, $pkg; return $self; @@ -52,14 +63,6 @@ sub delcluster; delete $cluster{$self->{call}}; } -%valid = ( - mynode => '0,Parent Node', - call => '0,Callsign', - confmode => '5,Conference Mode,yesno', - here => '5,Here?,yesno', - dxprot => '5,Channel ref', - version => '5,Node Version', -); # return a prompt for a field sub field_prompt @@ -68,6 +71,7 @@ sub field_prompt return $valid{$ele}; } +no strict; sub AUTOLOAD { my $self = shift; @@ -84,16 +88,17 @@ sub AUTOLOAD # USER special routines # -package DXUser; +package DXNodeuser; @ISA = qw(DXCluster); -%users = (); +use strict; +my %users = (); sub new { - my ($pkg, $mynode, $call, $confmode, $here, $dxprot) = @_; - my $self = $pkg->alloc($call, $confmode, $here, $dxprot); + my ($pkg, $mynode, $call, $confmode, $here, $dxchan) = @_; + my $self = $pkg->alloc($call, $confmode, $here, $dxchan); $self->{mynode} = $mynode; $users{$call} = $self; @@ -112,6 +117,8 @@ sub count return %users + 1; # + 1 for ME (naf eh!) } +no strict; + # # NODE special routines # @@ -120,13 +127,14 @@ package DXNode; @ISA = qw(DXCluster); -%nodes = (); +use strict; +my %nodes = (); sub new { - my ($pkg, $call, $confmode, $here, $version, $dxprot) = @_; - my $self = $pkg->alloc($call, $confmode, $here, $dxprot); - $self->{version} = $version; + my ($pkg, $call, $confmode, $here, $pcversion, $dxchan) = @_; + my $self = $pkg->alloc($call, $confmode, $here, $dxchan); + $self->{version} = $pcversion; $nodes{$call} = $self; return $self; } @@ -144,7 +152,7 @@ sub get_all my $list; my @out; foreach $list (values(%nodes)) { - push @out, $list if $list->{version}; + push @out, $list if $list->{pcversion}; } return @out; } diff --git a/perl/DXCommandmode.pm b/perl/DXCommandmode.pm index d48de1c8..474d2c9c 100644 --- a/perl/DXCommandmode.pm +++ b/perl/DXCommandmode.pm @@ -18,10 +18,22 @@ use DXVars; use DXDebug; use strict; -use vars qw( %Cache $last_dir_mtime @cmd); -$last_dir_mtime = 0; # the last time one of the cmd dirs was modified -@cmd = undef; # a list of commands+path pairs (in alphabetical order) +#use vars qw( %Cache $last_dir_mtime @cmd); +my %Cache = (); # cache of dynamically loaded routine's mod times +my $last_dir_mtime = 0; # the last time one of the cmd dirs was modified +my @cmd = undef; # a list of commands+path pairs (in alphabetical order) + +# +# obtain a new connection this is derived from dxchannel +# + +sub new +{ + my $self = DXChannel::alloc(@_); + $self->{sort} = 'U'; # in absence of how to find out what sort of an object I am + return $self; +} # this is how a a connection starts, you get a hello message and the motd with # possibly some other messages asking you to set various things up if you are @@ -42,7 +54,10 @@ sub start $self->{priv} = $user->priv; $self->{priv} = 0 if $line =~ /^(ax|te)/; # set the connection priv to 0 - can be upgraded later $self->{consort} = $line; # save the connection type - $self->sort('U'); # set the channel type + + # set some necessary flags on the user if they are connecting + $self->{wwv} = $self->{talk} = $self->{ann} = $self->{here} = $self->{dx} = 1; + } # @@ -127,6 +142,36 @@ sub prompt DXChannel::msg($self, 'pr', $call); } +# broadcast a message to all users [except those mentioned after buffer] +sub broadcast +{ + my $pkg = shift; # ignored + my $s = shift; # the line to be rebroadcast + my @except = @_; # to all channels EXCEPT these (dxchannel refs) + my @list = DXChannel->get_all(); # just in case we are called from some funny object + my ($chan, $except); + +L: foreach $chan (@list) { + next if !$chan->sort eq 'U'; # only interested in user channels + foreach $except (@except) { + next L if $except == $chan; # ignore channels in the 'except' list + } + chan->send($s); # send it + } +} + +# gimme all the users +sub get_all +{ + my @list = DXChannel->get_all(); + my $ref; + my @out; + foreach $ref (@list) { + push @out, $ref if $ref->sort eq 'U'; + } + return @out; +} + # # search for the command in the cache of short->long form commands # diff --git a/perl/DXM.pm b/perl/DXM.pm index 80b2fbc7..5c735fc7 100644 --- a/perl/DXM.pm +++ b/perl/DXM.pm @@ -39,6 +39,8 @@ require Exporter; l1 => 'Sorry $_[0], you are already logged on on another channel', l2 => 'Hello $_[0], this is $main::mycall located in $main::myqth', m2 => '$_[0] Information: $_[1]', + node => '$_[0] set as AK1A style Node', + nodee1 => 'You cannot use this command whilst your target ($_[0]) is on-line', pr => '$_[0] de $main::mycall $main::cldate $main::ztime >', prx => '$main::$mycall >', talks => 'Talk flag set on $_[0]', diff --git a/perl/DXProt.pm b/perl/DXProt.pm index 88fed5e3..3001d263 100644 --- a/perl/DXProt.pm +++ b/perl/DXProt.pm @@ -11,31 +11,44 @@ package DXProt; @ISA = qw(DXChannel); -use strict; - use DXUtil; use DXChannel; use DXUser; use DXM; use DXCluster; +use DXProtVars; +use DXCommandmode; + +use strict; + +# +# obtain a new connection this is derived from dxchannel +# + +sub new +{ + my $self = DXChannel::alloc(@_); + $self->{sort} = 'A'; # in absence of how to find out what sort of an object I am + return $self; +} # this is how a pc connection starts (for an incoming connection) # issue a PC38 followed by a PC18, then wait for a PC20 (remembering # all the crap that comes between). sub start { - my $self = shift; + my ($self, $line) = shift; my $call = $self->call; - # set the channel sort - $self->sort('A'); + # remember type of connection + $self->{consort} = $line; # set unbuffered - self->send_now('B',"0"); + $self->send_now('B',"0"); - # do we have him connected on the cluster somewhere else? - $self->send(pc38()); - $self->send(pc18()); + # send initialisation string + $self->send($self->pc38()) if DXNode->get_all(); + $self->send($self->pc18()); $self->{state} = 'incoming'; } @@ -44,7 +57,95 @@ sub start # sub normal { + my ($self, $line) = @_; + my @field = split /[\^\~]/, $line; + + # ignore any lines that don't start with PC + return if !$field[0] =~ /^PC/; + # process PC frames + my ($pcno) = $field[0] =~ /^PC(\d\d)/; # just get the number + return if $pcno < 10 || $pcno > 51; + + SWITCH: { + if ($pcno == 10) {last SWITCH;} + if ($pcno == 11) {last SWITCH;} + if ($pcno == 12) {last SWITCH;} + if ($pcno == 13) {last SWITCH;} + if ($pcno == 14) {last SWITCH;} + if ($pcno == 15) {last SWITCH;} + if ($pcno == 16) {last SWITCH;} + if ($pcno == 17) {last SWITCH;} + if ($pcno == 18) {last SWITCH;} + if ($pcno == 19) {last SWITCH;} + if ($pcno == 20) { # send local configuration + + # set our data (manually 'cos we only have a psuedo channel [at the moment]) + my $hops = $self->get_hops(); + $self->send("PC19^1^$main::mycall^0^$DXProt::myprot_version^$hops^"); + + # get all the local users and send them out + my @list; + for (@list = DXCommandmode::get_all(); @list; ) { + @list = $self->pc16(@list); + my $out = shift @list; + $self->send($out); + } + $self->send($self->pc22()); + last SWITCH; + } + if ($pcno == 21) {last SWITCH;} + if ($pcno == 22) {last SWITCH;} + if ($pcno == 23) {last SWITCH;} + if ($pcno == 24) {last SWITCH;} + if ($pcno == 25) {last SWITCH;} + if ($pcno == 26) {last SWITCH;} + if ($pcno == 27) {last SWITCH;} + if ($pcno == 28) {last SWITCH;} + if ($pcno == 29) {last SWITCH;} + if ($pcno == 30) {last SWITCH;} + if ($pcno == 31) {last SWITCH;} + if ($pcno == 32) {last SWITCH;} + if ($pcno == 33) {last SWITCH;} + if ($pcno == 34) {last SWITCH;} + if ($pcno == 35) {last SWITCH;} + if ($pcno == 36) {last SWITCH;} + if ($pcno == 37) {last SWITCH;} + if ($pcno == 38) {last SWITCH;} + if ($pcno == 39) {last SWITCH;} + if ($pcno == 40) {last SWITCH;} + if ($pcno == 41) {last SWITCH;} + if ($pcno == 42) {last SWITCH;} + if ($pcno == 43) {last SWITCH;} + if ($pcno == 44) {last SWITCH;} + if ($pcno == 45) {last SWITCH;} + if ($pcno == 46) {last SWITCH;} + if ($pcno == 47) {last SWITCH;} + if ($pcno == 48) {last SWITCH;} + if ($pcno == 49) {last SWITCH;} + if ($pcno == 50) {last SWITCH;} + if ($pcno == 51) {last SWITCH;} + } + + # if get here then rebroadcast the thing with its Hop count decremented (if + # the is one). If it has a hop count and it decrements to zero then don't + # rebroadcast it. + # + # NOTE - don't arrive here UNLESS YOU WANT this lump of protocol to be + # REBROADCAST!!!! + # + + my $hopfield = pop @field; + push @field, $hopfield; + + if ($hopfield =~ /H\d\d./o) { + my ($hops) = $hopfield =~ /H(\d+)/o; + $hops--; + if ($hops > 0) { + $line =~ s/\^H\d+(\^\~.)$/\^H$hops$1/; # change the hop count + DXProt->broadcast($line, $self); # send it to everyone but me + } + } } # @@ -58,10 +159,10 @@ sub process my $chan; foreach $chan (@chan) { - next if $chan->sort ne 'A'; + next if !$chan->is_ak1a(); # send a pc50 out on this channel - if ($t >= $chan->t + $main::pc50_interval) { + if ($t >= $chan->t + $DXProt::pc50_interval) { $chan->send(pc50()); $chan->t($t); } @@ -76,20 +177,56 @@ sub finish } +# +# add a (local) user to the cluster +# + +sub adduser +{ + +} + +# +# delete a (local) user to the cluster +# + +sub deluser +{ + +} + +# +# add a (locally connected) node to the cluster +# + +sub addnode +{ + +} + +# +# delete a (locally connected) node to the cluster +# +sub delnode +{ + +} + # # some active measures # +# broadcast a message to all clusters [except those mentioned after buffer] sub broadcast { - my $s = shift; - $s = shift if ref $s; # if I have been called $self-> ignore it. + my $pkg = shift; # ignored + my $s = shift; # the line to be rebroadcast my @except = @_; # to all channels EXCEPT these (dxchannel refs) my @chan = DXChannel->get_all(); my ($chan, $except); L: foreach $chan (@chan) { - next if $chan->sort != 'A'; # only interested in ak1a channels + next if !$chan->sort eq 'A'; # only interested in ak1a channels foreach $except (@except) { next L if $except == $chan; # ignore channels in the 'except' list } @@ -97,13 +234,108 @@ L: foreach $chan (@chan) { } } +# +# gimme all the ak1a nodes +# +sub get_all +{ + my @list = DXChannel->get_all(); + my $ref; + my @out; + foreach $ref (@list) { + push @out, $ref if $ref->sort eq 'A'; + } + return @out; +} + +# +# obtain the hops from the list for this callsign and pc no +# + +sub get_hops +{ + my ($self, $pcno) = @_; + return "H$DXProt::def_hopcount"; # for now +} + # # All the PCxx generation routines # +# +# add one or more users (I am expecting references that have 'call', +# 'confmode' & 'here' method) +# +# NOTE this sends back a list containing the PC string (first element) +# and the rest of the users not yet processed +# +sub pc16 +{ + my $self = shift; + my @list = @_; # list of users + my @out = ('PC16', $main::mycall); + my $i; + + for ($i = 0; @list && $i < $DXProt::pc16_max_users; $i++) { + my $ref = shift @list; + my $call = $ref->call; + my $s = sprintf "%s %s %d", $call, $ref->confmode ? '*' : '-', $ref->here; + push @out, $s; + } + push @out, $self->get_hops(); + my $str = join '^', @out; + $str .= '^'; + return ($str, @list); +} + +# Request init string sub pc18 { - return "PC18^wot a load of twaddle^$main::myprot_version^~"; + return "PC18^wot a load of twaddle^$DXProt::myprot_version^~"; +} + +# +# add one or more nodes +# +# NOTE this sends back a list containing the PC string (first element) +# and the rest of the nodes not yet processed (as PC16) +# +sub pc19 +{ + my $self = shift; + my @list = @_; # list of users + my @out = ('PC19', $main::mycall); + my $i; + + for ($i = 0; @list && $i < $DXProt::pc19_max_nodes; $i++) { + my $ref = shift @list; + push @out, $ref->here, $ref->call, $ref->confmode, $ref->pcversion; + } + push @out, $self->get_hops(); + my $str = join '^', @out; + $str .= '^'; + return ($str, @list); +} + +# end of Rinit phase +sub pc20 +{ + return 'PC20^'; +} + +# delete a node +sub pc21 +{ + my ($self, $ref, $reason) = @_; + my $call = $ref->call; + my $hops = $self->get_hops(); + return "PC21^$call^$reason^$hops^"; +} + +# end of init phase +sub pc22 +{ + return 'PC22^'; } # send all the DX clusters I reckon are connected @@ -121,7 +353,7 @@ sub pc38 sub pc50 { - my $n = DXUsers->count; + my $n = DXNodeuser->count; return "PC50^$main::mycall^$n^H99^"; } diff --git a/perl/DXProtVars.pm b/perl/DXProtVars.pm new file mode 100644 index 00000000..52477433 --- /dev/null +++ b/perl/DXProtVars.pm @@ -0,0 +1,38 @@ +# +# +# These are various values used by the AK1A protocol stack +# +# Change these at your peril (or if you know what you are doing)! +# +# Copyright (c) 1998 - Dirk Koopman G1TLH +# +# $Id$ +# + +package DXProt; + +# maximum number of users in a PC16 message +$pc16_max_users = 5; + +# maximum number of nodes in a PC19 message +$pc19_max_nodes = 5; + +# the interval between pc50s (in seconds) +$pc50_interval = 14*60; + +# the version of DX cluster (tm) software I am masquerading as +$myprot_version = "5447"; + +# default hopcount to use +$def_hopcount = 15; + +# some variable hop counts based on message type +%hopcount = ( + 11 => 25, + 16 => 10, + 17 => 10, + 19 => 10, + 21 => 10, +); + + diff --git a/perl/DXUser.pm b/perl/DXUser.pm index b593a6b2..cdbc0b23 100644 --- a/perl/DXUser.pm +++ b/perl/DXUser.pm @@ -32,15 +32,14 @@ $filename = undef; lastin => '0,Last Time in,cldatetime', passwd => '9,Password', addr => '0,Full Address', - sort => '0,Type of User', # A - ak1a, U - User, S - spider cluster, B - BBS - wwv => '0,Want WWV,yesno', - talk => '0,Want Talk,yesno', - ann => '0,Want Announce,yesno', - here => '0,Here Status,yesno', + sort => '0,Type of User', # A - ak1a, U - User, S - spider cluster, B - BBS xpert => '0,Expert Status,yesno', bbs => '0,Home BBS', node => '0,Home Node', - dx => '0,DX Spots,yesno', + lockout => '9,Locked out?,yesno', # won't let them in at all + dxok => '9,DX Spots?,yesno', # accept his dx spots? + annok => '9,Announces?,yesno', # accept his announces? + reg => '0,Registered?,yesno', # is this user registered? ); sub AUTOLOAD @@ -92,12 +91,16 @@ sub new my $self = {}; $self->{call} = $call; + $self->{sort} = 'U'; + $self->{dxok} = 1; + $self->{annok} = 1; bless $self, $pkg; $u{call} = $self; } # -# get - get an existing user +# get - get an existing user - this seems to return a different reference everytime it is +# called - see below # sub get @@ -106,6 +109,22 @@ sub get return $u{$call}; } +# +# get an existing either from the channel (if there is one) or from the database +# +# It is important to note that if you have done a get (for the channel say) and you +# want access or modify that you must use this call (and you must NOT use get's all +# over the place willy nilly!) +# + +sub get_current +{ + my ($pkg, $call) = @_; + my $dxchan = DXChannel->get($call); + return $dxchan->user if $dxchan; + return $u{$call}; +} + # # put - put a user # diff --git a/perl/DXVars.pm b/perl/DXVars.pm index 362f26e2..8cc17e6c 100644 --- a/perl/DXVars.pm +++ b/perl/DXVars.pm @@ -57,24 +57,15 @@ $clusterport = 27754; # cluster debug file $debugfn = "/tmp/debug_cluster"; -# the version of DX cluster (tm) software I am masquerading as -$myprot_version = "5447"; - # your favorite way to say 'Yes' $yes = 'Yes'; # your favorite way to say 'No' $no = 'No'; -# the interval between pc50s (in seconds) -$pc50_interval = 14*60; - # the interval between unsolicited prompts if not traffic $user_interval = 11*60; -# default hopcount to use - note this will override any incoming hop counts, if they are greater -$def_hopcount = 7; - # root of directory tree for this system $root = "/spider"; diff --git a/perl/client.pl b/perl/client.pl index f44120f2..84541433 100755 --- a/perl/client.pl +++ b/perl/client.pl @@ -143,11 +143,15 @@ sub rec_stdin } $call = uc shift @ARGV; -$call = uc $mycall if !$call; +$call = uc $myalias if !$call; $connsort = lc shift @ARGV; $connsort = 'local' if !$connsort; $mode = ($connsort =~ /^ax/o) ? 1 : 2; setmode(); +if ($call eq $mycall) { + print "You cannot connect as your cluster callsign ($mycall)", $nl; + cease(0); +} #select STDOUT; $| = 1; STDOUT->autoflush(1); diff --git a/perl/cluster.pl b/perl/cluster.pl index 76dea219..f9bc45ff 100755 --- a/perl/cluster.pl +++ b/perl/cluster.pl @@ -59,17 +59,13 @@ sub rec # set up the basic channel info - this needs a bit more thought - there is duplication here if (!defined $dxchan) { my ($sort, $call, $line) = $msg =~ /^(\w)(\S+)\|(.*)$/; - my $user = DXUser->get($call); - if (!defined $user) { - $user = DXUser->new($call); - } - my $sort = $user->sort(); - - # is there one already connected? + + # is there one already connected? if (DXChannel->get($call)) { my $mess = DXM::msg('conother', $call); dbg('chan', "-> D $call $mess\n"); $conn->send_now("D$call|$mess"); + sleep(1); dbg('chan', "-> Z $call bye\n"); $conn->send_now("Z$call|bye"); # this will cause 'client' to disconnect return; @@ -80,21 +76,20 @@ sub rec my $mess = DXM::msg('concluster', $call); dbg('chan', "-> D $call $mess\n"); $conn->send_now("D$call|$mess"); + sleep(1); dbg('chan', "-> Z $call bye\n"); $conn->send_now("Z$call|bye"); # this will cause 'client' to disconnect return; } - # set some necessary flags on the user if they are connecting - $user->wwv(1) if !$user->wwv(); - $user->talk(1) if !$user->talk(); - $user->ann(1) if !$user->ann(); - $user->here(1) if !$user->here(); - $user->sort('U') if !$user->sort(); + my $user = DXUser->get($call); + if (!defined $user) { + $user = DXUser->new($call); + } - # create the channel - $dxchan = DXCommandmode->new($call, $conn, $user) if ($sort eq 'U'); - $dxchan = DXProt->new($call, $conn, $user) if ($sort eq 'A'); + # create the channel + $dxchan = DXCommandmode->new($call, $conn, $user) if ($user->sort eq 'U'); + $dxchan = DXProt->new($call, $conn, $user) if ($user->sort eq 'A'); die "Invalid sort of user on $call = $sort" if !$dxchan; } diff --git a/perl/create_sysop.pl b/perl/create_sysop.pl index a08bb9ff..3b1196fe 100755 --- a/perl/create_sysop.pl +++ b/perl/create_sysop.pl @@ -28,6 +28,8 @@ sub create_it $self->{sort} = 'U'; # 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; + $self->{dxok} = 1; + $self->{annok} = 1; # write it away $self->close(); @@ -44,6 +46,8 @@ sub create_it $self->{sort} = 'U'; # 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; + $self->{dxok} = 1; + $self->{annok} = 1; # write it away $self->close(); -- 2.43.0