diff options
Diffstat (limited to 'Master/tlpkg/tlperl0/lib/Tk/MsgBox.pm')
-rwxr-xr-x | Master/tlpkg/tlperl0/lib/Tk/MsgBox.pm | 505 |
1 files changed, 0 insertions, 505 deletions
diff --git a/Master/tlpkg/tlperl0/lib/Tk/MsgBox.pm b/Master/tlpkg/tlperl0/lib/Tk/MsgBox.pm deleted file mode 100755 index d50c528916a..00000000000 --- a/Master/tlpkg/tlperl0/lib/Tk/MsgBox.pm +++ /dev/null @@ -1,505 +0,0 @@ -# -*- perl -*- - -# msgbox.tcl -- -# -# Implements messageboxes for platforms that do not have native -# messagebox support. -# -# RCS: @(#) $Id: msgbox.tcl,v 1.30 2006/01/25 18:22:04 dgp Exp $ -# -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# - -# Translated to Perl/Tk by Slaven Rezic - -package Tk::MsgBox; - -use Tk qw(Ev); - -use strict; -use vars qw($VERSION); -$VERSION = '4.001'; - -use base qw(Tk::Toplevel); -Construct Tk::Widget 'MsgBox'; - -sub import { - if (defined $_[1] and $_[1] eq 'as_default') { - local $^W = 0; - package Tk; - *tk_messageBox = sub { - Tk::MsgBox::_tk_messageBox(@_); - }; - } -} - -use vars qw(%image); - -sub ClassInit { - my($class, $mw) = @_; - $class->SUPER::ClassInit($mw); - - $image{b1}{$mw} = $mw->Bitmap(-foreground => 'black', - -data => "#define b1_width 32\n#define b1_height 32 -static unsigned char q1_bits[] = { - 0x00, 0xf8, 0x1f, 0x00, 0x00, 0x07, 0xe0, 0x00, 0xc0, 0x00, 0x00, 0x03, - 0x20, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x08, 0x08, 0x00, 0x00, 0x10, - 0x04, 0x00, 0x00, 0x20, 0x02, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x40, - 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, - 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, - 0x01, 0x00, 0x00, 0x80, 0x02, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x40, - 0x04, 0x00, 0x00, 0x20, 0x08, 0x00, 0x00, 0x10, 0x10, 0x00, 0x00, 0x08, - 0x60, 0x00, 0x00, 0x04, 0x80, 0x03, 0x80, 0x03, 0x00, 0x0c, 0x78, 0x00, - 0x00, 0x30, 0x04, 0x00, 0x00, 0x40, 0x04, 0x00, 0x00, 0x40, 0x04, 0x00, - 0x00, 0x80, 0x04, 0x00, 0x00, 0x00, 0x05, 0x00, 0x00, 0x00, 0x06, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"); - - $image{b2}{$mw} = $mw->Bitmap(-foreground => 'white', - -data => "#define b2_width 32\n#define b2_height 32 -static unsigned char b2_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x00, 0xf8, 0x1f, 0x00, 0x00, 0xff, 0xff, 0x00, - 0xc0, 0xff, 0xff, 0x03, 0xe0, 0xff, 0xff, 0x07, 0xf0, 0xff, 0xff, 0x0f, - 0xf8, 0xff, 0xff, 0x1f, 0xfc, 0xff, 0xff, 0x3f, 0xfc, 0xff, 0xff, 0x3f, - 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f, - 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f, - 0xfe, 0xff, 0xff, 0x7f, 0xfc, 0xff, 0xff, 0x3f, 0xfc, 0xff, 0xff, 0x3f, - 0xf8, 0xff, 0xff, 0x1f, 0xf0, 0xff, 0xff, 0x0f, 0xe0, 0xff, 0xff, 0x07, - 0x80, 0xff, 0xff, 0x03, 0x00, 0xfc, 0x7f, 0x00, 0x00, 0xf0, 0x07, 0x00, - 0x00, 0xc0, 0x03, 0x00, 0x00, 0x80, 0x03, 0x00, 0x00, 0x80, 0x03, 0x00, - 0x00, 0x00, 0x03, 0x00, 0x00, 0x00, 0x02, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"); - - $image{'q'}{$mw} = $mw->Bitmap(-foreground => 'blue', - -data => "#define q_width 32\n#define q_height 32 -static unsigned char q_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x07, 0x00, - 0x00, 0x10, 0x0f, 0x00, 0x00, 0x18, 0x1e, 0x00, 0x00, 0x38, 0x1e, 0x00, - 0x00, 0x38, 0x1e, 0x00, 0x00, 0x10, 0x0f, 0x00, 0x00, 0x80, 0x07, 0x00, - 0x00, 0xc0, 0x01, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0xc0, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0xe0, 0x01, 0x00, - 0x00, 0xe0, 0x01, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"); - - $image{'i'}{$mw} = $mw->Bitmap(-foreground => 'blue', - -data => "#define i_width 32\n#define i_height 32 -static unsigned char i_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0xe0, 0x01, 0x00, 0x00, 0xf0, 0x03, 0x00, 0x00, 0xf0, 0x03, 0x00, - 0x00, 0xe0, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0xf8, 0x03, 0x00, 0x00, 0xf0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00, - 0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00, - 0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00, 0x00, 0xf0, 0x07, 0x00, - 0x00, 0xf8, 0x0f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"); - - $image{'w1'}{$mw} = $mw->Bitmap(-foreground => 'black', - -data => "#define w1_width 32\n#define w1_height 32 -static unsigned char w1_bits[] = { - 0x00, 0x80, 0x01, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x20, 0x04, 0x00, - 0x00, 0x10, 0x04, 0x00, 0x00, 0x10, 0x08, 0x00, 0x00, 0x08, 0x08, 0x00, - 0x00, 0x08, 0x10, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x04, 0x20, 0x00, - 0x00, 0x02, 0x20, 0x00, 0x00, 0x02, 0x40, 0x00, 0x00, 0x01, 0x40, 0x00, - 0x00, 0x01, 0x80, 0x00, 0x80, 0x00, 0x80, 0x00, 0x80, 0x00, 0x00, 0x01, - 0x40, 0x00, 0x00, 0x01, 0x40, 0x00, 0x00, 0x02, 0x20, 0x00, 0x00, 0x02, - 0x20, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x08, - 0x08, 0x00, 0x00, 0x08, 0x08, 0x00, 0x00, 0x10, 0x04, 0x00, 0x00, 0x10, - 0x04, 0x00, 0x00, 0x20, 0x02, 0x00, 0x00, 0x20, 0x01, 0x00, 0x00, 0x40, - 0x01, 0x00, 0x00, 0x40, 0x01, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x20, - 0xfc, 0xff, 0xff, 0x1f, 0x00, 0x00, 0x00, 0x00};"); - - $image{'w2'}{$mw} = $mw->Bitmap(-foreground => 'yellow', - -data => "#define w2_width 32\n#define w2_height 32 -static unsigned char w2_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0xc0, 0x03, 0x00, - 0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x07, 0x00, 0x00, 0xf0, 0x07, 0x00, - 0x00, 0xf0, 0x0f, 0x00, 0x00, 0xf8, 0x0f, 0x00, 0x00, 0xf8, 0x1f, 0x00, - 0x00, 0xfc, 0x1f, 0x00, 0x00, 0xfc, 0x3f, 0x00, 0x00, 0xfe, 0x3f, 0x00, - 0x00, 0xfe, 0x7f, 0x00, 0x00, 0xff, 0x7f, 0x00, 0x00, 0xff, 0xff, 0x00, - 0x80, 0xff, 0xff, 0x00, 0x80, 0xff, 0xff, 0x01, 0xc0, 0xff, 0xff, 0x01, - 0xc0, 0xff, 0xff, 0x03, 0xe0, 0xff, 0xff, 0x03, 0xe0, 0xff, 0xff, 0x07, - 0xf0, 0xff, 0xff, 0x07, 0xf0, 0xff, 0xff, 0x0f, 0xf8, 0xff, 0xff, 0x0f, - 0xf8, 0xff, 0xff, 0x1f, 0xfc, 0xff, 0xff, 0x1f, 0xfe, 0xff, 0xff, 0x3f, - 0xfe, 0xff, 0xff, 0x3f, 0xfe, 0xff, 0xff, 0x3f, 0xfc, 0xff, 0xff, 0x1f, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"); - - $image{'w3'}{$mw} = $mw->Bitmap(-foreground => 'black', - -data => "#define w3_width 32\n#define w3_height 32 -static unsigned char w3_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0xc0, 0x03, 0x00, 0x00, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x07, 0x00, - 0x00, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x07, 0x00, - 0x00, 0xc0, 0x03, 0x00, 0x00, 0xc0, 0x03, 0x00, 0x00, 0xc0, 0x03, 0x00, - 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0xc0, 0x03, 0x00, - 0x00, 0xc0, 0x03, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"); - - $class; -} - -# ::tk::MessageBox -- -# -# Pops up a messagebox with an application-supplied message with -# an icon and a list of buttons. This procedure will be called -# by tk_messageBox if the platform does not have native -# messagebox support, or if the particular type of messagebox is -# not supported natively. -# -# Color icons are used on Unix displays that have a color -# depth of 4 or more and $tk_strictMotif is not on. -# -# This procedure is a private procedure shouldn't be called -# directly. Call tk_messageBox instead. -# -# See the user documentation for details on what tk_messageBox does. -# -sub Populate { - my($w, $args) = @_; - - $w->SUPER::Populate($args); - - { - my $icon = delete $args->{-icon}; - if (!defined $icon) { - $icon = 'info'; - } - if (!grep {$icon eq $_} qw(info warning error question)) { - die "bad -icon value \"$icon\": must be error, info, question, or warning"; - } - if ($Tk::platform eq 'aqua') { - if ($icon eq 'error') { - $icon = 'stop'; - } elsif ($icon eq 'warning') { - $icon = 'caution'; - } elsif ($icon eq 'info') { - $icon = 'note'; - } - } - $w->{Configure}{icon} = $icon; - } - - { - my $type = delete $args->{-type}; - if (!defined $type) { - $type = 'ok'; - } - if ($type =~ m{^abortretryignore$}i) { - $w->{Names} = [qw(abort retry ignore)]; - $w->{Labels} = [qw(&Abort &Retry &Ignore)]; - $w->{Cancel} = 'abort'; - } elsif ($type =~ m{^ok$}i) { - $w->{Names} = [qw(ok)]; - $w->{Labels} = [qw(&OK)]; - $w->{Cancel} = 'ok'; - } elsif ($type =~ m{^okcancel$}i) { - $w->{Names} = [qw(ok cancel)]; - $w->{Labels} = [qw(&OK &Cancel)]; - $w->{Cancel} = 'cancel'; - } elsif ($type =~ m{^retrycancel$}i) { - $w->{Names} = [qw(retry cancel)]; - $w->{Labels} = [qw(&Retry &Cancel)]; - $w->{Cancel} = 'cancel'; - } elsif ($type =~ m{^yesno$}i) { - $w->{Names} = [qw(yes no)]; - $w->{Labels} = [qw(&Yes &No)]; - $w->{Cancel} = 'no'; - } elsif ($type =~ m{^yesnocancel$}i) { - $w->{Names} = [qw(yes no cancel)]; - $w->{Labels} = [qw(&Yes &No &Cancel)]; - $w->{Cancel} = 'cancel'; - } else { - die "bad -type value \"$type\": must be abortretryignore, ok, okcancel, retrycancel, yesno, or yesnocancel"; - } - $w->{Configure}{type} = $type; - } - - $w->iconname('Dialog'); - - # - # The default value of the title is space (" ") not the empty string - # because for some window managers, a - # wm title .foo "" - # causes the window title to be "foo" instead of the empty string. - # - $w->ConfigSpecs - ('-default' => ['PASSIVE',undef,undef,''], - '-detail' => ['PASSIVE',undef,undef,''], - '-message' => ['PASSIVE',undef,undef,''], - #not needed, we can do it different way in perl: '-parent' => ['PASSIVE' ...], - '-title' => ['PASSIVE',undef,undef," "], - ); - $w; -} - -sub Show { - my $w = shift; - - # If reusing the widget: - $_->destroy for ($w->children); - - my @buttons; - for my $i (0 .. $#{ $w->{Names} }) { - my($name, $lab) = ($w->{Names}[$i], $w->{Labels}[$i]); - push @buttons, [$name, -text => $lab]; # XXX missing: mc (message catalog) - } - - # If no default button was specified, the default default is the - # first button (Bug: 2218). - - if ($w->cget(-default) eq "") { - $w->configure(-default => $buttons[0][0]); - } - - my $valid = 0; - foreach my $btn (@buttons) { - if ($btn->[0] eq $w->cget(-default)) { - $valid = 1; - last; - } - } - if (!$valid) { - die "invalid default button \"" . $w->cget(-default) . "\""; - } - - ### skip the step 2, not needed in Perl/Tk - - # 3. Create the top-level window and divide it into top - # and bottom parts. - - $w->title($w->cget(-title)); - $w->protocol('WM_DELETE_WINDOW' => sub { - $w->Subwidget($w->{Cancel})->invoke; - }); - # There is only one background colour for the whole dialog - my $bg = $w->cget(-background); - - # Message boxes should be transient with respect to their parent so that - # they always stay on top of the parent window. But some window managers - # will simply create the child window as withdrawn if the parent is not - # viewable (because it is withdrawn or iconified). This is not good for - # "grab"bed windows. So only make the message box transient if the parent - # is viewable. - # - if ($w->parent->toplevel->viewable) { - $w->transient($w->parent); - } - -#XXX? -# if {$windowingsystem eq "aqua"} { -# unsupported::MacWindowStyle style $w dBoxProc # XXX what's that? -# } - - my $w_bot = $w->Frame(-background => $bg)->pack(qw(-side bottom -fill both)); -#XXX??? NYI? $w_bot->gridAnchor('center'); - my $w_top = $w->Frame(-background => $bg)->pack(qw(-side top -fill both -expand 1)); - if ($Tk::platform ne "aqua") { - $w_bot->configure(qw(-relief raised -bd 1)); - $w_top->configure(qw(-relief raised -bd 1)); - } - - # 4. Fill the top part with bitmap, message and detail (use the - # option database for -wraplength and -font so that they can be - # overridden by the caller). - - $w->optionAdd('*MsgBox.msg.wrapLength', '3i', 'widgetDefault'); - $w->optionAdd('*MsgBox.dtl.wrapLength', '3i', 'widgetDefault'); - if ($Tk::platform eq "aqua") { - $w->optionAdd('*MsgBox.msg.font', 'system', 'widgetDefault'); - $w->optionAdd('*MsgBox.dtl.font', 'system', 'widgetDefault'); - } else { - $w->optionAdd('*MsgBox.msg.font', [qw(Times 14)], 'widgetDefault'); - $w->optionAdd('*MsgBox.dtl.font', [qw(Times 10)], 'widgetDefault'); - } - - my $w_msg = $w->Label(qw(Name msg -anchor nw -justify left), - -text => $w->cget(-message), - -background => $bg, - ); - my $w_dtl; - if ($w->cget(-detail) ne "") { - $w_dtl = $w->Label(qw(Name dtl -anchor nw -justify left), - -text => $w->cget(-detail), - -background => $bg, - ); - } - my $w_bitmap; - my $icon = $w->{Configure}{icon}; - if ($icon ne "") { - if ($Tk::platform eq "aqua" - || ($w->depth < 4) || $Tk::strictMotif) { - $w_bitmap = $w->Label(Name => "bitmap", - -bitmap => $icon, - -background => $bg, - ); - } else { - $w_bitmap = $w->Canvas(Name => "bitmap", - qw(-width 32 -height 32 -highlightthickness 0), - -background => $bg, - ); - my $mw = $w->MainWindow; - if ($icon eq 'error') { - $w_bitmap->create(qw(oval 0 0 31 31 -fill red -outline black)); - $w_bitmap->create(qw(line 9 9 23 23 -fill white -width 4)); - $w_bitmap->create(qw(line 9 23 23 9 -fill white -width 4)); - } elsif ($icon eq 'info') { - $w_bitmap->create(qw(image 0 0 -anchor nw), - -image => $image{b1}{$mw}); - $w_bitmap->create(qw(image 0 0 -anchor nw), - -image => $image{b2}{$mw}); - $w_bitmap->create(qw(image 0 0 -anchor nw), - -image => $image{i}{$mw}); - } elsif ($icon eq 'question') { - $w_bitmap->create(qw(image 0 0 -anchor nw), - -image => $image{b1}{$mw}); - $w_bitmap->create(qw(image 0 0 -anchor nw), - -image => $image{b2}{$mw}); - $w_bitmap->create(qw(image 0 0 -anchor nw), - -image => $image{'q'}{$mw}); - } else { - $w_bitmap->create(qw(image 0 0 -anchor nw), - -image => $image{w1}{$mw}); - $w_bitmap->create(qw(image 0 0 -anchor nw), - -image => $image{w2}{$mw}); - $w_bitmap->create(qw(image 0 0 -anchor nw), - -image => $image{w3}{$mw}); - } - } - } else { - # Unlike in Tcl/Tk, a placeholder is needed here - $w_bitmap = $w->Label; - } - Tk::grid($w_bitmap, $w_msg, -in => $w_top, qw(-sticky news -padx 2m -pady 2m)); - $w_top->gridColumnconfigure(qw(1 -weight 1)); - if (Tk::Exists($w_dtl)) { - Tk::grid('^', $w_dtl, -in => $w_top, qw(-sticky news -padx 2m), -pady => [0, '2m']); - $w_top->gridRowconfigure(qw(1 -weight 1)); - } else { - $w_top->gridRowconfigure(qw(0 -weight 1)); - } - - # 5. Create a row of buttons at the bottom of the dialog. - - my $i = 0; - for my $but (@buttons) { - my($name, @opts) = @$but; - if (!@opts) { - # Capitalize the first letter of $name - @opts = (-text => ucfirst $name); - } - - my $cw = $w->AmpWidget('Button', -padx => '3m', @opts, - -command => sub { $w->{selectedButton} = $name }); - $w->Advertise($name => $cw); - if ($name eq $w->cget(-default)) { - $cw->configure(qw(-default active)); - } else { - $cw->configure(qw(-default normal)); - } - $cw->grid(-in => $w_bot, -row => 0, -column => $i, - qw(-padx 3m -pady 2m -sticky ew)); - $w_bot->gridColumnconfigure($i, -uniform => 'buttons'); - $i++; - - # create the binding for the key accelerator, based on the underline - # - # set underIdx [$w.$name cget -under] - # if {$underIdx >= 0} { - # set key [string index [$w.$name cget -text] $underIdx] - # bind $w <Alt-[string tolower $key]> [list $w.$name invoke] - # bind $w <Alt-[string toupper $key]> [list $w.$name invoke] - # } - } - $w->bind('<Alt-Key>', [sub { $w->AltKeyInDialog($_[1]) }, Ev('%A')]); - - if ($w->cget(-default) ne "") { - $w->bind('<FocusIn>', sub { - my $e = shift->XEvent; - my $w = $e->W; - if ($w->isa('Tk::Button')) { - $w->configure(qw(-default active)); - } - }); - $w->bind('<FocusOut>', sub { - my $e = shift->XEvent; - my $w = $e->W; - if ($w->isa('Tk::Button')) { - $w->configure(qw(-default normal)); - } - }); - } - - # 6. Create bindings for <Return>, <Escape> and <Destroy> on the dialog - - $w->bind('<Return>' => sub { - my $e = shift->XEvent; - my $w = $e->W; - if ($w->isa('Tk::Button')) { - $w->invoke; - } - }); - - # Invoke the designated cancelling operation - $w->bind('<Escape>' => sub { $w->Subwidget($w->{Cancel})->invoke }); - - # At <Destroy> the buttons have vanished, so must do this directly. - $w_msg->bind('<Destroy>' => sub { $w->{selectedButton} = $w->{Cancel} }); - - # 7. Withdraw the window, then update all the geometry information - # so we know how big it wants to be, then center the window in the - # display and de-iconify it. - - # ::tk::PlaceWindow $w widget $data(-parent) - $w->withdraw; - $w->Popup; - - # 8. Set a grab and claim the focus too. - - my $focus; - if ($w->cget(-default) ne "") { - $focus = $w->Subwidget($w->cget(-default)); - } else { - $focus = $w; - } - $w->SetFocusGrab($focus); - - # 9. Wait for the user to respond, then restore the focus and - # return the index of the selected button. Restore the focus - # before deleting the window, since otherwise the window manager - # may take the focus away so we can't redirect it. Finally, - # restore any grab that was in effect. - - $w->waitVariable(\$w->{selectedButton}); - # Copy the result now so any <Destroy> that happens won't cause - # trouble - my $result = $w->{selectedButton}; - - $w->RestoreFocusGrab($focus, 'withdraw'); - - return $result; -} - -sub _tk_messageBox { - my(%args) = @_; - my $parent = delete $args{-parent}; - my $md = $parent->MsgBox(%args); - my $an = $md->Show; - $md->destroy; - $an; -} - -1; - -__END__ |