Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | package Tk::ColorSelect; |
2 | use strict; | |
3 | ||
4 | use vars qw($VERSION); | |
5 | $VERSION = '3.032'; # $Id: //depot/Tk8/Tk/ColorEditor.pm#32 $ | |
6 | ||
7 | use Tk qw(Ev); | |
8 | ||
9 | require Tk::Frame; | |
10 | ||
11 | use base qw(Tk::Frame); | |
12 | Construct Tk::Widget 'ColorSelect'; | |
13 | ||
14 | sub Populate | |
15 | { | |
16 | my ($middle,$args) = @_; | |
17 | my($i, @a); | |
18 | require Tk::Config; | |
19 | my(@xlibpath) = map { s/^-L//; "$_/X11/rgb.txt" } | |
20 | split /\s+/, $Tk::Config::xlib; | |
21 | foreach $i (@xlibpath, | |
22 | '/usr/local/lib/X11/rgb.txt', '/usr/lib/X11/rgb.txt', | |
23 | '/usr/X11R6/lib/X11/rgb.txt', | |
24 | '/usr/local/X11R5/lib/X11/rgb.txt', '/X11/R5/lib/X11/rgb.txt', | |
25 | '/X11/R4/lib/rgb/rgb.txt', '/usr/openwin/lib/X11/rgb.txt') { | |
26 | local *FOO; | |
27 | next if ! open FOO, $i; | |
28 | my $middle_left = $middle->Frame; | |
29 | $middle_left->pack( | |
30 | -side => 'left', | |
31 | -padx => '0.25c', | |
32 | -pady => '0.25c', | |
33 | ); | |
34 | my $names = $middle->Listbox( | |
35 | -width => 20, | |
36 | -height => 12, | |
37 | -relief => 'sunken', | |
38 | -borderwidth => 2, | |
39 | -exportselection => 0, | |
40 | ); | |
41 | ||
42 | $names->bind('<Double-1>' => [$middle,'color',Ev(['getSelected'])]); | |
43 | ||
44 | my $scroll = $middle->Scrollbar( | |
45 | -orient => 'vertical', | |
46 | -command => ['yview', $names], | |
47 | -relief => 'sunken', | |
48 | -borderwidth => 2, | |
49 | ); | |
50 | $names->configure(-yscrollcommand => ['set',$scroll]); | |
51 | $names->pack(-in => $middle_left, -side => 'left'); | |
52 | $scroll->pack(-in => $middle_left, -side => 'right', -fill => 'y'); | |
53 | ||
54 | while(<FOO>) { | |
55 | chomp; | |
56 | next if /^!/; | |
57 | my @a = split; | |
58 | my $color = join(' ', @a[3 .. $#a]); | |
59 | my $hex; | |
60 | eval { $hex = $middle->Hex($color); }; | |
61 | if ($@) { | |
62 | #print STDERR "unknown color: '$color'\n"; | |
63 | if ($@ =~ /unknown color name "/) { | |
64 | next; | |
65 | } else { | |
66 | chomp $@; | |
67 | die $@; | |
68 | } | |
69 | } | |
70 | if (!exists($Tk::ColorEditor::names{$hex}) || | |
71 | length($Tk::ColorEditor::names{$hex}) > length($color)) { | |
72 | $Tk::ColorEditor::names{$hex} = $color; | |
73 | $names->insert('end', $color); | |
74 | } | |
75 | } | |
76 | close FOO; | |
77 | last; | |
78 | } | |
79 | ||
80 | # Create the three scales for editing the color, and the entry for typing | |
81 | # in a color value. | |
82 | ||
83 | my $middle_middle = $middle->Frame; | |
84 | $middle_middle->pack(-side => 'left', -expand => 1, -fill => 'y'); | |
85 | my $mcm1 = $middle_middle->Optionmenu(-variable => \$middle->{'color_space'}, | |
86 | -command => [ $middle, 'color_space'], | |
87 | -relief => 'raised', | |
88 | -options => [ ['HSB color space' => 'hsb'], | |
89 | ['RGB color space' => 'rgb'], | |
90 | ['CMY color space' => 'cmy']]); | |
91 | $mcm1->pack(-side => 'top', -fill => 'x'); | |
92 | ||
93 | my(@middle_middle, @label, @scale); | |
94 | $middle_middle[0] = $middle_middle->Frame; | |
95 | $middle_middle[1] = $middle_middle->Frame; | |
96 | $middle_middle[2] = $middle_middle->Frame; | |
97 | $middle_middle[3] = $middle_middle->Frame; | |
98 | $middle_middle[0]->pack(-side => 'top', -expand => 1); | |
99 | $middle_middle[1]->pack(-side => 'top', -expand => 1); | |
100 | $middle_middle[2]->pack(-side => 'top', -expand => 1); | |
101 | $middle_middle[3]->pack(-side => 'top', -expand => 1, -fill => 'x'); | |
102 | $middle->{'Labels'} = ['zero','one','two']; | |
103 | foreach $i (0..2) { | |
104 | $label[$i] = $middle->Label(-textvariable => \$middle->{'Labels'}[$i]); | |
105 | $scale[$i] = $middle->Scale( | |
106 | -from => 0, | |
107 | -to => 1000, | |
108 | '-length' => '6c', | |
109 | -orient => 'horizontal', | |
110 | -command => [\&scale_changed, $middle], | |
111 | ); | |
112 | $scale[$i]->pack( | |
113 | -in => $middle_middle[$i], | |
114 | -side => 'top', | |
115 | -anchor => 'w', | |
116 | ); | |
117 | $label[$i]->pack( | |
118 | -in => $middle_middle[$i], | |
119 | -side => 'top', | |
120 | -anchor => 'w', | |
121 | ); | |
122 | } | |
123 | my $nameLabel = $middle->Label(-text => 'Name:'); | |
124 | $middle->{'Entry'} = ''; | |
125 | my $name = $middle->Entry( | |
126 | -relief => 'sunken', | |
127 | -borderwidth => 2, | |
128 | -textvariable => \$middle->{'Entry'}, | |
129 | -width => 10, | |
130 | # For some reason giving this font causes problems at end of t/create.t | |
131 | # -font => '-*-Courier-Medium-R-Normal--*-120-*-*-*-*-*-*' | |
132 | ); | |
133 | ||
134 | $nameLabel->pack(-in => $middle_middle[3], -side => 'left'); | |
135 | $name->pack( | |
136 | -in => $middle_middle[3], | |
137 | -side => 'right', | |
138 | -expand => 1, | |
139 | -fill => 'x', | |
140 | ); | |
141 | $name->bind('<Return>' => [ $middle, 'color', Ev(['get'])]); | |
142 | ||
143 | # Create the color display swatch on the right side of the window. | |
144 | ||
145 | my $middle_right = $middle->Frame; | |
146 | $middle_right->pack( | |
147 | -side => 'left', | |
148 | -pady => '.25c', | |
149 | -padx => '.25c', | |
150 | -anchor => 's', | |
151 | ); | |
152 | my $swatch = $middle->Canvas( | |
153 | -width => '2.5c', | |
154 | -height => '5c', | |
155 | ); | |
156 | my $swatch_item = $swatch->create('oval', '.5c', '.3c', '2.26c', '4.76c'); | |
157 | ||
158 | my $value = $middle->Label( | |
159 | -textvariable => \$middle->{'color'}, | |
160 | -width => 13, | |
161 | -font => '-*-Courier-Medium-R-Normal--*-120-*-*-*-*-*-*' | |
162 | ); | |
163 | ||
164 | $swatch->pack( | |
165 | -in => $middle_right, | |
166 | -side => 'top', | |
167 | -expand => 1, | |
168 | -fill => 'both', | |
169 | ); | |
170 | $value->pack(-in => $middle_right, -side => 'bottom', -pady => '.25c'); | |
171 | ||
172 | $middle->ConfigSpecs( | |
173 | '-color_space' => ['METHOD', undef, undef, 'hsb'], | |
174 | '-initialcolor' => '-color', | |
175 | '-color' => ['METHOD', 'background', 'Background', | |
176 | $middle->cget('-background')] | |
177 | ); | |
178 | ||
179 | $middle->{'swatch'} = $swatch; | |
180 | $middle->{'swatch_item'} = $swatch_item; | |
181 | $middle->{'scale'} = [@scale]; | |
182 | $middle->{'red'} = 0; | |
183 | $middle->{'blue'} = 0; | |
184 | $middle->{'green'} = 0; | |
185 | ||
186 | } | |
187 | ||
188 | sub Hex | |
189 | { | |
190 | my $w = shift; | |
191 | my @rgb = (@_ == 3) ? @_ : $w->rgb(@_); | |
192 | sprintf('#%04x%04x%04x',@rgb) | |
193 | } | |
194 | ||
195 | sub color_space { | |
196 | ||
197 | my($objref, $space) = @_; | |
198 | ||
199 | if (@_ > 1) | |
200 | { | |
201 | my %Labels = ( 'rgb' => [qw(Red Green Blue)], | |
202 | 'cmy' => [qw(Cyan Magenta Yellow)], | |
203 | 'hsb' => [qw(Hue Saturation Brightness)] ); | |
204 | ||
205 | # The procedure below is invoked when a new color space is selected. It | |
206 | # changes the labels on the scales and re-loads the scales with the | |
207 | # appropriate values for the current color in the new color space | |
208 | ||
209 | $space = 'hsb' unless (exists $Labels{$space}); | |
210 | my $i; | |
211 | for $i (0..2) | |
212 | { | |
213 | $objref->{'Labels'}[$i] = $Labels{$space}->[$i]; | |
214 | } | |
215 | $objref->{'color_space'} = $space; | |
216 | $objref->afterIdle(['set_scales',$objref]) unless ($objref->{'pending'}++); | |
217 | } | |
218 | return $objref->{'color_space'}; | |
219 | } # color_space | |
220 | ||
221 | sub hsvToRgb { | |
222 | ||
223 | # The procedure below converts an HSB value to RGB. It takes hue, | |
224 | # saturation, and value components (floating-point, 0-1.0) as arguments, | |
225 | # and returns a list containing RGB components (integers, 0-65535) as | |
226 | # result. The code here is a copy of the code on page 616 of | |
227 | # "Fundamentals of Interactive Computer Graphics" by Foley and Van Dam. | |
228 | ||
229 | my($hue, $sat, $value) = @_; | |
230 | my($v, $i, $f, $p, $q, $t); | |
231 | ||
232 | $v = int(65535 * $value); | |
233 | return ($v, $v, $v) if $sat == 0; | |
234 | $hue *= 6; | |
235 | $hue = 0 if $hue >= 6; | |
236 | $i = int($hue); | |
237 | $f = $hue - $i; | |
238 | $p = int(65535 * $value * (1 - $sat)); | |
239 | $q = int(65535 * $value * (1 - ($sat * $f))); | |
240 | $t = int(65535 * $value * (1 - ($sat * (1 - $f)))); | |
241 | return ($v, $t, $p) if $i == 0; | |
242 | return ($q, $v, $p) if $i == 1; | |
243 | return ($p, $v, $t) if $i == 2; | |
244 | return ($p, $q, $v) if $i == 3; | |
245 | return ($t, $p, $v) if $i == 4; | |
246 | return ($v, $p, $q) if $i == 5; | |
247 | ||
248 | } # end hsvToRgb | |
249 | ||
250 | sub color | |
251 | { | |
252 | my ($objref,$name) = @_; | |
253 | if (@_ > 1 && defined($name) && length($name)) | |
254 | { | |
255 | if ($name eq 'cancel') { | |
256 | $objref->{color} = undef; | |
257 | return; | |
258 | } | |
259 | my ($format, $shift); | |
260 | my ($red, $green, $blue); | |
261 | ||
262 | if ($name !~ /^#/) | |
263 | { | |
264 | ($red, $green, $blue) = $objref->{'swatch'}->rgb($name); | |
265 | } | |
266 | else | |
267 | { | |
268 | my $len = length $name; | |
269 | if($len == 4) { $format = '#(.)(.)(.)'; $shift = 12; } | |
270 | elsif($len == 7) { $format = '#(..)(..)(..)'; $shift = 8; } | |
271 | elsif($len == 10) { $format = '#(...)(...)(...)'; $shift = 4; } | |
272 | elsif($len == 13) { $format = '#(....)(....)(....)'; $shift = 0; } | |
273 | else { | |
274 | $objref->BackTrace( | |
275 | "ColorEditor error: syntax error in color name \"$name\""); | |
276 | return; | |
277 | } | |
278 | ($red,$green,$blue) = $name =~ /$format/; | |
279 | # Looks like a call for 'pack' or similar rather than eval | |
280 | eval "\$red = 0x$red; \$green = 0x$green; \$blue = 0x$blue;"; | |
281 | $red = $red << $shift; | |
282 | $green = $green << $shift; | |
283 | $blue = $blue << $shift; | |
284 | } | |
285 | $objref->{'red'} = $red; | |
286 | $objref->{'blue'} = $blue; | |
287 | $objref->{'green'} = $green; | |
288 | my $hex = sprintf('#%04x%04x%04x', $red, $green, $blue); | |
289 | $objref->{'color'} = $hex; | |
290 | $objref->{'Entry'} = $name; | |
291 | $objref->afterIdle(['set_scales',$objref]) unless ($objref->{'pending'}++); | |
292 | $objref->{'swatch'}->itemconfigure($objref->{'swatch_item'}, | |
293 | -fill => $objref->{'color'}); | |
294 | } | |
295 | return $objref->{'color'}; | |
296 | } | |
297 | ||
298 | sub rgbToHsv { | |
299 | ||
300 | # The procedure below converts an RGB value to HSB. It takes red, green, | |
301 | # and blue components (0-65535) as arguments, and returns a list | |
302 | # containing HSB components (floating-point, 0-1) as result. The code | |
303 | # here is a copy of the code on page 615 of "Fundamentals of Interactive | |
304 | # Computer Graphics" by Foley and Van Dam. | |
305 | ||
306 | my($red, $green, $blue) = @_; | |
307 | my($max, $min, $sat, $range, $hue, $rc, $gc, $bc); | |
308 | ||
309 | $max = ($red > $green) ? (($blue > $red) ? $blue : $red) : | |
310 | (($blue > $green) ? $blue : $green); | |
311 | $min = ($red < $green) ? (($blue < $red) ? $blue : $red) : | |
312 | (($blue < $green) ? $blue : $green); | |
313 | $range = $max - $min; | |
314 | if ($max == 0) { | |
315 | $sat = 0; | |
316 | } else { | |
317 | $sat = $range / $max; | |
318 | } | |
319 | if ($sat == 0) { | |
320 | $hue = 0; | |
321 | } else { | |
322 | $rc = ($max - $red) / $range; | |
323 | $gc = ($max - $green) / $range; | |
324 | $bc = ($max - $blue) / $range; | |
325 | $hue = ($max == $red)?(0.166667*($bc - $gc)): | |
326 | (($max == $green)?(0.166667*(2 + $rc - $bc)): | |
327 | (0.166667*(4 + $gc - $rc))); | |
328 | } | |
329 | return ($hue, $sat, $max/65535); | |
330 | ||
331 | } # end rgbToHsv | |
332 | ||
333 | sub scale_changed { | |
334 | ||
335 | # The procedure below is invoked when one of the scales is adjusted. It | |
336 | # propagates color information from the current scale readings to | |
337 | # everywhere else that it is used. | |
338 | ||
339 | my($objref) = @_; | |
340 | ||
341 | return if $objref->{'updating'}; | |
342 | my ($red, $green, $blue); | |
343 | ||
344 | if($objref->{'color_space'} eq 'rgb') { | |
345 | $red = int($objref->{'scale'}->[0]->get * 65.535 + 0.5); | |
346 | $green = int($objref->{'scale'}->[1]->get * 65.535 + 0.5); | |
347 | $blue = int($objref->{'scale'}->[2]->get * 65.535 + 0.5); | |
348 | } elsif($objref->{'color_space'} eq 'cmy') { | |
349 | $red = int(65535 - $objref->{'scale'}->[0]->get * 65.535 + 0.5); | |
350 | $green = int(65535 - $objref->{'scale'}->[1]->get * 65.535 + 0.5); | |
351 | $blue = int(65535 - $objref->{'scale'}->[2]->get * 65.535 + 0.5); | |
352 | } else { | |
353 | ($red, $green, $blue) = hsvToRgb($objref->{'scale'}->[0]->get/1000.0, | |
354 | $objref->{'scale'}->[1]->get/1000.0, | |
355 | $objref->{'scale'}->[2]->get/1000.0); | |
356 | } | |
357 | $objref->{'red'} = $red; | |
358 | $objref->{'blue'} = $blue; | |
359 | $objref->{'green'} = $green; | |
360 | $objref->color(sprintf('#%04x%04x%04x', $red, $green, $blue)); | |
361 | $objref->idletasks; | |
362 | ||
363 | } # end scale_changed | |
364 | ||
365 | sub set_scales { | |
366 | ||
367 | my($objref) = @_; | |
368 | $objref->{'pending'} = 0; | |
369 | $objref->{'updating'} = 1; | |
370 | ||
371 | # The procedure below is invoked to update the scales from the current red, | |
372 | # green, and blue intensities. It's invoked after a change in the color | |
373 | # space and after a named color value has been loaded. | |
374 | ||
375 | my($red, $blue, $green) = ($objref->{'red'}, $objref->{'blue'}, | |
376 | $objref->{'green'}); | |
377 | ||
378 | if($objref->{'color_space'} eq 'rgb') { | |
379 | $objref->{'scale'}->[0]->set(int($red / 65.535 + 0.5)); | |
380 | $objref->{'scale'}->[1]->set(int($green / 65.535 + 0.5)); | |
381 | $objref->{'scale'}->[2]->set(int($blue / 65.535 + 0.5)); | |
382 | } elsif($objref->{'color_space'} eq 'cmy') { | |
383 | $objref->{'scale'}->[0]->set(int((65535 - $red) / 65.535 + 0.5)); | |
384 | $objref->{'scale'}->[1]->set(int((65535 - $green) / 65.535 + 0.5)); | |
385 | $objref->{'scale'}->[2]->set(int((65535 - $blue) / 65.535 + 0.5)); | |
386 | } else { | |
387 | my ($s1, $s2, $s3) = rgbToHsv($red, $green, $blue); | |
388 | $objref->{'scale'}->[0]->set(int($s1 * 1000.0 + 0.5)); | |
389 | $objref->{'scale'}->[1]->set(int($s2 * 1000.0 + 0.5)); | |
390 | $objref->{'scale'}->[2]->set(int($s3 * 1000.0 + 0.5)); | |
391 | } | |
392 | $objref->{'updating'} = 0; | |
393 | ||
394 | } # end set_scales | |
395 | ||
396 | package Tk::ColorDialog; | |
397 | require Tk::Toplevel; | |
398 | use base qw(Tk::Toplevel); | |
399 | ||
400 | Construct Tk::Widget 'ColorDialog'; | |
401 | ||
402 | sub Accept | |
403 | { | |
404 | my $cw = shift; | |
405 | $cw->withdraw; | |
406 | $cw->{'done'} = 1; | |
407 | } | |
408 | ||
409 | sub Cancel | |
410 | { | |
411 | my $cw = shift; | |
412 | # $cw->configure(-color => undef); | |
413 | $cw->configure(-color => 'cancel'); | |
414 | $cw->Accept; | |
415 | } | |
416 | ||
417 | sub Populate | |
418 | { | |
419 | my ($cw,$args) = @_; | |
420 | $cw->SUPER::Populate($args); | |
421 | $cw->protocol('WM_DELETE_WINDOW' => [ 'Cancel' => $cw ]); | |
422 | $cw->transient($cw->Parent->toplevel); | |
423 | $cw->withdraw; | |
424 | my $sel = $cw->ColorSelect; | |
425 | my $accept = $cw->Button(-text => 'Accept', -command => ['Accept', $cw]); | |
426 | my $cancel = $cw->Button(-text => 'Cancel', -command => ['Cancel', $cw]); | |
427 | Tk::grid($sel); | |
428 | Tk::grid($accept,$cancel); | |
429 | $cw->ConfigSpecs(DEFAULT => [$sel]); | |
430 | } | |
431 | ||
432 | sub Show | |
433 | { | |
434 | my $cw = shift; | |
435 | $cw->configure(@_) if @_; | |
436 | $cw->Popup(); | |
437 | $cw->waitVariable(\$cw->{'done'}); | |
438 | $cw->withdraw; | |
439 | return $cw->cget('-color'); | |
440 | } | |
441 | ||
442 | package Tk::ColorEditor; | |
443 | ||
444 | use vars qw($VERSION $SET_PALETTE); | |
445 | $VERSION = '3.032'; # $Id: //depot/Tk8/Tk/ColorEditor.pm#32 $ | |
446 | ||
447 | use Tk qw(lsearch Ev); | |
448 | use Tk::Toplevel; | |
449 | use base qw(Tk::Toplevel); | |
450 | use Tk::widgets qw(Pixmap); | |
451 | Construct Tk::Widget 'ColorEditor'; | |
452 | ||
453 | %Tk::ColorEditor::names = (); | |
454 | ||
455 | ||
456 | use Tk::Dialog; | |
457 | use Tk::Pretty; | |
458 | ||
459 | BEGIN { $SET_PALETTE = 'Set Palette' }; | |
460 | ||
461 | use subs qw(color_space hsvToRgb rgbToHsv); | |
462 | ||
463 | # ColorEditor public methods. | |
464 | ||
465 | sub add_menu_item | |
466 | { | |
467 | my $objref = shift; | |
468 | my $value; | |
469 | foreach $value (@_) | |
470 | { | |
471 | if ($value eq 'SEP') | |
472 | { | |
473 | $objref->{'mcm2'}->separator; | |
474 | } | |
475 | else | |
476 | { | |
477 | $objref->{'mcm2'}->command( -label => $value, | |
478 | -command => [ 'configure', $objref, '-highlight' => $value ] ); | |
479 | push @{$objref->{'highlight_list'}}, $value; | |
480 | } | |
481 | } | |
482 | } | |
483 | ||
484 | sub set_title | |
485 | { | |
486 | my ($w) = @_; | |
487 | my $t = $w->{Configure}{'-title'} || '' ; | |
488 | my $h = $w->{Configure}{'-highlight'} || ''; | |
489 | $w->SUPER::title("$t $h Color Editor"); | |
490 | } | |
491 | ||
492 | sub highlight | |
493 | { | |
494 | my ($w,$h) = @_; | |
495 | if (@_ > 1) | |
496 | { | |
497 | $w->{'update'}->configure( -text => "Apply $h Color" ); | |
498 | my $state = ($h eq 'background') ? 'normal' : 'disabled'; | |
499 | $w->{'palette'}->entryconfigure( $SET_PALETTE, -state => $state); | |
500 | $w->{'highlight'} = $h; | |
501 | $w->configure(-color => $w->Palette->{$h}); | |
502 | $w->set_title; | |
503 | } | |
504 | return $w->{'highlight'}; | |
505 | } | |
506 | ||
507 | sub title | |
508 | { | |
509 | my ($w,$val) = @_; | |
510 | $w->set_title if (@_ > 1); | |
511 | return $w->{Configure}{'-title'}; | |
512 | } | |
513 | ||
514 | sub delete_menu_item | |
515 | { | |
516 | my $objref = shift; | |
517 | my $value; | |
518 | foreach $value (@_) | |
519 | { | |
520 | $objref->{'mcm2'}->delete($value); | |
521 | my $list_ord = $value =~ /\d+/ ? $value : lsearch($objref->{'highlight_list'}, $value); | |
522 | splice(@{$objref->{'highlight_list'}}, $list_ord, 1) if $list_ord != -1; | |
523 | } | |
524 | } | |
525 | ||
526 | sub delete_widgets { | |
527 | ||
528 | # Remove widgets from consideration by the color configurator. | |
529 | # $widgets_ref points to widgets previously added via `configure'. | |
530 | ||
531 | my($objref, $widgets_ref) = @_; | |
532 | ||
533 | my($i, $found, $r1, $r2, @wl) = (0, 0, 0, 0, @{$objref->cget(-widgets)}); | |
534 | foreach $r1 (@{$widgets_ref}) { | |
535 | $i = -1; | |
536 | $found = 0; | |
537 | foreach $r2 (@wl) { | |
538 | $i++; | |
539 | next if $r1 != $r2; | |
540 | $found = 1; | |
541 | last; | |
542 | } | |
543 | splice(@wl, $i, 1) if $found; | |
544 | } | |
545 | $objref->configure(-widgets => [@wl]); | |
546 | ||
547 | } # end delete_widgets | |
548 | ||
549 | sub ApplyDefault | |
550 | { | |
551 | my($objref) = @_; | |
552 | my $cb = $objref->cget('-command'); | |
553 | my $h; | |
554 | foreach $h (@{$objref->{'highlight_list'}}) | |
555 | { | |
556 | next if $h =~ /TEAR_SEP|SEP/; | |
557 | $cb->Call($h); | |
558 | die unless (defined $cb); | |
559 | } | |
560 | } | |
561 | ||
562 | sub Populate | |
563 | { | |
564 | ||
565 | # ColorEditor constructor. | |
566 | ||
567 | my($cw, $args) = @_; | |
568 | ||
569 | $cw->SUPER::Populate($args); | |
570 | $cw->withdraw; | |
571 | ||
572 | my $color_space = 'hsb'; # rgb, cmy, hsb | |
573 | my(@highlight_list) = qw( | |
574 | TEAR_SEP | |
575 | foreground background SEP | |
576 | activeForeground activeBackground SEP | |
577 | highlightColor highlightBackground SEP | |
578 | selectForeground selectBackground SEP | |
579 | disabledForeground insertBackground selectColor troughColor | |
580 | ); | |
581 | ||
582 | # Create the Usage Dialog; | |
583 | ||
584 | my $usage = $cw->Dialog( '-title' => 'ColorEditor Usage', | |
585 | -justify => 'left', | |
586 | -wraplength => '6i', | |
587 | -text => "The Colors menu allows you to:\n\nSelect a color attribute such as \"background\" that you wish to colorize. Click on \"Apply\" to update that single color attribute.\n\nSelect one of three color spaces. All color spaces display a color value as a hexadecimal number under the oval color swatch that can be directly supplied on widget commands.\n\nApply Tk's default color scheme to the application. Useful if you've made a mess of things and want to start over!\n\nChange the application's color palette. Make sure \"background\" is selected as the color attribute, find a pleasing background color to apply to all current and future application widgets, then select \"Set Palette\".", | |
588 | ); | |
589 | ||
590 | # Create the menu bar at the top of the window for the File, Colors | |
591 | # and Help menubuttons. | |
592 | ||
593 | my $m0 = $cw->Frame(-relief => 'raised', -borderwidth => 2); | |
594 | $m0->pack(-side => 'top', -fill => 'x'); | |
595 | my $mf = $m0->Menubutton( | |
596 | -text => 'File', | |
597 | -underline => 0, | |
598 | -bd => 1, | |
599 | -relief => 'raised', | |
600 | ); | |
601 | $mf->pack(-side => 'left'); | |
602 | my $close_command = [sub {shift->withdraw}, $cw]; | |
603 | $mf->command( | |
604 | -label => 'Close', | |
605 | -underline => 0, | |
606 | -command => $close_command, | |
607 | -accelerator => 'Ctrl-w', | |
608 | ); | |
609 | $cw->bind('<Control-Key-w>' => $close_command); | |
610 | $cw->protocol(WM_DELETE_WINDOW => $close_command); | |
611 | ||
612 | my $mc = $m0->Menubutton( | |
613 | -text => 'Colors', | |
614 | -underline => 0, | |
615 | -bd => 1, | |
616 | -relief => 'raised', | |
617 | ); | |
618 | $mc->pack(-side => 'left'); | |
619 | my $color_attributes = 'Color Attributes'; | |
620 | $mc->cascade(-label => $color_attributes, -underline => 6); | |
621 | $mc->separator; | |
622 | ||
623 | $mc->command( | |
624 | -label => 'Apply Default Colors', | |
625 | -underline => 6, | |
626 | -command => ['ApplyDefault',$cw] | |
627 | ); | |
628 | $mc->separator; | |
629 | $mc->command( | |
630 | -label => $SET_PALETTE, | |
631 | -underline => 0, | |
632 | -command => sub { $cw->setPalette($cw->cget('-color'))} | |
633 | ); | |
634 | ||
635 | my $m1 = $mc->cget(-menu); | |
636 | ||
637 | my $mcm2 = $m1->Menu; | |
638 | $m1->entryconfigure($color_attributes, -menu => $mcm2); | |
639 | my $mh = $m0->Menubutton( | |
640 | -text => 'Help', | |
641 | -underline => 0, | |
642 | -bd => 1, | |
643 | -relief => 'raised', | |
644 | ); | |
645 | $mh->pack(-side => 'right'); | |
646 | $mh->command( | |
647 | -label => 'Usage', | |
648 | -underline => 0, | |
649 | -command => [sub {shift->Show}, $usage], | |
650 | ); | |
651 | ||
652 | # Create the Apply button. | |
653 | ||
654 | my $bot = $cw->Frame(-relief => 'raised', -bd => 2); | |
655 | $bot->pack(-side => 'bottom', -fill =>'x'); | |
656 | my $update = $bot->Button( | |
657 | -command => [ | |
658 | sub { | |
659 | my ($objref) = @_; | |
660 | $objref->Callback(-command => ($objref->{'highlight'}, $objref->cget('-color'))); | |
661 | }, $cw, | |
662 | ], | |
663 | ); | |
664 | $update->pack(-pady => 1, -padx => '0.25c'); | |
665 | ||
666 | # Create the listbox that holds all of the color names in rgb.txt, if an | |
667 | # rgb.txt file can be found. | |
668 | ||
669 | my $middle = $cw->ColorSelect(-relief => 'raised', -borderwidth => 2); | |
670 | $middle->pack(-side => 'top', -fill => 'both'); | |
671 | # Create the status window. | |
672 | ||
673 | my $status = $cw->Toplevel; | |
674 | $status->withdraw; | |
675 | $status->geometry('+0+0'); | |
676 | my $status_l = $status->Label(-width => 50, -anchor => 'w'); | |
677 | $status_l->pack(-side => 'top'); | |
678 | ||
679 | $cw->{'highlight_list'} = [@highlight_list]; | |
680 | $cw->{'mcm2'} = $mcm2; | |
681 | ||
682 | foreach (@highlight_list) | |
683 | { | |
684 | next if /^TEAR_SEP$/; | |
685 | $cw->add_menu_item($_); | |
686 | } | |
687 | ||
688 | $cw->{'updating'} = 0; | |
689 | $cw->{'pending'} = 0; | |
690 | $cw->{'Status'} = $status; | |
691 | $cw->{'Status_l'} = $status_l; | |
692 | $cw->{'update'} = $update; | |
693 | $cw->{'gwt_depth'} = 0; | |
694 | $cw->{'palette'} = $mc; | |
695 | ||
696 | my $pixmap = $cw->Pixmap('-file' => Tk->findINC('ColorEdit.xpm')); | |
697 | $cw->Icon(-image => $pixmap); | |
698 | ||
699 | $cw->ConfigSpecs( | |
700 | DEFAULT => [$middle], | |
701 | -widgets => ['PASSIVE', undef, undef, | |
702 | [$cw->parent->Descendants]], | |
703 | -display_status => ['PASSIVE', undef, undef, 0], | |
704 | '-title' => ['METHOD', undef, undef, ''], | |
705 | -command => ['CALLBACK', undef, undef, ['set_colors',$cw]], | |
706 | '-highlight' => ['METHOD', undef, undef, 'background'], | |
707 | -cursor => ['DESCENDANTS', 'cursor', 'Cursor', 'left_ptr'], | |
708 | ); | |
709 | ||
710 | } # end Populate, ColorEditor constructor | |
711 | ||
712 | sub Show { | |
713 | ||
714 | my($objref) = @_; | |
715 | ||
716 | $objref->deiconify; | |
717 | ||
718 | } # end show | |
719 | ||
720 | # ColorEditor default configurator procedure - can be redefined by the | |
721 | # application. | |
722 | ||
723 | sub set_colors { | |
724 | ||
725 | # Configure all the widgets in $widgets for attribute $type and color | |
726 | # $color. If $color is undef then reset all colors | |
727 | # to the Tk defaults. | |
728 | ||
729 | my($objref, $type, $color) = @_; | |
730 | my $display = $objref->cget('-display_status'); | |
731 | ||
732 | $objref->{'Status'}->title("Configure $type"); | |
733 | $objref->{'Status'}->deiconify if $display; | |
734 | my $widget; | |
735 | my $reset = !defined($color); | |
736 | ||
737 | foreach $widget (@{$objref->cget('-widgets')}) { | |
738 | if ($display) { | |
739 | $objref->{'Status_l'}->configure( | |
740 | -text => 'WIDGET: ' . $widget->PathName | |
741 | ); | |
742 | $objref->update; | |
743 | } | |
744 | eval {local $SIG{'__DIE__'}; $color = ($widget->configure("-\L${type}"))[3]} if $reset; | |
745 | eval {local $SIG{'__DIE__'}; $widget->configure("-\L${type}" => $color)}; | |
746 | } | |
747 | ||
748 | $objref->{'Status'}->withdraw if $display; | |
749 | ||
750 | } # end set_colors | |
751 | ||
752 | # ColorEditor private methods. | |
753 | ||
754 | 1; | |
755 | ||
756 | __END__ | |
757 | ||
758 | =cut | |
759 |