projects / OpenSPARC-T2-DV / blame
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Initial commit of OpenSPARC T2 design and verification files.
[OpenSPARC-T2-DV] / tools / perl-5.8.0 / lib / site_perl / 5.8.0 / sun4-solaris / Tk / ColorEditor.pm
CommitLineData
86530b38
AT		 1package Tk::ColorSelect;
2use strict;
3
4use vars qw($VERSION);
5$VERSION = '3.032'; # $Id: //depot/Tk8/Tk/ColorEditor.pm#32 $
6
7use Tk qw(Ev);
8
9require Tk::Frame;
10
11use base qw(Tk::Frame);
12Construct Tk::Widget 'ColorSelect';
13
14sub 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
188sub Hex
189{
190 my $w = shift;
191 my @rgb = (@_ == 3) ? @_ : $w->rgb(@_);
192 sprintf('#%04x%04x%04x',@rgb)
193}
194
195sub 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
221sub 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
250sub 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
298sub 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
333sub 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
365sub 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
396package Tk::ColorDialog;
397require Tk::Toplevel;
398use base qw(Tk::Toplevel);
399
400Construct Tk::Widget 'ColorDialog';
401
402sub Accept
403{
404 my $cw = shift;
405 $cw->withdraw;
406 $cw->{'done'} = 1;
407}
408
409sub Cancel
410{
411 my $cw = shift;
412# $cw->configure(-color => undef);
413 $cw->configure(-color => 'cancel');
414 $cw->Accept;
415}
416
417sub 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
432sub 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
442package Tk::ColorEditor;
443
444use vars qw($VERSION $SET_PALETTE);
445$VERSION = '3.032'; # $Id: //depot/Tk8/Tk/ColorEditor.pm#32 $
446
447use Tk qw(lsearch Ev);
448use Tk::Toplevel;
449use base qw(Tk::Toplevel);
450use Tk::widgets qw(Pixmap);
451Construct Tk::Widget 'ColorEditor';
452
453%Tk::ColorEditor::names = ();
454
455
456use Tk::Dialog;
457use Tk::Pretty;
458
459BEGIN { $SET_PALETTE = 'Set Palette' };
460
461use subs qw(color_space hsvToRgb rgbToHsv);
462
463# ColorEditor public methods.
464
465sub 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
484sub 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
492sub 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
507sub title
508{
509 my ($w,$val) = @_;
510 $w->set_title if (@_ > 1);
511 return $w->{Configure}{'-title'};
512}
513
514sub 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
526sub 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
549sub 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
562sub 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
712sub 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
723sub 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
7541;
755
756__END__
757
758=cut
759
Full OpenSPARC design & verification tarball including full HDL.