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/local";
  18 }
  19
  20 use strict;
  21
  22 use vars qw(@modules);
  23
  24 @modules = ();                                  # is the list of modules that need init calling
  25                                                                 # on them. It is set up by each  'use'ed module
  26                                                                 # that has Gtk stuff in it
  27
  28 use DXVars;
  29 use IO::Socket::INET;
  30 use Gtk qw(-init);
  31 use Text;
  32 use DebugHandler;
  33
  34 #
  35 # main initialisation
  36 #
  37 my $call = uc shift @ARGV if @ARGV;
  38 $call = uc $main::myalias unless $call;
  39 my ($scall, $ssid) = split /-/, $call;
  40 $ssid = undef unless $ssid && $ssid =~ /^\d+$/;
  41 if ($ssid) {
  42         $ssid = 15 if $ssid > 15;
  43         $call = "$scall-$ssid";
  44 }
  45
  46 die "You cannot connect as your cluster callsign ($main::mycall)\n" if $call eq $main::mycall;
  47
  48
  49 my $sock = IO::Socket::INET->new(PeerAddr=>$main::clusteraddr, PeerPort=>$main::clusterport);
  50 die "Cannot connect to $main::clusteraddr/$main::clusterport ($!)\n" unless $sock;
  51 sendmsg('A', 'local');
  52
  53 #
  54 # start of GTK stuff
  55 #
  56
  57
  58 # main window
  59 my $main = new Gtk::Window('toplevel');
  60 $main->set_default_size(600, 600);
  61 $main->set_policy(0, 1, 0);
  62 $main->signal_connect('destroy', sub { Gtk->exit(0); });
  63 $main->signal_connect('delete_event', sub { Gtk->exit(0); });
  64 $main->set_title("gtkconsole - The DXSpider Console - $call");
  65
  66 # the main vbox
  67 my $vbox = new Gtk::VBox(0, 1);
  68 $vbox->border_width(1);
  69 $main->add($vbox);
  70 $vbox->show;
  71
  72 # the menu bar
  73 my @menu = (
  74                         {path => '/_File', type => '<Branch>'},
  75                         {path => '/_File/Quit', callback => sub {Gtk->exit(0)}},
  76                         {path => '/_Help', type => '<LastBranch>'},
  77                         {path => '/_Help/About'},
  78                    );
  79 my $accel = new Gtk::AccelGroup();
  80 my $itemf = new Gtk::ItemFactory('Gtk::MenuBar', '<main>', $accel);
  81 $itemf->create_items(@menu);
  82 $main->add_accel_group($accel);
  83 my $menu = $itemf->get_widget('<main>');
  84 $vbox->pack_start($menu, 0, 1, 0);
  85 $menu->show;
  86
  87 # create a vertically paned window and stick it in the bottom of the screen
  88 my $paned = new Gtk::VPaned;
  89 $vbox->pack_end($paned, 1, 1, 0);
  90
  91 my $top = new Text(1);
  92 my $toplist = $top->text;
  93 $toplist->set_editable(0);
  94 $paned->pack1($top, 1, 1);
  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 # the bottom handler
 101 my $bot = new Text(1);
 102 my $botlist = $bot->text;
 103 $botlist->set_editable(1);
 104 $botlist->signal_connect('activate', \&bothandler);
 105 $botlist->can_focus(1);
 106 $botlist->can_default(1);
 107 $botlist->grab_focus;
 108 $botlist->grab_default;
 109 $toplist->{signalid} = $toplist->signal_connect(insert_text => \&doinsert);
 110 $paned->pack2($bot, 0, 1);
 111 $paned->show;
 112
 113 # the main loop
 114 $main->show_all;
 115 Gtk->main;
 116
 117 #
 118 # handlers
 119 #
 120
 121 sub doinsert {
 122         my ($self, $text) = @_;
 123
 124         # we temporarily block this handler to avoid recursion
 125         $self->signal_handler_block($self->{signalid});
 126         my $pos = $self->insert($self->{font}, undef, undef, $text);
 127         $self->signal_handler_unblock($self->{signalid});
 128
 129         # we already inserted the text if it was valid: no need
 130         # for the self to process this signal emission
 131         $self->signal_emit_stop_by_name('insert-text');
 132         $self->signal_emit('activate') if $text eq "\n";
 133         1;
 134 }
 135
 136 sub bothandler
 137 {
 138         my ($self, $data) = @_;
 139         my ($msg) = $self->get_chars =~ /([^\n]*)\r?\n$/;
 140         $msg ||= '';
 141         senddata($msg);
 142 }
 143
 144 sub tophandler
 145 {
 146         my ($socket, $fd, $flags) = @_;
 147         if ($flags->{read}) {
 148                 my $offset = length $rbuf;
 149                 my $l = sysread($socket, $rbuf, 1024, $offset);
 150                 if (defined $l) {
 151                         my $freeze;
 152                         if ($l) {
 153                                 while ($rbuf =~ s/^([^\015\012]*)\015?\012//) {
 154                                         my $msg = $1;
 155                                         $msg =~ s/\%([0-9A-F][0-9A-F])/chr(hex($1))/eg;
 156                                         $msg =~ s/[\x00-\x08\x0a-\x19\x1b-\x1f\x80-\x9f]/./g;         # immutable CSI sequence + control characters
 157                                         $toplist->freeze unless $freeze++;
 158                                         handlemsg($msg);
 159                                 }
 160                                 if ($freeze) {
 161                                         $toplist->thaw;
 162                                         $toplist->vadj->set_value($toplist->vadj->upper);
 163                                         $toplist->vadj->value_changed;
 164                                 }
 165                         } else {
 166                                 Gtk->exit(0);
 167                         }
 168                 } else {
 169                         Gtk->exit(0);
 170                 }
 171         }
 172 }
 173
 174 sub handlemsg
 175 {
 176         my $msg = shift;
 177         my ($sort, $call, $line) = $msg =~ /^(\w)([^\|]+)\|(.*)$/;
 178         if ($sort eq 'D') {
 179                 $toplist->insert($toplist->{font}, undef, undef, "$line\n");
 180         } elsif ($sort eq 'Z') {
 181                 Gtk->exit(0);
 182         }
 183 }
 184
 185 #
 186 # subroutine
 187 #
 188
 189 sub senddata
 190 {
 191         my $msg = shift;
 192         sendmsg('I', $msg);
 193 }
 194
 195 sub sendmsg
 196 {
 197         my ($let, $msg) = @_;
 198         $msg =~ s/([\%\x00-\x1f\x7f-\xff])/sprintf("%%%02X", ord($1))/eg;
 199         $sock->print("$let$call|$msg\n");
 200 }