perl/console.pl

   1 #!/usr/bin/env perl
   2 #
   3 # this is the operators console.
   4 #
   5 # Calling syntax is:-
   6 #
   7 # console.pl [callsign]
   8 #
   9 # if the callsign isn't given then the sysop callsign in DXVars.pm is assumed
  10 #
  11 # Copyright (c) 1999 Dirk Koopman G1TLH
  12 #
  13 #
  14 #
  15
  16 require 5.16.1;
  17 use strict;
  18 use warnings;
  19
  20 our $root;
  21 our $is_win;
  22 our $myalias;
  23 our $mycall;
  24 our $clusteraddr;
  25 our $clusterport;
  26 our $maxshist;
  27 our $maxkhist;
  28 our $foreground;
  29 our $background;
  30 our $mycallcolor;
  31 our @colors;
  32 our $data;
  33 our $local_data;
  34
  35 # search local then perl directories
  36 BEGIN {
  37         # root of directory tree for this system
  38         $root = "/spider";
  39         $root = $ENV{'DXSPIDER_ROOT'} if $ENV{'DXSPIDER_ROOT'};
  40         $local_data = "$root/local_data";
  41         $data = "$root/data";
  42
  43         unshift @INC, "$root/perl";     # this IS the right way round!
  44         unshift @INC, "$root/local";
  45         $is_win = ($^O =~ /^MS/ || $^O =~ /^OS-2/) ? 1 : 0; # is it Windows?
  46 }
  47
  48
  49 use Mojo::IOLoop;
  50
  51 use DXVars;
  52 use SysVar;
  53
  54 use Msg;
  55 use IntMsg;
  56 use DXDebug;
  57 use DXUtil;
  58 use DXDebug;
  59 use IO::File;
  60 use Time::HiRes qw(gettimeofday tv_interval);
  61 use Curses 1.06;
  62 use Text::Wrap qw(wrap);
  63
  64 use Console;
  65
  66 #
  67 # initialisation
  68 #
  69
  70 $clusteraddr //= '127.0.0.1';
  71 $clusterport //= 27754;
  72
  73 our $call = "";                     # the callsign being used
  74 our $node = "";                     # the node callsign being used
  75 our $conn = 0;                      # the connection object for the cluster
  76 our $lasttime = time;               # lasttime something happened on the interface
  77
  78 our $connsort = "local";
  79 our @kh = ();
  80 our @sh = ();
  81 our $kpos = 0;
  82 our $inbuf = "";
  83 our $idle = 0;
  84 our $inscroll = 0;
  85
  86 my $top;
  87 my $bot;
  88 my $lines;
  89 my $scr;
  90 my $cols;
  91 my $pagel;
  92 my $has_colors;
  93 our $pos;
  94 our $lth;
  95 my $sh;
  96
  97 our $spos = $pos = $lth = 0;
  98
  99
 100
 101 #$SIG{WINCH} = sub {@time = gettimeofday};
 102
 103 $DXDebug::no_stdout = 1;
 104
 105 # do the screen initialisation
 106 sub do_initscr
 107 {
 108         $scr = new Curses;
 109         if ($has_colors) {
 110                 start_color();
 111                 init_pair(0, $foreground, $background);
 112 #               init_pair(0, $background, $foreground);
 113                 init_pair(1, COLOR_RED, $background);
 114                 init_pair(2, COLOR_YELLOW, $background);
 115                 init_pair(3, COLOR_GREEN, $background);
 116                 init_pair(4, COLOR_CYAN, $background);
 117                 init_pair(5, COLOR_BLUE, $background);
 118                 init_pair(6, COLOR_MAGENTA, $background);
 119                 init_pair(7, COLOR_RED, COLOR_BLUE);
 120                 init_pair(8, COLOR_YELLOW, COLOR_BLUE);
 121                 init_pair(9, COLOR_GREEN, COLOR_BLUE);
 122                 init_pair(10, COLOR_CYAN, COLOR_BLUE);
 123                 init_pair(11, COLOR_BLUE, COLOR_RED);
 124                 init_pair(12, COLOR_MAGENTA, COLOR_BLUE);
 125                 init_pair(13, COLOR_YELLOW, COLOR_GREEN);
 126                 init_pair(14, COLOR_RED, COLOR_GREEN);
 127                 eval { assume_default_colors($foreground, $background) } unless $is_win;
 128         }
 129
 130         $top = $scr->subwin($lines-4, $cols, 0, 0);
 131         $top->intrflush(0);
 132         $top->scrollok(0);
 133         $top->idlok(1);
 134         $top->meta(1);
 135         $top->leaveok(1);
 136         $top->clrtobot();
 137 #       $top->setscrreg(0, $lines-5);
 138
 139         $bot = $scr->subwin(3, $cols, $lines-3, 0);
 140         $bot->intrflush(0);
 141         $bot->scrollok(1);
 142         $bot->keypad(1);
 143         $bot->move(1,0);
 144         $bot->meta(1);
 145         $bot->nodelay(1);
 146         $bot->clrtobot();
 147         $scr->refresh();
 148
 149
 150         $pagel = $lines-4;
 151         $mycallcolor = COLOR_PAIR(1) unless $mycallcolor;
 152 }
 153
 154 sub doresize
 155 {
 156         endwin() if $scr;
 157         initscr();
 158         raw();
 159         noecho();
 160         nonl();
 161         $lines = LINES;
 162         $cols = COLS;
 163         $has_colors = has_colors();
 164         do_initscr();
 165
 166         $inscroll = 0;
 167         $spos = @sh < $pagel ? 0 :  @sh - $pagel;
 168         show_screen();
 169         $conn->send_later("C$call|$cols") if $conn;
 170 }
 171
 172 # cease communications
 173 sub cease
 174 {
 175         my $sendz = shift;
 176         $conn->disconnect if $conn;
 177         endwin();
 178         dbgclose();
 179         print @_ if @_;
 180         exit(0);
 181 }
 182
 183 # terminate program from signal
 184 sub sig_term
 185 {
 186         cease(1, @_);
 187 }
 188
 189 # determine the colour of the line
 190 sub setattr
 191 {
 192         if ($has_colors) {
 193                 foreach my $ref (@colors) {
 194                         if ($_[0] =~ m{$$ref[0]}) {
 195                                 $top->attrset($$ref[1]);
 196                                 last;
 197                         }
 198                 }
 199         }
 200 }
 201
 202
 203 # display the top screen
 204 sub show_screen
 205 {
 206         if ($inscroll) {
 207
 208                 dbg("B: s:$spos h:" . scalar @sh) if isdbg('console');
 209                 my ($i, $l);
 210
 211                 $spos = 0 if $spos < 0;
 212                 my $y = $spos;
 213                 $top->move(0, 0);
 214                 $top->attrset(COLOR_PAIR(0)) if $has_colors;
 215                 $top->clrtobot();
 216                 for ($i = 0; $i < $pagel && $y < @sh; ++$y) {
 217                         my $line = $sh[$y];
 218                         my $lines = 1;
 219                         $top->move($i, 0);
 220                         dbg("C: s:$spos y:$i sh:" . scalar @sh . " l:" . length($line) . " '$line'") if isdbg('console');
 221                         setattr($line);
 222                         $top->addstr($line);
 223                         $top->attrset(COLOR_PAIR(0)) if $has_colors;
 224                         $i += $lines;
 225                 }
 226                 if ($y >= @sh) {
 227                         $inscroll = 0;
 228                         $spos = @sh;
 229                 }
 230         }       elsif ($spos < @sh || $spos < $pagel) {
 231                 # if we really are scrolling thru at the end of the history
 232                 while ($spos < @sh) {
 233                         my $line = $sh[$spos];
 234                         my $y = $spos;
 235                         if ($y >= $pagel) {
 236                                 $top->scrollok(1);
 237                                 $top->scrl(1);
 238                                 $top->scrollok(0);
 239                                 $y = $pagel-1;
 240                         }
 241                         $top->move($y, 0);
 242                         dbg("A: s:$spos sh:" . scalar @sh . " y:$y l:" . length($line) . " '$line'") if isdbg('console');
 243                         $top->refresh;
 244                         setattr($line);
 245                         $line =~ s/\n//s;
 246                         $top->addstr($line);
 247                         $top->attrset(COLOR_PAIR(0)) if $has_colors;
 248                         ++$spos;
 249                 }
 250                 shift @sh while @sh > $maxshist;
 251                 $spos = @sh;
 252         }
 253
 254         $top->refresh;
 255     my $shl = @sh;
 256         my $size = $lines . 'x' . $cols . '-';
 257         my $add = "-$spos-$shl";
 258     my $time = ztime(time);
 259         my $c = "$call\@$node";
 260         my $str =  "-" . $time . '-' . ($inscroll ? 'S':'-') . '-' x ($cols - (length($size) + length($c) + length($add) + length($time) + 3));
 261         $scr->addstr($lines-4, 0, $str);
 262
 263         $scr->addstr($size);
 264         $scr->attrset($mycallcolor) if $has_colors;
 265         $scr->addstr($c);
 266         $scr->attrset(COLOR_PAIR(0)) if $has_colors;
 267     $scr->addstr($add);
 268         $scr->refresh();
 269 #       $top->refresh();
 270 }
 271
 272 sub rec_stdin
 273 {
 274         my $r = shift;
 275
 276         dbg("KEY: " . unpack("H*", $r). " '$r'") if isdbg('console');
 277
 278         #  my $prbuf;
 279         #  $prbuf = $buf;
 280         #  $prbuf =~ s/\r/\\r/;
 281         #  $prbuf =~ s/\n/\\n/;
 282         #  print "sys: $r ($prbuf)\n";
 283         if (defined $r) {
 284
 285                 $r = '0' if !$r;
 286
 287                 if ($r eq KEY_ENTER || $r eq "\n" || $r eq "\r") {
 288
 289                         # save the lines
 290                         $inbuf = " " unless length $inbuf;
 291
 292                         # check for a pling and do a search back for a command
 293                         if ($inbuf =~ /^!/o) {
 294                                 my $i;
 295                                 $inbuf =~ s/^!//o;
 296                                 for ($i = $#kh; $i >= 0; $i--) {
 297                                         if ($kh[$i] =~ /^$inbuf/) {
 298                                                 $inbuf = $kh[$i];
 299                                                 last;
 300                                         }
 301                                 }
 302                                 if ($i < 0) {
 303                                         beep();
 304                                         return;
 305                                 }
 306                         }
 307                         push @kh, $inbuf if length $inbuf;
 308                         shift @kh if @kh > $maxkhist;
 309                         $kpos = @kh;
 310                         $bot->move(0,0);
 311                         $bot->clrtoeol();
 312                         $bot->addstr(substr($inbuf, 0, $cols));
 313
 314                         if ($inscroll && $spos < @sh) {
 315                                 $spos = @sh - $pagel;
 316                                 $inscroll = 0;
 317                                 show_screen();
 318                         }
 319
 320                         addtotop(' ', $inbuf);
 321
 322                         # send it to the cluster
 323                         $conn->send_later("I$call|$inbuf");
 324                         $inbuf = "";
 325                         $pos = $lth = 0;
 326                 } elsif ($r eq KEY_UP || $r eq "\020") {
 327                         if ($kpos > 0) {
 328                                 --$kpos;
 329                                 $inbuf = $kh[$kpos];
 330                                 $pos = $lth = length $inbuf;
 331                         } else {
 332                                 beep();
 333                         }
 334                 } elsif ($r eq KEY_DOWN || $r eq "\016") {
 335                         if ($kpos < @kh - 1) {
 336                                 ++$kpos;
 337                                 $inbuf = $kh[$kpos];
 338                                 $pos = $lth = length $inbuf;
 339                         } else {
 340                                 beep();
 341                         }
 342                 } elsif ($r eq KEY_PPAGE || $r eq "\032") {
 343                         if ($spos > 0 && @sh > $pagel) {
 344                                 $spos -= $pagel+int($pagel/2);
 345                                 $spos = 0 if $spos < 0;
 346                                 $inscroll = 1;
 347                                 show_screen();
 348                         } else {
 349                                 beep();
 350                         }
 351                 } elsif ($r eq KEY_NPAGE || $r eq "\026") {
 352                         if ($inscroll && $spos < @sh) {
 353
 354                                 dbg("NPAGE sp:$spos $sh:". scalar @sh . " pl: $pagel") if isdbg('console');
 355                                 $spos += int($pagel/2);
 356                                 if ($spos > @sh - $pagel) {
 357                                         $spos = @sh - $pagel;
 358                                 }
 359                                 show_screen();
 360                                 if ($spos >= @sh) {
 361                                         $spos = @sh;
 362                                         $inscroll = 0;
 363                                 }
 364                         } else {
 365                                 beep();
 366                         }
 367                 } elsif ($r eq KEY_LEFT || $r eq "\002") {
 368                         if ($pos > 0) {
 369                                 --$pos;
 370                         } else {
 371                                 beep();
 372                         }
 373                 } elsif ($r eq KEY_RIGHT || $r eq "\006") {
 374                         if ($pos < $lth) {
 375                                 ++$pos;
 376                         } else {
 377                                 beep();
 378                         }
 379                 } elsif ($r eq KEY_HOME || $r eq "\001") {
 380                         $pos = 0;
 381                 } elsif ($r eq KEY_END || $r eq "\005") {
 382                         $pos = $lth;
 383                 } elsif ($r eq KEY_BACKSPACE || $r eq "\010" || $r eq "\x7f") {
 384                         if ($pos > 0) {
 385                                 my $a = substr($inbuf, 0, $pos-1);
 386                                 my $b = substr($inbuf, $pos) if $pos < $lth;
 387                                 $b = "" unless $b;
 388
 389                                 $inbuf = $a . $b;
 390                                 --$lth;
 391                                 --$pos;
 392                         } else {
 393                                 beep();
 394                         }
 395                 } elsif ($r eq KEY_DC || $r eq "\004") {
 396                         if ($pos < $lth) {
 397                                 my $a = substr($inbuf, 0, $pos);
 398                                 my $b = substr($inbuf, $pos+1) if $pos < $lth;
 399                                 $b = "" unless $b;
 400
 401                                 $inbuf = $a . $b;
 402                                 --$lth;
 403                         } else {
 404                                 beep();
 405                         }
 406                 } elsif ($r eq KEY_RESIZE || $r eq "\0632") {
 407                         doresize();
 408                         return;
 409                 } elsif ($r eq "\x12" || $r eq "\x0c") {
 410                         dbg("REDRAW called") if isdbg('console');
 411                         doresize();
 412                         return;
 413                 } elsif ($r eq "\013") {
 414                         $inbuf = substr($inbuf, 0, $pos);
 415                         $lth = length $inbuf;
 416                 } elsif (defined $r && is_pctext($r)) {
 417                         # move the top screen back to the bottom if you type something
 418
 419                         if ($inscroll && $spos < @sh) {
 420                                 $spos = @sh - $pagel;
 421                                 $inscroll = 0;
 422                                 show_screen();
 423                         }
 424
 425                 #       $r = ($r lt ' ' || $r gt "\x7e") ? sprintf("'%x", ord $r) : $r;
 426
 427                         # insert the character into the keyboard buffer
 428                         if ($pos < $lth) {
 429                                 my $a = substr($inbuf, 0, $pos);
 430                                 my $b = substr($inbuf, $pos);
 431                                 $inbuf = $a . $r . $b;
 432                         } else {
 433                                 $inbuf .= $r;
 434                         }
 435                         $pos++;
 436                         $lth++;
 437                 } else {
 438                         beep();
 439                 }
 440
 441                 $bot->move(1, 0);
 442                 $bot->clrtobot();
 443                 $bot->addstr($inbuf);
 444         }
 445         $bot->move(1, $pos);
 446         $bot->refresh();
 447 }
 448
 449
 450 # add a line to the end of the top screen
 451 sub addtotop
 452 {
 453         my $sort = shift;
 454         while (@_) {
 455                 my $inbuf = shift;
 456                 my $l = length $inbuf;
 457                 if ($l > $cols) {
 458                         $inbuf =~ s/\s+/ /g;
 459                         if (length $inbuf > $cols) {
 460                                 $Text::Wrap::columns = $cols;
 461                                 my $token;
 462                                 ($token) = $inbuf =~ m!^(.* de [-\w\d/\#]+:?\s+|\w{9}\@\d\d:\d\d:\d\d )!;
 463                                 $token ||= ' ' x 19;
 464                                 push @sh, split /\n/, wrap('', ' ' x length($token), $inbuf);
 465                         } else {
 466                                 push @sh, $inbuf;
 467                         }
 468                 } else {
 469                         push @sh, $inbuf;
 470                 }
 471         }
 472
 473         show_screen() unless $inscroll;
 474 }
 475
 476 # handle incoming messages
 477 sub rec_socket
 478 {
 479         my ($con, $msg, $err) = @_;
 480         if (defined $err && $err) {
 481                 cease(1);
 482         }
 483         if (defined $msg) {
 484                 my ($sort, $incall, $line) = $msg =~ /^(\w)([^\|]+)\|(.*)$/;
 485                 dbg("msg: " . length($msg) . " '$msg'") if isdbg('console');
 486                 if ($line =~ s/\x07+$//) {
 487                         beep();
 488                 }
 489                 $line =~ s/[\r\n]+//s;
 490
 491                 # change my call if my node says "tonight Michael you are Jane" or something like that...
 492                 $call = $incall if $call ne $incall;
 493
 494                 $line =~ s/[\x00-\x06\x08\x0a-\x19\x1b-\x1f\x80-\x9f]/./g;         # immutable CSI sequence + control characters
 495                 if ($sort && $sort eq 'Z') { # end, disconnect, go, away .....
 496                         cease(0);
 497                 } else {
 498                         $line = " " unless length($line);
 499                         addtotop($sort, $line);
 500                 }
 501
 502         } else {
 503                 cease(0);
 504         }
 505         $top->refresh();
 506         $lasttime = time;
 507 }
 508
 509 my $lastmin = 0;
 510
 511 sub idle_loop
 512 {
 513         my $t;
 514
 515         $t = time;
 516         if ($t > $lasttime) {
 517                 my ($min)= (gmtime($t))[1];
 518                 if ($min != $lastmin) {
 519                         show_screen() unless $inscroll;
 520                         $lastmin = $min;
 521                 }
 522                 $lasttime = $t;
 523         }
 524         my $ch = $bot->getch();         # this is here just to catch RESIZE events
 525         if (defined $ch) {
 526                 if ($ch eq KEY_RESIZE) {
 527                         doresize();
 528                 } else {
 529                         rec_stdin($ch) unless $ch eq '-1';
 530                 }
 531         }
 532         $top->refresh() if $top->is_wintouched;
 533         $bot->refresh();
 534 }
 535
 536 sub on_connect
 537 {
 538         my $conn = shift;
 539         $conn->send_later("A$call|$connsort width=$cols enhanced");
 540         $conn->send_later("I$call|set/page " . ($maxshist-5));
 541         $conn->send_later("I$call|set/nobeep");
 542 }
 543
 544 sub on_disconnect
 545 {
 546         $conn = shift;
 547         Mojo::IOLoop->remove($idle);
 548         Mojo::IOLoop->stop;
 549 }
 550
 551 #
 552 # deal with args
 553 #
 554
 555
 556 while (@ARGV && $ARGV[0] =~ /^-/) {
 557         my $arg = shift;
 558         if ($arg eq '-x') {
 559                 dbginit('console');
 560                 dbgadd('console');
 561                 $maxshist = 200;
 562         }
 563 }
 564
 565 $call = uc shift @ARGV if @ARGV;
 566 $call = uc $myalias unless $call;
 567 $node = uc $mycall unless $node;
 568
 569 $call = normalise_call($call);
 570 my ($scall, $ssid) = split /-/, $call;
 571 $ssid = undef unless $ssid && $ssid =~ /^\d+$/;
 572 if ($ssid) {
 573         $ssid = 99 if $ssid > 99;
 574         $call = "$scall-$ssid";
 575 }
 576
 577 if ($call eq $mycall) {
 578         print "You cannot connect as your cluster callsign ($mycall)\n";
 579         exit(0);
 580 }
 581
 582 unless ($DB::VERSION) {
 583         $SIG{'INT'} = \&sig_term;
 584         $SIG{'TERM'} = \&sig_term;
 585 }
 586
 587 $SIG{'HUP'} = \&sig_term;
 588
 589
 590 # start upb
 591 $Text::Wrap::columns = $cols;
 592 doresize();
 593
 594 $SIG{__DIE__} = \&sig_term;
 595
 596 $conn = IntMsg->connect($clusteraddr, $clusterport, rproc => \&rec_socket);
 597 $conn->{on_connect} = \&on_connect;
 598 $conn->{on_disconnect} = \&on_disconnect;
 599
 600 my $timer = Mojo::IOLoop->recurring(1, sub {DXLog::flushall()}) if $DXDebug::fp;
 601
 602 $idle = Mojo::IOLoop->recurring(0.100 => \&idle_loop);
 603 Mojo::IOLoop->singleton->reactor->io(\*STDIN => sub {
 604         my $ch = $bot->getch();
 605         if (defined $ch) {
 606                 if ($ch ne '-1') {
 607                         rec_stdin($ch);
 608                 }
 609         }
 610 })->watch(\*STDIN, 1, 0);
 611
 612
 613 Mojo::IOLoop->start;
 614
 615
 616 cease(0);