gtkconsole/gtkconsole

   1 #!/usr/bin/perl -w
   2 #
   3 # A GTK based console program
   4 #
   5 # Copyright (c) 2001 Dirk Koopman G1TLH
   6 #
   7 # $Id$
   8 #
   9
  10 # search local then perl directories
  11 BEGIN {
  12         # root of directory tree for this system
  13         $root = "/spider";
  14         $root = $ENV{'DXSPIDER_ROOT'} if $ENV{'DXSPIDER_ROOT'};
  15
  16         unshift @INC, "$root/perl";     # this IS the right way round!
  17         unshift @INC, "$root/gtkconsole";
  18         unshift @INC, "$root/local";
  19 }
  20
  21 use strict;
  22
  23 use vars qw(@modules);
  24
  25 @modules = ();                                  # is the list of modules that need init calling
  26                                                                 # on them. It is set up by each  'use'ed module
  27                                                                 # that has Gtk stuff in it
  28
  29 use DXVars;
  30 use DXUtil;
  31 use IO::Socket::INET;
  32 use Gtk qw(-init);
  33 use Text;
  34 use DebugHandler;
  35
  36 #
  37 # main initialisation
  38 #
  39 my $call = uc shift @ARGV if @ARGV;
  40 $call = uc $main::myalias unless $call;
  41 my ($scall, $ssid) = split /-/, $call;
  42 $ssid = undef unless $ssid && $ssid =~ /^\d+$/;
  43 if ($ssid) {
  44         $ssid = 15 if $ssid > 15;
  45         $call = "$scall-$ssid";
  46 }
  47
  48 die "You cannot connect as your cluster callsign ($main::mycall)\n" if $call eq $main::mycall;
  49
  50
  51 my $sock = IO::Socket::INET->new(PeerAddr=>$main::clusteraddr, PeerPort=>$main::clusterport);
  52 die "Cannot connect to $main::clusteraddr/$main::clusterport ($!)\n" unless $sock;
  53 sendmsg('A', 'local');
  54 sendmsg('G', '2');
  55 sendmsg('I', 'set/page 500');
  56 sendmsg('I', 'set/nobeep');
  57
  58 #
  59 # start of GTK stuff
  60 #
  61
  62
  63 # main window
  64 my $main = new Gtk::Window('toplevel');
  65 $main->set_default_size(600, 600);
  66 $main->set_policy(0, 1, 0);
  67 $main->signal_connect('destroy', sub { Gtk->exit(0); });
  68 $main->signal_connect('delete_event', sub { Gtk->exit(0); });
  69 $main->set_title("gtkconsole - The DXSpider Console - $call");
  70
  71 # the main vbox
  72 my $vbox = new Gtk::VBox(0, 1);
  73 $vbox->border_width(1);
  74 $main->add($vbox);
  75
  76 # the menu bar
  77 my @menu = (
  78                         {path => '/_File', type => '<Branch>'},
  79                         {path => '/_File/Quit', callback => sub {Gtk->exit(0)}},
  80                         {path => '/_Help', type => '<LastBranch>'},
  81                         {path => '/_Help/About'},
  82                    );
  83 my $accel = new Gtk::AccelGroup();
  84 my $itemf = new Gtk::ItemFactory('Gtk::MenuBar', '<main>', $accel);
  85 $itemf->create_items(@menu);
  86 $main->add_accel_group($accel);
  87 my $menu = $itemf->get_widget('<main>');
  88 $vbox->pack_start($menu, 0, 1, 0);
  89 $menu->show;
  90
  91
  92 my $top = new Text(1);
  93 my $toplist = $top->text;
  94 $toplist->set_editable(0);
  95
  96 # add the handler for incoming messages from the node
  97 my $tophandler = Gtk::Gdk->input_add($sock->fileno, ['read'], \&tophandler, $sock);
  98 my $rbuf = "";                                          # used in handler
  99
 100 $toplist->{signalid} = $toplist->signal_connect(insert_text => \&doinsert, $toplist);
 101 #$bot->{signalid} = $bot->signal_connect(insert_text => \&botinsert, $bot);
 102 $vbox->pack_start($top, 1, 1, 0);
 103 $vbox->show;
 104
 105 # the bottom handler
 106 my $bot = new Gtk::Entry;
 107 $bot->set_editable(1);
 108 $bot->signal_connect('activate', \&bothandler);
 109 $bot->can_focus(1);
 110 $bot->can_default(1);
 111 $bot->grab_focus;
 112 $bot->grab_default;
 113 $bot->show;
 114
 115 # a horizontal box
 116 my $hbox = new Gtk::HBox;
 117 $hbox->show;
 118
 119 # callsign and current date and time
 120 my $calllabel = new Gtk::Label($call);
 121 my $date = new Gtk::Label(cldatetime(time));
 122 Gtk->timeout_add(1000, \&updatetime);
 123 $calllabel->show;
 124 $date->show;
 125
 126 $hbox->pack_start( $calllabel, 0, 1, 0 );
 127 $hbox->pack_end($date, 0, 1, 0);
 128
 129
 130 $vbox->pack_start($hbox, 0, 1, 0);
 131
 132 # nice little separator
 133 my $separator = new Gtk::HSeparator();
 134 $vbox->pack_start( $separator, 0, 1, 0 );
 135 $separator->show();
 136 $vbox->pack_start($bot, 0, 1, 0);
 137
 138 # the main loop
 139 $main->show_all;
 140 Gtk->main;
 141
 142 #
 143 # handlers
 144 #
 145
 146 sub updatetime
 147 {
 148         $date->set_text(cldatetime(time));
 149         1;
 150 }
 151
 152 sub doinsert {
 153         my ($self, $text) = @_;
 154
 155         # we temporarily block this handler to avoid recursion
 156         $self->signal_handler_block($self->{signalid});
 157         my $pos = $self->insert($self->{font}, $toplist->style->black, $toplist->style->white, $text);
 158         $self->signal_handler_unblock($self->{signalid});
 159
 160         # we already inserted the text if it was valid: no need
 161         # for the self to process this signal emission
 162         $self->signal_emit_stop_by_name('insert-text');
 163         1;
 164 }
 165
 166 sub botinsert
 167 {
 168         my ($self, $text) = @_;
 169
 170         printf "%s\n", $text;
 171
 172         1;
 173 }
 174
 175 sub bothandler
 176 {
 177         my ($self, $data) = @_;
 178         my $msg = $self->get_text;
 179         $msg =~ s/\r?\n$//;
 180         $self->set_text('');
 181         senddata($msg);
 182 }
 183
 184 sub tophandler
 185 {
 186         my ($socket, $fd, $flags) = @_;
 187         if ($flags->{read}) {
 188                 my $offset = length $rbuf;
 189                 my $l = sysread($socket, $rbuf, 1024, $offset);
 190                 if (defined $l) {
 191                         my $freeze;
 192                         if ($l) {
 193                                 while ($rbuf =~ s/^([^\015\012]*)\015?\012//) {
 194                                         my $msg = $1;
 195                                         $msg =~ s/\%([0-9A-F][0-9A-F])/chr(hex($1))/eg;
 196                                         $msg =~ s/[\x00-\x08\x0a-\x19\x1b-\x1f\x80-\x9f]/./g;         # immutable CSI sequence + control characters
 197                                         $toplist->freeze unless $freeze++;
 198                                         handlemsg($msg);
 199                                 }
 200                                 if ($freeze) {
 201                                         $toplist->thaw;
 202                                         $toplist->vadj->set_value($toplist->vadj->upper);
 203                                         $toplist->vadj->value_changed;
 204                                 }
 205                         } else {
 206                                 Gtk->exit(0);
 207                         }
 208                 } else {
 209                         Gtk->exit(0);
 210                 }
 211         }
 212 }
 213
 214 sub handlemsg
 215 {
 216         my $msg = shift;
 217         my ($sort, $call, $line) = $msg =~ /^(\w)([^\|]+)\|(.*)$/;
 218         if ($sort eq 'D') {
 219                 $toplist->insert($toplist->{font}, undef, undef, "$line\n");
 220         } elsif ($sort eq 'X') {
 221                 $toplist->insert($toplist->{font}, undef, undef, "$line\n");
 222         } elsif ($sort eq 'Y') {
 223                 $toplist->insert($toplist->{font}, undef, undef, "$line\n");
 224         } elsif ($sort eq 'V') {
 225                 $toplist->insert($toplist->{font}, undef, undef, "$line\n");
 226         } elsif ($sort eq 'N') {
 227                 $toplist->insert($toplist->{font}, undef, undef, "$line\n");
 228         } elsif ($sort eq 'W') {
 229                 $toplist->insert($toplist->{font}, undef, undef, "$line\n");
 230         } elsif ($sort eq 'Z') {
 231                 Gtk->exit(0);
 232         }
 233 }
 234
 235 #
 236 # subroutine
 237 #
 238
 239 sub senddata
 240 {
 241         my $msg = shift;
 242         sendmsg('I', $msg);
 243 }
 244
 245 sub sendmsg
 246 {
 247         my ($let, $msg) = @_;
 248         $msg =~ s/([\%\x00-\x1f\x7f-\xff])/sprintf("%%%02X", ord($1))/eg;
 249         $sock->print("$let$call|$msg\n");
 250 }