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