home *** CD-ROM | disk | FTP | other *** search
/ CD Actual Thematic 7: Programming / CDAT7.iso / Share / Editores / Perl5 / perl / lib / site / Tk / Widget.pm < prev    next >
Encoding:
Perl POD Document  |  1997-08-10  |  24.8 KB  |  990 lines
  1. # Copyright (c) 1995-1997 Nick Ing-Simmons. All rights reserved.
  2. # This program is free software; you can redistribute it and/or
  3. # modify it under the same terms as Perl itself.
  4. package Tk::Widget;
  5. require Tk;
  6. use AutoLoader;
  7. require DynaLoader;
  8. use strict;
  9.  
  10. use Carp;
  11.  
  12. @Tk::Widget::ISA = qw(DynaLoader Tk);
  13.  
  14. # stubs for 'autoloaded' widget classes
  15. sub Button;
  16. sub Canvas;
  17. sub Checkbutton;
  18. sub Entry;
  19. sub Frame;
  20. sub Label;
  21. sub Listbox;
  22. sub Menu;
  23. sub Menubutton;
  24. sub Message;
  25. sub Scale;
  26. sub Scrollbar;
  27. sub Radiobutton;
  28. sub Text;
  29. sub Toplevel;
  30.  
  31. sub Pixmap;
  32. sub Bitmap;
  33. sub Photo;
  34.  
  35. sub ScrlListbox;
  36. sub Optionmenu; 
  37.  
  38. sub import
  39. {
  40.  my $package = shift;
  41.  carp "use Tk::Widget () to pre-load widgets is deprecated" if (@_ && $^W);
  42.  my $need;
  43.  foreach $need (@_)
  44.   {
  45.    unless (defined &{$need})
  46.     {
  47.      require "Tk/${need}.pm"; 
  48.     }
  49.    croak "Cannot locate $need" unless (defined &{$need});
  50.   }
  51. }
  52.  
  53. # Some tidy-ness functions for winfo stuff
  54.  
  55. sub True  { 1 }
  56. sub False { 0 }
  57.  
  58. use Tk::Submethods( 'grab' =>  [qw(current status release -global)],
  59.                     'focus' => [qw(-force -lastfor)],
  60.                     'pack'  => [qw(configure forget info propagate slaves)],
  61.                     'grid'  => [qw(bbox columnconfigure configure forget info location propagate rowconfigure size slaves)],
  62.                     'form'  => [qw(check configure forget grid info slaves)],
  63.                     'after' => [qw(cancel idle)],
  64.                     'place' => [qw(configure forget info slaves)],
  65.                     'wm'    => [qw(capture release)]
  66.                   );
  67.  
  68. *IsMenu       = \&False;
  69. *IsMenubutton = \&False;
  70.  
  71. Direct Tk::Submethods ( 'winfo' => [qw(cells class colormapfull depth exists
  72.                geometry height id ismapped manager name parent reqheight
  73.                reqwidth rootx rooty screen screencells screendepth screenheight
  74.                screenmmheight screenmmwidth  screenvisual screenwidth visual
  75.                visualsavailable  vrootheight viewable vrootwidth vrootx vrooty
  76.                width x y toplevel children pixels pointerx pointery pointerxy
  77.                server fpixels rgb )]);
  78.  
  79. sub DESTROY
  80. {
  81.  my $w = shift;
  82.  $w->destroy if ($w->IsWidget);
  83. }
  84.  
  85. sub Install 
  86. {
  87.  # Dynamically loaded widgets add their core commands 
  88.  # to the Tk base class here 
  89.  my ($package,$mw) = @_;
  90. }
  91.  
  92. sub ClassInit
  93. {
  94.  # Carry out class bindings (or whatever)
  95.  my ($package,$mw) = @_;
  96.  return $package;
  97. }
  98.  
  99. sub CreateArgs
  100. {
  101.  my ($package,$parent,$args) = @_;
  102.  # Remove from hash %$args any configure-like
  103.  # options which only apply at create time (e.g. -colormap for Frame)
  104.  # return these as a list of -key => value pairs
  105.  # Augment same hash with default values for missing mandatory options,
  106.  # allthough this can be done later in InitObject.
  107.  
  108.  # Honour -class => if present, we have hacked Tk_ConfigureWidget to 
  109.  # allow -class to be passed to any widget.                         
  110.  my @result = ();
  111.  my $class = delete $args->{'-class'};                     
  112.  ($class) = $package =~ /([A-Z][A-Z0-9_]*)$/i unless (defined $class);
  113.  push(@result, '-class' => "\u$class") if (defined $class);
  114.  return @result;
  115. }
  116.  
  117. sub InitObject
  118. {
  119.  my ($obj,$args) = @_;
  120.  # per object initialization, for example populating 
  121.  # with sub-widgets, adding a few object bindings to augment
  122.  # inherited class bindings, changing binding tags.
  123.  # Also another chance to mess with %$args before configure...
  124. }
  125.  
  126. sub SetBindtags
  127. {
  128.  my ($obj) = @_;
  129.  $obj->bindtags([ref($obj),$obj,$obj->toplevel,'all']);
  130. }
  131.  
  132. sub new
  133. {
  134.  local $SIG{'__DIE__'} = \&Carp::croak;
  135.  my $package = shift;
  136.  my $parent  = shift;
  137.  $package->InitClass($parent);
  138.  $parent->BackTrace("Odd number of args to $package->new(...)") unless ((@_ % 2) == 0);
  139.  my %args  = @_;
  140.  my @args  = $package->CreateArgs($parent,\%args);
  141.  my $cmd   = $package->Tk_cmd;
  142.  my $pname = $parent->PathName;
  143.  $pname    = "" if ($pname eq ".");
  144.  my $leaf  = delete $args{'Name'};
  145.  my $lname;
  146.  if (defined $leaf)
  147.   {
  148.    $lname = $pname . "." . $leaf;
  149.   }
  150.  else
  151.   {
  152.    ($leaf) = "\L$package" =~ /([a-z][a-z0-9_]*)$/;
  153.    $lname  = $pname . "." . $leaf;
  154.    # create a hash indexed by leaf name to speed up 
  155.    # creation of a lot of sub-widgets of the same type
  156.    # e.g. entries in Table
  157.    my $key = "_#$leaf";
  158.    $parent->{$key} = 0 unless (exists $parent->{$key});
  159.    while (defined ($parent->Widget($lname)))
  160.     {
  161.      $lname = $pname . "." . $leaf . ++$parent->{$key};
  162.     }
  163.   }
  164.  my $obj = &$cmd($parent, $lname, @args);
  165.  bless $obj,$package;
  166.  $obj->InitObject(\%args);
  167.  $obj->configure(%args) if (%args);
  168.  $obj->SetBindtags;
  169.  return $obj;
  170. }
  171.  
  172. sub DelegateFor
  173. {
  174.  my ($w,$method) = @_;
  175.  while(exists $w->{Delegates})
  176.   {
  177.    my $delegate = $w->{Delegates};
  178.    my $widget = $delegate->{$method};
  179.    $widget = $delegate->{DEFAULT} unless (defined $widget);
  180.    $widget = $w->Subwidget($widget) if (defined $widget && !ref $widget);
  181.    last unless (defined $widget);
  182.    last if $widget == $w;
  183.    $w = $widget;
  184.   }
  185.  return $w;
  186. }
  187.  
  188. sub Delegates
  189. {
  190.  my $cw = shift;
  191.  if (exists $cw->{'Delegates'})
  192.   {
  193.    my $specs = $cw->{'Delegates'};
  194.    while (@_)
  195.     {
  196.      my $key = shift;
  197.      my $val = shift;
  198.      $specs->{$key} = $val;
  199.     }
  200.   }
  201.  else
  202.   {
  203.    $cw->{'Delegates'} = { @_ };
  204.   }
  205.  return $cw->{'Delegates'}
  206. }
  207.  
  208. sub Construct
  209. {
  210.  my ($base,$name) = @_;
  211.  my $class = (caller(0))[0];
  212.  no strict 'refs';
  213.  
  214.  # DelegateFor  trickyness is to allow Frames and other derived things
  215.  # to force creation in a delegate e.g. a ScrlText with embeded windows
  216.  # need those windows to be children of the Text to get clipping right
  217.  # and not of the Frame which contains the Text and the scrollbars.
  218.  
  219.  *{$base.'::'."$name"}  = sub { $class->new(shift->DelegateFor('Construct'),@_) };
  220.  *{$base.'::Is'.$name}  = \&False;
  221.  *{$class.'::Is'.$name} = \&True;
  222. }
  223.  
  224. sub IS
  225. {
  226.  return (defined $_[1]) && $_[0] == $_[1];
  227. }
  228.  
  229. sub AUTOLOAD
  230. {
  231.  # Take a copy into a 'my' variable so we can recurse
  232.  my $what = $Tk::Widget::AUTOLOAD;
  233.  my $save = $@;
  234.  my $name;
  235.  # Braces used to preserve $1 et al.
  236.  {
  237.   my ($pkg,$func) = $what =~ /(.*)::([^:]+)$/;
  238.   confess("Attempt to load '$what'") unless defined $pkg;
  239.   $pkg =~ s#::#/#g;
  240.   if (defined($name=$INC{"$pkg.pm"}))
  241.    {
  242.     $name =~ s#^(.*)$pkg\.pm$#$1auto/$pkg/$func.al#;
  243.    }
  244.   else
  245.    {
  246.     $name = "auto/$what.al";
  247.     $name =~ s#::#/#g;
  248.    }
  249.  }
  250.  # This may fail, catch error and prevent user's __DIE__ handler
  251.  # from triggering as well...
  252.  eval {local $SIG{'__DIE__'}; require $name};
  253.  if ($@)
  254.   {
  255.    croak $@ unless ($@ =~ /Can't locate \Q$name\E/);
  256.    my($package,$method) = ($what =~ /^(.*)::([^:]*)$/);
  257.    if ($package eq 'Tk::Widget' && $method ne '__ANON__')
  258.     {
  259.      # carp "Assuming 'require Tk::$method;'" if ($^W);
  260.      require "Tk/$method.pm";
  261.     }
  262.    else 
  263.     {
  264.      if (ref $_[0] && $method !~ /^(ConfigSpecs|Delegates)/ )
  265.       {                                    
  266.        my $delegate = $_[0]->Delegates;    
  267.        if (%$delegate || tied %$delegate)                     
  268.         {                                  
  269.          my $widget = $delegate->{$method};
  270.          $widget = $delegate->{DEFAULT} unless (defined $widget);
  271.          if (defined $widget)              
  272.           {                                
  273.            my $subwidget = (ref $widget) ? $widget : $_[0]->Subwidget($widget);
  274.            if (defined $subwidget)         
  275.             {                              
  276.              no strict 'refs';
  277.              # print "AUTOLOAD: $what\n";
  278.              *{$what} = sub { shift->Delegate($method,@_) }; 
  279.             }                              
  280.            else                            
  281.             {                              
  282.              croak "No delegate subwidget '$widget' for $what";
  283.             }                              
  284.           }                                
  285.         }                                  
  286.        if (!defined(&$what) && $method =~ /^[A-Z]\w+$/ && ref($_[0]) && $_[0]->isa('Tk::Widget'))
  287.         {
  288.          $what = "Tk::Widget::$method";
  289.          carp "Assuming 'require Tk::$method;'" if ($^W);
  290.          require "Tk/$method.pm";
  291.         }
  292.       }                                    
  293.     }
  294.   }
  295.  $@ = $save;
  296.  $DB::sub = $what; # Tell debugger what is going on...
  297.  goto &$what;
  298. }
  299.  
  300. *isa = \&True if ($] <= 5.003);
  301.  
  302. *configure_self = \&Tk::configure;
  303. *cget_self = \&Tk::cget;
  304.  
  305. sub _Destroyed
  306. { 
  307.  my $w = shift;
  308.  my $a = delete $w->{'_Destroy_'};
  309.  return unless ref $a;
  310.  while (@$a)
  311.   {
  312.    eval {local $SIG{'__DIE__'}; pop(@$a)->Call };
  313.   }
  314. }
  315.  
  316. sub privateData
  317. {
  318.  my $w = shift;
  319.  my $p = shift || caller;
  320.  $w->{$p} ||= {};
  321. }
  322.  
  323. 1;                     
  324.  
  325. __END__
  326.  
  327. sub grabSave
  328. {
  329.  my ($w) = @_;
  330.  my $grab = $w->grabCurrent;
  331.  return sub {} if (!defined $grab);
  332.  my $method = ($grab->grabStatus eq 'global') ? 'grabGlobal' : 'grab';
  333.  return sub { eval {local $SIG{'__DIE__'};  $grab->$method() } };
  334. }
  335.  
  336. sub focusCurrent
  337. {
  338.  my ($w) = @_;
  339.  $w->Tk::focus('-displayof'); 
  340. }
  341.  
  342. sub focusSave
  343. {
  344.  my ($w) = @_;
  345.  my $focus = $w->focusCurrent;
  346.  return sub {} if (!defined $focus);
  347.  return sub { eval {local $SIG{'__DIE__'};  $focus->focus } };
  348. }
  349.  
  350. sub OnDestroy
  351. {
  352.  my $w = shift;
  353.  $w->{'_Destroy_'} = [] unless (exists $w->{'_Destroy_'});
  354.  push(@{$w->{'_Destroy_'}},Tk::Callback->new(@_));
  355. }
  356.  
  357. # This is supposed to replicate Tk::after behaviour,
  358. # but does auto-cancel when widget is deleted.
  359.  
  360.  
  361. sub after
  362. {
  363.  require Tk::After;
  364.  my $w = shift;
  365.  my $t = shift;
  366.  if (@_)
  367.   {
  368.    return Tk::After->new($w,$t,'once',@_) if ($t ne 'cancel');
  369.    while (@_)
  370.     {
  371.      my $what = shift;
  372.      if (ref $what)
  373.       {
  374.        $what->cancel;
  375.       }
  376.      else
  377.       {
  378.        carp "dubious cancel of $what";
  379.        $w->Tk::after('cancel' => $what);
  380.       }
  381.     }
  382.   }
  383.  else
  384.   {
  385.    $w->Tk::after($t);
  386.   }
  387. }
  388.  
  389. sub repeat
  390. {
  391.  require Tk::After;
  392.  my $w = shift;
  393.  my $t = shift;
  394.  return Tk::After->new($w,$t,'repeat',@_);
  395. }
  396.  
  397. sub Inherit
  398. {
  399.  carp "Inherit is deprecated - use SUPER::";
  400.  my $w = shift;
  401.  my $method = shift;
  402.  my ($class) = caller;
  403.  *{$class.'::Inherit::ISA'} = \@{$class.'::ISA'} unless (defined @{$class.'::Inherit::ISA'});
  404.  $class .= '::Inherit::';
  405.  $class .= $method;
  406.  return $w->$class(@_);
  407. }
  408.  
  409. sub InheritThis
  410. {
  411.  carp "InheritThis is deprecated - use SUPER::";
  412.  my $w      = shift;
  413.  my $what   = (caller(1))[3];
  414.  my ($class,$method) = $what =~ /^(.*)::([^:]+)$/;
  415.  *{$class.'::Inherit::ISA'} = \@{$class.'::ISA'} unless (defined @{$class.'::Inherit::ISA'});
  416.  $class .= '::Inherit::';
  417.  $class .= $method;
  418.  return $w->$class(@_);
  419. }
  420.  
  421. sub FindMenu
  422. {
  423.  # default FindMenu is that there no menu.
  424.  return undef;
  425. }
  426.  
  427. sub XEvent { shift->{"_XEvent_"} }
  428.  
  429. sub propertyRoot
  430. {
  431.  my $w = shift;
  432.  return $w->property(@_,'root');
  433. }
  434.  
  435. # atom, atomname, containing, interps, pathname 
  436. # don't work this way - there is no window arg
  437. # So we pretend there was an call the C versions from Tk.xs
  438.  
  439. sub atom       { shift->InternAtom(@_)  }
  440. sub atomname   { shift->GetAtomName(@_) }
  441. sub containing { shift->Containing(@_)  }
  442.  
  443.  
  444. # interps not done yet
  445. # pathname not done yet
  446.  
  447. # walk and descendants adapted from Stephen's composite
  448. # versions as they only use core features they can go here.
  449. # hierachy is reversed in that descendants calls walk rather
  450. # than vice versa as this avoids building a list.
  451. # Walk should possibly be enhanced so allow early termination
  452. # like '-prune' of find.
  453.  
  454. sub Walk 
  455. {
  456.  # Traverse a widget hierarchy while executing a subroutine.
  457.  my($cw, $proc, @args) = @_;
  458.  my $subwidget;
  459.  foreach $subwidget ($cw->children) 
  460.   {
  461.    $subwidget->Walk($proc,@args);
  462.    &$proc($subwidget, @args);
  463.   }
  464. } # end walk
  465.  
  466. sub Descendants
  467. {
  468.  # Return a list of widgets derived from a parent widget and all its
  469.  # descendants of a particular class.  
  470.  # If class is not passed returns the entire widget hierarchy.
  471.  
  472.  my($widget, $class) = @_;
  473.  my(@widget_tree)    = ();
  474.  
  475.  $widget->Walk(
  476.                sub { my ($widget,$list,$class) = @_;
  477.                      push(@$list, $widget) if  (!defined($class) or $class eq $widget->class);
  478.                    }, 
  479.                \@widget_tree, $class
  480.               );
  481.  return @widget_tree;
  482. } 
  483.  
  484. sub Palette
  485. {
  486.  my $w = shift->MainWindow;
  487.  unless (exists $w->{_Palette_})
  488.   {
  489.    my %Palette = ();
  490.    my $c = $w->Checkbutton();
  491.    my $e = $w->Entry();
  492.    my $s = $w->Scrollbar();
  493.    $Palette{"activeBackground"}    = ($c->configure("-activebackground"))[3] ;
  494.    $Palette{"activeForeground"}    = ($c->configure("-activeforeground"))[3];
  495.    $Palette{"background"}          = ($c->configure("-background"))[3];
  496.    $Palette{"disabledForeground"}  = ($c->configure("-disabledforeground"))[3];
  497.    $Palette{"foreground"}          = ($c->configure("-foreground"))[3];
  498.    $Palette{"highlightBackground"} = ($c->configure("-highlightbackground"))[3];
  499.    $Palette{"highlightColor"}      = ($c->configure("-highlightcolor"))[3];
  500.    $Palette{"insertBackground"}    = ($e->configure("-insertbackground"))[3];
  501.    $Palette{"selectColor"}         = ($c->configure("-selectcolor"))[3];
  502.    $Palette{"selectBackground"}    = ($e->configure("-selectbackground"))[3];
  503.    $Palette{"selectForeground"}    = ($e->configure("-selectforeground"))[3];
  504.    $Palette{"troughColor"}         = ($s->configure("-troughcolor"))[3];
  505.    $c->destroy;
  506.    $e->destroy;
  507.    $s->destroy;
  508.    $w->{_Palette_} = \%Palette;
  509.   }
  510.  return $w->{_Palette_};
  511. }
  512.  
  513.  
  514. # tk_setPalette --
  515. # Changes the default color scheme for a Tk application by setting
  516. # default colors in the option database and by modifying all of the
  517. # color options for existing widgets that have the default value.
  518. #
  519. # Arguments:
  520. # The arguments consist of either a single color name, which
  521. # will be used as the new background color (all other colors will
  522. # be computed from this) or an even number of values consisting of
  523. # option names and values. The name for an option is the one used
  524. # for the option database, such as activeForeground, not -activeforeground.
  525. sub setPalette
  526. {
  527.  my $w = shift->MainWindow;
  528.  my %new = (@_ == 1) ? (background => $_[0]) : @_;
  529.  my $priority = delete($new{'priority'}) || 'widgetDefault';
  530.  my $i;
  531.  
  532.  # Create an array that has the complete new palette. If some colors
  533.  # aren't specified, compute them from other colors that are specified.
  534.  
  535.  die "must specify a background color" if (!exists $new{background});
  536.  $new{"foreground"} = "black" unless (exists $new{foreground});
  537.  my @bg = $w->rgb($new{"background"});
  538.  my @fg = $w->rgb($new{"foreground"});
  539.  my $darkerBg = sprintf("#%02x%02x%02x",9*$bg[0]/2560,9*$bg[1]/2560,9*$bg[2]/2560);
  540.  foreach $i ("activeForeground","insertBackground","selectForeground","highlightColor")
  541.   {
  542.    $new{$i} = $new{"foreground"} unless (exists $new{$i});
  543.   }
  544.  unless (exists $new{"disabledForeground"})
  545.   {
  546.    $new{"disabledForeground"} = sprintf("#%02x%02x%02x",(3*$bg[0]+$fg[0])/1024,(3*$bg[1]+$fg[1])/1024,(3*$bg[2]+$fg[2])/1024);
  547.   }
  548.  $new{"highlightBackground"} = $new{"background"} unless (exists $new{"highlightBackground"});
  549.  
  550.  unless (exists $new{"activeBackground"})
  551.   {
  552.    my @light;
  553.    # Pick a default active background that is lighter than the
  554.    # normal background. To do this, round each color component
  555.    # up by 15% or 1/3 of the way to full white, whichever is
  556.    # greater.
  557.    foreach $i (0, 1, 2)
  558.     {
  559.      $light[$i] = $bg[$i]/256;
  560.      my $inc1 = $light[$i]*15/100;
  561.      my $inc2 = (255-$light[$i])/3;
  562.      if ($inc1 > $inc2)
  563.       {
  564.        $light[$i] += $inc1
  565.       }
  566.      else
  567.       {
  568.        $light[$i] += $inc2
  569.       }
  570.      $light[$i] = 255 if ($light[$i] > 255);
  571.     }
  572.    $new{"activeBackground"} = sprintf("#%02x%02x%02x",@light);
  573.   }
  574.  $new{"selectBackground"} = $darkerBg unless (exists $new{"selectBackground"});
  575.  $new{"troughColor"} = $darkerBg unless (exists $new{"troughColor"});
  576.  $new{"selectColor"} = "#b03060" unless (exists $new{"selectColor"});
  577.  
  578.  # Before doing this, make sure that the Tk::Palette variable holds
  579.  # the default values of all options, so that tkRecolorTree can
  580.  # be sure to only change options that have their default values.
  581.  # If the variable exists, then it is already correct (it was created
  582.  # the last time this procedure was invoked). If the variable
  583.  # doesn't exist, fill it in using the defaults from a few widgets.
  584.  my $Palette = $w->Palette;
  585.  
  586.  # Walk the widget hierarchy, recoloring all existing windows.
  587.  $w->RecolorTree(\%new);
  588.  # Change the option database so that future windows will get the
  589.  # same colors.
  590.  my $option;
  591.  foreach $option (keys %new)
  592.   {
  593.    $w->option("add","*$option",$new{$option},$priority);
  594.    # Save the options in the global variable Tk::Palette, for use the
  595.    # next time we change the options.
  596.    $Palette->{$option} = $new{$option};
  597.   }
  598. }
  599.  
  600. # tkRecolorTree --
  601. # This procedure changes the colors in a window and all of its
  602. # descendants, according to information provided by the colors
  603. # argument. It only modifies colors that have their default values
  604. # as specified by the Tk::Palette variable.
  605. #
  606. # Arguments:
  607. # w - The name of a window. This window and all its
  608. # descendants are recolored.
  609. # colors - The name of an array variable in the caller,
  610. # which contains color information. Each element
  611. # is named after a widget configuration option, and
  612. # each value is the value for that option.
  613. sub RecolorTree
  614. {
  615.  my ($w,$colors) = @_;
  616.  my $dbOption;
  617.  local ($@);
  618.  my $Palette = $w->Palette;
  619.  foreach $dbOption (keys %$colors)
  620.   {
  621.    my $option = "-\L$dbOption";
  622.    my $value;
  623.    eval {local $SIG{'__DIE__'}; $value = $w->cget($option) };
  624.    if (defined $value)
  625.     {
  626.      if ($value eq $Palette->{$dbOption})
  627.       {
  628.        $w->configure($option,$colors->{$dbOption})
  629.       }
  630.     }
  631.   }
  632.  my $child;
  633.  foreach $child ($w->children)
  634.   {
  635.    $child->RecolorTree($colors);
  636.   }
  637. }
  638. # tkDarken --
  639. # Given a color name, computes a new color value that darkens (or
  640. # brightens) the given color by a given percent.
  641. #
  642. # Arguments:
  643. # color - Name of starting color.
  644. # perecent - Integer telling how much to brighten or darken as a
  645. # percent: 50 means darken by 50%, 110 means brighten
  646. # by 10%.
  647. sub Darken
  648. {
  649.  my ($w,$color,$percent) = @_;
  650.  my @l = $w->rgb($color);
  651.  my $red = $l[0]/256;
  652.  my $green = $l[1]/256;
  653.  my $blue = $l[2]/256;
  654.  $red = int($red*$percent/100);
  655.  $red = 255 if ($red > 255);
  656.  $green = int($green*$percent/100);
  657.  $green = 255 if ($green > 255);
  658.  $blue = int($blue*$percent/100);
  659.  $blue = 255 if ($blue > 255);
  660.  sprintf("#%02x%02x%02x",$red,$green,$blue)
  661. }
  662. # tk_bisque --
  663. # Reset the Tk color palette to the old "bisque" colors.
  664. #
  665. # Arguments:
  666. # None.
  667. sub bisque
  668. {
  669.  shift->setPalette("activeBackground" => "#e6ceb1",
  670.                "activeForeground" => "black",
  671.                "background" => "#ffe4c4",
  672.                "disabledForeground" => "#b0b0b0",
  673.                "foreground" => "black",
  674.                "highlightBackground" => "#ffe4c4",
  675.                "highlightColor" => "black",
  676.                "insertBackground" => "black",
  677.                "selectColor" => "#b03060",
  678.                "selectBackground" => "#e6ceb1",
  679.                "selectForeground" => "black",
  680.                "troughColor" => "#cdb79e"
  681.               );
  682. }
  683.  
  684. sub PrintConfig
  685. {
  686.  require Tk::Pretty;
  687.  my ($w) = (@_);
  688.  my $c;
  689.  foreach $c ($w->configure)
  690.   {
  691.    print Tk::Pretty::Pretty(@$c),"\n";
  692.   }
  693. } 
  694.  
  695. sub Busy
  696. {
  697.  my ($w,%args) = @_;
  698.  return unless $w->viewable;
  699.  $args{'-cursor'} = 'watch' unless (exists $args{'-cursor'});
  700.  unless (exists $w->{'Busy'})
  701.   {
  702.    my %old = ();           
  703.    my $key;                
  704.    my @tags = $w->bindtags;
  705.    foreach $key (keys %args)
  706.     {
  707.      $old{$key} = $w->Tk::cget($key);
  708.     }
  709.    $old{'bindtags'} = \@tags;
  710.    $old{'grab'}     = $w->grabSave;
  711.    unless ($w->Tk::bind('Busy'))
  712.     {                     
  713.      $w->Tk::bind('Busy','<KeyPress>','bell');
  714.      $w->Tk::bind('Busy','<ButtonPress>','bell');
  715.     }                     
  716.    $w->bindtags(['Busy']);
  717.    $w->{'Busy'} = \%old;
  718.   }
  719.  $w->Tk::configure(%args);
  720.  eval {local $SIG{'__DIE__'};  $w->grab };
  721.  $w->update;
  722. }
  723.  
  724. sub Unbusy
  725. {
  726.  my ($w) = @_;
  727.  $w->grabRelease;
  728.  my $old = delete $w->{'Busy'};
  729.  if (defined $old)
  730.   {
  731.    my $grab = delete $old->{'grab'};
  732.    $w->update;  # flush events that happened with Busy bindings
  733.    $w->bindtags(delete $old->{'bindtags'});
  734.    $w->Tk::configure(%{$old}); 
  735.    $w->update;
  736.    &$grab;
  737.   }
  738. }
  739.  
  740. sub waitVisibility
  741. {
  742.  my ($w) = shift;
  743.  $w->tkwait('visibility',$w);
  744. }
  745.  
  746. sub waitVariable
  747. {
  748.  my ($w) = shift;
  749.  $w->tkwait('variable',@_);
  750. }
  751.  
  752. sub waitWindow
  753. {
  754.  my ($w) = shift;
  755.  $w->tkwait('window',$w);
  756. }
  757.  
  758. sub EventWidget
  759. {
  760.  my ($w) = @_;
  761.  return $w->{'_EventWidget_'};
  762. }
  763.  
  764. sub Popwidget
  765. {
  766.  my ($ew,$method,$w,@args) = @_;
  767.  $w->{'_EventWidget_'} = $ew;
  768.  $w->$method(@args);
  769. }
  770.  
  771. sub ColorOptions
  772. {
  773.  my ($w,$args) = @_;
  774.  my $opt;
  775.  $args = {} unless (defined $args);
  776.  foreach $opt (qw(-foreground -background -disabledforeground
  777.                   -activebackground -activeforeground
  778.               ))
  779.   {
  780.    $args->{$opt} = $w->cget($opt) unless (exists $arg{$opt})
  781.   }
  782.  return (wantarray) ? %$args : $args;
  783. }
  784.  
  785. sub XscrollBind
  786. {
  787.  my ($mw,$class) = @_;
  788.  $mw->bind($class,'<Left>',         ['xview','scroll',-1,'units']);
  789.  $mw->bind($class,'<Control-Left>', ['xview','scroll',-1,'pages']);
  790.  $mw->bind($class,'<Control-Prior>',['xview','scroll',-1,'pages']);
  791.  $mw->bind($class,'<Right>',        ['xview','scroll',1,'units']);
  792.  $mw->bind($class,'<Control-Right>',['xview','scroll',1,'pages']);
  793.  $mw->bind($class,'<Control-Next>', ['xview','scroll',1,'pages']);
  794.  
  795.  $mw->bind($class,'<Home>',         ['xview','moveto',0]);
  796.  $mw->bind($class,'<End>',          ['xview','moveto',1]);
  797. }
  798.  
  799. sub PriorNextBind
  800. {
  801.  my ($mw,$class) = @_;
  802.  $mw->bind($class,'<Next>',     ['yview','scroll',1,'pages']);
  803.  $mw->bind($class,'<Prior>',    ['yview','scroll',-1,'pages']);
  804. }
  805.  
  806. sub YscrollBind
  807. {
  808.  my ($mw,$class) = @_;
  809.  $mw->PriorNextBind($class);
  810.  $mw->bind($class,'<Up>',       ['yview','scroll',-1,'units']);
  811.  $mw->bind($class,'<Down>',     ['yview','scroll',1,'units']);
  812. }
  813.  
  814. sub XYscrollBind
  815. {
  816.  my ($mw,$class) = @_;
  817.  $mw->YscrollBind($class);
  818.  $mw->XscrollBind($class);
  819. }
  820.  
  821. sub ScrlListbox
  822. {
  823.  my $parent = shift; 
  824.  return $parent->Scrolled('Listbox',-scrollbars => 'w', @_);
  825. }
  826.  
  827. sub AddBindTag
  828. {
  829.  my ($w,$tag) = @_;
  830.  my $t;
  831.  my @tags = $w->bindtags;
  832.  foreach $t (@tags)
  833.   {
  834.    return if $t eq $tag;
  835.   }
  836.  $w->bindtags([@tags,$tag]);
  837. }
  838.  
  839. sub Callback
  840. {
  841.  my $w = shift;
  842.  my $name = shift;
  843.  my $cb = $w->cget($name);
  844.  return $cb->Call(@_) if (defined $cb);
  845.  return (wantarray) ? () : undef;
  846. }
  847.  
  848. sub packAdjust
  849. {
  850.  print 'packAdjust(',join(',',@_),")\n";
  851.  require Tk::Adjuster;
  852.  my ($w,%args) = @_;
  853.  my $delay = delete($args{'-delay'});
  854.  $delay = 1 unless (defined $delay);
  855.  $w->pack(%args);
  856.  %args = $w->packInfo;
  857.  my $adj = Tk::Adjuster->new($args{'-in'},
  858.             -widget => $w, -delay => $delay, -side => $args{'-side'});
  859.  $adj->packed($w,%args);
  860.  return $w;
  861. }
  862.  
  863. sub gridAdjust
  864. {
  865.  require Tk::Adjuster;
  866.  my ($w,%args) = @_;
  867.  my $delay = delete($args{'-delay'});
  868.  $delay = 1 unless (defined $delay);
  869.  $w->grid(%args);
  870.  %args = $w->gridInfo;
  871.  my $adj = Tk::Adjuster->new($args{'-in'},-widget => $w, -delay => $delay);
  872.  $adj->gridded($w,%args);
  873.  return $w;
  874. }
  875.  
  876. sub place
  877. {
  878.  local $SIG{'__DIE__'} = \&Carp::croak;
  879.  my $w = shift;
  880.  if (@_ && $_[0] =~ /^(?:configure|forget|info|slaves)$/x)
  881.   {
  882.    $w->Tk::place(@_);
  883.   }
  884.  else
  885.   {
  886.    # Two things going on here:
  887.    # 1. Add configure on the front so that we can drop leading '-' 
  888.    $w->Tk::place('configure',@_);
  889.    # 2. Return the widget rather than nothing
  890.    return $w;
  891.   }
  892. }
  893.  
  894. sub pack
  895. {
  896.  local $SIG{'__DIE__'} = \&Carp::croak;
  897.  my $w = shift;
  898.  if (@_ && $_[0] =~ /^(?:configure|forget|info|propagate|slaves)$/x)
  899.   {
  900.    $w->Tk::pack(@_);
  901.   }
  902.  else
  903.   {
  904.    # Two things going on here:
  905.    # 1. Add configure on the front so that we can drop leading '-' 
  906.    $w->Tk::pack('configure',@_);
  907.    # 2. Return the widget rather than nothing
  908.    return $w;
  909.   }
  910. }
  911.  
  912. sub grid
  913. {
  914.  local $SIG{'__DIE__'} = \&Carp::croak;
  915.  my $w = shift;
  916.  if (@_ && $_[0] =~ /^(?:bbox|columnconfigure|configure|forget|info|location|propagate|rowconfigure|size|slaves)$/x)
  917.   {
  918.    my $opt = shift;
  919.    Tk::grid($opt,$w,@_);
  920.   }
  921.  else
  922.   {
  923.    # Two things going on here:
  924.    # 1. Add configure on the front so that we can drop leading '-' 
  925.    Tk::grid('configure',$w,@_);
  926.    # 2. Return the widget rather than nothing
  927.    return $w;
  928.   }
  929. }
  930.  
  931. sub form
  932. {
  933.  local $SIG{'__DIE__'} = \&Carp::croak;
  934.  my $w = shift;
  935.  if (@_ && $_[0] =~ /^(?:configure|check|forget|grid|info|slaves)$/x)
  936.   {
  937.    $w->Tk::form(@_);
  938.   }
  939.  else
  940.   {
  941.    # Two things going on here:
  942.    # 1. Add configure on the front so that we can drop leading '-' 
  943.    $w->Tk::form('configure',@_);
  944.    # 2. Return the widget rather than nothing
  945.    return $w;
  946.   }
  947. }
  948.  
  949. sub Scrolled
  950. {
  951.  my ($parent,$kind,%args) = @_;
  952.  my @args = Tk::Frame->CreateArgs($parent,\%args);
  953.  my $name = delete $args{'Name'};
  954.  push(@args,'Name' => $name) if (defined $name);
  955.  my $cw = $parent->Frame(@args);
  956.  @args = ();
  957.  my $k;
  958.  # Need to consider other 'Frame' configure options...
  959.  foreach $k ('-scrollbars',map($_->[0],$cw->configure))
  960.   {
  961.    push(@args,$k,delete($args{$k})) if (exists $args{$k})
  962.   }
  963.  $cw->ConfigSpecs('-scrollbars' => ['METHOD','scrollbars','Scrollbars','se'],
  964.                   '-background' => ['CHILDREN','background','Background',undef], 
  965.                  );
  966.  my $w  = $cw->$kind(%args);
  967.  %args = @args;
  968.  $cw->AddScrollbars($w);
  969.  $cw->Default("\L$kind" => $w);
  970.  $cw->ConfigDefault(\%args);
  971.  $cw->configure(%args);
  972.  return $cw;
  973. }
  974.  
  975. sub Populate
  976. {
  977.  my ($cw,$args) = @_;
  978. }
  979.  
  980. sub ForwardEvent
  981. {
  982.  my $self = shift;
  983.  my $to   = shift;
  984.  $to->PassEvent($self->XEvent);
  985. }
  986.  
  987.  
  988.  
  989.  
  990.