summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl0/lib/Tk/MsgBox.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl0/lib/Tk/MsgBox.pm')
-rwxr-xr-xMaster/tlpkg/tlperl0/lib/Tk/MsgBox.pm505
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__