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::Derived; | |
5 | require Tk::Widget; | |
6 | require Tk::Configure; | |
7 | use strict; | |
8 | use Carp; | |
9 | ||
10 | use vars qw($VERSION); | |
11 | $VERSION = '3.046'; # $Id: //depot/Tk8/Tk/Derived.pm#46 $ | |
12 | ||
13 | $Tk::Derived::Debug = 0; | |
14 | ||
15 | my $ENHANCED_CONFIGSPECS = 0; # disable for now | |
16 | ||
17 | use Tk qw(NORMAL_BG BLACK); | |
18 | ||
19 | sub Subwidget | |
20 | { | |
21 | my $cw = shift; | |
22 | my @result = (); | |
23 | if (exists $cw->{SubWidget}) | |
24 | { | |
25 | if (@_) | |
26 | { | |
27 | foreach my $name (@_) | |
28 | { | |
29 | push(@result,$cw->{SubWidget}{$name}) if (exists $cw->{SubWidget}{$name}); | |
30 | } | |
31 | } | |
32 | else | |
33 | { | |
34 | @result = values %{$cw->{SubWidget}}; | |
35 | } | |
36 | } | |
37 | return (wantarray) ? @result : $result[0]; | |
38 | } | |
39 | ||
40 | sub _makelist | |
41 | { | |
42 | my $widget = shift; | |
43 | my (@specs) = (ref $widget && ref $widget eq 'ARRAY') ? (@$widget) : ($widget); | |
44 | return @specs; | |
45 | } | |
46 | ||
47 | sub Subconfigure | |
48 | { | |
49 | # This finds the widget or widgets to to which to apply a particular | |
50 | # configure option | |
51 | my ($cw,$opt) = @_; | |
52 | my $config = $cw->ConfigSpecs; | |
53 | my $widget; | |
54 | my @subwidget = (); | |
55 | my @arg = (); | |
56 | if (defined $opt) | |
57 | { | |
58 | $widget = $config->{$opt}; | |
59 | unless (defined $widget) | |
60 | { | |
61 | $widget = ($opt =~ /^-(.*)$/) ? $config->{$1} : $config->{-$opt}; | |
62 | } | |
63 | # Handle alias entries | |
64 | if (defined($widget) && !ref($widget)) | |
65 | { | |
66 | $opt = $widget; | |
67 | $widget = $config->{$widget}; | |
68 | } | |
69 | push(@arg,$opt) unless ($opt eq 'DEFAULT'); | |
70 | } | |
71 | $widget = $config->{DEFAULT} unless (defined $widget); | |
72 | if (defined $widget) | |
73 | { | |
74 | $cw->BackTrace("Invalid ConfigSpecs $widget") unless (ref($widget) && (ref $widget eq 'ARRAY')); | |
75 | $widget = $widget->[0]; | |
76 | } | |
77 | else | |
78 | { | |
79 | $widget = 'SELF'; | |
80 | } | |
81 | foreach $widget (_makelist($widget)) | |
82 | { | |
83 | $widget = 'SELF' if (ref($widget) && $widget == $cw); | |
84 | if (ref $widget) | |
85 | { | |
86 | my $ref = ref $widget; | |
87 | if ($ref eq 'ARRAY') | |
88 | { | |
89 | $widget = Tk::Configure->new(@$widget); | |
90 | push(@subwidget,$widget) | |
91 | } | |
92 | elsif ($ref eq 'HASH') | |
93 | { | |
94 | foreach my $key (%$widget) | |
95 | { | |
96 | foreach my $sw (_makelist($widget->{$key})) | |
97 | { | |
98 | push(@subwidget,Tk::Configure->new($sw,$key)); | |
99 | } | |
100 | } | |
101 | } | |
102 | else | |
103 | { | |
104 | push(@subwidget,$widget) | |
105 | } | |
106 | } | |
107 | elsif ($widget eq 'ADVERTISED') | |
108 | { | |
109 | push(@subwidget,$cw->Subwidget) | |
110 | } | |
111 | elsif ($widget eq 'DESCENDANTS') | |
112 | { | |
113 | push(@subwidget,$cw->Descendants) | |
114 | } | |
115 | elsif ($widget eq 'CHILDREN') | |
116 | { | |
117 | push(@subwidget,$cw->children) | |
118 | } | |
119 | elsif ($widget eq 'METHOD') | |
120 | { | |
121 | my ($method) = ($opt =~ /^-?(.*)$/); | |
122 | push(@subwidget,Tk::Configure->new($method,$method,$cw)) | |
123 | } | |
124 | elsif ($widget eq 'SETMETHOD') | |
125 | { | |
126 | my ($method) = ($opt =~ /^-?(.*)$/); | |
127 | push(@subwidget,Tk::Configure->new($method,'_cget',$cw,@arg)) | |
128 | } | |
129 | elsif ($widget eq 'SELF') | |
130 | { | |
131 | push(@subwidget,Tk::Configure->new('Tk::configure', 'Tk::cget', $cw,@arg)) | |
132 | } | |
133 | elsif ($widget eq 'PASSIVE') | |
134 | { | |
135 | push(@subwidget,Tk::Configure->new('_configure','_cget',$cw,@arg)) | |
136 | } | |
137 | elsif ($widget eq 'CALLBACK') | |
138 | { | |
139 | push(@subwidget,Tk::Configure->new('_callback','_cget',$cw,@arg)) | |
140 | } | |
141 | else | |
142 | { | |
143 | push(@subwidget,$cw->Subwidget($widget)); | |
144 | } | |
145 | } | |
146 | $cw->BackTrace("No delegate subwidget '$widget' for $opt") unless (@subwidget); | |
147 | return (wantarray) ? @subwidget : $subwidget[0]; | |
148 | } | |
149 | ||
150 | sub _cget | |
151 | { | |
152 | my ($cw,$opt) = @_; | |
153 | $cw->BackTrace('Wrong number of args to cget') unless (@_ == 2); | |
154 | return $cw->{Configure}{$opt} | |
155 | } | |
156 | ||
157 | sub _configure | |
158 | { | |
159 | my ($cw,$opt,$val) = @_; | |
160 | $cw->BackTrace('Wrong number of args to configure') unless (@_ == 3); | |
161 | $cw->{Configure}{$opt} = $val; | |
162 | } | |
163 | ||
164 | sub _callback | |
165 | { | |
166 | my ($cw,$opt,$val) = @_; | |
167 | $cw->BackTrace('Wrong number of args to configure') unless (@_ == 3); | |
168 | $val = Tk::Callback->new($val) if defined($val) && ref($val); | |
169 | $cw->{Configure}{$opt} = $val; | |
170 | } | |
171 | ||
172 | sub cget | |
173 | {my ($cw,$opt) = @_; | |
174 | my @result; | |
175 | local $SIG{'__DIE__'}; | |
176 | foreach my $sw ($cw->Subconfigure($opt)) | |
177 | { | |
178 | if (wantarray) | |
179 | { | |
180 | eval { @result = $sw->cget($opt) }; | |
181 | } | |
182 | else | |
183 | { | |
184 | eval { $result[0] = $sw->cget($opt) }; | |
185 | } | |
186 | last unless $@; | |
187 | } | |
188 | return wantarray ? @result : $result[0]; | |
189 | } | |
190 | ||
191 | sub Configured | |
192 | { | |
193 | # Called whenever a derived widget is re-configured | |
194 | my ($cw,$args,$changed) = @_; | |
195 | if (@_ > 1) | |
196 | { | |
197 | $cw->afterIdle(['ConfigChanged',$cw,$changed]) if (%$changed); | |
198 | } | |
199 | return exists $cw->{'Configure'}; | |
200 | } | |
201 | ||
202 | sub configure | |
203 | { | |
204 | # The default composite widget configuration method uses hash stored | |
205 | # in the widget's hash to map configuration options | |
206 | # onto subwidgets. | |
207 | # | |
208 | my @results = (); | |
209 | my $cw = shift; | |
210 | if (@_ <= 1) | |
211 | { | |
212 | # Enquiry cases | |
213 | my $spec = $cw->ConfigSpecs; | |
214 | if (@_) | |
215 | { | |
216 | # Return info on the nominated option | |
217 | my $opt = $_[0]; | |
218 | my $info = $spec->{$opt}; | |
219 | unless (defined $info) | |
220 | { | |
221 | $info = ($opt =~ /^-(.*)$/) ? $spec->{$1} : $spec->{-$opt}; | |
222 | } | |
223 | if (defined $info) | |
224 | { | |
225 | if (ref $info) | |
226 | { | |
227 | # If the default slot is undef then ask subwidgets in turn | |
228 | # for their default value until one accepts it. | |
229 | if ($ENHANCED_CONFIGSPECS && !defined($info->[3])) | |
230 | {local $SIG{'__DIE__'}; | |
231 | my @def; | |
232 | foreach my $sw ($cw->Subconfigure($opt)) | |
233 | { | |
234 | eval { @def = $sw->configure($opt) }; | |
235 | last unless $@; | |
236 | } | |
237 | $info->[3] = $def[3]; | |
238 | $info->[1] = $def[1] unless defined $info->[1]; | |
239 | $info->[2] = $def[2] unless defined $info->[2]; | |
240 | } | |
241 | push(@results,$opt,$info->[1],$info->[2],$info->[3],$cw->cget($opt)); | |
242 | } | |
243 | else | |
244 | { | |
245 | # Real (core) Tk widgets return db name rather than option name | |
246 | # for aliases so recurse to get that ... | |
247 | my @real = $cw->configure($info); | |
248 | push(@results,$opt,$real[1]); | |
249 | } | |
250 | } | |
251 | else | |
252 | { | |
253 | push(@results,$cw->Subconfigure($opt)->configure($opt)); | |
254 | } | |
255 | } | |
256 | else | |
257 | { | |
258 | my $opt; | |
259 | my %results; | |
260 | if (exists $spec->{'DEFAULT'}) | |
261 | { | |
262 | foreach $opt ($cw->Subconfigure('DEFAULT')->configure) | |
263 | { | |
264 | $results{$opt->[0]} = $opt; | |
265 | } | |
266 | } | |
267 | foreach $opt (keys %$spec) | |
268 | { | |
269 | $results{$opt} = [$cw->configure($opt)] if ($opt ne 'DEFAULT'); | |
270 | } | |
271 | foreach $opt (sort keys %results) | |
272 | { | |
273 | push(@results,$results{$opt}); | |
274 | } | |
275 | } | |
276 | } | |
277 | else | |
278 | { | |
279 | my (%args) = @_; | |
280 | my %changed = (); | |
281 | my ($opt,$val); | |
282 | my $config = $cw->TkHash('Configure'); | |
283 | ||
284 | while (($opt,$val) = each %args) | |
285 | { | |
286 | my $var = \$config->{$opt}; | |
287 | my $old = $$var; | |
288 | $$var = $val; | |
289 | my $accepted = 0; | |
290 | my $error = "No widget handles $opt"; | |
291 | foreach my $subwidget ($cw->Subconfigure($opt)) | |
292 | { | |
293 | next unless (defined $subwidget); | |
294 | eval {local $SIG{'__DIE__'}; $subwidget->configure($opt => $val) }; | |
295 | if ($@) | |
296 | { | |
297 | my $val2 = (defined $val) ? $val : 'undef'; | |
298 | $error = "Can't set $opt to `$val2' for $cw: " . $@; | |
299 | undef $@; | |
300 | } | |
301 | else | |
302 | { | |
303 | $accepted = 1; | |
304 | } | |
305 | } | |
306 | $cw->BackTrace($error) unless ($accepted); | |
307 | $val = $$var; | |
308 | $changed{$opt} = $val if (!defined $old || !defined $val || "$old" ne "$val"); | |
309 | } | |
310 | $cw->Configured(\%args,\%changed); | |
311 | } | |
312 | return (wantarray) ? @results : \@results; | |
313 | } | |
314 | ||
315 | sub ConfigDefault | |
316 | { | |
317 | my ($cw,$args) = @_; | |
318 | ||
319 | $cw->BackTrace('Bad args') unless (defined $args && ref $args eq 'HASH'); | |
320 | ||
321 | my $specs = $cw->ConfigSpecs; | |
322 | # Should we enforce a Delagates(DEFAULT => ) as well ? | |
323 | $specs->{'DEFAULT'} = ['SELF'] unless (exists $specs->{'DEFAULT'}); | |
324 | ||
325 | # | |
326 | # This is a pain with Text or Entry as core widget, they don't | |
327 | # inherit SELF's cursor. So comment it out for Tk402.001 | |
328 | # | |
329 | # $specs->{'-cursor'} = ['SELF',undef,undef,undef] unless (exists $specs->{'-cursor'}); | |
330 | ||
331 | # Now some hacks that cause colours to propogate down a composite widget | |
332 | # tree - really needs more thought, other options adding such as active | |
333 | # colours too and maybe fonts | |
334 | ||
335 | my $child = ($cw->children)[0]; # 1st child window (if any) | |
336 | ||
337 | unless (exists($specs->{'-background'})) | |
338 | { | |
339 | my (@bg) = ('SELF'); | |
340 | push(@bg,'CHILDREN') if $child; | |
341 | $specs->{'-background'} = [\@bg,'background','Background',NORMAL_BG]; | |
342 | } | |
343 | unless (exists($specs->{'-foreground'})) | |
344 | { | |
345 | my (@fg) = ('PASSIVE'); | |
346 | unshift(@fg,'CHILDREN') if $child; | |
347 | $specs->{'-foreground'} = [\@fg,'foreground','Foreground',BLACK]; | |
348 | } | |
349 | $cw->ConfigAlias(-fg => '-foreground', -bg => '-background'); | |
350 | ||
351 | # Pre-scan args for aliases - this avoids defaulting | |
352 | # options specified via alias | |
353 | foreach my $opt (keys %$args) | |
354 | { | |
355 | my $info = $specs->{$opt}; | |
356 | if (defined($info) && !ref($info)) | |
357 | { | |
358 | $args->{$info} = delete $args->{$opt}; | |
359 | } | |
360 | } | |
361 | ||
362 | # Now walk %$specs supplying defaults for all the options | |
363 | # which have a defined default value, potentially looking up .Xdefaults database | |
364 | # options for the name/class of the 'frame' | |
365 | ||
366 | foreach my $opt (keys %$specs) | |
367 | { | |
368 | if ($opt ne 'DEFAULT') | |
369 | { | |
370 | unless (exists $args->{$opt}) | |
371 | { | |
372 | my $info = $specs->{$opt}; | |
373 | if (ref $info) | |
374 | { | |
375 | # Not an alias | |
376 | if ($ENHANCED_CONFIGSPECS && !defined $info->[3]) | |
377 | { | |
378 | # configure inquire to fill in default slot from subwidget | |
379 | $cw->configure($opt); | |
380 | } | |
381 | if (defined $info->[3]) | |
382 | { | |
383 | if (defined $info->[1] && defined $info->[2]) | |
384 | { | |
385 | # Should we do this on the Subconfigure widget instead? | |
386 | # to match *Entry.Background | |
387 | my $db = $cw->optionGet($info->[1],$info->[2]); | |
388 | $info->[3] = $db if (defined $db); | |
389 | } | |
390 | $args->{$opt} = $info->[3]; | |
391 | } | |
392 | } | |
393 | } | |
394 | } | |
395 | } | |
396 | } | |
397 | ||
398 | sub ConfigSpecs | |
399 | { | |
400 | my $cw = shift; | |
401 | my $specs = $cw->TkHash('ConfigSpecs'); | |
402 | while (@_) | |
403 | { | |
404 | my $key = shift; | |
405 | my $val = shift; | |
406 | $specs->{$key} = $val; | |
407 | } | |
408 | return $specs; | |
409 | } | |
410 | ||
411 | sub _alias | |
412 | { | |
413 | my ($specs,$opt,$main) = @_; | |
414 | if (exists($specs->{$opt})) | |
415 | { | |
416 | unless (exists $specs->{$main}) | |
417 | { | |
418 | my $targ = $specs->{$opt}; | |
419 | if (ref($targ)) | |
420 | { | |
421 | # opt is a real option | |
422 | $specs->{$main} = $opt | |
423 | } | |
424 | else | |
425 | { | |
426 | # opt is itself an alias | |
427 | # make main point to same place | |
428 | $specs->{$main} = $targ unless $targ eq $main; | |
429 | } | |
430 | } | |
431 | return 1; | |
432 | } | |
433 | return 0; | |
434 | } | |
435 | ||
436 | sub ConfigAlias | |
437 | { | |
438 | my $cw = shift; | |
439 | my $specs = $cw->ConfigSpecs; | |
440 | while (@_ >= 2) | |
441 | { | |
442 | my $opt = shift; | |
443 | my $main = shift; | |
444 | unless (_alias($specs,$opt,$main) || _alias($specs,$main,$opt)) | |
445 | { | |
446 | $cw->BackTrace("Neither $opt nor $main exist"); | |
447 | } | |
448 | } | |
449 | $cw->BackTrace('Odd number of args to ConfigAlias') if (@_); | |
450 | } | |
451 | ||
452 | sub Delegate | |
453 | { | |
454 | my ($cw,$method,@args) = @_; | |
455 | my $widget = $cw->DelegateFor($method); | |
456 | if ($widget == $cw) | |
457 | { | |
458 | $method = "Tk::Widget::$method" | |
459 | } | |
460 | my @result; | |
461 | if (wantarray) | |
462 | { | |
463 | @result = $widget->$method(@args); | |
464 | } | |
465 | else | |
466 | { | |
467 | $result[0] = $widget->$method(@args); | |
468 | } | |
469 | return (wantarray) ? @result : $result[0]; | |
470 | } | |
471 | ||
472 | sub InitObject | |
473 | { | |
474 | my ($cw,$args) = @_; | |
475 | $cw->Populate($args); | |
476 | $cw->ConfigDefault($args); | |
477 | } | |
478 | ||
479 | sub ConfigChanged | |
480 | { | |
481 | my ($cw,$args) = @_; | |
482 | } | |
483 | ||
484 | sub Advertise | |
485 | { | |
486 | my ($cw,$name,$widget) = @_; | |
487 | confess 'No name' unless (defined $name); | |
488 | croak 'No widget' unless (defined $widget); | |
489 | my $hash = $cw->TkHash('SubWidget'); | |
490 | $hash->{$name} = $widget; # advertise it | |
491 | return $widget; | |
492 | } | |
493 | ||
494 | sub Component | |
495 | { | |
496 | my ($cw,$kind,$name,%args) = @_; | |
497 | $args{'Name'} = "\l$name" if (defined $name && !exists $args{'Name'}); | |
498 | # my $pack = delete $args{'-pack'}; | |
499 | my $delegate = delete $args{'-delegate'}; | |
500 | my $w = $cw->$kind(%args); # Create it | |
501 | # $w->pack(@$pack) if (defined $pack); | |
502 | $cw->Advertise($name,$w) if (defined $name); | |
503 | $cw->Delegates(map(($_ => $w),@$delegate)) if (defined $delegate); | |
504 | return $w; # and return it | |
505 | } | |
506 | ||
507 | 1; | |
508 | __END__ | |
509 | ||
510 |