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::Frame; | |
5 | require Tk::Widget; | |
6 | require Tk::Derived; | |
7 | use AutoLoader; | |
8 | use strict qw(vars); | |
9 | use Carp; | |
10 | ||
11 | use base qw(Tk::Derived Tk::Widget); | |
12 | ||
13 | Construct Tk::Widget 'Frame'; | |
14 | ||
15 | ||
16 | use vars qw($VERSION); | |
17 | $VERSION = '3.031'; # $Id: //depot/Tk8/Tk/Frame.pm#31 $ | |
18 | ||
19 | sub Tk_cmd { \&Tk::frame } | |
20 | ||
21 | sub CreateOptions | |
22 | { | |
23 | return (shift->SUPER::CreateOptions,'-colormap','-visual','-container') | |
24 | } | |
25 | ||
26 | sub Default | |
27 | { | |
28 | my ($cw,$name,$widget) = @_; | |
29 | confess 'No name' unless (defined $name); | |
30 | croak 'No widget' unless (defined $widget); | |
31 | $cw->Delegates(DEFAULT => $widget); | |
32 | $cw->ConfigSpecs(DEFAULT => [$widget]); | |
33 | $widget->pack('-expand' => 1, -fill => 'both') unless ($widget->manager); # Suspect | |
34 | $cw->Advertise($name,$widget); | |
35 | } | |
36 | ||
37 | sub ConfigDelegate | |
38 | { | |
39 | my ($cw,$name,@skip) = @_; | |
40 | my $sw = $cw->Subwidget($name); | |
41 | my $sc; | |
42 | my %skip = (); | |
43 | foreach $sc (@skip) | |
44 | { | |
45 | $skip{$sc} = 1; | |
46 | } | |
47 | foreach $sc ($sw->configure) | |
48 | { | |
49 | my (@info) = @$sc; | |
50 | next if (@info == 2); | |
51 | my $option = $info[0]; | |
52 | unless ($skip{$option}) | |
53 | { | |
54 | $option =~ s/^-(.*)/-$name\u$1/; | |
55 | $info[0] = Tk::Configure->new($sw,$info[0]); | |
56 | pop(@info); | |
57 | $cw->ConfigSpecs($option => \@info); | |
58 | } | |
59 | } | |
60 | } | |
61 | ||
62 | sub bind | |
63 | {my ($cw,@args) = @_; | |
64 | $cw->Delegate('bind',@args); | |
65 | } | |
66 | ||
67 | sub menu | |
68 | {my ($cw,@args) = @_; | |
69 | $cw->Delegate('menu',@args); | |
70 | } | |
71 | ||
72 | sub focus | |
73 | {my ($cw,@args) = @_; | |
74 | $cw->Delegate('focus',@args); | |
75 | } | |
76 | ||
77 | #sub bindtags | |
78 | #{my ($cw,@args) = @_; | |
79 | # $cw->Delegate('bindtags',@args); | |
80 | #} | |
81 | ||
82 | sub selection | |
83 | {my ($cw,@args) = @_; | |
84 | $cw->Delegate('selection',@args); | |
85 | } | |
86 | ||
87 | sub Populate | |
88 | { | |
89 | my ($cw,$args) = @_; | |
90 | $cw->ConfigSpecs('-labelPack' => [ 'METHOD', undef, undef, undef]); | |
91 | $cw->ConfigSpecs('-labelVariable' => [ 'METHOD', undef, undef, undef]); | |
92 | $cw->ConfigSpecs('-label' => [ 'METHOD', undef, undef, undef]); | |
93 | $cw->labelPack([]) if grep /^-label\w+/, keys %$args; | |
94 | } | |
95 | ||
96 | sub Menubar | |
97 | { | |
98 | my $frame = shift; | |
99 | my $menu = $frame->cget('-menu'); | |
100 | if (defined $menu) | |
101 | { | |
102 | $menu->configure(@_) if @_; | |
103 | } | |
104 | else | |
105 | { | |
106 | $menu = $frame->Menu(-type => 'menubar',@_); | |
107 | $frame->configure('-menu' => $menu); | |
108 | } | |
109 | $frame->Advertise('menubar' => $menu); | |
110 | return $menu; | |
111 | } | |
112 | ||
113 | 1; | |
114 | ||
115 | __END__ | |
116 | ||
117 | sub labelPack | |
118 | { | |
119 | my ($cw,$val) = @_; | |
120 | my $w = $cw->Subwidget('label'); | |
121 | my @result = (); | |
122 | if (@_ > 1) | |
123 | { | |
124 | if (defined($w) && !defined($val)) | |
125 | { | |
126 | $w->packForget; | |
127 | } | |
128 | elsif (defined($val) && !defined ($w)) | |
129 | { | |
130 | require Tk::Label; | |
131 | $w = Tk::Label->new($cw,-textvariable => $cw->labelVariable); | |
132 | $cw->Advertise('label' => $w); | |
133 | $cw->ConfigDelegate('label',qw(-text -textvariable)); | |
134 | } | |
135 | if (defined($val) && defined($w)) | |
136 | { | |
137 | my %pack = @$val; | |
138 | unless (exists $pack{-side}) | |
139 | { | |
140 | $pack{-side} = 'top' unless (exists $pack{-side}); | |
141 | } | |
142 | unless (exists $pack{-fill}) | |
143 | { | |
144 | $pack{-fill} = 'x' if ($pack{-side} =~ /(top|bottom)/); | |
145 | $pack{-fill} = 'y' if ($pack{-side} =~ /(left|right)/); | |
146 | } | |
147 | unless (exists($pack{'-before'}) || exists($pack{'-after'})) | |
148 | { | |
149 | my $before = ($cw->packSlaves)[0]; | |
150 | $pack{'-before'} = $before if (defined $before); | |
151 | } | |
152 | $w->pack(%pack); | |
153 | } | |
154 | } | |
155 | @result = $w->packInfo if (defined $w); | |
156 | return (wantarray) ? @result : \@result; | |
157 | } | |
158 | ||
159 | sub labelVariable | |
160 | { | |
161 | my ($cw,$val) = @_; | |
162 | my $var = \$cw->{Configure}{'-labelVariable'}; | |
163 | if (@_ > 1 && defined $val) | |
164 | { | |
165 | $$var = $val; | |
166 | $$val = '' unless (defined $$val); | |
167 | my $w = $cw->Subwidget('label'); | |
168 | unless (defined $w) | |
169 | { | |
170 | $cw->labelPack([]); | |
171 | $w = $cw->Subwidget('label'); | |
172 | } | |
173 | $w->configure(-textvariable => $val); | |
174 | } | |
175 | return $$var; | |
176 | } | |
177 | ||
178 | sub label | |
179 | { | |
180 | my ($cw,$val) = @_; | |
181 | my $var = $cw->cget('-labelVariable'); | |
182 | if (@_ > 1 && defined $val) | |
183 | { | |
184 | if (!defined $var) | |
185 | { | |
186 | $var = \$cw->{Configure}{'-label'}; | |
187 | $cw->labelVariable($var); | |
188 | } | |
189 | $$var = $val; | |
190 | } | |
191 | return (defined $var) ? $$var : undef;; | |
192 | } | |
193 | ||
194 | sub queuePack | |
195 | { | |
196 | my ($cw) = @_; | |
197 | unless ($cw->{'pack_pending'}) | |
198 | { | |
199 | $cw->{'pack_pending'} = 1; | |
200 | $cw->afterIdle([$cw,'packscrollbars']); | |
201 | } | |
202 | } | |
203 | ||
204 | sub sbset | |
205 | { | |
206 | my ($cw,$sb,$ref,@args) = @_; | |
207 | $sb->set(@args); | |
208 | $cw->queuePack if (@args == 2 && $sb->Needed != $$ref); | |
209 | } | |
210 | ||
211 | sub freeze_on_map | |
212 | { | |
213 | my ($w) = @_; | |
214 | unless ($w->Tk::bind('Freeze','<Map>')) | |
215 | { | |
216 | $w->Tk::bind('Freeze','<Map>',['packPropagate' => 0]) | |
217 | } | |
218 | $w->AddBindTag('Freeze'); | |
219 | } | |
220 | ||
221 | sub AddScrollbars | |
222 | { | |
223 | require Tk::Scrollbar; | |
224 | my ($cw,$w) = @_; | |
225 | my $def = ''; | |
226 | my ($x,$y) = ('',''); | |
227 | my $s = 0; | |
228 | my $c; | |
229 | $cw->freeze_on_map; | |
230 | foreach $c ($w->configure) | |
231 | { | |
232 | my $opt = $c->[0]; | |
233 | if ($opt eq '-yscrollcommand') | |
234 | { | |
235 | my $slice = Tk::Frame->new($cw,Name => 'ysbslice'); | |
236 | my $ysb = Tk::Scrollbar->new($slice,-orient => 'vertical', -command => [ 'yview', $w ]); | |
237 | my $size = $ysb->cget('-width'); | |
238 | my $corner = Tk::Frame->new($slice,Name=>'corner','-relief' => 'raised', | |
239 | '-width' => $size, '-height' => $size); | |
240 | $ysb->pack(-side => 'left', -fill => 'y'); | |
241 | $cw->Advertise('yscrollbar' => $ysb); | |
242 | $cw->Advertise('corner' => $corner); | |
243 | $cw->Advertise('ysbslice' => $slice); | |
244 | $corner->{'before'} = $ysb->PathName; | |
245 | $slice->{'before'} = $w->PathName; | |
246 | $y = 'w'; | |
247 | $s = 1; | |
248 | } | |
249 | elsif ($opt eq '-xscrollcommand') | |
250 | { | |
251 | my $xsb = Tk::Scrollbar->new($cw,-orient => 'horizontal', -command => [ 'xview', $w ]); | |
252 | $cw->Advertise('xscrollbar' => $xsb); | |
253 | $xsb->{'before'} = $w->PathName; | |
254 | $x = 's'; | |
255 | $s = 1; | |
256 | } | |
257 | } | |
258 | if ($s) | |
259 | { | |
260 | $cw->Advertise('scrolled' => $w); | |
261 | $cw->ConfigSpecs('-scrollbars' => ['METHOD','scrollbars','Scrollbars',$x.$y]); | |
262 | } | |
263 | } | |
264 | ||
265 | sub packscrollbars | |
266 | { | |
267 | my ($cw) = @_; | |
268 | my $opt = $cw->cget('-scrollbars'); | |
269 | my $slice = $cw->Subwidget('ysbslice'); | |
270 | my $xsb = $cw->Subwidget('xscrollbar'); | |
271 | my $corner = $cw->Subwidget('corner'); | |
272 | my $w = $cw->Subwidget('scrolled'); | |
273 | my $xside = (($opt =~ /n/) ? 'top' : 'bottom'); | |
274 | my $havex = 0; | |
275 | my $havey = 0; | |
276 | $opt =~ s/r//; | |
277 | $cw->{'pack_pending'} = 0; | |
278 | if (defined $slice) | |
279 | { | |
280 | my $reqy; | |
281 | my $ysb = $cw->Subwidget('yscrollbar'); | |
282 | if ($opt =~ /(o)?[we]/ && (($reqy = !defined($1)) || $ysb->Needed)) | |
283 | { | |
284 | my $yside = (($opt =~ /w/) ? 'left' : 'right'); | |
285 | $slice->pack(-side => $yside, -fill => 'y',-before => $slice->{'before'}); | |
286 | $havey = 1; | |
287 | if ($reqy) | |
288 | { | |
289 | $w->configure(-yscrollcommand => ['set', $ysb]); | |
290 | } | |
291 | else | |
292 | { | |
293 | $w->configure(-yscrollcommand => ['sbset', $cw, $ysb, \$cw->{'packysb'}]); | |
294 | } | |
295 | } | |
296 | else | |
297 | { | |
298 | $w->configure(-yscrollcommand => undef) unless $opt =~ s/[we]//; | |
299 | $slice->packForget; | |
300 | } | |
301 | $cw->{'packysb'} = $havey; | |
302 | } | |
303 | if (defined $xsb) | |
304 | { | |
305 | my $reqx; | |
306 | if ($opt =~ /(o)?[ns]/ && (($reqx = !defined($1)) || $xsb->Needed)) | |
307 | { | |
308 | $xsb->pack(-side => $xside, -fill => 'x',-before => $xsb->{'before'}); | |
309 | $havex = 1; | |
310 | if ($reqx) | |
311 | { | |
312 | $w->configure(-xscrollcommand => ['set', $xsb]); | |
313 | } | |
314 | else | |
315 | { | |
316 | $w->configure(-xscrollcommand => ['sbset', $cw, $xsb, \$cw->{'packxsb'}]); | |
317 | } | |
318 | } | |
319 | else | |
320 | { | |
321 | $w->configure(-xscrollcommand => undef) unless $opt =~ s/[ns]//; | |
322 | $xsb->packForget; | |
323 | } | |
324 | $cw->{'packxsb'} = $havex; | |
325 | } | |
326 | if (defined $corner) | |
327 | { | |
328 | if ($havex && $havey && defined $corner->{'before'}) | |
329 | { | |
330 | my $anchor = $opt; | |
331 | $anchor =~ s/o//g; | |
332 | $corner->configure(-height => $xsb->ReqHeight); | |
333 | $corner->pack(-before => $corner->{'before'}, -side => $xside, | |
334 | -anchor => $anchor, -fill => 'x'); | |
335 | } | |
336 | else | |
337 | { | |
338 | $corner->packForget; | |
339 | } | |
340 | } | |
341 | } | |
342 | ||
343 | sub scrollbars | |
344 | { | |
345 | my ($cw,$opt) = @_; | |
346 | my $var = \$cw->{'-scrollbars'}; | |
347 | if (@_ > 1) | |
348 | { | |
349 | my $old = $$var; | |
350 | if (!defined $old || $old ne $opt) | |
351 | { | |
352 | $$var = $opt; | |
353 | $cw->queuePack; | |
354 | } | |
355 | } | |
356 | return $$var; | |
357 | } | |
358 | ||
359 | sub FindMenu | |
360 | { | |
361 | my ($w,$char) = @_; | |
362 | my $child; | |
363 | my $match; | |
364 | foreach $child ($w->children) | |
365 | { | |
366 | next unless (ref $child); | |
367 | $match = $child->FindMenu($char); | |
368 | return $match if (defined $match); | |
369 | } | |
370 | return undef; | |
371 | } | |
372 | ||
373 |