home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _661edab6dbcc5c5901538f3ee805f5b4 < prev    next >
Encoding:
Text File  |  2004-06-01  |  23.1 KB  |  762 lines
  1. package Tk::ColorSelect;
  2. use strict;
  3.  
  4. use vars qw($VERSION);
  5. $VERSION = sprintf '4.%03d', q$Revision: #8 $ =~ /\D(\d+)\s*$/;
  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.     $hue += 1 if $hue < 0;
  330.     return ($hue, $sat, $max/65535);
  331.  
  332. } # end rgbToHsv
  333.  
  334. sub scale_changed {
  335.  
  336.     # The procedure below is invoked when one of the scales is adjusted.  It
  337.     # propagates color information from the current scale readings to
  338.     # everywhere else that it is used.
  339.  
  340.     my($objref) = @_;
  341.  
  342.     return if $objref->{'updating'};
  343.     my ($red, $green, $blue);
  344.  
  345.     if($objref->{'color_space'} eq 'rgb') {
  346.         $red = int($objref->{'scale'}->[0]->get * 65.535 + 0.5);
  347.         $green = int($objref->{'scale'}->[1]->get * 65.535 + 0.5);
  348.         $blue = int($objref->{'scale'}->[2]->get * 65.535 + 0.5);
  349.     } elsif($objref->{'color_space'} eq 'cmy') {
  350.         $red = int(65535 - $objref->{'scale'}->[0]->get * 65.535 + 0.5);
  351.         $green = int(65535 - $objref->{'scale'}->[1]->get * 65.535 + 0.5);
  352.         $blue = int(65535 - $objref->{'scale'}->[2]->get * 65.535 + 0.5);
  353.     } else {
  354.         ($red, $green, $blue) = hsvToRgb($objref->{'scale'}->[0]->get/1000.0,
  355.                                          $objref->{'scale'}->[1]->get/1000.0,
  356.                                          $objref->{'scale'}->[2]->get/1000.0);
  357.     }
  358.     $objref->{'red'} = $red;
  359.     $objref->{'blue'} = $blue;
  360.     $objref->{'green'} = $green;
  361.     $objref->color(sprintf('#%04x%04x%04x', $red, $green, $blue));
  362.     $objref->idletasks;
  363.  
  364. } # end scale_changed
  365.  
  366. sub set_scales {
  367.  
  368.     my($objref) = @_;
  369.     $objref->{'pending'} = 0;
  370.     $objref->{'updating'} = 1;
  371.  
  372.     # The procedure below is invoked to update the scales from the current red,
  373.     # green, and blue intensities.  It's invoked after a change in the color
  374.     # space and after a named color value has been loaded.
  375.  
  376.     my($red, $blue, $green) = ($objref->{'red'}, $objref->{'blue'},
  377.                                $objref->{'green'});
  378.  
  379.     if($objref->{'color_space'} eq 'rgb') {
  380.         $objref->{'scale'}->[0]->set(int($red / 65.535 + 0.5));
  381.         $objref->{'scale'}->[1]->set(int($green / 65.535 + 0.5));
  382.         $objref->{'scale'}->[2]->set(int($blue / 65.535 + 0.5));
  383.     } elsif($objref->{'color_space'} eq 'cmy') {
  384.         $objref->{'scale'}->[0]->set(int((65535 - $red) / 65.535 + 0.5));
  385.         $objref->{'scale'}->[1]->set(int((65535 - $green) / 65.535 + 0.5));
  386.         $objref->{'scale'}->[2]->set(int((65535 - $blue) / 65.535 + 0.5));
  387.     } else {
  388.         my ($s1, $s2, $s3) = rgbToHsv($red, $green, $blue);
  389.         $objref->{'scale'}->[0]->set(int($s1 * 1000.0 + 0.5));
  390.         $objref->{'scale'}->[1]->set(int($s2 * 1000.0 + 0.5));
  391.         $objref->{'scale'}->[2]->set(int($s3 * 1000.0 + 0.5));
  392.     }
  393.     $objref->{'updating'} = 0;
  394.  
  395. } # end set_scales
  396.  
  397. package Tk::ColorDialog;
  398. require Tk::Toplevel;
  399. use base  qw(Tk::Toplevel);
  400.  
  401. Construct Tk::Widget 'ColorDialog';
  402.  
  403. sub Accept
  404. {
  405.  my $cw  = shift;
  406.  $cw->withdraw;
  407.  $cw->{'done'} = 1;
  408. }
  409.  
  410. sub Cancel
  411. {
  412.  my $cw  = shift;
  413. # $cw->configure(-color => undef);
  414.  $cw->configure(-color => 'cancel');
  415.  $cw->Accept;
  416. }
  417.  
  418. sub Populate
  419. {
  420.  my ($cw,$args) = @_;
  421.  $cw->SUPER::Populate($args);
  422.  $cw->protocol('WM_DELETE_WINDOW' => [ 'Cancel' => $cw ]);
  423.  $cw->transient($cw->Parent->toplevel);
  424.  $cw->withdraw;
  425.  my $sel = $cw->ColorSelect;
  426.  my $accept = $cw->Button(-text => 'Accept', -command => ['Accept', $cw]);
  427.  my $cancel = $cw->Button(-text => 'Cancel', -command => ['Cancel', $cw]);
  428.  Tk::grid($sel);
  429.  Tk::grid($accept,$cancel);
  430.  $cw->ConfigSpecs(DEFAULT => [$sel]);
  431. }
  432.  
  433. sub Show
  434. {
  435.  my $cw = shift;
  436.  $cw->configure(@_) if @_;
  437.  $cw->Popup();
  438.  $cw->waitVariable(\$cw->{'done'});
  439.  $cw->withdraw;
  440.  return $cw->cget('-color');
  441. }
  442.  
  443. package Tk::ColorEditor;
  444.  
  445. use vars qw($VERSION $SET_PALETTE);
  446. $VERSION = sprintf '4.%03d', q$Revision: #8 $ =~ /\D(\d+)\s*$/;
  447.  
  448. use Tk qw(lsearch Ev);
  449. use Tk::Toplevel;
  450. use base  qw(Tk::Toplevel);
  451. use Tk::widgets qw(Pixmap);
  452. Construct Tk::Widget 'ColorEditor';
  453.  
  454. %Tk::ColorEditor::names = ();
  455.  
  456.  
  457. use Tk::Dialog;
  458. use Tk::Pretty;
  459.  
  460. BEGIN { $SET_PALETTE = 'Set Palette' };
  461.  
  462. use subs qw(color_space hsvToRgb rgbToHsv);
  463.  
  464. # ColorEditor public methods.
  465.  
  466. sub add_menu_item
  467. {
  468.  my $objref = shift;
  469.  my $value;
  470.  foreach $value (@_)
  471.   {
  472.    if ($value eq 'SEP')
  473.     {
  474.      $objref->{'mcm2'}->separator;
  475.     }
  476.    else
  477.     {
  478.      $objref->{'mcm2'}->command( -label => $value,
  479.            -command => [ 'configure', $objref, '-highlight' => $value ] );
  480.      push @{$objref->{'highlight_list'}}, $value;
  481.     }
  482.   }
  483. }
  484.  
  485. sub set_title
  486. {
  487.  my ($w) = @_;
  488.  my $t = $w->{Configure}{'-title'} || '' ;
  489.  my $h = $w->{Configure}{'-highlight'} || '';
  490.  $w->SUPER::title("$t $h Color Editor");
  491. }
  492.  
  493. sub highlight
  494. {
  495.  my ($w,$h) = @_;
  496.  if (@_ > 1)
  497.   {
  498.    $w->{'update'}->configure( -text => "Apply $h Color" );
  499.    my $state = ($h eq 'background') ? 'normal' : 'disabled';
  500.    $w->{'palette'}->entryconfigure( $SET_PALETTE, -state => $state);
  501.    $w->{'highlight'} = $h;
  502.    $w->configure(-color => $w->Palette->{$h});
  503.    $w->set_title;
  504.   }
  505.  return $w->{'highlight'};
  506. }
  507.  
  508. sub title
  509. {
  510.  my ($w,$val) = @_;
  511.  $w->set_title if (@_ > 1);
  512.  return $w->{Configure}{'-title'};
  513. }
  514.  
  515. sub delete_menu_item
  516. {
  517.  my $objref = shift;
  518.  my $value;
  519.  foreach $value (@_)
  520.   {
  521.    $objref->{'mcm2'}->delete($value);
  522.    my $list_ord = $value =~ /\d+/ ? $value : lsearch($objref->{'highlight_list'}, $value);
  523.    splice(@{$objref->{'highlight_list'}}, $list_ord, 1) if $list_ord != -1;
  524.   }
  525. }
  526.  
  527. sub delete_widgets {
  528.  
  529.     # Remove widgets from consideration by the color configurator.
  530.     # $widgets_ref points to widgets previously added via `configure'.
  531.  
  532.     my($objref, $widgets_ref) = @_;
  533.  
  534.     my($i, $found, $r1, $r2, @wl) = (0, 0, 0, 0, @{$objref->cget(-widgets)});
  535.     foreach $r1 (@{$widgets_ref}) {
  536.         $i = -1;
  537.         $found = 0;
  538.         foreach $r2 (@wl) {
  539.             $i++;
  540.             next if $r1 != $r2;
  541.             $found = 1;
  542.             last;
  543.         }
  544.         splice(@wl, $i, 1) if $found;
  545.     }
  546.     $objref->configure(-widgets => [@wl]);
  547.  
  548. } # end delete_widgets
  549.  
  550. sub ApplyDefault
  551. {
  552.  my($objref) = @_;
  553.  my $cb = $objref->cget('-command');
  554.  my $h;
  555.  foreach $h (@{$objref->{'highlight_list'}})
  556.   {
  557.    next if $h =~ /TEAR_SEP|SEP/;
  558.    $cb->Call($h);
  559.    die unless (defined $cb);
  560.   }
  561. }
  562.  
  563. sub Populate
  564. {
  565.  
  566.     # ColorEditor constructor.
  567.  
  568.     my($cw, $args) = @_;
  569.  
  570.     $cw->SUPER::Populate($args);
  571.     $cw->withdraw;
  572.  
  573.     my $color_space = 'hsb';    # rgb, cmy, hsb
  574.     my(@highlight_list) = qw(
  575.         TEAR_SEP
  576.         foreground background SEP
  577.         activeForeground activeBackground SEP
  578.         highlightColor highlightBackground SEP
  579.         selectForeground selectBackground SEP
  580.         disabledForeground insertBackground selectColor troughColor
  581.     );
  582.  
  583.     # Create the Usage Dialog;
  584.  
  585.     my $usage = $cw->Dialog( '-title' => 'ColorEditor Usage',
  586.         -justify    => 'left',
  587.         -wraplength => '6i',
  588.         -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\".",
  589.     );
  590.  
  591.     # Create the menu bar at the top of the window for the File, Colors
  592.     # and Help menubuttons.
  593.  
  594.     my $m0 = $cw->Frame(-relief => 'raised', -borderwidth => 2);
  595.     $m0->pack(-side => 'top', -fill => 'x');
  596.     my $mf = $m0->Menubutton(
  597.         -text      => 'File',
  598.         -underline => 0,
  599.         -bd        => 1,
  600.         -relief    => 'raised',
  601.     );
  602.     $mf->pack(-side => 'left');
  603.     my $close_command = [sub {shift->withdraw}, $cw];
  604.     $mf->command(
  605.         -label       => 'Close',
  606.         -underline   => 0,
  607.         -command     => $close_command,
  608.         -accelerator => 'Ctrl-w',
  609.     );
  610.     $cw->bind('<Control-Key-w>' => $close_command);
  611.     $cw->protocol(WM_DELETE_WINDOW => $close_command);
  612.  
  613.     my $mc = $m0->Menubutton(
  614.         -text      => 'Colors',
  615.         -underline => 0,
  616.         -bd        => 1,
  617.         -relief    => 'raised',
  618.     );
  619.     $mc->pack(-side => 'left');
  620.     my $color_attributes = 'Color Attributes';
  621.     $mc->cascade(-label => $color_attributes, -underline => 6);
  622.     $mc->separator;
  623.  
  624.     $mc->command(
  625.         -label     => 'Apply Default Colors',
  626.         -underline => 6,
  627.         -command   => ['ApplyDefault',$cw]
  628.     );
  629.     $mc->separator;
  630.     $mc->command(
  631.         -label     => $SET_PALETTE,
  632.         -underline => 0,
  633.         -command   => sub { $cw->setPalette($cw->cget('-color'))}
  634.     );
  635.  
  636.     my $m1 = $mc->cget(-menu);
  637.  
  638.     my $mcm2 = $m1->Menu;
  639.     $m1->entryconfigure($color_attributes, -menu => $mcm2);
  640.     my $mh = $m0->Menubutton(
  641.         -text      => 'Help',
  642.         -underline => 0,
  643.         -bd        => 1,
  644.         -relief    => 'raised',
  645.     );
  646.     $mh->pack(-side => 'right');
  647.     $mh->command(
  648.         -label       => 'Usage',
  649.         -underline   => 0,
  650.         -command     => [sub {shift->Show}, $usage],
  651.     );
  652.  
  653.     # Create the Apply button.
  654.  
  655.     my $bot = $cw->Frame(-relief => 'raised', -bd => 2);
  656.     $bot->pack(-side => 'bottom', -fill =>'x');
  657.     my $update = $bot->Button(
  658.         -command => [
  659.             sub {
  660.                 my ($objref) = @_;
  661.                 $objref->Callback(-command => ($objref->{'highlight'}, $objref->cget('-color')));
  662.         $cw->{'done'} = 1;
  663.             }, $cw,
  664.         ],
  665.     );
  666.     $update->pack(-pady => 1, -padx => '0.25c');
  667.  
  668.     # Create the listbox that holds all of the color names in rgb.txt, if an
  669.     # rgb.txt file can be found.
  670.  
  671.     my $middle = $cw->ColorSelect(-relief => 'raised', -borderwidth => 2);
  672.     $middle->pack(-side => 'top', -fill => 'both');
  673.     # Create the status window.
  674.  
  675.     my $status = $cw->Toplevel;
  676.     $status->withdraw;
  677.     $status->geometry('+0+0');
  678.     my $status_l = $status->Label(-width => 50,  -anchor => 'w');
  679.     $status_l->pack(-side => 'top');
  680.  
  681.     $cw->{'highlight_list'} = [@highlight_list];
  682.     $cw->{'mcm2'} = $mcm2;
  683.  
  684.     foreach (@highlight_list)
  685.      {
  686.       next if /^TEAR_SEP$/;
  687.       $cw->add_menu_item($_);
  688.      }
  689.  
  690.     $cw->{'updating'} = 0;
  691.     $cw->{'pending'} = 0;
  692.     $cw->{'Status'} = $status;
  693.     $cw->{'Status_l'} = $status_l;
  694.     $cw->{'update'} = $update;
  695.     $cw->{'gwt_depth'} = 0;
  696.     $cw->{'palette'} = $mc;
  697.  
  698.     my $pixmap = $cw->Pixmap('-file' => Tk->findINC('ColorEdit.xpm'));
  699.     $cw->Icon(-image => $pixmap);
  700.  
  701.     $cw->ConfigSpecs(
  702.         DEFAULT         => [$middle],
  703.         -widgets        => ['PASSIVE', undef, undef,
  704.                                [$cw->parent->Descendants]],
  705.         -display_status => ['PASSIVE', undef, undef, 0],
  706.         '-title'        => ['METHOD', undef, undef, ''],
  707.         -command        => ['CALLBACK', undef, undef, ['set_colors',$cw]],
  708.         '-highlight'    => ['METHOD', undef, undef, 'background'],
  709.         -cursor         => ['DESCENDANTS', 'cursor', 'Cursor', 'left_ptr'],
  710.     );
  711.  
  712. } # end Populate, ColorEditor constructor
  713.  
  714. sub Show {
  715.  
  716.     my($objref, @args) = @_;
  717.  
  718.     Tk::ColorDialog::Show(@_);
  719.  
  720. } # end show
  721.  
  722. # ColorEditor default configurator procedure - can be redefined by the
  723. # application.
  724.  
  725. sub set_colors {
  726.  
  727.     # Configure all the widgets in $widgets for attribute $type and color
  728.     # $color.  If $color is undef then reset all colors
  729.     # to the Tk defaults.
  730.  
  731.     my($objref, $type, $color) = @_;
  732.     my $display = $objref->cget('-display_status');
  733.  
  734.     $objref->{'Status'}->title("Configure $type");
  735.     $objref->{'Status'}->deiconify if $display;
  736.     my $widget;
  737.     my $reset = !defined($color);
  738.  
  739.     foreach $widget (@{$objref->cget('-widgets')}) {
  740.         if ($display) {
  741.             $objref->{'Status_l'}->configure(
  742.                 -text => 'WIDGET:  ' . $widget->PathName
  743.             );
  744.             $objref->update;
  745.         }
  746.         eval {local $SIG{'__DIE__'}; $color = ($widget->configure("-\L${type}"))[3]} if $reset;
  747.         eval {local $SIG{'__DIE__'}; $widget->configure("-\L${type}" => $color)};
  748.     }
  749.  
  750.     $objref->{'Status'}->withdraw if $display;
  751.  
  752. } # end set_colors
  753.  
  754. # ColorEditor private methods.
  755.  
  756. 1;
  757.  
  758. __END__
  759.  
  760. =cut
  761.  
  762.