Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | # |
2 | # DialogBox is similar to Dialog except that it allows any widget | |
3 | # in the top frame. Widgets can be added with the add method. Currently | |
4 | # there exists no way of deleting a widget once it has been added. | |
5 | ||
6 | package Tk::DialogBox; | |
7 | ||
8 | use strict; | |
9 | use Carp; | |
10 | ||
11 | use vars qw($VERSION); | |
12 | $VERSION = '3.032'; # $Id: //depot/Tk8/Tixish/DialogBox.pm#32 $ | |
13 | ||
14 | use base qw(Tk::Toplevel); | |
15 | ||
16 | Tk::Widget->Construct('DialogBox'); | |
17 | ||
18 | sub Populate { | |
19 | my ($cw, $args) = @_; | |
20 | ||
21 | $cw->SUPER::Populate($args); | |
22 | my $buttons = delete $args->{'-buttons'}; | |
23 | $buttons = ['OK'] unless defined $buttons; | |
24 | my $default_button = delete $args->{'-default_button'}; | |
25 | $default_button = $buttons->[0] unless defined $default_button; | |
26 | ||
27 | $cw->{'selected_button'} = ''; | |
28 | $cw->transient($cw->Parent->toplevel); | |
29 | $cw->withdraw; | |
30 | $cw->protocol('WM_DELETE_WINDOW' => sub {}); | |
31 | ||
32 | # create the two frames | |
33 | my $top = $cw->Component('Frame', 'top'); | |
34 | $top->configure(-relief => 'raised', -bd => 1) unless $Tk::platform eq 'MSWin32'; | |
35 | my $bot = $cw->Component('Frame', 'bottom'); | |
36 | $bot->configure(-relief => 'raised', -bd => 1) unless $Tk::platform eq 'MSWin32'; | |
37 | $bot->pack(qw/-side bottom -fill both -ipady 3 -ipadx 3/); | |
38 | $top->pack(qw/-side top -fill both -ipady 3 -ipadx 3 -expand 1/); | |
39 | ||
40 | # create a row of buttons in the bottom. | |
41 | my $bl; # foreach my $var: perl > 5.003_08 | |
42 | foreach $bl (@$buttons) | |
43 | { | |
44 | my $b = $bot->Button(-text => $bl, -command => sub { $cw->{'selected_button'} = "$bl" } ); | |
45 | $cw->Advertise("B_$bl" => $b); | |
46 | if ($Tk::platform eq 'MSWin32') | |
47 | { | |
48 | $b->configure(-width => 10, -pady => 0); | |
49 | } | |
50 | if ($bl eq $default_button) { | |
51 | if ($Tk::platform eq 'MSWin32') { | |
52 | $b->pack(-side => 'left', -expand => 1, -padx => 1, -pady => 1); | |
53 | } else { | |
54 | my $db = $bot->Frame(-relief => 'sunken', -bd => 1); | |
55 | $b->raise($db); | |
56 | $b->pack(-in => $db, -padx => '2', -pady => '2'); | |
57 | $db->pack(-side => 'left', -expand => 1, -padx => 1, -pady => 1); | |
58 | } | |
59 | $cw->bind('<Return>' => [ $b, 'Invoke']); | |
60 | $cw->{'default_button'} = $b; | |
61 | } else { | |
62 | $b->pack(-side => 'left', -expand => 1, -padx => 1, -pady => 1); | |
63 | } | |
64 | } | |
65 | $cw->ConfigSpecs(-command => ['CALLBACK', undef, undef, undef ], | |
66 | -foreground => ['DESCENDANTS', 'foreground','Foreground', 'black'], | |
67 | -background => ['DESCENDANTS', 'background','Background', undef], | |
68 | ); | |
69 | $cw->Delegates('Construct',$top); | |
70 | } | |
71 | ||
72 | sub add { | |
73 | my ($cw, $wnam, @args) = @_; | |
74 | my $w = $cw->Subwidget('top')->$wnam(@args); | |
75 | $cw->Advertise("\L$wnam" => $w); | |
76 | return $w; | |
77 | } | |
78 | ||
79 | sub Wait | |
80 | { | |
81 | my $cw = shift; | |
82 | $cw->waitVariable(\$cw->{'selected_button'}); | |
83 | $cw->grabRelease; | |
84 | $cw->withdraw; | |
85 | $cw->Callback(-command => $cw->{'selected_button'}); | |
86 | } | |
87 | ||
88 | sub Show { | |
89 | my ($cw, $grab) = @_; | |
90 | croak 'DialogBox: "Show" method requires at least 1 argument' | |
91 | if scalar @_ < 1; | |
92 | my $old_focus = $cw->focusSave; | |
93 | my $old_grab = $cw->grabSave; | |
94 | ||
95 | $cw->Popup(); | |
96 | ||
97 | Tk::catch { | |
98 | if (defined $grab && length $grab && ($grab =~ /global/)) { | |
99 | $cw->grabGlobal; | |
100 | } else { | |
101 | $cw->grab; | |
102 | } | |
103 | }; | |
104 | if (defined $cw->{'default_button'}) { | |
105 | $cw->{'default_button'}->focus; | |
106 | } else { | |
107 | $cw->focus; | |
108 | } | |
109 | $cw->Wait; | |
110 | &$old_focus; | |
111 | &$old_grab; | |
112 | return $cw->{'selected_button'}; | |
113 | } | |
114 | ||
115 | 1; |