add some flesh to a gtk based console program

This commit is contained in:
minima 2006-07-19 23:51:19 +00:00
parent 9bfe1c6fb4
commit 757d8a7050
9 changed files with 425 additions and 131 deletions

14
cmd/set/gtk.pl Normal file
View File

@ -0,0 +1,14 @@
#
# set the gtk flag
#
# Copyright (c) 2006 - Dirk Koopman
#
# $Id$
#
my ($self, $line) = @_;
my @out;
$self->gtk(1);
$self->enhanced(1);
push @out, $self->msg('gtks', $self->call);
return (1, @out);

View File

@ -14,9 +14,9 @@ return (1, $self->msg('e9')) unless $line;
my ($var, $rest) = split /=|\s+/, $line, 2;
$rest =~ s/^=\s*//;
Log('DXCommand', $self->call . " set $var = $rest" );
Log('DXCommand', $self->call . " set $var = " . dd($rest) );
eval "$var = $rest";
return (1, $@ ? $@ : "Ok, $var = $rest" );
return (1, $@ ? $@ : "Ok, $var = " . dd($rest) );

View File

@ -20,11 +20,7 @@ foreach $f (@f) {
my @in;
push @in, (eval $f);
if (@in) {
my $dd = Data::Dumper->new([ \@in ], [ "$f" ]);
$dd->Indent(1);
$dd->Quotekeys(0);
my $s = $dd->Dumpxs;
push @out, $s;
push @out, "$f = ". dd(\@in);
Log('DXCommand', $self->call . " show/var $f");
} else {
push @out, $@ ? $@ : $self->msg('e3', 'show/var', $f);

14
cmd/unset/gtk.pl Normal file
View File

@ -0,0 +1,14 @@
#
# unset the gtk flag
#
# Copyright (c) 2006 - Dirk Koopman
#
# $Id$
#
my ($self, $line) = @_;
my @out;
$self->gtk(0);
$self->enhanced(0);
push @out, $self->msg('gtku', $self->call);
return (1, @out);

View File

@ -20,15 +20,16 @@ BEGIN {
use strict;
use Gtk qw(-init);
use Glib;
use Gtk2 qw(-init);
use Gtk2::Helper;
use Gtk2::SimpleList;
use vars qw(@modules $font);
@modules = (); # is the list of modules that need init calling
# on them. It is set up by each 'use'ed module
# that has Gtk stuff in it
$font = Gtk::Gdk::Font->load("-misc-fixed-medium-r-normal-*-*-130-*-*-c-*-koi8-r");
use DXVars;
use DXUtil;
use IO::Socket::INET;
@ -49,11 +50,15 @@ if ($ssid) {
die "You cannot connect as your cluster callsign ($main::mycall)\n" if $call eq $main::mycall;
my $host = 'localhost';
my $port = 7301;
my $sock = IO::Socket::INET->new(PeerAddr=>$main::clusteraddr, PeerPort=>$main::clusterport);
die "Cannot connect to $main::clusteraddr/$main::clusterport ($!)\n" unless $sock;
sendmsg('A', 'local');
sendmsg('G', '2');
my $sock = IO::Socket::INET->new(PeerAddr=>$host, PeerPort=>$port);
die "Cannot connect to $host/$port ($!)\n" unless $sock;
sendmsg('I', $call);
sendmsg('I', 'set/gtk');
#sendmsg('A', 'local');
#sendmsg('G', '2');
sendmsg('I', 'set/page 500');
sendmsg('I', 'set/nobeep');
@ -62,87 +67,197 @@ sendmsg('I', 'set/nobeep');
#
#
# +--------+-------+------------------------------------------------------------------------------------+
# | _File | _Help | |
# +--------+-------+------------------------------------------------------------------------------------+
#
# main window
my $main = new Gtk::Window('toplevel');
my $main = new Gtk2::Window('toplevel');
$main->set_default_size(600, 600);
$main->set_policy(0, 1, 0);
$main->signal_connect('destroy', sub { Gtk->exit(0); });
$main->signal_connect('delete_event', sub { Gtk->exit(0); });
$main->signal_connect('delete_event', sub { Gtk2->main_quit; });
$main->set_title("gtkconsole - The DXSpider Console - $call");
# the main vbox
my $vbox = new Gtk::VBox(0, 1);
$vbox->border_width(1);
my $vbox = new Gtk2::VBox(0, 1);
$main->add($vbox);
# the menu bar
my @menu = (
{path => '/_File', type => '<Branch>'},
{path => '/_File/Quit', callback => sub {Gtk->exit(0)}},
{path => '/_File/Quit', callback => sub {Gtk2->main_quit}},
{path => '/_Help', type => '<LastBranch>'},
{path => '/_Help/About'},
);
my $accel = new Gtk::AccelGroup();
my $itemf = new Gtk::ItemFactory('Gtk::MenuBar', '<main>', $accel);
my $itemf = new Gtk2::ItemFactory('Gtk2::MenuBar', '<main>');
$itemf->create_items(@menu);
$main->add_accel_group($accel);
my $menu = $itemf->get_widget('<main>');
$vbox->pack_start($menu, 0, 1, 0);
$menu->show;
my $top = new Text(1);
my $toplist = $top->text;
$toplist->set_editable(0);
$toplist->sensitive(0);
# another hbox is packed as the bottom of the vbox
my $bhbox = Gtk2::HBox->new(0, 1);
$vbox->pack_end($bhbox, 1, 1, 0);
# add the handler for incoming messages from the node
my $tophandler = Gtk::Gdk->input_add($sock->fileno, ['read'], \&tophandler, $sock);
my $rbuf = ""; # used in handler
# now pack two vboxes into the hbox
my $lhvbox = Gtk2::VBox->new(0, 1);
my $rhvbox = Gtk2::VBox->new(0, 1);
$bhbox->pack_start($lhvbox, 1, 1, 5);
$bhbox->pack_start(Gtk2::VSeparator->new, 0, 1, 0);
$bhbox->pack_end($rhvbox, 1, 1, 5);
#$toplist->{signalid} = $toplist->signal_connect(insert_text => \&doinsert, $toplist);
#$bot->{signalid} = $bot->signal_connect(insert_text => \&botinsert, $bot);
$vbox->pack_start($top, 1, 1, 0);
$vbox->show;
# first add a column type for the QRG
my $font = 'monospace 10';
my $oddbg = 'light blue';
my $evenbg = 'white';
Gtk2::SimpleList->add_column_type( 'qrg',
type => 'Glib::Scalar',
renderer => 'Gtk2::CellRendererText',
attr => sub {
my ($treecol, $cell, $model, $iter, $col_num) = @_;
my $info = $model->get ($iter, $col_num);
$cell->set(text => sprintf("%.1f", $info), font => $font);
}
);
Gtk2::SimpleList->add_column_type( 'tt',
type => 'Glib::Scalar',
renderer => 'Gtk2::CellRendererText',
attr => sub {
my ($treecol, $cell, $model, $iter, $col_num) = @_;
my $info = $model->get ($iter, $col_num);
$cell->set(text => $info, font => $font);
}
);
#
# LEFT HAND SIDE
#
# DX window
my $dxlist = Gtk2::SimpleList->new(
'RxTime' => 'tt',
'QRG' => 'qrg',
'DX Call' => 'tt',
'Grid' => 'tt',
'Remarks' => 'tt',
'By' => 'tt',
'Grid' => 'tt',
'TxTime' => 'tt',
);
my $dxscroll = Gtk2::ScrolledWindow->new (undef, undef);
$dxscroll->set_shadow_type ('etched-out');
$dxscroll->set_policy ('never', 'automatic');
#$dxscroll->set_size_request (700, 400);
$dxscroll->add($dxlist);
$dxscroll->set_border_width(5);
$lhvbox->pack_start($dxscroll, 1, 1, 0);
# The command list
my $cmdlist = Gtk2::SimpleList->new(
RxTime => 'tt',
Information => 'tt',
);
my $cmdscroll = Gtk2::ScrolledWindow->new (undef, undef);
$cmdscroll->set_shadow_type ('etched-out');
$cmdscroll->set_policy ('never', 'automatic');
#$cmdscroll->set_size_request (700, 400);
$cmdscroll->add($cmdlist);
$cmdscroll->set_border_width(5);
$lhvbox->pack_start($cmdscroll, 1, 1, 0);
# nice little separator
$lhvbox->pack_start(Gtk2::HSeparator->new, 0, 1, 0 );
# callsign and current date and time
my $hbox = new Gtk2::HBox;
my $calllabel = new Gtk2::Label($call);
my $date = new Gtk2::Label(cldatetime(time));
$date->{tick} = Glib::Timeout->add(1000, \&updatetime, 0);
$hbox->pack_start( $calllabel, 0, 1, 0 );
$hbox->pack_end($date, 0, 1, 0);
$lhvbox->pack_start($hbox, 0, 1, 0);
$lhvbox->pack_start(Gtk2::HSeparator->new, 0, 1, 0);
# the bottom handler
my $bot = new Gtk::Entry;
my $style = $toplist->style;
$style->font($main::font);
$bot->set_style($style);
my $bot = new Gtk2::Entry;
$bot->set_editable(1);
$bot->signal_connect('activate', \&bothandler);
$bot->can_default(1);
$lhvbox->pack_end($bot, 0, 1, 0);
$bot->grab_default;
$bot->show;
# a horizontal box
my $hbox = new Gtk::HBox;
$hbox->show;
#
# RIGHT HAND SIDE
#
# callsign and current date and time
my $calllabel = new Gtk::Label($call);
my $date = new Gtk::Label(cldatetime(time));
Gtk->timeout_add(1000, \&updatetime);
$calllabel->show;
$date->show;
# The announce list
my $annlist = Gtk2::SimpleList->new(
RxTime => 'tt',
From => 'tt',
To => 'tt',
Announcement => 'tt',
);
my $annscroll = Gtk2::ScrolledWindow->new (undef, undef);
$annscroll->set_shadow_type ('etched-out');
$annscroll->set_policy ('automatic', 'automatic');
#$annscroll->set_size_request (700, 400);
$annscroll->add($annlist);
$annscroll->set_border_width(5);
$rhvbox->pack_start($annscroll, 0, 1, 0);
# The wwv list
my $wwvlist = Gtk2::SimpleList->new(
RxTime => 'tt',
From => 'tt',
SFI => 'int',
A => 'int',
K => 'int',
Remarks => 'tt',
Hour => 'tt'
);
my $wwvscroll = Gtk2::ScrolledWindow->new (undef, undef);
$wwvscroll->set_shadow_type ('etched-out');
$wwvscroll->set_policy ('never', 'automatic');
#$wwvscroll->set_size_request (700, 200);
$wwvscroll->add($wwvlist);
$wwvscroll->set_border_width(5);
$rhvbox->pack_start($wwvscroll, 1, 1, 0);
# The wcy list
my $wcylist = Gtk2::SimpleList->new(
RxTime => 'tt',
From => 'tt',
K => 'int',
ExpK => 'int',
A => 'int',
R => 'int',
SFI => 'int',
SA => 'tt',
GMF => 'tt',
Aurora => 'tt',
Time => 'tt'
);
my $wcyscroll = Gtk2::ScrolledWindow->new (undef, undef);
$wcyscroll->set_shadow_type ('etched-out');
$wcyscroll->set_policy ('never', 'automatic');
#$wcyscroll->set_size_request (700, 200);
$wcyscroll->add($wcylist);
$wcyscroll->set_border_width(5);
$rhvbox->pack_start($wcyscroll, 1, 1, 0);
my $sock_helper = Gtk2::Helper->add_watch($sock->fileno, 'in', \&tophandler, $sock);
$hbox->pack_start( $calllabel, 0, 1, 0 );
$hbox->pack_end($date, 0, 1, 0);
$vbox->pack_start($hbox, 0, 1, 0);
# nice little separator
my $separator = new Gtk::HSeparator();
$vbox->pack_start( $separator, 0, 1, 0 );
$separator->show();
$vbox->pack_start($bot, 0, 1, 0);
# the main loop
$main->show_all;
$bot->grab_focus;
Gtk->main;
Gtk2->main;
exit(0);
#
# handlers
@ -154,20 +269,6 @@ sub updatetime
1;
}
sub doinsert {
my ($self, $text) = @_;
# we temporarily block this handler to avoid recursion
$self->signal_handler_block($self->{signalid});
my $pos = $self->insert($self->{font}, $toplist->style->black, $toplist->style->white, $text);
$self->signal_handler_unblock($self->{signalid});
# we already inserted the text if it was valid: no need
# for the self to process this signal emission
$self->signal_emit_stop_by_name('insert-text');
1;
}
sub bothandler
{
my ($self, $data) = @_;
@ -178,57 +279,140 @@ sub bothandler
senddata($msg);
}
my $rbuf;
sub tophandler
{
my ($socket, $fd, $flags) = @_;
if ($flags->{read}) {
my $offset = length $rbuf;
my $l = sysread($socket, $rbuf, 1024, $offset);
if (defined $l) {
my $freeze;
if ($l) {
while ($rbuf =~ s/^([^\015\012]*)\015?\012//) {
my $msg = $1;
$msg =~ s/\%([0-9A-F][0-9A-F])/chr(hex($1))/eg;
$msg =~ s/[\x00-\x08\x0a-\x19\x1b-\x1f\x80-\x9f]/./g; # immutable CSI sequence + control characters
$toplist->freeze unless $freeze++;
handlemsg($msg);
}
if ($freeze) {
$toplist->thaw;
$toplist->vadj->set_value($toplist->vadj->upper);
$toplist->vadj->value_changed;
}
} else {
Gtk->exit(0);
my ($fd, $condx, $socket) = @_;
my $offset = length $rbuf;
my $l = sysread($socket, $rbuf, 1024, $offset);
if (defined $l) {
if ($l) {
while ($rbuf =~ s/^([^\015\012]*)\015?\012//) {
my $msg = $1;
handlemsg($msg);
}
} else {
Gtk->exit(0);
Gtk2->main_quit;
}
} else {
Gtk2->main_quit;
}
1;
}
sub handlemsg
{
my $msg = shift;
my ($sort, $call, $line) = $msg =~ /^(\w)([^\|]+)\|(.*)$/;
if ($sort eq 'D') {
$toplist->insert($toplist->{font}, undef, undef, "$line\n");
} elsif ($sort eq 'X') {
$toplist->insert($toplist->{font}, undef, undef, "$line\n");
} elsif ($sort eq 'T') {
$toplist->insert($toplist->{font}, undef, undef, "$line\n");
} elsif ($sort eq 'Y') {
$toplist->insert($toplist->{font}, undef, undef, "$line\n");
} elsif ($sort eq 'V') {
$toplist->insert($toplist->{font}, undef, undef, "$line\n");
} elsif ($sort eq 'N') {
$toplist->insert($toplist->{font}, undef, undef, "$line\n");
} elsif ($sort eq 'W') {
$toplist->insert($toplist->{font}, undef, undef, "$line\n");
} elsif ($sort eq 'Z') {
Gtk->exit(0);
my $line = shift;
# this is truely evil and I bet there is a better way...
chomp $line;
my $list;
if ($line =~ /^'\w{2,4}',/) {
$list = eval qq([$line]);
} else {
$list = ['cmd', $line];
}
unless ($@) {
no strict 'refs';
my $cmd = shift @$list;
my $handle = "handle_$cmd";
if (__PACKAGE__->can($handle)) {
__PACKAGE__->$handle($list);
} else {
push @$list, $cmd;
__PACKAGE__->handle_def($list);
}
}
}
sub handle_cmd
{
my $self = shift;
my $ref = shift;
my ($t, $ts) = (time, '');
my $s;
$s = ref $ref ? join ', ',@$ref : $ref;
if (exists $cmdlist->{lasttime} != $t) {
$ts = tim($t);
$cmdlist->{lasttime} = $t;
}
chomp $s;
push @{$cmdlist->{data}}, [$ts, $s];
}
sub handle_def
{
my $self = shift;
my $ref = shift;
my $s;
$s = ref $ref ? join ', ',@$ref : $ref;
my ($t, $ts) = (time, '');
if (exists $cmdlist->{lasttime} != $t) {
$ts = tim($t);
$cmdlist->{lasttime} = $t;
}
chomp $s;
push @{$cmdlist->{data}}, [$ts, $s];
}
sub handle_dx
{
my $self = shift;
my $ref = shift;
my ($t, $ts) = (time, '');
if (exists $dxlist->{lasttime} != $t) {
$ts = tim($t);
$dxlist->{lasttime} = $t;
}
push @{$dxlist->{data}}, [$ts, @$ref[0,1,15,3,4,16], stim($ref->[2]) ];
}
sub handle_ann
{
my $self = shift;
my $ref = shift;
my ($t, $ts) = (time, '');
my $s;
$s = ref $ref ? join ', ',@$ref : $ref;
if (exists $cmdlist->{lasttime} != $t) {
$ts = tim($t);
$cmdlist->{lasttime} = $t;
}
chomp $s;
push @{$cmdlist->{data}}, [$ts, @$ref[0,1,2]];
}
sub handle_wcy
{
my $self = shift;
my $ref = shift;
my $s;
$s = ref $ref ? join ', ',@$ref : $ref;
chomp $s;
push @{$cmdlist->{data}}, [tim(), @$ref[10,4,5,3,6,2,7,8,9,1] ];
}
sub handle_wwv
{
my $self = shift;
my $ref = shift;
my $s;
$s = ref $ref ? join ', ',@$ref : $ref;
chomp $s;
push @{$cmdlist->{data}}, [tim(), @$ref[6,2,3,4,5,1] ];
}
#
@ -244,6 +428,19 @@ sub senddata
sub sendmsg
{
my ($let, $msg) = @_;
$msg =~ s/([\%\x00-\x1f\x7f-\xff])/sprintf("%%%02X", ord($1))/eg;
$sock->print("$let$call|$msg\n");
# $msg =~ s/([\%\x00-\x1f\x7f-\xff])/sprintf("%%%02X", ord($1))/eg;
# $sock->print("$let$call|$msg\n");
$sock->print("$msg\n");
}
sub tim
{
my $t = shift || time;
return sprintf "%02d:%02d:%02d", (gmtime($t))[2,1,0];
}
sub stim
{
my $t = shift || time;
return sprintf "%02d:%02d", (gmtime($t))[2,1];
}

View File

@ -101,6 +101,7 @@ $count = 0;
itu => '0,ITU Zone',
cq => '0,CQ Zone',
enhanced => '5,Enhanced Client,yesno',
gtk => '5,Using GTK,yesno',
senddbg => '8,Sending Debug,yesno',
width => '0,Column Width',
disconnecting => '9,Disconnecting,yesno',

View File

@ -600,6 +600,9 @@ sub disconnect
sub prompt
{
my $self = shift;
return if $self->{gtk}; # 'cos prompts are not a concept that applies here
my $call = $self->call;
my $date = cldate($main::systime);
my $time = ztime($main::systime);
@ -797,6 +800,18 @@ sub find_cmd_name {
return $package;
}
sub send
{
my $self = shift;
if ($self->{gtk}) {
for (@_) {
$self->SUPER::send(dd(['cmd',$_]));
}
} else {
$self->SUPER::send(@_);
}
}
sub local_send
{
my ($self, $let, $buf) = @_;
@ -816,7 +831,13 @@ sub talk
{
my ($self, $from, $to, $via, $line) = @_;
$line =~ s/\\5E/\^/g;
$self->local_send('T', "$to de $from: $line") if $self->{talk};
if ($self->{talk}) {
if ($self->{gtk}) {
$self->local_send('T', dd(['talk',$to,$from,$via,$line,@_]));
} else {
$self->local_send('T', "$to de $from: $line");
}
}
Log('talk', $to, $from, $via?$via:$main::mycall, $line);
# send a 'not here' message if required
unless ($self->{here} && $from ne $to) {
@ -858,9 +879,14 @@ sub announce
return if $_[0] ne $main::myalias && $_[0] ne $main::mycall;
}
return if $target eq 'SYSOP' && $self->{priv} < 5;
my $buf = "$to$target de $_[0]: $text";
$buf =~ s/\%5E/^/g;
$buf .= "\a\a" if $self->{beep};
my $buf;
if ($self->{gtk}) {
$buf = dd(['ann', $to, $target, $text, @_])
} else {
$buf = "$to$target de $_[0]: $text";
$buf =~ s/\%5E/^/g;
$buf .= "\a\a" if $self->{beep};
}
$self->local_send($target eq 'WX' ? 'W' : 'N', $buf);
}
@ -878,9 +904,14 @@ sub chat
return unless grep uc $_ eq $target, @{$self->{user}->{group}};
$text =~ s/^\#\d+ //;
my $buf = "$target de $_[0]: $text";
$buf =~ s/\%5E/^/g;
$buf .= "\a\a" if $self->{beep};
my $buf;
if ($self->{gtk}) {
$buf = dd(['chat', $to, $target, $text, @_])
} else {
$buf = "$target de $_[0]: $text";
$buf =~ s/\%5E/^/g;
$buf .= "\a\a" if $self->{beep};
}
$self->local_send('C', $buf);
}
@ -935,6 +966,24 @@ sub dx_spot
my $buf;
if ($self->{ve7cc}) {
$buf = VE7CC::dx_spot($self, @_);
} elsif ($self->{gtk}) {
my ($dxloc, $byloc);
my $ref = DXUser->get_current($_[4]);
if ($ref) {
$byloc = $ref->qra;
$byloc = substr($byloc, 0, 4) if $byloc;
}
my $spot = $_[1];
$spot =~ s|/\w{1,4}$||;
$ref = DXUser->get_current($spot);
if ($ref) {
$dxloc = $ref->qra;
$dxloc = substr($dxloc, 0, 4) if $dxloc;
}
$buf = dd(['dx', @_, ($dxloc||''), ($byloc||'')]);
} else {
$buf = $self->format_dx_spot(@_);
$buf .= "\a\a" if $self->{beep};
@ -958,8 +1007,14 @@ sub wwv
return unless $filter;
}
my $buf = "WWV de $_[6] <$_[1]>: SFI=$_[2], A=$_[3], K=$_[4], $_[5]";
$buf .= "\a\a" if $self->{beep};
my $buf;
if ($self->{gtk}) {
$buf = dd(['wwv', @_])
} else {
$buf = "WWV de $_[6] <$_[1]>: SFI=$_[2], A=$_[3], K=$_[4], $_[5]";
$buf .= "\a\a" if $self->{beep};
}
$self->local_send('V', $buf);
}
@ -977,8 +1032,13 @@ sub wcy
return unless $filter;
}
my $buf = "WCY de $_[10] <$_[1]> : K=$_[4] expK=$_[5] A=$_[3] R=$_[6] SFI=$_[2] SA=$_[7] GMF=$_[8] Au=$_[9]";
$buf .= "\a\a" if $self->{beep};
my $buf;
if ($self->{gtk}) {
$buf = dd(['wcy', @_])
} else {
$buf = "WCY de $_[10] <$_[1]> : K=$_[4] expK=$_[5] A=$_[3] R=$_[6] SFI=$_[2] SA=$_[7] GMF=$_[8] Au=$_[9]";
$buf .= "\a\a" if $self->{beep};
}
$self->local_send('Y', $buf);
}
@ -989,7 +1049,11 @@ sub broadcast_debug
foreach my $dxchan (DXChannel::get_all) {
next unless $dxchan->{enhanced} && $dxchan->{senddbg};
$dxchan->send_later('L', $s);
if ($dxchan->{gtk}) {
$dxchan->local_send('L', dd(['db', $s]));
} else {
$dxchan->local_send('L', $s);
}
}
}

View File

@ -85,6 +85,7 @@ $v3 = 0;
wantusstate => '0,Show US State,yesno',
wantdxcq => '0,Show CQ Zone,yesno',
wantdxitu => '0,Show ITU Zone,yesno',
wantgtk => '0,Want GTK interface,yesno',
lastoper => '9,Last for/oper,cldatetime',
nothere => '0,Not Here Text',
registered => '9,Registered?,yesno',
@ -716,6 +717,11 @@ sub wantdxitu
return _want('dxitu', @_);
}
sub wantgtk
{
return _want('gtk', @_);
}
sub wantlogininfo
{
my $self = shift;

View File

@ -121,6 +121,8 @@ package DXM;
grayline2 => 'Location dd/mm/yyyy Dawn Rise Set Dusk',
grids => 'DX Grid enabled for $_[0]',
gridu => 'DX Grid disabled for $_[0]',
gtks => 'GTK output enabled for $_[0]',
gtku => 'GTK output disabled for $_[0]',
illcall => 'Sorry, $_[0] is an invalid callsign',
hasha => '$_[0] already exists in $_[1]',
hashb => '$_[0] added to $_[1]',