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