]> dxcluster.net Git - spider.git/blob - perl/console.pl
887600e31ee6438ca9f96188b13fd5c2e60b5d93
[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 DXVars;
30 use DXDebug;
31 use IO::File;
32 use Curses;
33
34 use Carp qw{cluck};
35
36 use Console;
37
38 #
39 # initialisation
40 #
41
42 $call = "";                     # the callsign being used
43 $conn = 0;                      # the connection object for the cluster
44 $lasttime = time;               # lasttime something happened on the interface
45
46 $connsort = "local";
47 @khistory = ();
48 @shistory = ();
49 $khistpos = 0;
50 $spos = $pos = $lth = 0;
51 $inbuf = "";
52
53 # do the screen initialisation
54 sub do_initscr
55 {
56         $scr = new Curses;
57         raw();
58         noecho();
59         $has_colors = has_colors();
60         
61         if ($has_colors) {
62                 start_color();
63                 init_pair(0, $foreground, $background);
64                 init_pair(1, COLOR_RED, $background);
65                 init_pair(2, COLOR_YELLOW, $background);
66                 init_pair(3, COLOR_GREEN, $background);
67                 init_pair(4, COLOR_CYAN, $background);
68                 init_pair(5, COLOR_BLUE, $background);
69                 init_pair(6, COLOR_MAGENTA, $background);
70         }
71         
72         $top = $scr->subwin(LINES()-4, COLS, 0, 0);
73         $top->intrflush(0);
74         $top->scrollok(1);
75         $scr->addstr(LINES()-4, 0, '-' x COLS);
76         $bot = $scr->subwin(3, COLS, LINES()-3, 0);
77         $bot->intrflush(0);
78         $bot->scrollok(1);
79         $bot->keypad(1);
80         $bot->move(1,0);
81         $scr->refresh();
82         
83         $pagel = LINES()-4;
84         $mycallcolor = COLOR_PAIR(1) unless $mycallcolor;
85 }
86
87 sub do_resize
88 {
89         undef $scr;
90         do_initscr();
91 }
92
93 # cease communications
94 sub cease
95 {
96         my $sendz = shift;
97         if ($conn && $sendz) {
98                 $conn->send_now("Z$call|bye...\n");
99         }
100         endwin();
101         dbgclose();
102         print @_ if @_;
103         exit(0);        
104 }
105
106 # terminate program from signal
107 sub sig_term
108 {
109         cease(1, @_);
110 }
111
112 # determine the colour of the line
113 sub setattr
114 {
115         if ($has_colors) {
116                 foreach my $ref (@colors) {
117                         if ($_[0] =~ m{$$ref[0]}) {
118                                 $top->attrset($$ref[1]);
119                                 last;
120                         }
121                 }
122         }
123 }
124
125 # measure the no of screen lines a line will take
126 sub measure
127 {
128         my $line = shift;
129         return 0 unless $line;
130
131         my $l = length $line;
132         my $lines = int ($l / COLS());
133         $lines++ if $l / COLS() > $lines;
134         return $lines;
135 }
136
137 # display the top screen
138 sub show_screen
139 {
140         if ($spos == @shistory - 1) {
141
142                 # if we really are scrolling thru at the end of the history
143                 my $line = $shistory[$spos];
144                 $top->addstr("\n") if $spos > 0;
145                 setattr($line);
146                 $top->addstr($line);
147                 $top->attrset(COLOR_PAIR(0)) if $has_colors;
148                 $spos = @shistory;
149                 
150         } else {
151                 
152                 # anywhere else
153                 my ($i, $l);
154                 my $p = $spos-1;
155                 for ($i = 0; $i < $pagel && $p >= 0; ) {
156                         $l = measure($shistory[$p]);
157                         $i += $l;
158                         $p-- if $i < $pagel;
159                 }
160                 $p = 0 if $p < 0;
161                 
162                 $top->move(0, 0);
163                 $top->attrset(COLOR_PAIR(0)) if $has_colors;
164                 $top->clrtobot();
165                 for ($i = 0; $i < $pagel && $p < @shistory; $p++) {
166                         my $line = $shistory[$p];
167                         my $lines = measure($line);
168                         last if $i + $lines > $pagel;
169                         setattr($line);
170                         $top->addstr($i, 0, $line);
171                         $top->attrset(COLOR_PAIR(0)) if $has_colors;
172                         $i += $lines;
173                 }
174                 $spos = $p;
175                 $spos = @shistory if $spos > @shistory;
176         }
177     my $shl = @shistory;
178         my $add = "-$spos-$shl";
179     $scr->addstr(LINES()-4, 0, '-' x (COLS() - (length($call) + length($add))));
180         $scr->attrset($mycallcolor) if $has_colors;
181         $scr->addstr("$call");
182         $scr->attrset(COLOR_PAIR(0)) if $has_colors;
183     $scr->addstr($add);
184         $scr->refresh();
185 #       $top->refresh();
186 }
187
188 # add a line to the end of the top screen
189 sub addtotop
190 {
191         while (@_) {
192                 my $inbuf = shift;
193                 push @shistory, $inbuf;
194                 shift @shistory if @shistory > $maxshist;
195         }
196         show_screen();
197 }
198
199 # handle incoming messages
200 sub rec_socket
201 {
202         my ($con, $msg, $err) = @_;
203         if (defined $err && $err) {
204                 cease(1);
205         }
206         if (defined $msg) {
207                 my ($sort, $call, $line) = $msg =~ /^(\w)(\S+)\|(.*)$/;
208                 
209                 if ($sort && $sort eq 'D') {
210                         addtotop($line);
211                 } elsif ($sort && $sort eq 'Z') { # end, disconnect, go, away .....
212                         cease(0);
213                 }         
214         }
215         $top->refresh();
216         $lasttime = time; 
217 }
218
219 sub rec_stdin
220 {
221         my ($fh) = @_;
222
223         $r = $bot->getch();
224         
225         #  my $prbuf;
226         #  $prbuf = $buf;
227         #  $prbuf =~ s/\r/\\r/;
228         #  $prbuf =~ s/\n/\\n/;
229         #  print "sys: $r ($prbuf)\n";
230         if (defined $r) {
231                 
232                 if ($r eq KEY_ENTER || $r eq "\n" || $r eq "\r") {
233                         
234                         # save the lines
235                         if ($inbuf) {
236                                 # check for a pling and do a search back for a command
237                                 if ($inbuf =~ /^!/o) {
238                                         my $i;
239                                         $inbuf =~ s/^!//o;
240                                         for ($i = $#khistory; $i >= 0; $i--) {
241                                                 if ($khistory[$i] =~ /^$inbuf/) {
242                                                         $inbuf = $khistory[$i];
243                                                         last;
244                                                 }
245                                         }
246                                         if ($i < 0) {
247                                                 beep();
248                                                 return;
249                                         }
250                                 }
251                                 push @khistory, $inbuf if $inbuf;
252                                 shift @khistory if @khistory > $maxkhist;
253                                 $khistpos = @khistory;
254                                 $bot->move(0,0);
255                                 $bot->clrtoeol();
256                                 $bot->addstr(substr($inbuf, 0, COLS));
257                         }
258
259                         # add it to the monitor window
260                         unless ($spos == @shistory) {
261                                 $spos = @shistory;
262                                 show_screen();
263                         };
264                         addtotop($inbuf) if $inbuf;
265                 
266                         # send it to the cluster
267                         $inbuf = " " unless $inbuf;
268                         $conn->send_later("I$call|$inbuf");
269                         $inbuf = "";
270                         $pos = $lth = 0;
271                 } elsif ($r eq KEY_UP || $r eq "\020") {
272                         if ($khistpos > 0) {
273                                 --$khistpos;
274                                 $inbuf = $khistory[$khistpos];
275                                 $pos = $lth = length $inbuf;
276                         } else {
277                                 beep();
278                         }
279                 } elsif ($r eq KEY_DOWN || $r eq "\016") {
280                         if ($khistpos < @khistory - 1) {
281                                 ++$khistpos;
282                                 $inbuf = $khistory[$khistpos];
283                                 $pos = $lth = length $inbuf;
284                         } else {
285                                 beep();
286                         }
287                 } elsif ($r eq KEY_PPAGE || $r eq "\032") {
288                         if ($spos > 0) {
289                                 my ($i, $l);
290                                 for ($i = 0; $i <= $pagel && $spos >= 0; ) {
291                                         $l = measure($shistory[$spos]);
292                                         $i += $l;
293                                         $spos-- if $i <= $pagel;
294                                 }
295                                 $spos = 0 if $spos < 0;
296                                 show_screen();
297                         } else {
298                                 beep();
299                         }
300                 } elsif ($r eq KEY_NPAGE || $r eq "\026") {
301                         if ($spos < @shistory - 1) {
302                                 my ($i, $l);
303                                 for ($i = 0; $i <= $pagel && $spos <= @shistory; ) {
304                                         $l = measure($shistory[$spos]);
305                                         $i += $l;
306                                         $spos++ if $i <= $pagel;
307                                 }
308                                 $spos = @shistory if $spos >= @shistory - 1;
309                                 show_screen();
310                         } else {
311                                 beep();
312                         }
313                 } elsif ($r eq KEY_LEFT || $r eq "\002") {
314                         if ($pos > 0) {
315                                 --$pos;
316                         } else {
317                                 beep();
318                         }
319                 } elsif ($r eq KEY_RIGHT || $r eq "\006") {
320                         if ($pos < $lth) {
321                                 ++$pos;
322                         } else {
323                                 beep();
324                         }
325                 } elsif ($r eq KEY_HOME || $r eq "\001") {
326                         $pos = 0;
327                 } elsif ($r eq KEY_END || $r eq "\005") {
328                         $pos = $lth;
329                 } elsif ($r eq KEY_BACKSPACE || $r eq "\010") {
330                         if ($pos > 0) {
331                                 my $a = substr($inbuf, 0, $pos-1);
332                                 my $b = substr($inbuf, $pos) if $pos < $lth;
333                                 $b = "" unless $b;
334                                 
335                                 $inbuf = $a . $b;
336                                 --$lth;
337                                 --$pos;
338                         } else {
339                                 beep();
340                         }
341                 } elsif ($r eq KEY_DC || $r eq "\004") {
342                         if ($pos < $lth) {
343                                 my $a = substr($inbuf, 0, $pos);
344                                 my $b = substr($inbuf, $pos+1) if $pos < $lth;
345                                 $b = "" unless $b;
346                                 
347                                 $inbuf = $a . $b;
348                                 --$lth;
349                         } else {
350                                 beep();
351                         }
352                 } elsif ($r ge ' ' && $r le '~') {
353                         # move the top screen back to the bottom if you type something
354                         if ($spos < @shistory) {
355                                 $spos = @shistory;
356                                 show_screen();
357                         }
358                 
359                         # insert the character into the keyboard buffer
360                         if ($pos < $lth) {
361                                 my $a = substr($inbuf, 0, $pos);
362                                 my $b = substr($inbuf, $pos);
363                                 $inbuf = $a . $r . $b;
364                         } else {
365                                 $inbuf .= $r;
366                         }
367                         $pos++;
368                         $lth++;
369                 } elsif ($r eq "\014" || $r eq "\022") {
370                         #do_resize();
371                         return;
372                 } elsif ($r eq "\013") {
373                         $inbuf = substr($inbuf, 0, $pos);
374                         $lth = length $inbuf;
375                 } else {
376                         beep();
377                 }
378                 $bot->move(1, 0);
379                 $bot->clrtobot();
380                 $bot->addstr($inbuf);
381         } 
382         $bot->move(1, $pos);
383         $bot->refresh();
384 }
385
386
387 #
388 # deal with args
389 #
390
391 $call = uc shift @ARGV if @ARGV;
392 $call = uc $myalias if !$call;
393
394 if ($call eq $mycall) {
395         print "You cannot connect as your cluster callsign ($mycall)\n";
396         exit(0);
397 }
398
399 $conn = Msg->connect("$clusteraddr", $clusterport, \&rec_socket);
400 if (! $conn) {
401         if (-r "$data/offline") {
402                 open IN, "$data/offline" or die;
403                 while (<IN>) {
404                         print $_;
405                 }
406                 close IN;
407         } else {
408                 print "Sorry, the cluster $mycall is currently off-line\n";
409         }
410         exit(0);
411 }
412
413
414 $SIG{'INT'} = \&sig_term;
415 $SIG{'TERM'} = \&sig_term;
416 #$SIG{'WINCH'} = \&do_resize;
417 $SIG{'HUP'} = 'IGNORE';
418
419 do_initscr();
420
421 $SIG{__DIE__} = \&sig_term;
422
423 $conn->send_now("A$call|$connsort");
424 $conn->send_now("I$call|set/page $maxshist");
425 $conn->send_now("I$call|set/nobeep");
426
427 Msg->set_event_handler(\*STDIN, "read" => \&rec_stdin);
428
429 for (;;) {
430         my $t;
431         Msg->event_loop(1, 1);
432         $top->refresh() if $top->is_wintouched;
433         $bot->refresh();
434         $t = time;
435         if ($t > $lasttime) {
436                 $lasttime = $t;
437         }
438 }
439
440 exit(0);