From 6b6a8002929017b6d4217f68fa492a2d728ee1fe Mon Sep 17 00:00:00 2001 From: djk Date: Sat, 20 Jun 1998 17:11:50 +0000 Subject: [PATCH] Started on the dx cluster database stuff added a load of real and dummy commands to be getting on with Started some DOCUMENTATION (shock horror) --- cmd/Notes.txt | 89 +++++++++++++++++++++++++++++++++++++++++ cmd/announce.pl | 0 cmd/{bye => bye.pl} | 0 cmd/create/node.pl | 0 cmd/create/user.pl | 0 cmd/delete/node.pl | 0 cmd/delete/user.pl | 0 cmd/dx.pl | 0 cmd/set/address.pl | 0 cmd/set/announce.pl | 0 cmd/set/debug.pl | 15 +++++++ cmd/set/dx.pl | 0 cmd/set/email.pl | 0 cmd/set/here.pl | 0 cmd/set/homenode.pl | 0 cmd/set/location.pl | 0 cmd/set/name.pl | 0 cmd/set/{qra => qra.pl} | 0 cmd/set/{qth => qth.pl} | 0 cmd/set/talk.pl | 0 cmd/set/wwv.pl | 0 cmd/show/ann.pl | 0 cmd/show/channel.pl | 30 ++++++++++++++ cmd/show/conf.pl | 0 cmd/show/debug.pl | 16 ++++++++ cmd/show/talk.pl | 0 cmd/show/user | 18 --------- cmd/show/user.pl | 32 +++++++++++++++ cmd/show/users.pl | 0 cmd/show/version.pl | 0 cmd/show/wwv.pl | 0 cmd/show/wx.pl | 0 cmd/shutdown | 6 --- cmd/shutdown.pl | 10 +++++ cmd/talk.pl | 0 cmd/unset/announce.pl | 0 cmd/unset/debug.pl | 15 +++++++ cmd/unset/dx.pl | 0 cmd/unset/here.pl | 0 cmd/unset/talk.pl | 0 cmd/unset/wwv.pl | 0 cmd/wwv.pl | 0 perl/DXChannel.pm | 44 ++++++++++++++------ perl/DXCommandmode.pm | 21 +++++++--- perl/DXM.pm | 2 + perl/DXProt.pm | 12 ++++++ perl/DXUser.pm | 4 +- perl/DXVars.pm | 2 +- perl/client.pl | 32 +++++++-------- perl/cluster.pl | 35 +++++++++++++--- perl/create_sysop.pl | 2 +- 51 files changed, 318 insertions(+), 67 deletions(-) create mode 100644 cmd/Notes.txt create mode 100644 cmd/announce.pl rename cmd/{bye => bye.pl} (100%) create mode 100644 cmd/create/node.pl create mode 100644 cmd/create/user.pl create mode 100644 cmd/delete/node.pl create mode 100644 cmd/delete/user.pl create mode 100644 cmd/dx.pl create mode 100644 cmd/set/address.pl create mode 100644 cmd/set/announce.pl create mode 100644 cmd/set/debug.pl create mode 100644 cmd/set/dx.pl create mode 100644 cmd/set/email.pl create mode 100644 cmd/set/here.pl create mode 100644 cmd/set/homenode.pl create mode 100644 cmd/set/location.pl create mode 100644 cmd/set/name.pl rename cmd/set/{qra => qra.pl} (100%) rename cmd/set/{qth => qth.pl} (100%) create mode 100644 cmd/set/talk.pl create mode 100644 cmd/set/wwv.pl create mode 100644 cmd/show/ann.pl create mode 100644 cmd/show/channel.pl create mode 100644 cmd/show/conf.pl create mode 100644 cmd/show/debug.pl create mode 100644 cmd/show/talk.pl delete mode 100644 cmd/show/user create mode 100644 cmd/show/user.pl create mode 100644 cmd/show/users.pl create mode 100644 cmd/show/version.pl create mode 100644 cmd/show/wwv.pl create mode 100644 cmd/show/wx.pl delete mode 100644 cmd/shutdown create mode 100644 cmd/shutdown.pl create mode 100644 cmd/talk.pl create mode 100644 cmd/unset/announce.pl create mode 100644 cmd/unset/debug.pl create mode 100644 cmd/unset/dx.pl create mode 100644 cmd/unset/here.pl create mode 100644 cmd/unset/talk.pl create mode 100644 cmd/unset/wwv.pl create mode 100644 cmd/wwv.pl diff --git a/cmd/Notes.txt b/cmd/Notes.txt new file mode 100644 index 00000000..3768d2c3 --- /dev/null +++ b/cmd/Notes.txt @@ -0,0 +1,89 @@ +Programming Notes ($Id$) + +* Every command that can used on the command line lives in either this + directory ('cmd') or in a local version ('local_cmd'). You are cajoled or + ordered not to and generally discouraged from altering the commands in + the 'cmd' directory. You can put local copies in the 'local_cmd' directory + and they will override the standard ones. + +* If you want to play, do it in the 'local_cmd' directory. It's very easy and + reasonably safe. You can override a command whilst the cluster is running. + Compilation errors will simply give you error messages, it won't stop the + cluster running - this only happens if you mess with the internals to the + extent that it gets confused... + +* A command is a piece of perl, it is simply a small snippet of program + that is dynamically loaded into the cluster on invocation from the + command line. The last modification time is used to determine whether to + reload it. + +* New (or altered) commands are available for test the moment you save them. + +* A command is placed into the appropriate directory with a '.pl' appended + to the end. So the 'show/qra' command lives in 'cmd/show/qra.pl' (or a + local version would be in 'local_cmd/show/qra.pl'. + +* For the security conscious, potentially dubious characters (i.e. not + [A-Za-z0-9_/]) are converted to their hex equivalents. This will almost + certainly mean that the user will get an error message (unless you have + your secret squirrel hat on and have deliberately put such commands up + [in 'local_cmd' of course]). + +* The snippets of program you put here are wrapped in an eval { } and + are subroutines derived from the DXChannel class. They effectively + the following declaration :- + + sub Emb_($self, $args) + { + ... + your code here + ... + } + +* slash characters are replaced by '_' so the equivalent name for 'show/qth' + is 'Emb_show_qth'. + +* you would normally do a 'my $self = shift;' as the first thing. There + are a complete set of accessors for DXUser, DXCommandmode and DXChannel + classes and these are the recommended way of getting at these classes. + A fairly standard start might be:- + + $self = shift; + $call = $self->call; + $user = $self->user; + +* $args is the rest of the line after the command (as a string). + +* You are responsible for maintaining user security. If you have a command + that does something a normal system shouldn't be allowed to do or see, + there is $self->priv (using the above example) which gives you the running + privilege level of the channel. USE IT! + +* The normal privilege levels are:- + 0 - user privilege. + 5 - sysop privilege. + 9 - console privilege. + + The sysop privilege is for things that you are prepared for remote + sysops and clusters to do or see. + + A console privilege can only be executed locally (at least if you have + correctly installed the client program in inetd or ax25d). + + The set/priv command can only be executed by a console privileged + session. + +* You must return a list with a 0 or 1 as the first element. 1 means + success and 0 means fail. Each element of the list which follows is + assumed to be one line for output. Don't put \n characters at the end + of an element (the client will put the correct one in if required + [but see below]). + +* Anything you output with a > as the last character is taken to mean + that this is a prompt and will not have a \r or \n appended to it. + +* help files can also be placed in the appropriate place. These files + have exactly the same naming conventions as commands except that they + have a '.hlp' appended to the command name rather than a '.pl'. All + in the help file are sent to the user except those starting with a '#' + character. diff --git a/cmd/announce.pl b/cmd/announce.pl new file mode 100644 index 00000000..e69de29b diff --git a/cmd/bye b/cmd/bye.pl similarity index 100% rename from cmd/bye rename to cmd/bye.pl diff --git a/cmd/create/node.pl b/cmd/create/node.pl new file mode 100644 index 00000000..e69de29b diff --git a/cmd/create/user.pl b/cmd/create/user.pl new file mode 100644 index 00000000..e69de29b diff --git a/cmd/delete/node.pl b/cmd/delete/node.pl new file mode 100644 index 00000000..e69de29b diff --git a/cmd/delete/user.pl b/cmd/delete/user.pl new file mode 100644 index 00000000..e69de29b diff --git a/cmd/dx.pl b/cmd/dx.pl new file mode 100644 index 00000000..e69de29b diff --git a/cmd/set/address.pl b/cmd/set/address.pl new file mode 100644 index 00000000..e69de29b diff --git a/cmd/set/announce.pl b/cmd/set/announce.pl new file mode 100644 index 00000000..e69de29b diff --git a/cmd/set/debug.pl b/cmd/set/debug.pl new file mode 100644 index 00000000..e5c4658b --- /dev/null +++ b/cmd/set/debug.pl @@ -0,0 +1,15 @@ +# +# add a debug level +# +# $Id$ +# + +use DXDebug; + +$self = shift; +return (0) if $self->priv < 9; + +dbgadd(split); +my $set = join ' ', dbglist(); + +return (1, "Debug Levels now: $set"); diff --git a/cmd/set/dx.pl b/cmd/set/dx.pl new file mode 100644 index 00000000..e69de29b diff --git a/cmd/set/email.pl b/cmd/set/email.pl new file mode 100644 index 00000000..e69de29b diff --git a/cmd/set/here.pl b/cmd/set/here.pl new file mode 100644 index 00000000..e69de29b diff --git a/cmd/set/homenode.pl b/cmd/set/homenode.pl new file mode 100644 index 00000000..e69de29b diff --git a/cmd/set/location.pl b/cmd/set/location.pl new file mode 100644 index 00000000..e69de29b diff --git a/cmd/set/name.pl b/cmd/set/name.pl new file mode 100644 index 00000000..e69de29b diff --git a/cmd/set/qra b/cmd/set/qra.pl similarity index 100% rename from cmd/set/qra rename to cmd/set/qra.pl diff --git a/cmd/set/qth b/cmd/set/qth.pl similarity index 100% rename from cmd/set/qth rename to cmd/set/qth.pl diff --git a/cmd/set/talk.pl b/cmd/set/talk.pl new file mode 100644 index 00000000..e69de29b diff --git a/cmd/set/wwv.pl b/cmd/set/wwv.pl new file mode 100644 index 00000000..e69de29b diff --git a/cmd/show/ann.pl b/cmd/show/ann.pl new file mode 100644 index 00000000..e69de29b diff --git a/cmd/show/channel.pl b/cmd/show/channel.pl new file mode 100644 index 00000000..4b4a7920 --- /dev/null +++ b/cmd/show/channel.pl @@ -0,0 +1,30 @@ +# +# show the channel status +# +# $Id$ +# + +my $self = shift; +#return (0) if ($self->priv < 9); # only console users allowed +my @list = split; # generate a list of callsigns +@list = ($self->call) if !@list; # my channel if no callsigns + +my $call; +my @out; +foreach $call (@list) { + my $ref = DXChannel->get($call); + return (0, "Channel: $call not found") if !$ref; + + my @fields = $ref->fields; + my $field; + push @out, "User Information $call"; + foreach $field (@fields) { + my $prompt = $ref->field_prompt($field); + my $val = $ref->{$field}; + push @out, "$prompt: $val"; + } +} + +return (1, @out); + + diff --git a/cmd/show/conf.pl b/cmd/show/conf.pl new file mode 100644 index 00000000..e69de29b diff --git a/cmd/show/debug.pl b/cmd/show/debug.pl new file mode 100644 index 00000000..0d560a4e --- /dev/null +++ b/cmd/show/debug.pl @@ -0,0 +1,16 @@ +# +# show the debug status +# +# $Id$ +# + +use DXDebug; + +my $self = shift; +#return (0) if ($self->priv < 9); # only console users allowed + +my $set = join ' ', dbglist(); # generate space delimited list + +return (1, "debug levels: $set"); + + diff --git a/cmd/show/talk.pl b/cmd/show/talk.pl new file mode 100644 index 00000000..e69de29b diff --git a/cmd/show/user b/cmd/show/user deleted file mode 100644 index eab5895d..00000000 --- a/cmd/show/user +++ /dev/null @@ -1,18 +0,0 @@ -# -# show either the current user or a nominated set -# -# $Id$ -# - -my $self = shift; -my @set = split; # the list of users you want listings (may be null) - -@set = ($self->call) if !@set; # my call if no args - -my ($call, $field); -my @fields = DXUser->fields(); -foreach $call (@set) { - my $user = DXUser->get($call); -} - - diff --git a/cmd/show/user.pl b/cmd/show/user.pl new file mode 100644 index 00000000..919fda66 --- /dev/null +++ b/cmd/show/user.pl @@ -0,0 +1,32 @@ +# +# show either the current user or a nominated set +# +# $Id$ +# + +my $self = shift; +#return (0) if ($self->priv < 9); # only console users allowed +my @list = split; # generate a list of callsigns +@list = ($self->call) if !@list; # my channel if no callsigns + +my $call; +my @out; +foreach $call (@list) { + my $ref = DXUser->get($call); + return (0, "User: $call not found") if !$ref; + + my @fields = $ref->fields; + my $field; + push @out, "User Information $call"; + foreach $field (@fields) { + my $prompt = $ref->field_prompt($field); + my $val = $ref->{$field}; + push @out, "$prompt: $val"; + } +} + +return (1, @out); + + + + diff --git a/cmd/show/users.pl b/cmd/show/users.pl new file mode 100644 index 00000000..e69de29b diff --git a/cmd/show/version.pl b/cmd/show/version.pl new file mode 100644 index 00000000..e69de29b diff --git a/cmd/show/wwv.pl b/cmd/show/wwv.pl new file mode 100644 index 00000000..e69de29b diff --git a/cmd/show/wx.pl b/cmd/show/wx.pl new file mode 100644 index 00000000..e69de29b diff --git a/cmd/shutdown b/cmd/shutdown deleted file mode 100644 index dea787a0..00000000 --- a/cmd/shutdown +++ /dev/null @@ -1,6 +0,0 @@ -# -# the shutdown command -# -# $Id$ -# -&main::cease(); diff --git a/cmd/shutdown.pl b/cmd/shutdown.pl new file mode 100644 index 00000000..43b6fb75 --- /dev/null +++ b/cmd/shutdown.pl @@ -0,0 +1,10 @@ +# +# the shutdown command +# +# $Id$ +# +my $self = shift; +if ($self->priv >= 5) { + &main::cease(); +} +return (0); diff --git a/cmd/talk.pl b/cmd/talk.pl new file mode 100644 index 00000000..e69de29b diff --git a/cmd/unset/announce.pl b/cmd/unset/announce.pl new file mode 100644 index 00000000..e69de29b diff --git a/cmd/unset/debug.pl b/cmd/unset/debug.pl new file mode 100644 index 00000000..78a82527 --- /dev/null +++ b/cmd/unset/debug.pl @@ -0,0 +1,15 @@ +# +# add a debug level +# +# $Id$ +# + +use DXDebug; + +$self = shift; +return (0) if $self->priv < 9; + +dbgsub(split); +my $set = join ' ', dbglist(); + +return (1, "Debug Levels now: $set"); diff --git a/cmd/unset/dx.pl b/cmd/unset/dx.pl new file mode 100644 index 00000000..e69de29b diff --git a/cmd/unset/here.pl b/cmd/unset/here.pl new file mode 100644 index 00000000..e69de29b diff --git a/cmd/unset/talk.pl b/cmd/unset/talk.pl new file mode 100644 index 00000000..e69de29b diff --git a/cmd/unset/wwv.pl b/cmd/unset/wwv.pl new file mode 100644 index 00000000..e69de29b diff --git a/cmd/wwv.pl b/cmd/wwv.pl new file mode 100644 index 00000000..e69de29b diff --git a/perl/DXChannel.pm b/perl/DXChannel.pm index 093bfb00..cfa3d150 100644 --- a/perl/DXChannel.pm +++ b/perl/DXChannel.pm @@ -28,6 +28,7 @@ package DXChannel; use Msg; use DXUtil; use DXM; +use DXDebug; %channels = undef; @@ -41,10 +42,11 @@ use DXM; oldstate => 'Last State', list => 'Dependant DXChannels list', name => 'User Name', + connsort => 'Connection Type' ); -# create a new connection object [$obj = DXChannel->new($call, $msg_conn_obj, $user_obj)] +# create a new channel object [$obj = DXChannel->new($call, $msg_conn_obj, $user_obj)] sub new { my ($pkg, $call, $conn, $user) = @_; @@ -61,21 +63,21 @@ sub new return $channels{$call} = $self; } -# obtain a connection object by callsign [$obj = DXChannel->get($call)] +# obtain a channel object by callsign [$obj = DXChannel->get($call)] sub get { my ($pkg, $call) = @_; - return $connect{$call}; + return $channels{$call}; } -# obtain all the connection objects +# obtain all the channel objects sub get_all { my ($pkg) = @_; return values(%channels); } -# obtain a connection object by searching for its connection reference +# obtain a channel object by searching for its connection reference sub get_by_cnum { my ($pkg, $conn) = @_; @@ -87,7 +89,7 @@ sub get_by_cnum return undef; } -# get rid of a connection object [$obj->del()] +# get rid of a channel object [$obj->del()] sub del { my $self = shift; @@ -115,10 +117,8 @@ sub send_now my $line; foreach $line (@_) { - my $t = atime; chomp $line; - print main::DEBUG "$t -> $sort $call $line\n" if defined DEBUG; - print "-> $sort $call $line\n"; + dbg('chan', "-> $sort $call $line\n"); $conn->send_now("$sort$call|$line"); } } @@ -144,10 +144,8 @@ sub send # this is always later and always data my $line; foreach $line (@_) { - my $t = atime; chomp $line; - print main::DEBUG "$t -> D $call $line\n" if defined DEBUG; - print "-> D $call $line\n"; + dbg('chan', "-> D $call $line\n"); $conn->send_later("D$call|$line"); } } @@ -180,10 +178,30 @@ sub state my $self = shift; $self->{oldstate} = $self->{state}; $self->{state} = shift; - print "Db $self->{call} channel state $self->{oldstate} -> $self->{state}\n" if $main::debug; + dbg('state', "$self->{call} channel state $self->{oldstate} -> $self->{state}\n"); } # various access routines + +# +# return a list of valid elements +# + +sub fields +{ + return keys(%valid); +} + +# +# return a prompt for a field +# + +sub field_prompt +{ + my ($self, $ele) = @_; + return $valid{$ele}; +} + sub AUTOLOAD { my $self = shift; diff --git a/perl/DXCommandmode.pm b/perl/DXCommandmode.pm index d8e1ac10..6a3603ab 100644 --- a/perl/DXCommandmode.pm +++ b/perl/DXCommandmode.pm @@ -15,6 +15,7 @@ use DXUtil; use DXChannel; use DXUser; use DXVars; +use DXDebug; use strict; use vars qw( %Cache $last_dir_mtime @cmd); @@ -28,16 +29,19 @@ $last_dir_mtime = 0; # the last time one of the cmd dirs was modified sub start { - my $self = shift; + my ($self, $line) = @_; my $user = $self->{user}; my $call = $self->{call}; my $name = $self->{name}; $name = $call if !defined $name; + $self->msg('l2',$name); $self->send_file($main::motd) if (-e $main::motd); $self->msg('pr', $call); $self->state('prompt'); # a bit of room for further expansion, passwords etc - $self->{priv} = 0; # set the connection priv to 0 - can be upgraded later + $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 } # @@ -162,7 +166,7 @@ sub eval_file { my $path = shift; my $cmdname = shift; my $package = valid_package_name($cmdname); - my $filename = "$path/$cmdname"; + my $filename = "$path/$cmdname.pl"; my $mtime = -M $filename; # return if we can't find it @@ -184,7 +188,14 @@ sub eval_file { #wrap the code into a subroutine inside our unique package my $eval = qq{package DXChannel; sub $package { $sub; }}; - print "eval $eval\n"; + if (isdbg('eval')) { + my @list = split /\n/, $eval; + my $line; + foreach (@list) { + dbg('eval', $_, "\n"); + } + } + #print "eval $eval\n"; { #hide our variables within this block my($filename,$mtime,$package,$sub); @@ -201,7 +212,7 @@ sub eval_file { my @r; my $c = qq{ \@r = \$self->$package(\@_); }; - print "c = $c\n"; + dbg('eval', "cluster cmd = $c\n"); eval $c; ; if ($@) { delete_package($package); diff --git a/perl/DXM.pm b/perl/DXM.pm index 435e32f9..9be30989 100644 --- a/perl/DXM.pm +++ b/perl/DXM.pm @@ -26,6 +26,8 @@ require Exporter; pr => '$_[0] de $main::mycall $main::cldate $main::ztime >', e1 => 'Invalid command', e2 => 'Error: $_[0]', + conother => 'Sorry $_[0] you are connected on another port', + concluster => 'Sorry $_[0] you are already connected elsewhere on the cluster', ); sub msg diff --git a/perl/DXProt.pm b/perl/DXProt.pm index f0a0a3b2..92e3b0d0 100644 --- a/perl/DXProt.pm +++ b/perl/DXProt.pm @@ -15,6 +15,7 @@ use DXUtil; use DXChannel; use DXUser; use DXM; +use DXCluster; # this is how a pc connection starts (for an incoming connection) # issue a PC38 followed by a PC18, then wait for a PC20 (remembering @@ -22,6 +23,13 @@ use DXM; sub start { my $self = shift; + my $call = $self->call; + + # do we have him connected on the cluster somewhere else? + if (DXCluster->get + $self->pc38(); + $self->pc18(); + $self->{state} = 'incoming'; } # @@ -48,6 +56,10 @@ sub finish { } + +# +# All the various PC routines +# 1; __END__ diff --git a/perl/DXUser.pm b/perl/DXUser.pm index 101340c8..f5f7e049 100644 --- a/perl/DXUser.pm +++ b/perl/DXUser.pm @@ -131,7 +131,7 @@ sub close # return a list of valid elements # -sub elements +sub fields { return keys(%valid); } @@ -140,7 +140,7 @@ sub elements # return a prompt for a field # -sub prompt +sub field_prompt { my ($self, $ele) = @_; return $valid{$ele}; diff --git a/perl/DXVars.pm b/perl/DXVars.pm index beab7953..39549e64 100644 --- a/perl/DXVars.pm +++ b/perl/DXVars.pm @@ -84,4 +84,4 @@ $userfn = "$data/users"; $motd = "$data/motd"; # are we debugging ? -$debug = 1; +@debug = ('chan'); diff --git a/perl/client.pl b/perl/client.pl index b2dcfa3a..c3efad34 100755 --- a/perl/client.pl +++ b/perl/client.pl @@ -20,11 +20,12 @@ BEGIN { use Msg; use DXVars; -$mode = 1; # 1 - \n = \r as EOL, 2 - \n = \n, 0 - transparent +$mode = 2; # 1 - \n = \r as EOL, 2 - \n = \n, 0 - transparent $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 +$mynl = "\n"; # standard terminator # cease communications sub cease @@ -45,16 +46,11 @@ sub sig_term sub setmode { if ($mode == 1) { - $nl = "\r"; + $mynl = "\r"; } else { - $nl = "\n"; - } - $/ = $nl; - if ($mode == 0) { - $\ = undef; - } else { - $\ = $nl; + $mynl = "\n"; } + $/ = $mynl; } # handle incoming messages @@ -68,9 +64,12 @@ sub rec_socket my ($sort, $call, $line) = $msg =~ /^(\w)(\S+)\|(.*)$/; if ($sort eq 'D') { - $nl = "" if $mode == 0; + my $snl = $mynl; + $snl = "" if $mode == 0; + $snl = ' ' if ($mode && $line =~ />$/); $line =~ s/\n/\r/og if $mode == 1; - print $line; + #my $p = qq($line$snl); + print $line, $snl; } elsif ($sort eq 'M') { $mode = $line; # set new mode from cluster setmode(); @@ -115,12 +114,13 @@ sub rec_stdin } } -$call = uc $ARGV[0]; -die "client.pl []\r\n" if (!$call); -$mode = $ARGV[1] if (@ARGV > 1); +$call = uc shift @ARGV; +$call = uc $mycall if !$call; +$connsort = lc shift @ARGV; +$connsort = 'local' if !$connsort; +$mode = ($connsort =~ /^ax/) ? 1 : 2; setmode(); - #select STDOUT; $| = 1; STDOUT->autoflush(1); @@ -129,7 +129,7 @@ $SIG{'TERM'} = \&sig_term; $SIG{'HUP'} = \&sig_term; $conn = Msg->connect("$clusteraddr", $clusterport, \&rec_socket); -$conn->send_now("A$call|start"); +$conn->send_now("A$call|$connsort"); Msg->set_event_handler(\*STDIN, "read" => \&rec_stdin); Msg->event_loop(); diff --git a/perl/cluster.pl b/perl/cluster.pl index 8da9fe00..435d0087 100755 --- a/perl/cluster.pl +++ b/perl/cluster.pl @@ -20,6 +20,8 @@ use DXUser; use DXM; use DXCommandmode; use DXProt; +use DXCluster; +use DXDebug; package main; @@ -57,6 +59,28 @@ sub rec $user = DXUser->new($call) if !defined $user; $user->sort('U') if (!$user->sort()); my $sort = $user->sort(); + + # 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"); + dbg('chan', "-> Z $call bye\n"); + $conn->send_now("Z$call|bye"); # this will cause 'client' to disconnect + return; + } + + # is there one already connected elsewhere in the cluster? + if (DXCluster->get($call)) { + my $mess = DXM::msg('concluster', $call); + dbg('chan', "-> D $call $mess\n"); + $conn->send_now("D$call|$mess"); + dbg('chan', "-> Z $call bye\n"); + $conn->send_now("Z$call|bye"); # this will cause 'client' to disconnect + return; + } + + # create the channel $dxchan = DXCommandmode->new($call, $conn, $user) if ($sort eq 'U'); $dxchan = DXProt->new($call, $conn, $user) if ($sort eq 'A'); die "Invalid sort of user on $call = $sort" if !$dxchan; @@ -98,8 +122,7 @@ sub process_inqueue my ($sort, $call, $line) = $data =~ /^(\w)(\S+)\|(.*)$/; # do the really sexy console interface bit! (Who is going to do the TK interface then?) - print DEBUG atime, " <- $sort $call $line\n" if defined DEBUG; - print "<- $sort $call $line\n"; + dbg('chan', "<- $sort $call $line\n"); # handle A records my $user = $dxchan->user; @@ -123,9 +146,11 @@ sub process_inqueue ############################################################# # open the debug file, set various FHs to be unbuffered -open(DEBUG, ">>$debugfn") or die "can't open $debugfn($!)"; -select DEBUG; $| = 1; -select STDOUT; $| = 1; +dbginit($debugfn); +foreach(@debug) { + dbgadd($_); +} +STDOUT->autoflush(1); # initialise User file system DXUser->init($userfn); diff --git a/perl/create_sysop.pl b/perl/create_sysop.pl index 43d59785..a08bb9ff 100755 --- a/perl/create_sysop.pl +++ b/perl/create_sysop.pl @@ -25,7 +25,7 @@ sub create_it $self->{long} = $mylongtitude; $self->{email} = $myemail; $self->{bbsaddr} = $mybbsaddr; - $self->{sort} = 'C'; # C - Console user, S - Spider cluster, A - AK1A, U - User, B - BBS + $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; -- 2.43.0