home *** CD-ROM | disk | FTP | other *** search
/ CD Actual Thematic 7: Programming / CDAT7.iso / Share / Editores / Perl5 / perl / lib / site / auto / Tk / Widget / setPalette.al < prev    next >
Encoding:
Text File  |  1997-08-10  |  3.4 KB  |  91 lines
  1. # NOTE: Derived from blib\lib\Tk\Widget.pm.  Changes made here will be lost.
  2. package Tk::Widget;
  3.  
  4. # tk_setPalette --
  5. # Changes the default color scheme for a Tk application by setting
  6. # default colors in the option database and by modifying all of the
  7. # color options for existing widgets that have the default value.
  8. #
  9. # Arguments:
  10. # The arguments consist of either a single color name, which
  11. # will be used as the new background color (all other colors will
  12. # be computed from this) or an even number of values consisting of
  13. # option names and values. The name for an option is the one used
  14. # for the option database, such as activeForeground, not -activeforeground.
  15. sub setPalette
  16. {
  17.  my $w = shift->MainWindow;
  18.  my %new = (@_ == 1) ? (background => $_[0]) : @_;
  19.  my $priority = delete($new{'priority'}) || 'widgetDefault';
  20.  my $i;
  21.  
  22.  # Create an array that has the complete new palette. If some colors
  23.  # aren't specified, compute them from other colors that are specified.
  24.  
  25.  die "must specify a background color" if (!exists $new{background});
  26.  $new{"foreground"} = "black" unless (exists $new{foreground});
  27.  my @bg = $w->rgb($new{"background"});
  28.  my @fg = $w->rgb($new{"foreground"});
  29.  my $darkerBg = sprintf("#%02x%02x%02x",9*$bg[0]/2560,9*$bg[1]/2560,9*$bg[2]/2560);
  30.  foreach $i ("activeForeground","insertBackground","selectForeground","highlightColor")
  31.   {
  32.    $new{$i} = $new{"foreground"} unless (exists $new{$i});
  33.   }
  34.  unless (exists $new{"disabledForeground"})
  35.   {
  36.    $new{"disabledForeground"} = sprintf("#%02x%02x%02x",(3*$bg[0]+$fg[0])/1024,(3*$bg[1]+$fg[1])/1024,(3*$bg[2]+$fg[2])/1024);
  37.   }
  38.  $new{"highlightBackground"} = $new{"background"} unless (exists $new{"highlightBackground"});
  39.  
  40.  unless (exists $new{"activeBackground"})
  41.   {
  42.    my @light;
  43.    # Pick a default active background that is lighter than the
  44.    # normal background. To do this, round each color component
  45.    # up by 15% or 1/3 of the way to full white, whichever is
  46.    # greater.
  47.    foreach $i (0, 1, 2)
  48.     {
  49.      $light[$i] = $bg[$i]/256;
  50.      my $inc1 = $light[$i]*15/100;
  51.      my $inc2 = (255-$light[$i])/3;
  52.      if ($inc1 > $inc2)
  53.       {
  54.        $light[$i] += $inc1
  55.       }
  56.      else
  57.       {
  58.        $light[$i] += $inc2
  59.       }
  60.      $light[$i] = 255 if ($light[$i] > 255);
  61.     }
  62.    $new{"activeBackground"} = sprintf("#%02x%02x%02x",@light);
  63.   }
  64.  $new{"selectBackground"} = $darkerBg unless (exists $new{"selectBackground"});
  65.  $new{"troughColor"} = $darkerBg unless (exists $new{"troughColor"});
  66.  $new{"selectColor"} = "#b03060" unless (exists $new{"selectColor"});
  67.  
  68.  # Before doing this, make sure that the Tk::Palette variable holds
  69.  # the default values of all options, so that tkRecolorTree can
  70.  # be sure to only change options that have their default values.
  71.  # If the variable exists, then it is already correct (it was created
  72.  # the last time this procedure was invoked). If the variable
  73.  # doesn't exist, fill it in using the defaults from a few widgets.
  74.  my $Palette = $w->Palette;
  75.  
  76.  # Walk the widget hierarchy, recoloring all existing windows.
  77.  $w->RecolorTree(\%new);
  78.  # Change the option database so that future windows will get the
  79.  # same colors.
  80.  my $option;
  81.  foreach $option (keys %new)
  82.   {
  83.    $w->option("add","*$option",$new{$option},$priority);
  84.    # Save the options in the global variable Tk::Palette, for use the
  85.    # next time we change the options.
  86.    $Palette->{$option} = $new{$option};
  87.   }
  88. }
  89.  
  90. 1;
  91.