home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _6ba765c5f2078db587ffa721d4d3bf44 < prev    next >
Encoding:
Text File  |  2004-06-01  |  1.4 KB  |  46 lines
  1. # clrpick.pl
  2.  
  3. use Tk qw/catch/;
  4. use subs qw/setColor setColor_helper/;
  5. use vars qw/$TOP/;
  6.  
  7. sub clrpick {
  8.     my($demo) = @_;
  9.     $TOP = $MW->WidgetDemo(
  10.         -name             => $demo,
  11.         -text             => 'Press the buttons below to choose the foreground and background colors for the widgets in this window.',
  12.         -title            => 'chooseColor Demo',
  13.         -iconname         => 'chooseColor',
  14.     );
  15.  
  16.     my(@pl) = qw/-side top -anchor c -pady 2m/;
  17.     my($back, $front);
  18.     $back = $TOP->Button(-text => 'Set background color ...')->pack(@pl);
  19.     $back->configure(-command => [\&setColor => $TOP, $back, '-background',
  20.               [-background, -highlightbackground]]);
  21.     $front = $TOP->Button(-text => 'Set foreground color ...')->pack(@pl);
  22.     $front->configure(-command => [\&setColor => $TOP, $front, '-foreground',
  23.               [-foreground]]);
  24. }
  25.  
  26. sub setColor {
  27.     my($top, $button, $name, $options) = @_;
  28.     my $initialColor = $button->cget($name);
  29.     my $color = $button->chooseColor(-title => "Choose a $name color",
  30.                      -initialcolor => $initialColor);
  31.     setColor_helper $top, $options, $color if defined $color;
  32. }
  33.  
  34. sub setColor_helper {
  35.     my($widget, $options, $color) = @_;
  36.     foreach my $option (@$options) {
  37.     catch {
  38.         $widget->configure($option => $color);
  39.     }
  40.     }
  41.     foreach my $child ($widget->children) {
  42.     setColor_helper $child, $options, $color;
  43.     }
  44. }
  45.  
  46.