From 57b5e464bc44ae8eee23ab94c1f499f527595dc9 Mon Sep 17 00:00:00 2001 From: djk Date: Sat, 3 Oct 1998 22:30:56 +0000 Subject: [PATCH] a mostly working send message implementation also added set privilege debug sb sp --- INSTALL | 6 +- cmd/debug.pl | 15 +++ cmd/disconnect.pl | 7 +- cmd/kill.pl | 2 + cmd/sb.pl | 11 ++ cmd/send.pl | 105 +++++++++++++++ cmd/set/privilege.pl | 36 ++++++ cmd/show/dx.pl | 4 +- cmd/sp.pl | 11 ++ perl/DXChannel.pm | 16 ++- perl/DXCluster.pm | 2 +- perl/DXCommandmode.pm | 183 +++++++++++++++++--------- perl/DXDebug.pm | 1 + perl/DXM.pm | 10 +- perl/DXMsg.pm | 295 ++++++++++++++++++++++++++++++++++++++---- perl/DXProt.pm | 75 ++++++++--- perl/DXProtout.pm | 46 ++++++- perl/DXUtil.pm | 1 + perl/DXVars.pm | 2 +- perl/Julian.pm | 1 + perl/Prefix.pm | 1 + perl/Spot.pm | 50 +++++-- perl/client.pl | 7 +- perl/cluster.pl | 12 +- 24 files changed, 747 insertions(+), 152 deletions(-) create mode 100644 cmd/debug.pl create mode 100644 cmd/sb.pl create mode 100644 cmd/set/privilege.pl create mode 100644 cmd/sp.pl diff --git a/INSTALL b/INSTALL index 3a5dc6ed..9180e36d 100644 --- a/INSTALL +++ b/INSTALL @@ -62,10 +62,12 @@ the following modules:- users with useradd -m . Alter the default .bashrc so that it contains just one line (assuming you use the default bash shell). - exec /spider/perl/client.pl + exec /spider/perl/client.pl telnet Don't forget to give them a real password. This is really for network - cluster logins + cluster logins. The telnet argument does two things, it sets the EOL + convention to \n rather than AX25's \r and it automatically reduces + the privilege of the to a 'safe[r]' level. 7) for incoming AX25 connections you are expected to have got the AX25 utilities setup, tested and working. See the AX25-HOWTO for more info diff --git a/cmd/debug.pl b/cmd/debug.pl new file mode 100644 index 00000000..608f1daf --- /dev/null +++ b/cmd/debug.pl @@ -0,0 +1,15 @@ +# +# go INSTANTLY into debug mode (if you are in the debugger!) +# +# remember perl -d cluster.pl to use this +# +# Copyright (c) 1998 Dirk Koopman G1TLH +# +# $Id$ +# + +my $self = shift; +return if $self->priv < 9; + +$DB::single = 1; + diff --git a/cmd/disconnect.pl b/cmd/disconnect.pl index 6154d3cc..32cb543f 100644 --- a/cmd/disconnect.pl +++ b/cmd/disconnect.pl @@ -12,13 +12,14 @@ if ($self->priv < 9) { foreach $call (@calls) { $call = uc $call; + next if $call eq $main::mycall; my $dxchan = DXChannel->get($call); if ($dxchan) { if ($dxchan->is_ak1a) { - $dxchan->send_now("D", $self->pc39('Disconnected')); - } else { + $dxchan->send_now("D", DXProt::pc39($dxchan->call, 'Disconnected')); + } else { $dxchan->disconnect; - } + } push @out, "disconnected $call"; } else { push @out, "$call not connected locally"; diff --git a/cmd/kill.pl b/cmd/kill.pl index 0d787dd6..b410bc14 100644 --- a/cmd/kill.pl +++ b/cmd/kill.pl @@ -13,6 +13,8 @@ my @out; my @body; my $ref; +# $DB::single = 1; + for $msgno (@f) { $ref = DXMsg::get($msgno); if (!$ref) { diff --git a/cmd/sb.pl b/cmd/sb.pl new file mode 100644 index 00000000..c228037d --- /dev/null +++ b/cmd/sb.pl @@ -0,0 +1,11 @@ +# +# synonym for send or SP send private +# +# Copyright (c) 1998 Dirk Koopman G1TLH +# +# $Id$ +# + +my $ref = DXCommandmode::find_cmd_ref('send'); +return ( &{$ref}(@_) ) if $ref; +return (0,()); diff --git a/cmd/send.pl b/cmd/send.pl index aabf2172..8667d0cc 100644 --- a/cmd/send.pl +++ b/cmd/send.pl @@ -1,7 +1,112 @@ # # send a message # +# this should handle +# +# send [ .. ] +# send private [ .. ] +# send private rr [ .. ] +# send rr [ .. ] +# send noprivate [ .. ] +# send b [ .. ] +# send copy [ .. ] +# send copy rr [ .. ] +# # Copyright (c) Dirk Koopman G1TLH # # $Id$ # +my ($self, $line) = @_; +my @out; +my $loc; + +#$DB::single = 1; + +if ($self->state eq "prompt") { + + my @f = split /\s+/, $line; + + $f[0] = uc $f[0]; + + # first deal with copies + if ($f[0] eq 'C' || $f[0] eq 'CC' || $f[0] eq 'COPY') { + my $i = 1; + my $rr = '0'; + if (uc $f[$i] eq 'RR') { + $rr = '1'; + $i++; + } + my $oref = DXMsg::get($f[$i]); + #return (0, $self->msg('esend1', $f[$i])) if !$oref; + #return (0, $self->msg('esend2')) if $i+1 > @f; + return (0, "msgno $f[$i] not found") if !$oref; + return (0, "need a callsign") if $i+1 > @f; + + # separate copy to everyone listed + for ($i++ ; $i < @f; $i++) { + my $msgno = DXMsg::next_transno('Msgno'); + my $newsubj = "CC: " . $oref->subject; + my $nref = DXMsg->alloc($msgno, + uc $f[$i], + $self->call, + $main::systime, + '1', + $newsubj, + $main::mycall, $rr); + my @list; + my $from = $oref->from; + my $to = $oref->to; + my $date = cldate($oref->t); + my $time = ztime($oref->t); + my $buf = "Original from: $from To: $to Date: $date $time"; + push @list, $buf; + push @list, $oref->read_msg_body(); + $nref->store(\@list); + $nref->add_dir(); + #push @out, $self->msg('sendcc', $oref->msgno, $f[$i]); + push @out, "copy of msg $oref->{msgno} sent to $to"; + } + DXMsg::queue_msg(); + return (1, @out); + } + + # now deal with real message inputs + # parse out send line for various possibilities + $loc = $self->{loc} = {}; + + my $i = 0; + $f[0] = uc $f[0]; + $loc->{private} = '1'; + if ($f[0] eq 'B' || $f[0] =~ /^NOP/oi) { + $loc->{private} = '0'; + $i += 1; + } elsif ($f[0] eq 'P' || $f[0] =~ /^PRI/oi) { + $i += 1; + } + + $loc->{rrreq} = '0'; + if (uc $f[$i] eq 'RR') { + $loc->{rrreq} = '1'; + $i++; + } + + # check we have some callsigns + if ($i > @f) { + delete $self->{loc}; + #return (0, $self->msg('esend2')); + return (0, "need a callsign"); + } + + # now save all the 'to' callsigns for later + my @to = @f[ $i..$#f ]; + $loc->{to} = \@to; + + # find me and set the state and the function on my state variable to + # keep calling me for every line until I relinquish control + $self->func("DXMsg::do_send_stuff"); + $self->state('send1'); + #push @out, $self->msg('sendsubj'); + push @out, "Enter Subject (30 characters) >"; +} + +return (1, @out); diff --git a/cmd/set/privilege.pl b/cmd/set/privilege.pl new file mode 100644 index 00000000..87be2aa8 --- /dev/null +++ b/cmd/set/privilege.pl @@ -0,0 +1,36 @@ +# +# set the privilege of the user +# +# call as set/priv n ... +# +# Copyright (c) 1998 Dirk Koopman G1TLH +# +# $Id$ +# +my ($self, $line) = @_; +my @args = split /\s+/, $line; +my $call; +my $priv = shift @args; +my @out; +my $user; + +$DB::single = 1; + +return (0) if $self->priv < 9; + +if ($priv < 0 || $priv > 9) { + return (0, $self->msg('e5')); +} + +foreach $call (@args) { + $call = uc $call; + my $user = DXUser->get_current($call); + if ($user) { + $user->priv($priv); + $user->put(); + push @out, $self->msg('priv', $call); + } else { + push @out, $self->msg('e3', "Set Privilege", $call); + } +} +return (1, @out); diff --git a/cmd/show/dx.pl b/cmd/show/dx.pl index fe2bf636..42fb646c 100644 --- a/cmd/show/dx.pl +++ b/cmd/show/dx.pl @@ -108,9 +108,7 @@ my $ref; my @dx; foreach $ref (@res) { @dx = @$ref; - my $t = ztime($dx[2]); - my $d = cldate($dx[2]); - push @out, sprintf "%9s %-12s %s %s %-28s <%s>", $dx[0], $dx[1], $d, $t, $dx[3], $dx[4]; + push @out, Spot::formatl(@dx); } return (1, @out); diff --git a/cmd/sp.pl b/cmd/sp.pl new file mode 100644 index 00000000..c228037d --- /dev/null +++ b/cmd/sp.pl @@ -0,0 +1,11 @@ +# +# synonym for send or SP send private +# +# Copyright (c) 1998 Dirk Koopman G1TLH +# +# $Id$ +# + +my $ref = DXCommandmode::find_cmd_ref('send'); +return ( &{$ref}(@_) ) if $ref; +return (0,()); diff --git a/perl/DXChannel.pm b/perl/DXChannel.pm index d21497bd..6ca2fc2c 100644 --- a/perl/DXChannel.pm +++ b/perl/DXChannel.pm @@ -26,8 +26,8 @@ package DXChannel; use Msg; -use DXUtil; use DXM; +use DXUtil; use DXDebug; use Carp; @@ -59,6 +59,7 @@ use vars qw(%channels %valid); redirect => '0,Redirect messages to', lang => '0,Language', func => '9,Function', + loc => '9,Local Vars', # used by func to store local variables in ); # create a new channel object [$obj = DXChannel->new($call, $msg_conn_obj, $user_obj)] @@ -182,20 +183,23 @@ sub send_file $self->send(@buf); } -# just a shortcut for $dxchan->send(msg(...)); +# this will implement language independence (in time) sub msg { my $self = shift; - $self->send(DXM::msg(@_)); + return DXM::msg(@_); } # change the state of the channel - lots of scope for debugging here :-) sub state { my $self = shift; - $self->{oldstate} = $self->{state}; - $self->{state} = shift; - dbg('state', "$self->{call} channel func $self->{func} state $self->{oldstate} -> $self->{state}\n"); + if (@_) { + $self->{oldstate} = $self->{state}; + $self->{state} = shift; + dbg('state', "$self->{call} channel func $self->{func} state $self->{oldstate} -> $self->{state}\n"); + } + return $self->{state}; } # disconnect this channel diff --git a/perl/DXCluster.pm b/perl/DXCluster.pm index 3269073a..98ceafa9 100644 --- a/perl/DXCluster.pm +++ b/perl/DXCluster.pm @@ -16,8 +16,8 @@ package DXCluster; use Exporter; @ISA = qw(Exporter); -use Carp; use DXDebug; +use Carp; use strict; use vars qw(%cluster %valid); diff --git a/perl/DXCommandmode.pm b/perl/DXCommandmode.pm index b51d9c4c..024ccb0e 100644 --- a/perl/DXCommandmode.pm +++ b/perl/DXCommandmode.pm @@ -17,14 +17,15 @@ use DXUser; use DXVars; use DXDebug; use DXM; +use FileHandle; use Carp; use strict; -use vars qw(%Cache %cmd_cache); +use vars qw(%Cache %cmd_cache $errstr); %Cache = (); # cache of dynamically loaded routine's mod times %cmd_cache = (); # cache of short names - +$errstr = (); # error string from eval # # obtain a new connection this is derived from dxchannel # @@ -48,9 +49,9 @@ sub start my $name = $user->{name}; $self->{name} = $name ? $name : $call; - $self->msg('l2',$self->{name}); + $self->send($self->msg('l2',$self->{name})); $self->send_file($main::motd) if (-e $main::motd); - $self->msg('pr', $call); + $self->send($self->msg('pr', $call)); $self->state('prompt'); # a bit of room for further expansion, passwords etc $self->{priv} = $user->priv; $self->{lang} = $user->lang; @@ -59,7 +60,7 @@ sub start # set some necessary flags on the user if they are connecting $self->{wwv} = $self->{talk} = $self->{ann} = $self->{here} = $self->{dx} = 1; - $self->prompt() if $self->{state} =~ /^prompt/o; +# $self->prompt() if $self->{state} =~ /^prompt/o; # add yourself to the database my $node = DXNode->get($main::mycall) or die "$main::mycall not allocated in DXNode database"; @@ -81,36 +82,64 @@ sub normal my $user = $self->{user}; my $call = $self->{call}; my $cmdline = shift; + my @ans; + + # are we in stored state? + if ($self->{func}) { + my $c = qq{ \@ans = $self->{func}(\$self, \$cmdline) }; + dbg('eval', "stored func cmd = $c\n"); + eval $c; + if ($@) { + return (1, "Syserr: Eval err $errstr on stored func $self->{func}"); + } + } else { - # strip out // - $cmdline =~ s|//|/|og; + # special case only \n input => " " + if ($cmdline eq " ") { + $self->prompt(); + return; + } + + # strip out // + $cmdline =~ s|//|/|og; - # split the command line up into parts, the first part is the command - my ($cmd, $args) = $cmdline =~ /^([\w\/]+)\s*(.*)/o; + # split the command line up into parts, the first part is the command + my ($cmd, $args) = $cmdline =~ /^([\w\/]+)\s*(.*)/o; - if ($cmd) { + if ($cmd) { - my ($path, $fcmd); + my ($path, $fcmd); - # first expand out the entry to a command - ($path, $fcmd) = search($main::localcmd, $cmd, "pl"); - ($path, $fcmd) = search($main::cmd, $cmd, "pl") if !$path || !$fcmd; - - my @ans = $self->eval_file($path, $fcmd, $args) if $path && $fcmd; -# @ans = $self->eval_file($main::cmd, $cmd, $args) if !$ans[0]; - if ($ans[0]) { - shift @ans; - $self->send(@ans) if @ans > 0; - } else { - shift @ans; - if (@ans > 0) { - $self->msg('e2', @ans); - } else { - $self->msg('e1'); + # first expand out the entry to a command + ($path, $fcmd) = search($main::localcmd, $cmd, "pl"); + ($path, $fcmd) = search($main::cmd, $cmd, "pl") if !$path || !$fcmd; + + my $package = find_cmd_name($path, $fcmd); + @ans = (0, "Syserr: compile err on $package\n$@$errstr") if !$package ; + + if ($package) { + my $c = qq{ \@ans = $package(\$self, \$args) }; + dbg('eval', "cluster cmd = $c\n"); + eval $c; + if ($@) { + @ans = (0, "Syserr: Eval err cached $package\n$@"); + } } } + } + +# my @ans = $self->eval_file($path, $fcmd, $args) if $path && $fcmd; +# @ans = $self->eval_file($main::cmd, $cmd, $args) if !$ans[0]; + if ($ans[0]) { + shift @ans; + $self->send(@ans) if @ans > 0; } else { - $self->msg('e1'); + shift @ans; + if (@ans > 0) { + $self->send($self->msg('e2', @ans)); + } else { + $self->send($self->msg('e1')); + } } # send a prompt only if we are in a prompt state @@ -168,7 +197,8 @@ sub prompt { my $self = shift; my $call = $self->{call}; - DXChannel::msg($self, 'pr', $call); + $self->send($self->msg('pr', $call)); + #DXChannel::msg($self, 'pr', $call); } # broadcast a message to all users [except those mentioned after buffer] @@ -286,7 +316,7 @@ sub valid_package_name { $string =~ s|/(\d)|sprintf("/_%2x",unpack("C",$1))|eg; #Dress it up as a real package name - $string =~ s|/|_|g; + $string =~ s/\//_/og; return "Emb_" . $string; } @@ -296,16 +326,43 @@ sub delete_package { my ($stem, $leaf); no strict 'refs'; - $pkg = "DXChannel::$pkg\::"; # expand to full symbol table name + $pkg = "DXCommandmode::$pkg\::"; # expand to full symbol table name ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/; - - my $stem_symtab = *{$stem}{HASH}; - - delete $stem_symtab->{$leaf}; + + if ($stem && $leaf) { + my $stem_symtab = *{$stem}{HASH}; + delete $stem_symtab->{$leaf}; + } } -sub eval_file { - my $self = shift; +# find a cmd reference +# this is really for use in user written stubs +# +# use the result as a symbolic reference:- +# +# no strict 'refs'; +# @out = &$r($self, $line); +# +sub find_cmd_ref +{ + my $cmd = shift; + my $r; + + if ($cmd) { + + # first expand out the entry to a command + my ($path, $fcmd) = search($main::localcmd, $cmd, "pl"); + ($path, $fcmd) = search($main::cmd, $cmd, "pl") if !$path || !$fcmd; + + # make sure it is loaded + $r = find_cmd_name($path, $fcmd); + } + return $r; +} + +# +# this bit of magic finds a command in the offered directory +sub find_cmd_name { my $path = shift; my $cmdname = shift; my $package = valid_package_name($cmdname); @@ -313,7 +370,11 @@ sub eval_file { my $mtime = -M $filename; # return if we can't find it - return (0, DXM::msg('e1')) if !defined $mtime; + $errstr = undef; + if (undef $mtime) { + $errstr = DXM::msg('e1'); + return undef; + } if(defined $Cache{$package}{mtime} && $Cache{$package}{mtime } <= $mtime) { #we have compiled this subroutine already, @@ -321,50 +382,50 @@ sub eval_file { #print STDERR "already compiled $package->handler\n"; ; } else { - local *FH; - if (!open FH, $filename) { - return (0, "Syserr: can't open '$filename' $!"); + my $fh = new FileHandle; + if (!open $fh, $filename) { + $errstr = "Syserr: can't open '$filename' $!"; }; - local($/) = undef; - my $sub = ; - close FH; + my $old = $fh->input_record_separator(undef); + my $sub = <$fh>; + $fh->input_record_separator($old); + close $fh; #wrap the code into a subroutine inside our unique package - my $eval = qq{package DXChannel; sub $package { $sub; }}; + my $eval = qq{ + sub $package + { + $sub + } }; + if (isdbg('eval')) { my @list = split /\n/, $eval; my $line; - foreach (@list) { + for (@list) { dbg('eval', $_, "\n"); } } - #print "eval $eval\n"; + { #hide our variables within this block my($filename,$mtime,$package,$sub); eval $eval; } + if ($@) { + print "\$\@ = $@"; + $errstr = $@; delete_package($package); - return (1, "Syserr: Eval err $@ on $package"); + $package = undef; + } else { + #cache it unless we're cleaning out each time + $Cache{$package}{mtime} = $mtime; } - - #cache it unless we're cleaning out each time - $Cache{$package}{mtime} = $mtime; } - my @r; - my $c = qq{ \@r = \$self->$package(\@_); }; - dbg('eval', "cluster cmd = $c\n"); - eval $c; - if ($@) { - delete_package($package); - return (1, "Syserr: Eval err $@ on cached $package"); - } - - #take a look if you want #print Devel::Symdump->rnew($package)->as_string, $/; - return @r; + $package = "DXCommandmode::$package" if $package; + return $package; } 1; diff --git a/perl/DXDebug.pm b/perl/DXDebug.pm index bc53457f..084401ed 100644 --- a/perl/DXDebug.pm +++ b/perl/DXDebug.pm @@ -18,6 +18,7 @@ use vars qw(%dbglevel $dbgfh); use FileHandle; use DXUtil; +use Carp; %dbglevel = (); $dbgfh = ""; diff --git a/perl/DXM.pm b/perl/DXM.pm index e92f9f7a..64602a26 100644 --- a/perl/DXM.pm +++ b/perl/DXM.pm @@ -16,9 +16,7 @@ package DXM; -require Exporter; -@ISA = qw(Exporter); -@EXPORT = qw(msg); +use DXVars; %msgs = ( addr => 'Address set to: $_[0]', @@ -32,6 +30,7 @@ require Exporter; e2 => 'Error: $_[0]', e3 => '$_[0]: $_[1] not found', e4 => 'Need at least a prefix or callsign', + e5 => 'Not Allowed', email => 'E-mail address set to: $_[0]', heres => 'Here set on $_[0]', hereu => 'Here unset on $_[0]', @@ -43,6 +42,7 @@ require Exporter; 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 >', + priv => 'Privilege level changed on $_[0]', prx => '$main::$mycall >', talks => 'Talk flag set on $_[0]', talku => 'Talk flag unset on $_[0]', @@ -55,6 +55,8 @@ sub msg my $self = shift; my $s = $msgs{$self}; return "unknown message '$self'" if !defined $s; - return eval qq("$s"); + my $ans = eval qq{ "$s" }; + confess $@ if $@; + return $ans; } diff --git a/perl/DXMsg.pm b/perl/DXMsg.pm index f916ff54..9c032ba5 100644 --- a/perl/DXMsg.pm +++ b/perl/DXMsg.pm @@ -23,10 +23,11 @@ use FileHandle; use Carp; use strict; -use vars qw(%work @msg $msgdir %valid); +use vars qw(%work @msg $msgdir %valid %busy); %work = (); # outstanding jobs @msg = (); # messages we have +%busy = (); # station interlocks $msgdir = "$main::root/msg"; # directory contain the msgs %valid = ( @@ -65,6 +66,7 @@ sub alloc $self->{subject} = shift; $self->{origin} = shift; $self->{read} = shift; + $self->{gotit} = []; return $self; } @@ -92,7 +94,7 @@ sub process if ($pcno == 28) { # incoming message my $t = cltounix($f[5], $f[6]); my $stream = next_transno($f[2]); - my $ref = DXMsg->alloc($stream, $f[3], $f[4], $t, $f[7], $f[8], $f[13], '0'); + my $ref = DXMsg->alloc($stream, $f[3], $f[4], $t, $f[7], $f[8], $f[13], '0', $f[11]); # fill in various forwarding state variables $ref->{fromnode} = $f[2]; @@ -102,13 +104,14 @@ sub process $ref->{stream} = $stream; $ref->{count} = 0; # no of lines between PC31s dbg('msg', "new message from $f[4] to $f[3] '$f[8]' stream $stream\n"); - $work{"$f[1]$f[2]$stream"} = $ref; # store in work + $work{"$f[2]$stream"} = $ref; # store in work + $busy{$f[2]} = $ref; # set interlock $self->send(DXProt::pc30($f[2], $f[1], $stream)); # send ack last SWITCH; } if ($pcno == 29) { # incoming text - my $ref = $work{"$f[1]$f[2]$f[3]"}; + my $ref = $work{"$f[2]$f[3]"}; if ($ref) { push @{$ref->{lines}}, $f[4]; $ref->{count}++; @@ -121,35 +124,72 @@ sub process last SWITCH; } - if ($pcno == 30) { + if ($pcno == 30) { # this is a incoming subject ack + my $ref = $work{$f[2]}; # note no stream at this stage + delete $work{$f[2]}; + $ref->{stream} = $f[3]; + $ref->{count} = 0; + $ref->{linesreq} = 5; + $work{"$f[2]$f[3]"} = $ref; # new ref + dbg('msg', "incoming subject ack stream $[3]\n"); + $busy{$f[2]} = $ref; # interlock + $ref->{lines} = []; + push @{$ref->{lines}}, ($ref->read_msg_body); + $ref->send_tranche($self); last SWITCH; } - if ($pcno == 31) { + if ($pcno == 31) { # acknowledge a tranche of lines + my $ref = $work{"$f[2]$f[3]"}; + if ($ref) { + dbg('msg', "tranche ack stream $f[3]\n"); + $ref->send_tranche($self); + } else { + $self->send(DXProt::pc42($f[2], $f[1], $f[3])); # unknown stream + } last SWITCH; } if ($pcno == 32) { # incoming EOM dbg('msg', "stream $f[3]: EOM received\n"); - my $ref = $work{"$f[1]$f[2]$f[3]"}; + my $ref = $work{"$f[2]$f[3]"}; if ($ref) { $self->send(DXProt::pc33($f[2], $f[1], $f[3]));# acknowledge it # get the next msg no - note that this has NOTHING to do with the stream number in PC protocol - # store the file or message - # remove extraneous rubbish from the hash - # remove it from the work in progress vector - # stuff it on the msg queue - $ref->{msgno} = next_transno("Msgno") if !$ref->{file}; - $ref->store($ref->{lines}); - $ref->workclean; - delete $work{"$f[1]$f[2]$f[3]"}; - push @msg, $ref; + # store the file or message + # remove extraneous rubbish from the hash + # remove it from the work in progress vector + # stuff it on the msg queue + if ($ref->{lines} && @{$ref->{lines}} > 0) { # ignore messages with 0 lines + $ref->{msgno} = next_transno("Msgno") if !$ref->{file}; + push @{$ref->{gotit}}, $f[2]; # mark this up as being received + $ref->store($ref->{lines}); + add_dir($ref); + } + $ref->stop_msg($self); + queue_msg(); + } else { + $self->send(DXProt::pc42($f[2], $f[1], $f[3])); # unknown stream } + queue_msg(); last SWITCH; } - if ($pcno == 33) { + if ($pcno == 33) { # acknowledge the end of message + my $ref = $work{"$f[2]$f[3]"}; + if ($ref) { + if ($ref->{private}) { # remove it if it private and gone off site# + $ref->del_msg; + } else { + push @{$ref->{gotit}}, $f[2]; # mark this up as being received + $ref->store($ref->{lines}); # re- store the file + } + $ref->stop_msg($self); + } else { + $self->send(DXProt::pc42($f[2], $f[1], $f[3])); # unknown stream + } + queue_msg(); last SWITCH; } @@ -172,7 +212,7 @@ sub process dbg('msg', "created directory $fn\n"); } my $stream = next_transno($f[2]); - my $ref = DXMsg->alloc($stream, "$main::root/$f[3]", $self->call, time, !$f[4], $f[3], ' ', '0'); + my $ref = DXMsg->alloc($stream, "$main::root/$f[3]", $self->call, time, !$f[4], $f[3], ' ', '0', '0'); # forwarding variables $ref->{fromnode} = $f[1]; @@ -181,23 +221,36 @@ sub process $ref->{stream} = $stream; $ref->{count} = 0; # no of lines between PC31s $ref->{file} = 1; - $work{"$f[1]$f[2]$stream"} = $ref; # store in work + $work{"$f[2]$stream"} = $ref; # store in work $self->send(DXProt::pc30($f[2], $f[1], $stream)); # send ack last SWITCH; } + + if ($pcno == 42) { # abort transfer + dbg('msg', "stream $f[3]: abort received\n"); + my $ref = $work{"$f[2]$f[3]"}; + if ($ref) { + $ref->stop_msg($self); + $ref = undef; + } + + last SWITCH; + } } } # store a message away on disc or whatever +# +# NOTE the second arg is a REFERENCE not a list sub store { my $ref = shift; my $lines = shift; # we only proceed if there are actually any lines in the file - if (@{$lines} == 0) { + if (!$lines || @{$lines} == 0) { return; } @@ -222,19 +275,20 @@ sub store my $fn = filename($ref->{msgno}); dbg('msg', "To be stored in $fn\n"); - + + # now save the file, overwriting what's there, YES I KNOW OK! (I will change it if it's a problem) my $fh = new FileHandle "$fn", "w"; if (defined $fh) { - print $fh "=== $ref->{msgno}^$ref->{to}^$ref->{from}^$ref->{t}^$ref->{private}^$ref->{subject}^$ref->{origin}^$ref->{read}\n"; - print $fh "=== $ref->{fromnode}\n"; + my $rr = $ref->{rrreq} ? '1' : '0'; + my $priv = $ref->{private} ? '1': '0'; + print $fh "=== $ref->{msgno}^$ref->{to}^$ref->{from}^$ref->{t}^$priv^$ref->{subject}^$ref->{origin}^$ref->{read}^$rr\n"; + print $fh "=== ", join('^', @{$ref->{gotit}}), "\n"; my $line; $ref->{size} = 0; foreach $line (@{$lines}) { $ref->{size} += (length $line) + 1; print $fh "$line\n"; } - $ref->{gotit} = []; - push @{$ref->{gotit}}, $ref->{fromnode} if $ref->{fromnode}; $fh->close; dbg('msg', "msg $ref->{msgno} stored\n"); } else { @@ -251,8 +305,13 @@ sub del_msg # remove it from the active message list @msg = map { $_ != $self ? $_ : () } @msg; + # belt and braces (one day I will ask someone if this is REALLY necessary) + delete $self->{gotit}; + delete $self->{list}; + # remove the file unlink filename($self->{msgno}); + dbg('msg', "deleting $self->{msgno}\n"); } # read in a message header @@ -292,7 +351,7 @@ sub read_msg_header $line =~ s/^=== //o; $ref->{gotit} = []; @f = split /\^/, $line; - push @{$ref->{goit}}, @f; + push @{$ref->{gotit}}, @f; $ref->{size} = $size; close($file); @@ -323,6 +382,116 @@ sub read_msg_body return @out; } +# send a tranche of lines to the other end +sub send_tranche +{ + my ($self, $dxchan) = @_; + my @out; + my $to = $self->{tonode}; + my $from = $self->{fromnode}; + my $stream = $self->{stream}; + my $i; + + for ($i = 0; $i < $self->{linesreq} && $self->{count} < @{$self->{lines}}; $i++, $self->{count}++) { + push @out, DXProt::pc29($to, $from, $stream, ${$self->{lines}}[$self->{count}]); + } + push @out, DXProt::pc32($to, $from, $stream) if $i < $self->{linesreq}; + $dxchan->send(@out); +} + + +# find a message to send out and start the ball rolling +sub queue_msg +{ + my $sort = shift; + my @nodelist = DXProt::get_all_ak1a(); + my $ref; + my $clref; + my $dxchan; + + # bat down the message list looking for one that needs to go off site and whose + # nearest node is not busy. + + dbg('msg', "queue msg ($sort)\n"); + foreach $ref (@msg) { + # firstly, is it private and unread? if so can I find the recipient + # in my cluster node list offsite? + if ($ref->{private}) { + if ($ref->{read} == 0) { + $clref = DXCluster->get($ref->{to}); + if ($clref && !grep { $clref->{dxchan} == $_ } DXCommandmode::get_all) { + $dxchan = $clref->{dxchan}; + $ref->start_msg($dxchan) if $clref && !get_busy($dxchan->call); + } + } + } elsif ($sort == undef) { + # otherwise we are dealing with a bulletin, compare the gotit list with + # the nodelist up above, if there are sites that haven't got it yet + # then start sending it - what happens when we get loops is anyone's + # guess, use (to, from, time, subject) tuple? + my $noderef; + foreach $noderef (@nodelist) { + next if $noderef->call eq $main::mycall; + next if grep { $_ eq $noderef->call } @{$ref->{gotit}}; + + # if we are here we have a node that doesn't have this message + $ref->start_msg($noderef) if !get_busy($noderef->call); + last; + } + } + + # if all the available nodes are busy then stop + last if @nodelist == scalar grep { get_busy($_->call) } @nodelist; + } +} + +# start the message off on its travels with a PC28 +sub start_msg +{ + my ($self, $dxchan) = @_; + + dbg('msg', "start msg $self->{msgno}\n"); + $self->{linesreq} = 5; + $self->{count} = 0; + $self->{tonode} = $dxchan->call; + $self->{fromnode} = $main::mycall; + $busy{$dxchan->call} = $self; + $work{"$self->{tonode}"} = $self; + $dxchan->send(DXProt::pc28($self->{tonode}, $self->{fromnode}, $self->{to}, $self->{from}, $self->{t}, $self->{private}, $self->{subject}, $self->{origin}, $self->{rrreq})); +} + +# get the ref of a busy node +sub get_busy +{ + my $call = shift; + return $busy{$call}; +} + +# get the busy queue +sub get_all_busy +{ + return values %busy; +} + +# get the forwarding queue +sub get_fwq +{ + return values %work; +} + +# stop a message from continuing, clean it out, unlock interlocks etc +sub stop_msg +{ + my ($self, $dxchan) = @_; + my $node = $dxchan->call; + + dbg('msg', "stop msg $self->{msgno} stream $self->{stream}\n"); + delete $work{$node}; + delete $work{"$node$self->{stream}"}; + $self->workclean; + delete $busy{$node}; +} + # get a new transaction number from the file specified sub next_transno { @@ -366,12 +535,20 @@ sub init $ref = read_msg_header("$msgdir/$_"); next if !$ref; - # add the clusters that have this - push @msg, $ref; + # add the message to the available queue + add_dir($ref); } } +# add the message to the directory listing +sub add_dir +{ + my $ref = shift; + confess "tried to add a non-ref to the msg directory" if !ref $ref; + push @msg, $ref; +} + # return all the current messages sub get_all { @@ -426,6 +603,68 @@ sub AUTOLOAD @_ ? $self->{$name} = shift : $self->{$name} ; } +sub do_send_stuff +{ + my $self = shift; + my $line = shift; + my @out; + + if ($self->state eq 'send1') { +# $DB::single = 1; + confess "local var gone missing" if !ref $self->{loc}; + my $loc = $self->{loc}; + $loc->{subject} = $line; + $loc->{lines} = []; + $self->state('sendbody'); + #push @out, $self->msg('sendbody'); + push @out, "Enter Message /EX (^Z) to send or /ABORT (^Y) to exit"; + } elsif ($self->state eq 'sendbody') { + confess "local var gone missing" if !ref $self->{loc}; + my $loc = $self->{loc}; + if ($line eq "\032" || uc $line eq "/EX") { + my $to; + + if (@{$loc->{lines}} > 0) { + foreach $to (@{$loc->{to}}) { + my $ref; + my $systime = $main::systime; + my $mycall = $main::mycall; + $ref = DXMsg->alloc(DXMsg::next_transno('Msgno'), + uc $to, + $self->call, + $systime, + $loc->{private}, + $loc->{subject}, + $mycall, + $loc->{rrreq}); + $ref->store($loc->{lines}); + $ref->add_dir(); + #push @out, $self->msg('sendsent', $to); + push @out, "msgno $ref->{msgno} sent to $to"; + } + } + delete $loc->{lines}; + delete $loc->{to}; + delete $self->{loc}; + $self->state('prompt'); + $self->func(undef); + DXMsg::queue_msg(); + } elsif ($line eq "\031" || uc $line eq "/ABORT" || uc $line eq "/QUIT") { + #push @out, $self->msg('sendabort'); + push @out, "aborted"; + delete $loc->{lines}; + delete $loc->{to}; + delete $self->{loc}; + $self->func(undef); + $self->state('prompt'); + } else { + + # i.e. it ain't and end or abort, therefore store the line + push @{$loc->{lines}}, $line; + } + } + return (1, @out); +} 1; diff --git a/perl/DXProt.pm b/perl/DXProt.pm index 7e1c530e..552468b9 100644 --- a/perl/DXProt.pm +++ b/perl/DXProt.pm @@ -20,11 +20,16 @@ use DXProtVars; use DXCommandmode; use Spot; use DXProtout; +use Carp; use strict; -use vars qw($me); +use vars qw($me $pc11_max_age $pc11_dup_age %dup $last_hour); -$me = undef; # the channel id for this cluster +$me = undef; # the channel id for this cluster +$pc11_max_age = 1*3600; # the maximum age for an incoming 'real-time' pc11 +$pc11_dup_age = 24*3600; # the maximum time to keep the dup list for +%dup = (); # the pc11 and 26 dup hash +$last_hour = time; # last time I did an hourly periodic update sub init { @@ -61,7 +66,7 @@ sub start # send initialisation string $self->send(pc38()) if DXNode->get_all(); $self->send(pc18()); - $self->state('normal'); + $self->state('init'); $self->pc50_t(time); } @@ -97,34 +102,34 @@ sub normal return; } - if ($pcno == 11) { # dx spot + if ($pcno == 11 || $pcno == 26) { # dx spot # if this is a 'nodx' node then ignore it last SWITCH if grep $field[7] =~ /^$_/, @DXProt::nodx_node; # convert the date to a unix date my $d = cltounix($field[3], $field[4]); -# my $date = $field[3]; -# my $time = $field[4]; -# $date =~ s/^\s*(\d+)-(\w\w\w)-(19\d\d)$/$1 $2 $3/; -# $time =~ s/^(\d\d)(\d\d)Z$/$1:$2 +0000/; -# my $d = str2time("$date $time"); - return if !$d; # bang out (and don't pass on) if date is invalid + return if !$d || ($pcno == 11 && $d < $main::systime - $pc11_max_age); # bang out (and don't pass on) if date is invalid or the spot is too old # strip off the leading & trailing spaces from the comment my $text = unpad($field[5]); # store it away - Spot::add($field[1], $field[2], $d, $text, $field[6]); - - # format and broadcast it to users my $spotter = $field[6]; $spotter =~ s/-\d+$//o; # strip off the ssid from the spotter - $spotter .= ':'; # add a colon + + # do some de-duping + my $dupkey = "$field[1]$field[2]$d$text$field[6]"; + return if $dup{$dupkey}; + $dup{$dupkey} = $d; + + my $spot = Spot::add($field[1], $field[2], $d, $text, $spotter); # send orf to the users - my $buf = sprintf "DX de %-7.7s %13.13s %-12.12s %-30.30s %5.5s\a\a", $spotter, $field[1], $field[2], $text, $field[4]; - broadcast_users($buf); + if ($spot && $pcno == 11) { + my $buf = Spot::formatb($field[1], $field[2], $d, $text, $spotter); + broadcast_users("$buf\a\a"); + } last SWITCH; } @@ -190,6 +195,9 @@ sub normal $user->node($node->call) if !$user->node; $user->put; } + + # queue up any messages (look for privates only) + DXMsg::queue_msg(1) if $self->state eq 'normal'; last SWITCH; } @@ -200,9 +208,9 @@ sub normal } if ($pcno == 18) { # link request - $self->send_local_config(); $self->send(pc20()); + $self->state('init'); last SWITCH; } @@ -221,13 +229,24 @@ sub normal next if $ver < 5000; # only works with version 5 software next if length $call < 3; # min 3 letter callsigns DXNode->new($self, $call, $confmode, $here, $ver); + + # unbusy and stop and outgoing mail (ie if somehow we receive another PC19 without a disconnect) + my $mref = DXMsg::get_busy($call); + $mref->stop_msg($self) if $mref; } + + # queue up any messages + DXMsg::queue_msg() if $self->state eq 'normal'; last SWITCH; } if ($pcno == 20) { # send local configuration $self->send_local_config(); $self->send(pc22()); + $self->state('normal'); + + # queue mail + DXMsg::queue_msg(); return; } @@ -239,7 +258,10 @@ sub normal } if ($pcno == 22) {last SWITCH;} - if ($pcno == 23) {last SWITCH;} + + if ($pcno == 23 || $pcno == 27) { # WWV info + last SWITCH; + } if ($pcno == 24) { # set here status my $call = uc $field[1]; @@ -250,8 +272,6 @@ sub normal } if ($pcno == 25) {last SWITCH;} - if ($pcno == 26) {last SWITCH;} - if ($pcno == 27) {last SWITCH;} if (($pcno >= 28 && $pcno <= 33) || $pcno == 40 || $pcno == 42) { # mail/file handling DXMsg::process($self, $line); @@ -366,6 +386,17 @@ sub process $chan->pc50_t($t); } } + + my $key; + my $val; + my $cutoff; + if ($main::systime - 3600 > $last_hour) { + $cutoff = $main::systime - $pc11_dup_age; + while (($key, $val) = each %dup) { + delete $dup{$key} if $val < $cutoff; + } + $last_hour = $main::systime; + } } # @@ -375,6 +406,10 @@ sub finish { my $self = shift; my $ref = DXCluster->get($self->call); + + # unbusy and stop and outgoing mail + my $mref = DXMsg::get_busy($self->call); + $mref->stop_msg($self) if $mref; # broadcast to all other nodes that all the nodes connected to via me are gone my @gonenodes = map { $_->dxchan == $self ? $_ : () } DXNode::get_all(); diff --git a/perl/DXProtout.pm b/perl/DXProtout.pm index 0be2f0ea..ad431481 100644 --- a/perl/DXProtout.pm +++ b/perl/DXProtout.pm @@ -15,6 +15,7 @@ package DXProt; use DXUtil; use DXM; +use Carp; use strict; @@ -86,7 +87,7 @@ sub pc17 { my ($self, $ref) = @_; my $hops = get_hops(17); - return "PC17^$self->{call}^$ref->{call}^$hops^"; + return "PC17^$ref->{call}^$self->{call}^$hops^"; } # Request init string @@ -154,11 +155,12 @@ sub pc24 # message start (fromnode, tonode, to, from, t, private, subject, origin) sub pc28 { - my ($fromnode, $tonode, $to, $from, $t, $private, $subject, $origin) = @_; + my ($tonode, $fromnode, $to, $from, $t, $private, $subject, $origin, $rr) = @_; my $date = cldate($t); my $time = ztime($t); $private = $private ? '1' : '0'; - return "PC28^$fromnode^$tonode^$to^from^$date^$time^$private^$subject^ ^5^0^ ^$origin^~"; + $rr = $rr ? '1' : '0'; + return "PC28^$tonode^$fromnode^$to^$from^$date^$time^$private^$subject^ ^5^$rr^ ^$origin^~"; } # message text (from and to node same way round as pc29) @@ -166,7 +168,7 @@ sub pc29 { my ($fromnode, $tonode, $stream, $text) = @_; $text =~ s/\^//og; # remove ^ - return "PC29^$fromnode^$tonode^$stream^text^~"; + return "PC29^$fromnode^$tonode^$stream^$text^~"; } # subject acknowledge (will have to and from node reversed to pc28) @@ -197,7 +199,6 @@ sub pc33 return "PC33^$fromnode^$tonode^$stream^"; } - # send all the DX clusters I reckon are connected sub pc38 { @@ -214,13 +215,44 @@ sub pc38 # tell the local node to discconnect sub pc39 { - my ($ref, $reason) = @_; - my $call = $ref->call; + my ($call, $reason) = @_; my $hops = get_hops(21); $reason = "Gone." if !$reason; return "PC39^$call^$reason^"; } +# cue up bulletin or file for transfer +sub pc40 +{ + my ($to, $from, $fn, $bull) = @_; + $bull = $bull ? '1' : '0'; + return "PC40^$to^$from^$fn^$bull^5^"; +} + +# user info +sub pc41 +{ + my ($call, $sort, $info) = @_; + my $hops = get_hops(41); + $sort = $sort ? "$sort" : '0'; + return "PC41^$call^$sort^$info^$hops^~"; +} + +# abort message +sub pc42 +{ + my ($fromnode, $tonode, $stream) = @_; + return "PC42^$fromnode^$tonode^$stream^"; +} + +# bull delete +sub pc49 +{ + my ($from, $subject) = @_; + my $hops = get_hops(49); + return "PC49^$from^$subject^$hops^~"; +} + # periodic update of users, plus keep link alive device (always H99) sub pc50 { diff --git a/perl/DXUtil.pm b/perl/DXUtil.pm index 24ab19a6..667194af 100644 --- a/perl/DXUtil.pm +++ b/perl/DXUtil.pm @@ -9,6 +9,7 @@ package DXUtil; use Date::Parse; +use Carp; require Exporter; @ISA = qw(Exporter); diff --git a/perl/DXVars.pm b/perl/DXVars.pm index 42e8f8ab..bac7a6de 100644 --- a/perl/DXVars.pm +++ b/perl/DXVars.pm @@ -86,4 +86,4 @@ $userfn = "$data/users"; $motd = "$data/motd"; # are we debugging ? -@debug = ('chan'); +@debug = ('chan', 'state', 'msg'); diff --git a/perl/Julian.pm b/perl/Julian.pm index cc8c6151..17a020ec 100644 --- a/perl/Julian.pm +++ b/perl/Julian.pm @@ -10,6 +10,7 @@ package Julian; use FileHandle; use DXDebug; +use Carp; use strict; diff --git a/perl/Prefix.pm b/perl/Prefix.pm index 5f23fce9..dbaa1c84 100644 --- a/perl/Prefix.pm +++ b/perl/Prefix.pm @@ -12,6 +12,7 @@ use Carp; use DXVars; use DB_File; use Data::Dumper; +use Carp; use strict; use vars qw($db %prefix_loc %pre); diff --git a/perl/Spot.pm b/perl/Spot.pm index 08520c5b..fee069a2 100644 --- a/perl/Spot.pm +++ b/perl/Spot.pm @@ -11,6 +11,7 @@ package Spot; use FileHandle; use DXVars; use DXDebug; +use DXUtil; use Julian; use Prefix; use Carp; @@ -55,7 +56,10 @@ sub add my @dxcc = Prefix::extract($spot[1]); push @spot, (@dxcc > 0 ) ? $dxcc[1]->dxcc() : 0; - $fh->print(join("\^", @spot), "\n"); + my $buf = join("\^", @spot); + $fh->print($buf, "\n"); + + return $buf; } # search the spot database for records based on the field no and an expression @@ -111,11 +115,24 @@ sub search } $expr =~ s/\$f(\d)/\$ref->[$1]/g; # swap the letter n for the correct field name +# $expr =~ s/\$f(\d)/\$spots[$1]/g; # swap the letter n for the correct field name dbg("search", "expr='$expr', spotno=$from-$to, day=$dayfrom-$dayto\n"); # build up eval to execute - $eval = qq(my \$c; + $eval = qq( +# while (<\$fh>) { +# chomp; +# my \@spots = split /\\^/o; +# if ($expr) { # note NO \$expr +# \$count++; +# next if \$count < \$from; # wait until from +# push(\@out, \\\@spots); +# last LOOP if \$count >= \$to; # stop after to +# } +# } + my \$c; + my \$ref; for (\$c = \$#spots; \$c >= 0; \$c--) { \$ref = \$spots[\$c]; if ($expr) { @@ -124,11 +141,12 @@ sub search push(\@out, \$ref); last LOOP if \$count >= \$to; # stop after to } - }); + } + ); LOOP: - for ($i = 0; $i < 60; ++$i) { - my @now = Julian::sub(@fromdate, $i); + for ($i = 0; $i < $maxdays; ++$i) { # look thru $maxdays worth of files only + my @now = Julian::sub(@fromdate, $i); # but you can pick which $maxdays worth last if Julian::cmp(@now, @todate) <= 0; my @spots = (); @@ -138,11 +156,10 @@ LOOP: my $in; foreach $in (<$fh>) { chomp $in; - push @spots, [ split('\^', $in) ]; + push @spots, [ split('\^', $in) ]; } - my $ref; eval $eval; # do the search on this file - return ("error", $@) if $@; + return ("Spot search error", $@) if $@; } } @@ -162,4 +179,21 @@ sub close # do nothing, unreferencing or overwriting the $self will close it } +# format a spot for user output in 'broadcast' mode +sub formatb +{ + my @dx = @_; + my $t = ztime($dx[2]); + return sprintf "DX de %-9.9s: %9.1f %-12s %-30s<%s>", $dx[4], $dx[0], $dx[1], $dx[3], $t ; +} + +# format a spot for user output in list mode +sub formatl +{ + my @dx = @_; + my $t = ztime($dx[2]); + my $d = cldate($dx[2]); + return sprintf "%9.1f %-12s %s %s %-30s<%s>", $dx[0], $dx[1], $d, $t, $dx[3], $dx[4] ; +} + 1; diff --git a/perl/client.pl b/perl/client.pl index 2a41c221..834aaf37 100755 --- a/perl/client.pl +++ b/perl/client.pl @@ -39,6 +39,7 @@ BEGIN { use Msg; use DXVars; +use Carp; $mode = 2; # 1 - \n = \r as EOL, 2 - \n = \n, 0 - transparent $call = ""; # the callsign being used @@ -147,7 +148,11 @@ sub rec_stdin if ($mode) { $buf =~ s/\r/\n/og if $mode == 1; $dangle = !($buf =~ /\n$/); - @lines = split /\n/, $buf; + if ($buf eq "\n") { + @lines = (" "); + } else { + @lines = split /\n/, $buf; + } if ($dangle) { # pull off any dangly bits $buf = pop @lines; } else { diff --git a/perl/cluster.pl b/perl/cluster.pl index 9511435d..5b3f6466 100755 --- a/perl/cluster.pl +++ b/perl/cluster.pl @@ -35,6 +35,7 @@ use DXCron; use DXConnect; use Prefix; use Bands; +use Carp; package main; @@ -142,13 +143,10 @@ sub process_inqueue $dxchan->start($line); } elsif ($sort eq 'D') { die "\$user not defined for $call" if !defined $user; - if ($dxchan->{func}) { - # call an ongoing routine if there is a function specified - &{$dxchan->{func}} ($dxchan, $line); - } else { - # normal input - $dxchan->normal($line); - } + + # normal input + $dxchan->normal($line); + disconnect($dxchan) if ($dxchan->{state} eq 'bye'); } elsif ($sort eq 'Z') { disconnect($dxchan); -- 2.34.1