You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
101 lines
2.7 KiB
101 lines
2.7 KiB
# ----------------------------------------------------------------------------- |
|
# Author(s) : Bill Atkins |
|
# Title : Tk-Win32 initialization file |
|
# Date : 1.22.02 |
|
# Desc : initializes the Tk-GUI plugin |
|
# Notes : for more information see the plugin documentation |
|
# License : it's on our TODO list... |
|
# ----------------------------------------------------------------------------- |
|
|
|
package TkGUI; |
|
|
|
use warnings; |
|
|
|
use Tk; |
|
use Tk::ItemStyle; |
|
use Milkbone; |
|
|
|
my $mw = MainWindow->new(); |
|
$mw->withdraw(); |
|
$mw->OnDestroy(\&on_destroy); |
|
|
|
if(win32()) |
|
{ |
|
$defaultFont = 'tahoma'; |
|
} |
|
else |
|
{ |
|
$defaultFont = '{open look glyph}'; |
|
} |
|
|
|
$mw->optionAdd("*font", "-*-$defaultFont-norma-r-*-*-*-120-*-*-*-*-*-*") if win32(); |
|
$mw->optionAdd("*font", "{open look glyph} 8 bold") if nix(); |
|
$mw->optionAdd("*borderWidth", 1); |
|
$mw->optionAdd("*highlightThickness", 0); |
|
|
|
$mw->optionAdd("*background", option("ThemeColor")) if(option("ThemeColor")); |
|
|
|
my $icon = $mw->Photo(-file => "images/icon.bmp"); |
|
|
|
register_hook("tk_seticon", sub { $ARGS{-wnd}->Icon(-image => $icon); }); |
|
register_hook("tk_get_default_font", sub { $defaultFont }); |
|
|
|
register_hook("tick", \&tick); |
|
register_hook("tk_getmain", sub { |
|
return $mw; |
|
}); |
|
|
|
register_hook("tk_bindwheel", sub { |
|
if($^O =~ /win32/i) |
|
{ |
|
$ARGS{-window}->bind('<MouseWheel>', |
|
[ sub { $_[0]->yview('scroll', -($_[1] / 120), 'units') }, Tk::Ev('D')]); |
|
} |
|
else |
|
{ |
|
$ARGS{-window}->bind('<4>' => sub { $_[0]->yview('scroll', -1, 'units') unless $Tk::strictMotif; |
|
}); |
|
|
|
$ARGS{-window}->bind('<5>' => sub { $_[0]->yview('scroll', 1, 'units') unless $Tk::strictMotif; |
|
}); |
|
} |
|
}); |
|
|
|
register_hook("after", sub { |
|
$mw->after($ARGS{-time}, $ARGS{-code}); |
|
}); |
|
|
|
|
|
sub tick |
|
{ |
|
return unless $mw; |
|
|
|
$mw->DoOneEvent(Tk::ALL_EVENTS); |
|
} |
|
|
|
sub on_destroy |
|
{ |
|
abort(); |
|
} |
|
|
|
register_hook("error", sub { |
|
my $text = $ARGS{-short}; |
|
($text) = $text =~ m/^(.*?)\n/; |
|
my $error_box = $mw->Toplevel(-title => "Milkbone Error"); |
|
$error_box->Label(-text => $ARGS{-short}, -wraplength => 200)->pack; |
|
$error_box->Button(-text => "OK", -command => [sub { |
|
my ($self, $fatal) = @_; |
|
$self->destroy; |
|
hook("protocol_signoff") if $fatal; |
|
$mw->destroy if $fatal && hook("protocol_signed_in"); |
|
}, $error_box, $ARGS{-fatal}])->pack->focus; |
|
hook("tk_seticon", -wnd => $error_box); |
|
$error_box->withdraw; |
|
$error_box->geometry("+" . int(($mw->screenwidth() / 2) - int($error_box->width() / 2)) . "+" . int(($mw->screenheight() / 2) - int($error_box->height() / 2)) ); |
|
$error_box->deiconify; |
|
$error_box->update; |
|
$error_box->focus; |
|
}); |
|
|
|
|
|
1;
|
|
|