Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | # Copyright (c) 1995-1999 Nick Ing-Simmons. All rights reserved. |
2 | # This program is free software; you can redistribute it and/or | |
3 | # modify it under the same terms as Perl itself. | |
4 | package Tk::Toplevel; | |
5 | use AutoLoader; | |
6 | ||
7 | use vars qw($VERSION); | |
8 | $VERSION = '3.028'; # $Id: //depot/Tk8/Tk/Toplevel.pm#28 $ | |
9 | ||
10 | use base qw(Tk::Wm Tk::Frame); | |
11 | ||
12 | Construct Tk::Widget 'Toplevel'; | |
13 | ||
14 | sub Tk_cmd { \&Tk::toplevel } | |
15 | ||
16 | sub CreateOptions | |
17 | { | |
18 | return (shift->SUPER::CreateOptions,'-screen','-use') | |
19 | } | |
20 | ||
21 | sub Populate | |
22 | { | |
23 | my ($cw,$arg) = @_; | |
24 | $cw->SUPER::Populate($arg); | |
25 | $cw->ConfigSpecs('-title',['METHOD',undef,undef,$cw->class]); | |
26 | } | |
27 | ||
28 | sub Icon | |
29 | { | |
30 | my ($top,%args) = @_; | |
31 | my $icon = $top->iconwindow; | |
32 | my $state = $top->state; | |
33 | if ($state ne 'withdrawn') | |
34 | { | |
35 | $top->withdraw; | |
36 | $top->update; # Let attributes propogate | |
37 | } | |
38 | unless (defined $icon) | |
39 | { | |
40 | $icon = Tk::Toplevel->new($top,'-borderwidth' => 0,'-class'=>'Icon'); | |
41 | $icon->withdraw; | |
42 | # Fake Populate | |
43 | my $lab = $icon->Component('Label' => 'icon'); | |
44 | $lab->pack('-expand'=>1,'-fill' => 'both'); | |
45 | $icon->ConfigSpecs(DEFAULT => ['DESCENDANTS']); | |
46 | # Now do tail of InitObject | |
47 | $icon->ConfigDefault(\%args); | |
48 | # And configure that new would have done | |
49 | $top->iconwindow($icon); | |
50 | $top->update; | |
51 | $lab->DisableButtonEvents; | |
52 | $lab->update; | |
53 | } | |
54 | $top->iconimage($args{'-image'}) if (exists $args{'-image'}); | |
55 | $icon->configure(%args); | |
56 | $icon->idletasks; # Let size request propogate | |
57 | $icon->geometry($icon->ReqWidth . 'x' . $icon->ReqHeight); | |
58 | $icon->update; # Let attributes propogate | |
59 | $top->deiconify if ($state eq 'normal'); | |
60 | $top->iconify if ($state eq 'iconic'); | |
61 | } | |
62 | ||
63 | sub menu | |
64 | { | |
65 | my $w = shift; | |
66 | my $menu; | |
67 | $menu = $w->cget('-menu'); | |
68 | unless (defined $menu) | |
69 | { | |
70 | $w->configure(-menu => ($menu = $w->SUPER::menu)) | |
71 | } | |
72 | $menu->configure(@_) if @_; | |
73 | return $menu; | |
74 | } | |
75 | ||
76 | ||
77 | 1; | |
78 | __END__ | |
79 | ||
80 | #---------------------------------------------------------------------- | |
81 | # | |
82 | # Focus Group | |
83 | # | |
84 | # Focus groups are used to handle the user's focusing actions inside a | |
85 | # toplevel. | |
86 | # | |
87 | # One example of using focus groups is: when the user focuses on an | |
88 | # entry, the text in the entry is highlighted and the cursor is put to | |
89 | # the end of the text. When the user changes focus to another widget, | |
90 | # the text in the previously focused entry is validated. | |
91 | # | |
92 | ||
93 | #---------------------------------------------------------------------- | |
94 | # tkFocusGroup_Create -- | |
95 | # | |
96 | # Create a focus group. All the widgets in a focus group must be | |
97 | # within the same focus toplevel. Each toplevel can have only | |
98 | # one focus group, which is identified by the name of the | |
99 | # toplevel widget. | |
100 | # | |
101 | sub FG_Create { | |
102 | my $t = shift; | |
103 | unless (exists $t->{'_fg'}) { | |
104 | $t->{'_fg'} = 1; | |
105 | $t->bind('<FocusIn>', sub { | |
106 | my $w = shift; | |
107 | my $Ev = $w->XEvent; | |
108 | $t->FG_In($w, $Ev->d); | |
109 | } | |
110 | ); | |
111 | $t->bind('<FocusOut>', sub { | |
112 | my $w = shift; | |
113 | my $Ev = $w->XEvent; | |
114 | $t->FG_Out($w, $Ev->d); | |
115 | } | |
116 | ); | |
117 | $t->bind('<Destroy>', sub { | |
118 | my $w = shift; | |
119 | my $Ev = $w->XEvent; | |
120 | $t->FG_Destroy($w); | |
121 | } | |
122 | ); | |
123 | # <Destroy> is not sufficient to break loops if never mapped. | |
124 | $t->OnDestroy([$t,'FG_Destroy']); | |
125 | } | |
126 | } | |
127 | ||
128 | # tkFocusGroup_BindIn -- | |
129 | # | |
130 | # Add a widget into the "FocusIn" list of the focus group. The $cmd will be | |
131 | # called when the widget is focused on by the user. | |
132 | # | |
133 | sub FG_BindIn { | |
134 | my($t, $w, $cmd) = @_; | |
135 | $t->Error("focus group \"$t\" doesn't exist") unless (exists $t->{'_fg'}); | |
136 | $t->{'_FocusIn'}{$w} = Tk::Callback->new($cmd); | |
137 | } | |
138 | ||
139 | # tkFocusGroup_BindOut -- | |
140 | # | |
141 | # Add a widget into the "FocusOut" list of the focus group. The | |
142 | # $cmd will be called when the widget loses the focus (User | |
143 | # types Tab or click on another widget). | |
144 | # | |
145 | sub FG_BindOut { | |
146 | my($t, $w, $cmd) = @_; | |
147 | $t->Error("focus group \"$t\" doesn't exist") unless (exists $t->{'_fg'}); | |
148 | $t->{'_FocusOut'}{$w} = Tk::Callback->new($cmd); | |
149 | } | |
150 | ||
151 | # tkFocusGroup_Destroy -- | |
152 | # | |
153 | # Cleans up when members of the focus group is deleted, or when the | |
154 | # toplevel itself gets deleted. | |
155 | # | |
156 | sub FG_Destroy { | |
157 | my($t, $w) = @_; | |
158 | if (!defined($w) || $t == $w) { | |
159 | delete $t->{'_fg'}; | |
160 | delete $t->{'_focus'}; | |
161 | delete $t->{'_FocusOut'}; | |
162 | delete $t->{'_FocusIn'}; | |
163 | } else { | |
164 | if (exists $t->{'_focus'}) { | |
165 | delete $t->{'_focus'} if ($t->{'_focus'} == $w); | |
166 | } | |
167 | delete $t->{'_FocusIn'}{$w}; | |
168 | delete $t->{'_FocusOut'}{$w}; | |
169 | } | |
170 | } | |
171 | ||
172 | # tkFocusGroup_In -- | |
173 | # | |
174 | # Handles the <FocusIn> event. Calls the FocusIn command for the newly | |
175 | # focused widget in the focus group. | |
176 | # | |
177 | sub FG_In { | |
178 | my($t, $w, $detail) = @_; | |
179 | if (defined $t->{'_focus'} and $t->{'_focus'} eq $w) { | |
180 | # This is already in focus | |
181 | return; | |
182 | } else { | |
183 | $t->{'_focus'} = $w; | |
184 | $t->{'_FocusIn'}{$w}->Call if exists $t->{'_FocusIn'}{$w}; | |
185 | } | |
186 | } | |
187 | ||
188 | # tkFocusGroup_Out -- | |
189 | # | |
190 | # Handles the <FocusOut> event. Checks if this is really a lose | |
191 | # focus event, not one generated by the mouse moving out of the | |
192 | # toplevel window. Calls the FocusOut command for the widget | |
193 | # who loses its focus. | |
194 | # | |
195 | sub FG_Out { | |
196 | my($t, $w, $detail) = @_; | |
197 | if ($detail ne 'NotifyNonlinear' and $detail ne 'NotifyNonlinearVirtual') { | |
198 | # This is caused by mouse moving out of the window | |
199 | return; | |
200 | } | |
201 | unless (exists $t->{'_FocusOut'}{$w}) { | |
202 | return; | |
203 | } else { | |
204 | $t->{'_FocusOut'}{$w}->Call; | |
205 | delete $t->{'_focus'}; | |
206 | } | |
207 | } | |
208 | ||
209 | 1; | |
210 | ||
211 | __END__ |