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