diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/ColorEditor.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/Tk/ColorEditor.pm | 781 |
1 files changed, 781 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/ColorEditor.pm b/Master/tlpkg/tlperl/lib/Tk/ColorEditor.pm new file mode 100644 index 00000000000..82b38991f11 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/ColorEditor.pm @@ -0,0 +1,781 @@ +package Tk::ColorSelect; # XXX why is this the Tk::ColorSelect package? +use strict; + +use vars qw($VERSION); +$VERSION = '4.012'; # was: sprintf '4.%03d', q$Revision: #8 $ =~ /\D(\d+)\s*$/; + +use Tk qw(Ev); + +require Tk::Frame; + +use base qw(Tk::Frame); +Construct Tk::Widget 'ColorSelect'; + +sub Populate +{ + my ($middle,$args) = @_; + my($i, @a); + my %seen_names; + foreach $i ($middle->_rgbTxtPath) { + local *FOO; + next if ! open FOO, $i; + my $middle_left = $middle->Frame; + $middle_left->pack( + -side => 'left', + -padx => '0.25c', + -pady => '0.25c', + ); + my $names = $middle->Listbox( + -width => 20, + -height => 12, + -relief => 'sunken', + -borderwidth => 2, + -exportselection => 0, + ); + $middle->Advertise(Names => $names); + + $names->bind('<Double-1>' => [$middle,'color',Ev(['getSelected'])]); + + my $scroll = $middle->Scrollbar( + -orient => 'vertical', + -command => ['yview', $names], + -relief => 'sunken', + -borderwidth => 2, + ); + $names->configure(-yscrollcommand => ['set',$scroll]); + $names->pack(-in => $middle_left, -side => 'left'); + $scroll->pack(-in => $middle_left, -side => 'right', -fill => 'y'); + + while(<FOO>) { + chomp; + next if /^!/; + my @a = split; + my $color = join(' ', @a[3 .. $#a]); + my $hex; + eval { $hex = $middle->Hex($color); }; + if ($@) { + #print STDERR "unknown color: '$color'\n"; + if ($@ =~ /unknown color name "/) { + next; + } else { + chomp $@; + die $@; + } + } + if (!exists($seen_names{$hex}) || + length($seen_names{$hex}) > length($color)) { + $seen_names{$hex} = $color; + $names->insert('end', $color); + } + } + close FOO; + last; + } + + # Create the three scales for editing the color, and the entry for typing + # in a color value. + + my $middle_middle = $middle->Frame; + $middle_middle->pack(-side => 'left', -expand => 1, -fill => 'y'); + my $mcm1 = $middle_middle->Optionmenu(-variable => \$middle->{'color_space'}, + -command => [ $middle, 'color_space'], + -relief => 'raised', + -options => [ ['HSB color space' => 'hsb'], + ['RGB color space' => 'rgb'], + ['CMY color space' => 'cmy']]); + $mcm1->pack(-side => 'top', -fill => 'x'); + + my(@middle_middle, @label, @scale); + $middle_middle[0] = $middle_middle->Frame; + $middle_middle[1] = $middle_middle->Frame; + $middle_middle[2] = $middle_middle->Frame; + $middle_middle[3] = $middle_middle->Frame; + $middle_middle[0]->pack(-side => 'top', -expand => 1); + $middle_middle[1]->pack(-side => 'top', -expand => 1); + $middle_middle[2]->pack(-side => 'top', -expand => 1); + $middle_middle[3]->pack(-side => 'top', -expand => 1, -fill => 'x'); + $middle->{'Labels'} = ['zero','one','two']; + foreach $i (0..2) { + $label[$i] = $middle->Label(-textvariable => \$middle->{'Labels'}[$i]); + $scale[$i] = $middle->Scale( + -from => 0, + -to => 1000, + '-length' => '6c', + -orient => 'horizontal', + -command => [\&scale_changed, $middle], + ); + $scale[$i]->pack( + -in => $middle_middle[$i], + -side => 'top', + -anchor => 'w', + ); + $label[$i]->pack( + -in => $middle_middle[$i], + -side => 'top', + -anchor => 'w', + ); + } + my $nameLabel = $middle->Label(-text => 'Name:'); + $middle->{'Entry'} = ''; + my $name = $middle->Entry( + -relief => 'sunken', + -borderwidth => 2, + -textvariable => \$middle->{'Entry'}, + -width => 10, +# For some reason giving this font causes problems at end of t/create.t +# -font => '-*-Courier-Medium-R-Normal--*-120-*-*-*-*-*-*' + ); + + $nameLabel->pack(-in => $middle_middle[3], -side => 'left'); + $name->pack( + -in => $middle_middle[3], + -side => 'right', + -expand => 1, + -fill => 'x', + ); + $name->bind('<Return>' => [ $middle, 'color', Ev(['get'])]); + + # Create the color display swatch on the right side of the window. + + my $middle_right = $middle->Frame; + $middle_right->pack( + -side => 'left', + -pady => '.25c', + -padx => '.25c', + -anchor => 's', + ); + my $swatch = $middle->Canvas( + -width => '2.5c', + -height => '5c', + ); + my $swatch_item = $swatch->create('oval', '.5c', '.3c', '2.26c', '4.76c'); + + my $value = $middle->Label( + -textvariable => \$middle->{'color'}, + -width => 13, + -font => '-*-Courier-Medium-R-Normal--*-120-*-*-*-*-*-*' + ); + + $swatch->pack( + -in => $middle_right, + -side => 'top', + -expand => 1, + -fill => 'both', + ); + $value->pack(-in => $middle_right, -side => 'bottom', -pady => '.25c'); + + $middle->ConfigSpecs( + '-color_space' => ['METHOD', undef, undef, 'hsb'], + '-initialcolor' => '-color', + '-color' => ['METHOD', 'background', 'Background', + $middle->cget('-background')] + ); + + $middle->{'swatch'} = $swatch; + $middle->{'swatch_item'} = $swatch_item; + $middle->{'scale'} = [@scale]; + $middle->{'red'} = 0; + $middle->{'blue'} = 0; + $middle->{'green'} = 0; + +} + +sub _rgbTxtPath +{ + require Tk::Config; + my(@xlibpath) = map { s/^-L//; "$_/X11/rgb.txt" } + split /\s+/, $Tk::Config::xlib; + ( + @xlibpath, + '/usr/local/lib/X11/rgb.txt', + '/usr/lib/X11/rgb.txt', + '/usr/X11R6/lib/X11/rgb.txt', + '/usr/local/X11R5/lib/X11/rgb.txt', + '/X11/R5/lib/X11/rgb.txt', + '/X11/R4/lib/rgb/rgb.txt', + '/usr/openwin/lib/X11/rgb.txt', + '/usr/share/X11/rgb.txt', # This is the Debian location + '/usr/X11/share/X11/rgb.txt', # seen on a Mac OS X 10.5.1 system + '/usr/X11R6/share/X11/rgb.txt', # seen on a OpenBSD 4.2 system + '/etc/X11R6/rgb.txt', + '/etc/X11/rgb.txt', # seen on HP-UX 11.31 + ); +} + +sub Hex +{ + my $w = shift; + my @rgb = (@_ == 3) ? @_ : $w->rgb(@_); + sprintf('#%04x%04x%04x',@rgb) +} + +sub color_space { + + my($objref, $space) = @_; + + if (@_ > 1) + { + my %Labels = ( 'rgb' => [qw(Red Green Blue)], + 'cmy' => [qw(Cyan Magenta Yellow)], + 'hsb' => [qw(Hue Saturation Brightness)] ); + + # The procedure below is invoked when a new color space is selected. It + # changes the labels on the scales and re-loads the scales with the + # appropriate values for the current color in the new color space + + $space = 'hsb' unless (exists $Labels{$space}); + my $i; + for $i (0..2) + { + $objref->{'Labels'}[$i] = $Labels{$space}->[$i]; + } + $objref->{'color_space'} = $space; + $objref->afterIdle(['set_scales',$objref]) unless ($objref->{'pending'}++); + } + return $objref->{'color_space'}; +} # color_space + +sub hsvToRgb { + + # The procedure below converts an HSB value to RGB. It takes hue, + # saturation, and value components (floating-point, 0-1.0) as arguments, + # and returns a list containing RGB components (integers, 0-65535) as + # result. The code here is a copy of the code on page 616 of + # "Fundamentals of Interactive Computer Graphics" by Foley and Van Dam. + + my($hue, $sat, $value) = @_; + my($v, $i, $f, $p, $q, $t); + + $v = int(65535 * $value); + return ($v, $v, $v) if $sat == 0; + $hue *= 6; + $hue = 0 if $hue >= 6; + $i = int($hue); + $f = $hue - $i; + $p = int(65535 * $value * (1 - $sat)); + $q = int(65535 * $value * (1 - ($sat * $f))); + $t = int(65535 * $value * (1 - ($sat * (1 - $f)))); + return ($v, $t, $p) if $i == 0; + return ($q, $v, $p) if $i == 1; + return ($p, $v, $t) if $i == 2; + return ($p, $q, $v) if $i == 3; + return ($t, $p, $v) if $i == 4; + return ($v, $p, $q) if $i == 5; + +} # end hsvToRgb + +sub color +{ + my ($objref,$name) = @_; + if (@_ > 1 && defined($name) && length($name)) + { + if ($name eq 'cancel') { + $objref->{color} = undef; + return; + } + my ($format, $shift); + my ($red, $green, $blue); + + if ($name !~ /^#/) + { + ($red, $green, $blue) = $objref->{'swatch'}->rgb($name); + } + else + { + my $len = length $name; + if($len == 4) { $format = '#(.)(.)(.)'; $shift = 12; } + elsif($len == 7) { $format = '#(..)(..)(..)'; $shift = 8; } + elsif($len == 10) { $format = '#(...)(...)(...)'; $shift = 4; } + elsif($len == 13) { $format = '#(....)(....)(....)'; $shift = 0; } + else { + $objref->BackTrace( + "ColorEditor error: syntax error in color name \"$name\""); + return; + } + ($red,$green,$blue) = $name =~ /$format/; + # Looks like a call for 'pack' or similar rather than eval + eval "\$red = 0x$red; \$green = 0x$green; \$blue = 0x$blue;"; + $red = $red << $shift; + $green = $green << $shift; + $blue = $blue << $shift; + } + $objref->{'red'} = $red; + $objref->{'blue'} = $blue; + $objref->{'green'} = $green; + my $hex = sprintf('#%04x%04x%04x', $red, $green, $blue); + $objref->{'color'} = $hex; + $objref->{'Entry'} = $name; + $objref->afterIdle(['set_scales',$objref]) unless ($objref->{'pending'}++); + $objref->{'swatch'}->itemconfigure($objref->{'swatch_item'}, + -fill => $objref->{'color'}); + } + return $objref->{'color'}; +} + +sub rgbToHsv { + + # The procedure below converts an RGB value to HSB. It takes red, green, + # and blue components (0-65535) as arguments, and returns a list + # containing HSB components (floating-point, 0-1) as result. The code + # here is a copy of the code on page 615 of "Fundamentals of Interactive + # Computer Graphics" by Foley and Van Dam. + + my($red, $green, $blue) = @_; + my($max, $min, $sat, $range, $hue, $rc, $gc, $bc); + + $max = ($red > $green) ? (($blue > $red) ? $blue : $red) : + (($blue > $green) ? $blue : $green); + $min = ($red < $green) ? (($blue < $red) ? $blue : $red) : + (($blue < $green) ? $blue : $green); + $range = $max - $min; + if ($max == 0) { + $sat = 0; + } else { + $sat = $range / $max; + } + if ($sat == 0) { + $hue = 0; + } else { + $rc = ($max - $red) / $range; + $gc = ($max - $green) / $range; + $bc = ($max - $blue) / $range; + $hue = ($max == $red)?(0.166667*($bc - $gc)): + (($max == $green)?(0.166667*(2 + $rc - $bc)): + (0.166667*(4 + $gc - $rc))); + } + $hue += 1 if $hue < 0; + return ($hue, $sat, $max/65535); + +} # end rgbToHsv + +sub scale_changed { + + # The procedure below is invoked when one of the scales is adjusted. It + # propagates color information from the current scale readings to + # everywhere else that it is used. + + my($objref) = @_; + + return if $objref->{'updating'}; + my ($red, $green, $blue); + + if($objref->{'color_space'} eq 'rgb') { + $red = int($objref->{'scale'}->[0]->get * 65.535 + 0.5); + $green = int($objref->{'scale'}->[1]->get * 65.535 + 0.5); + $blue = int($objref->{'scale'}->[2]->get * 65.535 + 0.5); + } elsif($objref->{'color_space'} eq 'cmy') { + $red = int(65535 - $objref->{'scale'}->[0]->get * 65.535 + 0.5); + $green = int(65535 - $objref->{'scale'}->[1]->get * 65.535 + 0.5); + $blue = int(65535 - $objref->{'scale'}->[2]->get * 65.535 + 0.5); + } else { + ($red, $green, $blue) = hsvToRgb($objref->{'scale'}->[0]->get/1000.0, + $objref->{'scale'}->[1]->get/1000.0, + $objref->{'scale'}->[2]->get/1000.0); + } + $objref->{'red'} = $red; + $objref->{'blue'} = $blue; + $objref->{'green'} = $green; + $objref->color(sprintf('#%04x%04x%04x', $red, $green, $blue)); + $objref->idletasks; + +} # end scale_changed + +sub set_scales { + + my($objref) = @_; + $objref->{'pending'} = 0; + $objref->{'updating'} = 1; + + # The procedure below is invoked to update the scales from the current red, + # green, and blue intensities. It's invoked after a change in the color + # space and after a named color value has been loaded. + + my($red, $blue, $green) = ($objref->{'red'}, $objref->{'blue'}, + $objref->{'green'}); + + if($objref->{'color_space'} eq 'rgb') { + $objref->{'scale'}->[0]->set(int($red / 65.535 + 0.5)); + $objref->{'scale'}->[1]->set(int($green / 65.535 + 0.5)); + $objref->{'scale'}->[2]->set(int($blue / 65.535 + 0.5)); + } elsif($objref->{'color_space'} eq 'cmy') { + $objref->{'scale'}->[0]->set(int((65535 - $red) / 65.535 + 0.5)); + $objref->{'scale'}->[1]->set(int((65535 - $green) / 65.535 + 0.5)); + $objref->{'scale'}->[2]->set(int((65535 - $blue) / 65.535 + 0.5)); + } else { + my ($s1, $s2, $s3) = rgbToHsv($red, $green, $blue); + $objref->{'scale'}->[0]->set(int($s1 * 1000.0 + 0.5)); + $objref->{'scale'}->[1]->set(int($s2 * 1000.0 + 0.5)); + $objref->{'scale'}->[2]->set(int($s3 * 1000.0 + 0.5)); + } + $objref->{'updating'} = 0; + +} # end set_scales + +package Tk::ColorDialog; +require Tk::Toplevel; +use base qw(Tk::Toplevel); + +Construct Tk::Widget 'ColorDialog'; + +sub Accept +{ + my $cw = shift; + $cw->withdraw; + $cw->{'done'} = 1; +} + +sub Cancel +{ + my $cw = shift; +# $cw->configure(-color => undef); + $cw->configure(-color => 'cancel'); + $cw->Accept; +} + +sub Populate +{ + my ($cw,$args) = @_; + $cw->SUPER::Populate($args); + $cw->protocol('WM_DELETE_WINDOW' => [ 'Cancel' => $cw ]); + $cw->transient($cw->Parent->toplevel); + $cw->withdraw; + my $sel = $cw->ColorSelect; + my $accept = $cw->Button(-text => 'Accept', -command => ['Accept', $cw]); + my $cancel = $cw->Button(-text => 'Cancel', -command => ['Cancel', $cw]); + Tk::grid($sel); + Tk::grid($accept,$cancel); + $cw->ConfigSpecs(DEFAULT => [$sel]); +} + +sub Show +{ + my $cw = shift; + $cw->configure(@_) if @_; + $cw->Popup(); + $cw->OnDestroy(sub { $cw->{'done'} = 0 }); # auto-cancel + $cw->waitVariable(\$cw->{'done'}); + if (Tk::Exists($cw)) + { + $cw->withdraw; + $cw->cget('-color'); + } + else + { + undef; + } +} + +package Tk::ColorEditor; + +use vars qw($VERSION $SET_PALETTE); +$VERSION = '4.009'; # was: sprintf '4.%03d', q$Revision: #8 $ =~ /\D(\d+)\s*$/; + +use Tk qw(lsearch Ev); +use Tk::Toplevel; +use base qw(Tk::Toplevel); +use Tk::widgets qw(Pixmap); +Construct Tk::Widget 'ColorEditor'; + +use Tk::Dialog; +use Tk::Pretty; + +BEGIN { $SET_PALETTE = 'Set Palette' }; + +use subs qw(color_space hsvToRgb rgbToHsv); + +# ColorEditor public methods. + +sub add_menu_item +{ + my $objref = shift; + my $value; + foreach $value (@_) + { + if ($value eq 'SEP') + { + $objref->{'mcm2'}->separator; + } + else + { + $objref->{'mcm2'}->command( -label => $value, + -command => [ 'configure', $objref, '-highlight' => $value ] ); + push @{$objref->{'highlight_list'}}, $value; + } + } +} + +sub set_title +{ + my ($w) = @_; + my $t = $w->{Configure}{'-title'} || '' ; + my $h = $w->{Configure}{'-highlight'} || ''; + $w->SUPER::title("$t $h Color Editor"); +} + +sub highlight +{ + my ($w,$h) = @_; + if (@_ > 1) + { + $w->{'update'}->configure( -text => "Apply $h Color" ); + my $state = ($h eq 'background') ? 'normal' : 'disabled'; + $w->{'palette'}->entryconfigure( $SET_PALETTE, -state => $state); + $w->{'highlight'} = $h; + $w->configure(-color => $w->Palette->{$h}); + $w->set_title; + } + return $w->{'highlight'}; +} + +sub title +{ + my ($w,$val) = @_; + $w->set_title if (@_ > 1); + return $w->{Configure}{'-title'}; +} + +sub delete_menu_item +{ + my $objref = shift; + my $value; + foreach $value (@_) + { + $objref->{'mcm2'}->delete($value); + my $list_ord = $value =~ /\d+/ ? $value : lsearch($objref->{'highlight_list'}, $value); + splice(@{$objref->{'highlight_list'}}, $list_ord, 1) if $list_ord != -1; + } +} + +sub delete_widgets { + + # Remove widgets from consideration by the color configurator. + # $widgets_ref points to widgets previously added via `configure'. + + my($objref, $widgets_ref) = @_; + + my($i, $found, $r1, $r2, @wl) = (0, 0, 0, 0, @{$objref->cget(-widgets)}); + foreach $r1 (@{$widgets_ref}) { + $i = -1; + $found = 0; + foreach $r2 (@wl) { + $i++; + next if $r1 != $r2; + $found = 1; + last; + } + splice(@wl, $i, 1) if $found; + } + $objref->configure(-widgets => [@wl]); + +} # end delete_widgets + +sub ApplyDefault +{ + my($objref) = @_; + my $cb = $objref->cget('-command'); + my $h; + foreach $h (@{$objref->{'highlight_list'}}) + { + next if $h =~ /TEAR_SEP|SEP/; + $cb->Call($h); + die unless (defined $cb); + } +} + +sub Populate +{ + + # ColorEditor constructor. + + my($cw, $args) = @_; + + $cw->SUPER::Populate($args); + $cw->withdraw; + + my $color_space = 'hsb'; # rgb, cmy, hsb + my(@highlight_list) = qw( + TEAR_SEP + foreground background SEP + activeForeground activeBackground SEP + highlightColor highlightBackground SEP + selectForeground selectBackground SEP + disabledForeground insertBackground selectColor troughColor + ); + + # Create the Usage Dialog; + + my $usage = $cw->Dialog( '-title' => 'ColorEditor Usage', + -justify => 'left', + -wraplength => '6i', + -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\".", + ); + + # Create the menu bar at the top of the window for the File, Colors + # and Help menubuttons. + + my $m0 = $cw->Frame(-relief => 'raised', -borderwidth => 2); + $m0->pack(-side => 'top', -fill => 'x'); + my $mf = $m0->Menubutton( + -text => 'File', + -underline => 0, + -bd => 1, + -relief => 'raised', + ); + $mf->pack(-side => 'left'); + my $close_command = [sub {shift->withdraw}, $cw]; + $mf->command( + -label => 'Close', + -underline => 0, + -command => $close_command, + -accelerator => 'Ctrl-w', + ); + $cw->bind('<Control-Key-w>' => $close_command); + $cw->protocol(WM_DELETE_WINDOW => $close_command); + + my $mc = $m0->Menubutton( + -text => 'Colors', + -underline => 0, + -bd => 1, + -relief => 'raised', + ); + $mc->pack(-side => 'left'); + my $color_attributes = 'Color Attributes'; + $mc->cascade(-label => $color_attributes, -underline => 6); + $mc->separator; + + $mc->command( + -label => 'Apply Default Colors', + -underline => 6, + -command => ['ApplyDefault',$cw] + ); + $mc->separator; + $mc->command( + -label => $SET_PALETTE, + -underline => 0, + -command => sub { $cw->setPalette($cw->cget('-color'))} + ); + + my $m1 = $mc->cget(-menu); + + my $mcm2 = $m1->Menu; + $m1->entryconfigure($color_attributes, -menu => $mcm2); + my $mh = $m0->Menubutton( + -text => 'Help', + -underline => 0, + -bd => 1, + -relief => 'raised', + ); + $mh->pack(-side => 'right'); + $mh->command( + -label => 'Usage', + -underline => 0, + -command => [sub {shift->Show}, $usage], + ); + + # Create the Apply button. + + my $bot = $cw->Frame(-relief => 'raised', -bd => 2); + $bot->pack(-side => 'bottom', -fill =>'x'); + my $update = $bot->Button( + -command => [ + sub { + my ($objref) = @_; + $objref->Callback(-command => ($objref->{'highlight'}, $objref->cget('-color'))); + $cw->{'done'} = 1; + }, $cw, + ], + ); + $update->pack(-pady => 1, -padx => '0.25c'); + + # Create the listbox that holds all of the color names in rgb.txt, if an + # rgb.txt file can be found. + + my $middle = $cw->ColorSelect(-relief => 'raised', -borderwidth => 2); + $middle->pack(-side => 'top', -fill => 'both'); + # Create the status window. + + my $status = $cw->Toplevel; + $status->withdraw; + $status->geometry('+0+0'); + my $status_l = $status->Label(-width => 50, -anchor => 'w'); + $status_l->pack(-side => 'top'); + + $cw->{'highlight_list'} = [@highlight_list]; + $cw->{'mcm2'} = $mcm2; + + foreach (@highlight_list) + { + next if /^TEAR_SEP$/; + $cw->add_menu_item($_); + } + + $cw->{'updating'} = 0; + $cw->{'pending'} = 0; + $cw->{'Status'} = $status; + $cw->{'Status_l'} = $status_l; + $cw->{'update'} = $update; + $cw->{'gwt_depth'} = 0; + $cw->{'palette'} = $mc; + + my $pixmap = $cw->Pixmap('-file' => Tk->findINC('ColorEdit.xpm')); + $cw->Icon(-image => $pixmap); + + $cw->ConfigSpecs( + DEFAULT => [$middle], + -widgets => ['PASSIVE', undef, undef, + [$cw->parent->Descendants]], + -display_status => ['PASSIVE', undef, undef, 0], + '-title' => ['METHOD', undef, undef, ''], + -command => ['CALLBACK', undef, undef, ['set_colors',$cw]], + '-highlight' => ['METHOD', undef, undef, 'background'], + -cursor => ['DESCENDANTS', 'cursor', 'Cursor', 'left_ptr'], + ); + +} # end Populate, ColorEditor constructor + +sub Show { + + my($objref, @args) = @_; + + Tk::ColorDialog::Show(@_); + +} # end show + +# ColorEditor default configurator procedure - can be redefined by the +# application. + +sub set_colors { + + # Configure all the widgets in $widgets for attribute $type and color + # $color. If $color is undef then reset all colors + # to the Tk defaults. + + my($objref, $type, $color) = @_; + my $display = $objref->cget('-display_status'); + + $objref->{'Status'}->title("Configure $type"); + $objref->{'Status'}->deiconify if $display; + my $widget; + my $reset = !defined($color); + + foreach $widget (@{$objref->cget('-widgets')}) { + if ($display) { + $objref->{'Status_l'}->configure( + -text => 'WIDGET: ' . $widget->PathName + ); + $objref->update; + } + eval {local $SIG{'__DIE__'}; $color = ($widget->configure("-\L${type}"))[3]} if $reset; + eval {local $SIG{'__DIE__'}; $widget->configure("-\L${type}" => $color)}; + } + + $objref->{'Status'}->withdraw if $display; + +} # end set_colors + +# ColorEditor private methods. + +1; + +__END__ + |