perl/console.pl

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