diff options
Diffstat (limited to 'Master/tlpkg/tlperl/site/lib/Tk/MsgBox.pm')
-rw-r--r-- | Master/tlpkg/tlperl/site/lib/Tk/MsgBox.pm | 506 |
1 files changed, 506 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/site/lib/Tk/MsgBox.pm b/Master/tlpkg/tlperl/site/lib/Tk/MsgBox.pm new file mode 100644 index 00000000000..9c753cf4e33 --- /dev/null +++ b/Master/tlpkg/tlperl/site/lib/Tk/MsgBox.pm @@ -0,0 +1,506 @@ +# -*- 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.002'; + +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'); + + $w->withdraw; + # + # 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__ |