From 431c8a14cdecd0ec455b6619380687dbe84e2a35 Mon Sep 17 00:00:00 2001 From: Dirk Koopman Date: Sun, 5 Jul 2020 01:27:02 +0100 Subject: [PATCH] fix console.pl Including removing the 80-1 limit on local connections, fixing the scrolling and generally tarting console.pl up. Change dx spot RBN format to "traditional" '-#' format. --- Changes | 13 + cmd/load/dxqsl.pl | 4 +- perl/Console.pm | 4 +- perl/DXCommandmode.pm | 22 +- perl/QSL.pm | 12 +- perl/RBN.pm | 8 +- perl/console.pl | 354 ++++++++++++++---------- perl/{create_qsl.pl => create_dxqsl.pl} | 0 8 files changed, 249 insertions(+), 168 deletions(-) rename perl/{create_qsl.pl => create_dxqsl.pl} (100%) diff --git a/Changes b/Changes index 39cedc25..e1ad3258 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,16 @@ +04Jul20======================================================================= +1. Give console.pl (or dx) a good going over with a bog brush to *finally* + (cough) make it work correctly with a full 80 column window (and not just + to a width of 79 really). Also fix scrolling. +28Jun20======================================================================= +1. Merge mojo with users.v3j to remove all vestages of Storable from DXSpider + in an effort to make the whole storage thing more reliable (and also a + bit faster). The user file will be auto-upgraded on restart. This may take + up to 20 seconds on slower hardware (and maybe a bit longer on huge user + files). On my 180,000 odd users, on my hardware, it takes 4 seconds. +2. The DXQSL system storage is also upgraded, Please run + /spider/perl/create_dxqsl.pl in a spare shell. This will recreate the + dxqsl.v1j file. Run 'load/dxqsl' in the console to activate it. 17Jun20======================================================================= 1. Change the Spot file reading mechanism back to the default of using 'tac'. 08Jun20======================================================================= diff --git a/cmd/load/dxqsl.pl b/cmd/load/dxqsl.pl index b1738229..679864c0 100644 --- a/cmd/load/dxqsl.pl +++ b/cmd/load/dxqsl.pl @@ -5,4 +5,6 @@ my $self = shift; return (1, $self->msg('e5')) if $self->priv < 9; QSL::finish(); my $r = QSL::init(1); -return (1, $r ? $self->msg('ok') : $self->msg('e2', "$!")); +my @out; +push @out, $self->msg($r ? 'ok':'e2', "$!"); +return (1, @out); diff --git a/perl/Console.pm b/perl/Console.pm index f1cefa49..9dfacfb6 100644 --- a/perl/Console.pm +++ b/perl/Console.pm @@ -41,7 +41,7 @@ if ($ENV{'TERM'} =~ /(xterm|ansi)/) { @colors = ( [ '^[-A-Z0-9]+ de [-A-Z0-9]+ \d\d-\w\w\w-\d\d\d\d \d\d\d\dZ', COLOR_PAIR(0) ], [ '^DX de [\-A-Z0-9]+:\s+([57][01]\d\d\d\.|\d\d\d\d\d\d+.)', COLOR_PAIR(1) ], - [ '^RB de', COLOR_PAIR(2) ], + [ '-#', COLOR_PAIR(2) ], [ '^To', COLOR_PAIR(3) ], [ '^WX', COLOR_PAIR(3) ], [ '^(?:WWV|WCY)', COLOR_PAIR(4) ], @@ -57,7 +57,7 @@ if ($ENV{'TERM'} =~ /(console|linux)/) { $mycallcolor = COLOR_PAIR(1); @colors = ( [ '^DX de [\-A-Z0-9]+:\s+([57][01]\d\d\d\.|\d\d\d\d\d\d+.)', COLOR_PAIR(1) ], - [ '^RN de', COLOR_PAIR(2) ], + [ '^-#:', COLOR_PAIR(2) ], [ '^DX', COLOR_PAIR(4) ], [ '^To', COLOR_PAIR(3) ], [ '^(?:WWV|WCY)', COLOR_PAIR(5) ], diff --git a/perl/DXCommandmode.pm b/perl/DXCommandmode.pm index e6b612fa..38773783 100644 --- a/perl/DXCommandmode.pm +++ b/perl/DXCommandmode.pm @@ -997,25 +997,23 @@ sub format_dx_spot my $t = ztime($_[2]); my $loc = ''; my $clth = 30; - --$clth if $self->{consort} eq 'local'; + # --$clth if $self->{consort} eq 'local'; my $comment = substr (($_[3] || ''), 0, $clth); $comment .= ' ' x ($clth - (length($comment))); - if ($self->{user}->wantgrid) { - my $ref = DXUser::get_current($_[4]); - if ($ref && $ref->qra) { - $loc = ' ' . substr($ref->qra, 0, 4); - } - } - if ($self->{user}->wantgrid) { my $ref = DXUser::get_current($_[1]); + if ($ref && $ref->qra) { + my $cloc = ' ' . substr($ref->qra, 0, 4); + $comment = substr $comment, 0, ($clth - (length($comment)+length($cloc))); + $comment .= $cloc; + } + my $origin = $_[4]; + $origin =~ s/-#$//; # sigh...... + $ref = DXUser::get_current($origin); if ($ref && $ref->qra) { $loc = ' ' . substr($ref->qra, 0, 4); - $comment = substr $comment, 0, ($clth - (length($comment)+length($loc))); - $comment .= $loc; - $loc = ''; } } elsif ($self->{user}->wantdxitu) { $loc = ' ' . sprintf("%2d", $_[10]) if defined $_[10]; @@ -1028,7 +1026,7 @@ sub format_dx_spot $comment = substr($comment, 0, $clth-3) . ' ' . $_[12] if $_[12]; } - return sprintf "DX de %-7.7s%11.1f %-12.12s %-s $t$loc", "$_[4]:", $_[0], $_[1], $comment; + return sprintf "DX de %-9.9s%10.1f %-12.12s %-s $t$loc", "$_[4]:", $_[0], $_[1], $comment; } # send a dx spot diff --git a/perl/QSL.pm b/perl/QSL.pm index e303e123..d10345ed 100644 --- a/perl/QSL.pm +++ b/perl/QSL.pm @@ -21,6 +21,7 @@ $qslfn = 'dxqsl'; $dbm = undef; $maxentries = 50; +my %u; my $json; localdata_mv("$qslfn.v1j"); @@ -33,10 +34,9 @@ sub init $json = JSON->new->canonical(1); Prefix::load() unless Prefix::loaded(); - - my %u; - undef $dbm; + finish() if $dbm; + if ($mode) { $dbm = tie (%u, 'DB_File', $ufn, O_CREAT|O_RDWR, 0666, $DB_BTREE) or confess "can't open qsl file: $qslfn ($!)"; } else { @@ -47,7 +47,9 @@ sub init sub finish { + $dbm->sync; undef $dbm; + untie %u; } sub new @@ -129,8 +131,8 @@ sub put sub remove_files { - unlink "$main::data/qsl.v1j"; - unlink "$main::local_data/qsl.v1j"; + unlink "$main::data/$qslfn.v1j"; + unlink "$main::local_data/$qslfn.v1j"; } # thaw the user diff --git a/perl/RBN.pm b/perl/RBN.pm index cecbc4ba..bb64330b 100644 --- a/perl/RBN.pm +++ b/perl/RBN.pm @@ -307,7 +307,7 @@ sub normal $quality = 9 if $quality > 9; $quality = "Q:$quality"; if (isdbg('progress')) { - my $s = "RBN: SPOT key: '$sp' = $r->[2] on $r->[1] \@ $r->[5] $quality"; + my $s = "RBN: SPOT key: '$sp' = $r->[2] on $r->[1] by $r->[0] \@ $r->[5] $quality"; $s .= " route: $self->{call}"; dbg($s); } @@ -492,9 +492,13 @@ sub dx_spot $buf = VE7CC::dx_spot($dxchan, @$saver); $saver->[4] = $call; } else { + my $call = $saver->[4]; + $saver->[4] = substr($call, 0, 6); + $saver->[4] .= '-#'; $buf = $dxchan->format_dx_spot(@$saver); + $saver->[4] = $call; } - $buf =~ s/^DX/RB/; +# $buf =~ s/^DX/RB/; $dxchan->local_send('N', $buf); ++$self->{nospot}; diff --git a/perl/console.pl b/perl/console.pl index 97b6220d..48c7ff8c 100755 --- a/perl/console.pl +++ b/perl/console.pl @@ -43,7 +43,7 @@ use DXDebug; use IO::File; use Time::HiRes qw(gettimeofday tv_interval); use Curses 1.06; -use Text::Wrap; +use Text::Wrap qw(wrap); use Console; @@ -56,18 +56,19 @@ $conn = 0; # the connection object for the cluster $lasttime = time; # lasttime something happened on the interface $connsort = "local"; -@khistory = (); -@shistory = (); -$khistpos = 0; +@kh = (); +@sh = (); +$kpos = 0; $spos = $pos = $lth = 0; $inbuf = ""; -@time = (); $lastmin = 0; $idle = 0; - +$inscroll = 0; #$SIG{WINCH} = sub {@time = gettimeofday}; +$DXDebug::no_stdout = 1; + sub mydbg { local *STDOUT = undef; @@ -101,25 +102,29 @@ sub do_initscr $top = $scr->subwin($lines-4, $cols, 0, 0); $top->intrflush(0); - $top->scrollok(1); + $top->scrollok(0); $top->idlok(1); $top->meta(1); -# $scr->addstr($lines-4, 0, '-' x $cols); + $top->leaveok(1); + $top->clrtobot(); +# $top->setscrreg(0, $lines-5); + $bot = $scr->subwin(3, $cols, $lines-3, 0); $bot->intrflush(0); $bot->scrollok(1); - $top->idlok(1); $bot->keypad(1); $bot->move(1,0); $bot->meta(1); $bot->nodelay(1); + $bot->clrtobot(); $scr->refresh(); + $pagel = $lines-4; $mycallcolor = COLOR_PAIR(1) unless $mycallcolor; } -sub do_resize +sub doresize { endwin() if $scr; initscr(); @@ -131,6 +136,8 @@ sub do_resize $has_colors = has_colors(); do_initscr(); + $inscroll = 0; + $spos = @sh < $pagel ? 0 : @sh - $pagel; show_screen(); } @@ -179,54 +186,66 @@ sub measure # display the top screen sub show_screen { - if ($spos == @shistory - 1) { - # if we really are scrolling thru at the end of the history - my $line = $shistory[$spos]; - my $y = $spos; - if ($spos >= $pagel) { - $top->scrl(1); - $y = $pagel-1; -# $top->addstr("\r"); - } - $top->move($y, 0); - $top->refresh; - setattr($line); - $top->addstr($line); - $top->attrset(COLOR_PAIR(0)) if $has_colors; - $spos = @shistory; + if ($inscroll) { - } else { - - # anywhere else + dbg("B: s:$spos h:" . scalar @sh) if isdbg('console'); my ($i, $l); - my $p = $spos-1; - for ($i = 0; $i < $pagel && $p >= 0; ) { - $l = measure($shistory[$p]); - $i += $l; - $p-- if $i < $pagel; - } - $p = 0 if $p < 0; - +# for ($i = 0; $i < $pagel && $p >= 0; ) { +# $l = measure($sh[$p]); +# $i += $l; +# $p-- if $i < $pagel; + # } + + $spos = 0 if $spos < 0; + my $y = $spos; $top->move(0, 0); $top->attrset(COLOR_PAIR(0)) if $has_colors; $top->clrtobot(); - for ($i = 0; $i < $pagel && $p < @shistory; $p++) { - my $line = $shistory[$p]; - my $lines = measure($line); + for ($i = 0; $i < $pagel && $y < @sh; ++$y) { + my $line = $sh[$y]; +# my $lines = measure($line); + my $lines = 1; $top->move($i, 0); + dbg("C: s:$spos y:$i sh:" . scalar @sh . " l:" . length($line) . " '$line'") if isdbg('console'); setattr($line); $top->addstr($line); $top->attrset(COLOR_PAIR(0)) if $has_colors; $i += $lines; } - $spos = $p; - $spos = @shistory if $spos > @shistory; + if ($y >= @sh) { + $inscroll = 0; + $spos = @sh; + } + } elsif ($spos < @sh || $spos < $pagel) { + # if we really are scrolling thru at the end of the history + while ($spos < @sh) { + my $line = $sh[$spos]; + my $y = $spos; + if ($y >= $pagel) { + $top->scrollok(1); + $top->scrl(1); + $top->scrollok(0); + $y = $pagel-1; + } + $top->move($y, 0); + dbg("A: s:$spos sh:" . scalar @sh . " y:$y l:" . length($line) . " '$line'") if isdbg('console'); + $top->refresh; + setattr($line); + $line =~ s/\n//s; + $top->addstr($line); + $top->attrset(COLOR_PAIR(0)) if $has_colors; + ++$spos; + } + shift @sh while @sh > $maxshist; + $spos = @sh; } - my $shl = @shistory; + + $top->refresh; + my $shl = @sh; my $size = $lines . 'x' . $cols . '-'; my $add = "-$spos-$shl"; my $time = ztime(time); - my $str = "-" . $time . '-' x ($cols - (length($size) + length($call) + length($add) + length($time) + 1)); + my $str = "-" . $time . '-' . ($inscroll ? 'S':'-') . '-' x ($cols - (length($size) + length($call) + length($add) + length($time) + 3)); $scr->addstr($lines-4, 0, $str); $scr->addstr($size); @@ -238,62 +257,12 @@ sub show_screen # $top->refresh(); } -# add a line to the end of the top screen -sub addtotop -{ - while (@_) { - my $inbuf = shift; - if ($inbuf =~ s/\x07+$//) { - beep(); - } - $inbuf =~ s/\s+$//s; - if (length $inbuf > $cols) { - $Text::Wrap::Columns = $cols; - push @shistory, wrap('',"\t", $inbuf); - } else { - push @shistory, $inbuf; - } - shift @shistory while @shistory > $maxshist; - } - show_screen(); -} - -# handle incoming messages -sub rec_socket -{ - my ($con, $msg, $err) = @_; - if (defined $err && $err) { - cease(1); - } - if (defined $msg) { - my ($sort, $incall, $line) = $msg =~ /^(\w)([^\|]+)\|(.*)$/; - - # change my call if my node says "tonight Michael you are Jane" or something like that... - $call = $incall if $call ne $incall; - - $line =~ s/[\x00-\x06\x08\x0a-\x19\x1b-\x1f\x80-\x9f]/./g; # immutable CSI sequence + control characters - if ($sort && $sort eq 'D') { - $line = " " unless length($line); - addtotop($line); - } elsif ($sort && $sort eq 'Z') { # end, disconnect, go, away ..... - cease(0); - } - # ****************************************************** - # ****************************************************** - # any other sorts that might happen are silently ignored. - # ****************************************************** - # ****************************************************** - } else { - cease(0); - } - $top->refresh(); - $lasttime = time; -} - sub rec_stdin { - my $r = shift;; + my $r = shift; + dbg("KEY: " . unpack("H*", $r). " '$r'") if isdbg('console'); + # my $prbuf; # $prbuf = $buf; # $prbuf =~ s/\r/\\r/; @@ -302,7 +271,7 @@ sub rec_stdin if (defined $r) { $r = '0' if !$r; - + if ($r eq KEY_ENTER || $r eq "\n" || $r eq "\r") { # save the lines @@ -312,9 +281,9 @@ sub rec_stdin if ($inbuf =~ /^!/o) { my $i; $inbuf =~ s/^!//o; - for ($i = $#khistory; $i >= 0; $i--) { - if ($khistory[$i] =~ /^$inbuf/) { - $inbuf = $khistory[$i]; + for ($i = $#kh; $i >= 0; $i--) { + if ($kh[$i] =~ /^$inbuf/) { + $inbuf = $kh[$i]; last; } } @@ -323,18 +292,24 @@ sub rec_stdin return; } } - push @khistory, $inbuf if length $inbuf; - shift @khistory if @khistory > $maxkhist; - $khistpos = @khistory; + push @kh, $inbuf if length $inbuf; + shift @kh if @kh > $maxkhist; + $kpos = @kh; $bot->move(0,0); $bot->clrtoeol(); $bot->addstr(substr($inbuf, 0, $cols)); # add it to the monitor window - unless ($spos == @shistory) { - $spos = @shistory; +# unless ($spos == @sh) { +# $spos = @sh; +# show_screen(); +# } + if ($inscroll && $spos < @sh) { + $spos = @sh - $pagel; + $inscroll = 0; show_screen(); - }; + } + addtotop($inbuf); # send it to the cluster @@ -342,44 +317,55 @@ sub rec_stdin $inbuf = ""; $pos = $lth = 0; } elsif ($r eq KEY_UP || $r eq "\020") { - if ($khistpos > 0) { - --$khistpos; - $inbuf = $khistory[$khistpos]; + if ($kpos > 0) { + --$kpos; + $inbuf = $kh[$kpos]; $pos = $lth = length $inbuf; } else { beep(); } } elsif ($r eq KEY_DOWN || $r eq "\016") { - if ($khistpos < @khistory - 1) { - ++$khistpos; - $inbuf = $khistory[$khistpos]; + if ($kpos < @kh - 1) { + ++$kpos; + $inbuf = $kh[$kpos]; $pos = $lth = length $inbuf; } else { beep(); } } elsif ($r eq KEY_PPAGE || $r eq "\032") { - if ($spos > 0) { - my ($i, $l); - for ($i = 0; $i < $pagel-1 && $spos >= 0; ) { - $l = measure($shistory[$spos]); - $i += $l; - $spos-- if $i <= $pagel; - } + if ($spos > 0 && @sh > $pagel) { +# my ($i, $l); +# for ($i = 0; $i < $pagel-1 && $spos >= 0; ) { +# $l = measure($sh[$spos]); +# $i += $l; +# --$spos if $i <= $pagel; +# } + $spos -= $pagel+int($pagel/2); $spos = 0 if $spos < 0; + $inscroll = 1; show_screen(); } else { beep(); } } elsif ($r eq KEY_NPAGE || $r eq "\026") { - if ($spos < @shistory - 1) { - my ($i, $l); - for ($i = 0; $i <= $pagel && $spos <= @shistory; ) { - $l = measure($shistory[$spos]); - $i += $l; - $spos++ if $i <= $pagel; - } - $spos = @shistory if $spos >= @shistory - 1; + if ($inscroll && $spos < @sh) { +# my ($i, $l); +# for ($i = 0; $i <= $pagel && $spos < @sh; ) { +# $l = measure($sh[$spos]); +# $i += $l; +# ++$spos if $i <= $pagel && $spos < @sh; +# } + + dbg("NPAGE sp:$spos $sh:". scalar @sh . " pl: $pagel") if isdbg('console'); + $spos += int($pagel/2); + if ($spos > @sh - $pagel) { + $spos = @sh - $pagel; + } show_screen(); + if ($spos >= @sh) { + $spos = @sh; + $inscroll = 0; + } } else { beep(); } @@ -423,12 +409,21 @@ sub rec_stdin beep(); } } elsif ($r eq KEY_RESIZE || $r eq "\0632") { - do_resize(); + doresize(); + return; + } elsif ($r eq "\x12" || $r eq "\x0c") { + dbg("REDRAW called") if isdbg('console'); + doresize(); return; + } elsif ($r eq "\013") { + $inbuf = substr($inbuf, 0, $pos); + $lth = length $inbuf; } elsif (defined $r && is_pctext($r)) { # move the top screen back to the bottom if you type something - if ($spos < @shistory) { - $spos = @shistory; + + if ($inscroll && $spos < @sh) { + $spos = @sh - $pagel; + $inscroll = 0; show_screen(); } @@ -444,16 +439,10 @@ sub rec_stdin } $pos++; $lth++; - } elsif ($r eq "\014" || $r eq "\022") { - touchwin(curscr, 1); - refresh(curscr); - return; - } elsif ($r eq "\013") { - $inbuf = substr($inbuf, 0, $pos); - $lth = length $inbuf; } else { beep(); } + $bot->move(1, 0); $bot->clrtobot(); $bot->addstr($inbuf); @@ -462,6 +451,62 @@ sub rec_stdin $bot->refresh(); } + +# add a line to the end of the top screen +sub addtotop +{ + while (@_) { + my $inbuf = shift; + my $l = length $inbuf; + if ($l > $cols) { +# $Text::Wrap::Columns = $cols; +# push @sh, wrap('',"\t", $inbuf); + push @sh, $inbuf; + } else { + push @sh, $inbuf; + } + } + show_screen() unless $inscroll; +} + +# handle incoming messages +sub rec_socket +{ + my ($con, $msg, $err) = @_; + if (defined $err && $err) { + cease(1); + } + if (defined $msg) { + dbg("msg: " . length($msg) . " '$msg'") if isdbg('console'); + my ($sort, $incall, $line) = $msg =~ /^(\w)([^\|]+)\|(.*)$/; + if ($line =~ s/\x07+$//) { + beep(); + } + $line =~ s/[\r\n]+//s; + + # change my call if my node says "tonight Michael you are Jane" or something like that... + $call = $incall if $call ne $incall; + + $line =~ s/[\x00-\x06\x08\x0a-\x19\x1b-\x1f\x80-\x9f]/./g; # immutable CSI sequence + control characters + if ($sort && $sort eq 'D') { + $line = " " unless length($line); + addtotop($line); + } elsif ($sort && $sort eq 'Z') { # end, disconnect, go, away ..... + cease(0); + } + # ****************************************************** + # ****************************************************** + # any other sorts that might happen are silently ignored. + # ****************************************************** + # ****************************************************** + } else { + cease(0); + } + $top->refresh(); + $lasttime = time; +} + + sub idle_loop { my $t; @@ -470,18 +515,17 @@ sub idle_loop if ($t > $lasttime) { my ($min)= (gmtime($t))[1]; if ($min != $lastmin) { - show_screen(); + show_screen() unless $inscroll; $lastmin = $min; } $lasttime = $t; } - my $ch = $bot->getch(); - if (@time && tv_interval(\@time, [gettimeofday]) >= 1) { - next; - } + my $ch = $bot->getch(); # this is here just to catch RESIZE events if (defined $ch) { - if ($ch ne '-1') { - rec_stdin($ch); + if ($ch == KEY_RESIZE) { + doresize(); + } else { + rec_stdin($ch) unless $ch == '-1'; } } $top->refresh() if $top->is_wintouched; @@ -507,6 +551,12 @@ sub on_disconnect # deal with args # + +while (@ARGV && $ARGV[0] =~ /^-/) { + my $arg = shift; + dbgadd('console'), $maxshist = 200 if $arg eq '-x'; +} + $call = uc shift @ARGV if @ARGV; $call = uc $myalias if !$call; my ($scall, $ssid) = split /-/, $call; @@ -531,11 +581,11 @@ unless ($DB::VERSION) { $SIG{'HUP'} = \&sig_term; # start up -do_resize(); +doresize(); $SIG{__DIE__} = \&sig_term; -$Text::Wrap::Columns = $cols; +#$Text::Wrap::Columns = $cols; my $lastmin = 0; @@ -544,7 +594,19 @@ $conn = IntMsg->connect($clusteraddr, $clusterport, rproc => \&rec_socket); $conn->{on_connect} = \&on_connect; $conn->{on_disconnect} = \&on_disconnect; +my $timer = Mojo::IOLoop->recurring(1, sub {DXLog::flushall()}); + $idle = Mojo::IOLoop->recurring(0.100 => \&idle_loop); +Mojo::IOLoop->singleton->reactor->io(\*STDIN => sub { + my $ch = $bot->getch(); + if (defined $ch) { + if ($ch ne '-1') { + rec_stdin($ch); + } + } +})->watch(\*STDIN, 1, 0); + + Mojo::IOLoop->start; diff --git a/perl/create_qsl.pl b/perl/create_dxqsl.pl similarity index 100% rename from perl/create_qsl.pl rename to perl/create_dxqsl.pl -- 2.34.1