home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2004 July / APC0407D2.iso / workshop / apache / files / ActivePerl-5.6.1.638-MSWin32-x86.msi / _02e3f7684e64478e9a0052109c3ca785 < prev    next >
Encoding:
Text File  |  2004-04-13  |  31.5 KB  |  1,299 lines
  1. # Copyright (c) 1995-1999 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. use vars qw($VERSION @DefaultMenuLabels);
  6. $VERSION = '3.080'; # $Id: //depot/Tk8/Tk/Widget.pm#80 $
  7.  
  8. require Tk;
  9. use AutoLoader;
  10. use strict;
  11. use Carp;
  12. use base qw(DynaLoader Tk);
  13.  
  14. # stubs for 'autoloaded' widget classes
  15.  
  16. sub Button;
  17. sub Canvas;
  18. sub Checkbutton;
  19. sub Entry;
  20. sub Frame;
  21. sub Label;
  22. sub Listbox;
  23. sub Menu;
  24. sub Menubutton;
  25. sub Message;
  26. sub Scale;
  27. sub Scrollbar;
  28. sub Radiobutton;
  29. sub Text;
  30. sub Toplevel;
  31.  
  32. sub Pixmap;
  33. sub Bitmap;
  34. sub Photo;
  35.  
  36. sub ScrlListbox;
  37. sub Optionmenu;
  38.  
  39. sub import
  40. {
  41.  my $package = shift;
  42.  carp 'use Tk::Widget () to pre-load widgets is deprecated' if (@_);
  43.  my $need;
  44.  foreach $need (@_)
  45.   {
  46.    unless (defined &{$need})
  47.     {
  48.      require "Tk/${need}.pm";
  49.     }
  50.    croak "Cannot locate $need" unless (defined &{$need});
  51.   }
  52. }
  53.  
  54. @DefaultMenuLabels = qw[~File ~Help];
  55.  
  56. # Some tidy-ness functions for winfo stuff
  57.  
  58. sub True  { 1 }
  59. sub False { 0 }
  60.  
  61. use Tk::Submethods( 'grab' =>  [qw(current status release -global)],
  62.                     'focus' => [qw(-force -lastfor)],
  63.                     'pack'  => [qw(configure forget info propagate slaves)],
  64.                     'grid'  => [qw(bbox columnconfigure configure forget info location propagate rowconfigure size slaves)],
  65.                     'form'  => [qw(check configure forget grid info slaves)],
  66.                     'event' => [qw(add delete generate info)],
  67.                     'place' => [qw(configure forget info slaves)],
  68.                     'wm'    => [qw(capture release)],
  69.                     'font'  => [qw(actual configure create delete families measure metrics names)]
  70.                   );
  71.  
  72. BEGIN  {
  73.  # FIXME - these don't work in the compiler
  74.  *IsMenu         = \&False;
  75.  *IsMenubutton   = \&False;
  76.  *configure_self = \&Tk::configure;
  77.  *cget_self      = \&Tk::cget;
  78. }
  79.  
  80.  
  81.  
  82. Direct Tk::Submethods (
  83.   'winfo' => [qw(cells class colormapfull depth exists
  84.                geometry height id ismapped manager name parent reqheight
  85.                reqwidth rootx rooty screen screencells screendepth screenheight
  86.                screenmmheight screenmmwidth  screenvisual screenwidth visual
  87.                visualsavailable  vrootheight viewable vrootwidth vrootx vrooty
  88.                width x y toplevel children pixels pointerx pointery pointerxy
  89.                server fpixels rgb )],
  90.    'tk'   => [qw(appname scaling)]);
  91.  
  92.  
  93. sub DESTROY
  94. {
  95.  my $w = shift;
  96.  $w->destroy if ($w->IsWidget);
  97. }
  98.  
  99. sub Install
  100. {
  101.  # Dynamically loaded widgets add their core commands
  102.  # to the Tk base class here
  103.  my ($package,$mw) = @_;
  104. }
  105.  
  106. sub ClassInit
  107. {
  108.  # Carry out class bindings (or whatever)
  109.  my ($package,$mw) = @_;
  110.  return $package;
  111. }
  112.  
  113. sub CreateOptions
  114. {
  115.  return ();
  116. }
  117.  
  118. sub CreateArgs
  119. {
  120.  my ($package,$parent,$args) = @_;
  121.  # Remove from hash %$args any configure-like
  122.  # options which only apply at create time (e.g. -colormap for Frame),
  123.  # or which may as well be applied right away
  124.  # return these as a list of -key => value pairs
  125.  # Augment same hash with default values for missing mandatory options,
  126.  # allthough this can be done later in InitObject.
  127.  
  128.  # Honour -class => if present, we have hacked Tk_ConfigureWidget to
  129.  # allow -class to be passed to any widget.
  130.  my @result = ();
  131.  my $class = delete $args->{'-class'};
  132.  ($class) = $package =~ /([A-Z][A-Z0-9_]*)$/i unless (defined $class);
  133.  push(@result, '-class' => "\u$class") if (defined $class);
  134.  foreach my $opt ($package->CreateOptions)
  135.   {
  136.    push(@result, $opt => delete $args->{$opt}) if exists $args->{$opt};
  137.   }
  138.  return @result;
  139. }
  140.  
  141. sub InitObject
  142. {
  143.  my ($obj,$args) = @_;
  144.  # per object initialization, for example populating
  145.  # with sub-widgets, adding a few object bindings to augment
  146.  # inherited class bindings, changing binding tags.
  147.  # Also another chance to mess with %$args before configure...
  148. }
  149.  
  150. sub SetBindtags
  151. {
  152.  my ($obj) = @_;
  153.  $obj->bindtags([ref($obj),$obj,$obj->toplevel,'all']);
  154. }
  155.  
  156. sub new
  157. {
  158.  local $SIG{'__DIE__'} = \&Carp::croak;
  159.  my $package = shift;
  160.  my $parent  = shift;
  161.  $package->InitClass($parent);
  162.  $parent->BackTrace("Odd number of args to $package->new(...)") unless ((@_ % 2) == 0);
  163.  my %args  = @_;
  164.  my @args  = $package->CreateArgs($parent,\%args);
  165.  my $cmd   = $package->Tk_cmd;
  166.  my $pname = $parent->PathName;
  167.  $pname    = '' if ($pname eq '.');
  168.  my $leaf  = delete $args{'Name'};
  169.  if (defined $leaf)
  170.   {
  171.    $leaf =~ s/[^a-z0-9_]+/_/ig;
  172.    $leaf = lcfirst($leaf);
  173.   }
  174.  else
  175.   {
  176.    ($leaf) = "\L$package" =~ /([a-z][a-z0-9_]*)$/;
  177.   }
  178.  my $lname  = $pname . '.' . $leaf;
  179.  # create a hash indexed by leaf name to speed up
  180.  # creation of a lot of sub-widgets of the same type
  181.  # e.g. entries in Table
  182.  my $nhash = $parent->TkHash('_names_');
  183.  $nhash->{$leaf} = 0 unless (exists $nhash->{$leaf});
  184.  while (defined ($parent->Widget($lname)))
  185.   {
  186.    $lname = $pname . '.' . $leaf . ++$nhash->{$leaf};
  187.   }
  188.  my $obj = eval { &$cmd($parent, $lname, @args) };
  189.  confess $@ if $@;
  190.  bless $obj,$package;
  191.  $obj->SetBindtags;
  192.  my $notice = $parent->can('NoticeChild');
  193.  $parent->$notice($obj,\%args) if $notice;
  194.  $obj->InitObject(\%args);
  195. # ASkludge(\%args,1);
  196.  $obj->configure(%args) if (%args);
  197. # ASkludge(\%args,0);
  198.  return $obj;
  199. }
  200.  
  201. sub DelegateFor
  202. {
  203.  my ($w,$method) = @_;
  204.  while(exists $w->{'Delegates'})
  205.   {
  206.    my $delegate = $w->{'Delegates'};
  207.    my $widget = $delegate->{$method};
  208.    $widget = $delegate->{DEFAULT} unless (defined $widget);
  209.    $widget = $w->Subwidget($widget) if (defined $widget && !ref $widget);
  210.    last unless (defined $widget);
  211.    last if $widget == $w;
  212.    $w = $widget;
  213.   }
  214.  return $w;
  215. }
  216.  
  217. sub Delegates
  218. {
  219.  my $cw = shift;
  220.  my $specs = $cw->TkHash('Delegates');
  221.  while (@_)
  222.   {
  223.    my $key = shift;
  224.    my $val = shift;
  225.    $specs->{$key} = $val;
  226.   }
  227.  return $specs;
  228. }
  229.  
  230. sub Construct
  231. {
  232.  my ($base,$name) = @_;
  233.  my $class = (caller(0))[0];
  234.  no strict 'refs';
  235.  
  236.  # Hack for broken ->isa in perl5.6.0
  237.  delete ${"$class\::"}{'::ISA::CACHE::'} if $] == 5.006;
  238.  
  239.  # Pre ->isa scheme
  240.  *{$base.'::Is'.$name}  = \&False;
  241.  *{$class.'::Is'.$name} = \&True;
  242.  
  243.  # DelegateFor  trickyness is to allow Frames and other derived things
  244.  # to force creation in a delegate e.g. a ScrlText with embeded windows
  245.  # need those windows to be children of the Text to get clipping right
  246.  # and not of the Frame which contains the Text and the scrollbars.
  247.  *{$base.'::'."$name"}  = sub { $class->new(shift->DelegateFor('Construct'),@_) };
  248. }
  249.  
  250. sub IS
  251. {
  252.  return (defined $_[1]) && $_[0] == $_[1];
  253. }
  254.  
  255. sub _AutoloadTkWidget
  256. {
  257.  my ($self,$method) = @_;
  258.  my $what = "Tk::Widget::$method";
  259.  unless (defined &$what)
  260.   {
  261.    require "Tk/$method.pm";
  262.   }
  263.  return $what;
  264. }
  265.  
  266. require UNIVERSAL;
  267.  
  268. sub AUTOLOAD
  269. {
  270.  # Take a copy into a 'my' variable so we can recurse
  271.  my $what = $Tk::Widget::AUTOLOAD;
  272.  my $save = $@;
  273.  my $name;
  274.  # warn "AUTOLOAD $what ".(ref($_[0]) || $_[0])."\n";
  275.  # Braces used to preserve $1 et al.
  276.  {
  277.   my ($pkg,$func) = $what =~ /(.*)::([^:]+)$/;
  278.   confess("Attempt to load '$what'") unless defined($pkg) && $func =~ /^[\w:]+$/;
  279.   $pkg =~ s#::#/#g;
  280.   if (defined($name=$INC{"$pkg.pm"}))
  281.    {
  282.     $name =~ s#^(.*)$pkg\.pm$#$1auto/$pkg/$func.al#;
  283.    }
  284.   else
  285.    {
  286.     $name = "auto/$what.al";
  287.     $name =~ s#::#/#g;
  288.    }
  289.  }
  290.  # This may fail, catch error and prevent user's __DIE__ handler
  291.  # from triggering as well...
  292.  eval {local $SIG{'__DIE__'}; require $name};
  293.  if ($@)
  294.   {
  295.    croak $@ unless ($@ =~ /Can't locate\s+(?:file\s+)?'?\Q$name\E'?/);
  296.    my($package,$method) = ($what =~ /^(.*)::([^:]*)$/);
  297.    if (ref $_[0] && !$_[0]->can($method)
  298.        && $_[0]->can('Delegate')
  299.        && $method !~ /^(ConfigSpecs|Delegates)/ )
  300.     {
  301.      my $delegate = $_[0]->Delegates;
  302.      if (%$delegate || tied %$delegate)
  303.       {
  304.        my $widget = $delegate->{$method};
  305.        $widget = $delegate->{DEFAULT} unless (defined $widget);
  306.        if (defined $widget)
  307.         {
  308.          my $subwidget = (ref $widget) ? $widget : $_[0]->Subwidget($widget);
  309.          if (defined $subwidget)
  310.           {
  311.            no strict 'refs';
  312.            # print "AUTOLOAD: $what\n";
  313.            *{$what} = sub { shift->Delegate($method,@_) };
  314.           }
  315.          else
  316.           {
  317.            croak "No delegate subwidget '$widget' for $what";
  318.           }
  319.         }
  320.       }
  321.     }
  322.    if (!defined(&$what) && $method =~ /^[A-Z]\w+$/)
  323.     {
  324.      # Use ->can as ->isa is broken in perl5.6.0
  325.      my $sub = UNIVERSAL::can($_[0],'_AutoloadTkWidget');
  326.      if ($sub)
  327.       {
  328.        carp "Assuming 'require Tk::$method;'" unless $_[0]->can($method);
  329.        $what = $_[0]->$sub($method)
  330.       }
  331.     }
  332.   }
  333.  $@ = $save;
  334.  $DB::sub = $what; # Tell debugger what is going on...
  335.  unless (defined &$what)
  336.   {
  337.    no strict 'refs';
  338.    *{$what} = sub { croak("Failed to AUTOLOAD '$what'") };
  339.   }
  340.  goto &$what;
  341. }
  342.  
  343. sub _Destroyed
  344. {
  345.  my $w = shift;
  346.  my $a = delete $w->{'_Destroy_'};
  347.  if (ref($a))
  348.   {
  349.    while (@$a)
  350.     {
  351.      my $ent = pop(@$a);
  352.      if (ref $ent)
  353.       {
  354.        eval {local $SIG{'__DIE__'}; $ent->Call };
  355.       }
  356.      else
  357.       {
  358.        delete $w->{$ent};
  359.       }
  360.     }
  361.   }
  362. }
  363.  
  364. sub _OnDestroy
  365. {
  366.  my $w = shift;
  367.  $w->{'_Destroy_'} = [] unless (exists $w->{'_Destroy_'});
  368.  push(@{$w->{'_Destroy_'}},@_);
  369. }
  370.  
  371. sub OnDestroy
  372. {
  373.  my $w = shift;
  374.  $w->_OnDestroy(Tk::Callback->new(@_));
  375. }
  376.  
  377. sub TkHash
  378. {
  379.  my ($w,$key) = @_;
  380.  return $w->{$key} if exists $w->{$key};
  381.  my $hash = $w->{$key} = {};
  382.  $w->_OnDestroy($key);
  383.  return $hash;
  384. }
  385.  
  386. sub privateData
  387. {
  388.  my $w = shift;
  389.  my $p = shift || caller;
  390.  $w->{$p} ||= {};
  391. }
  392.  
  393. my @image_types;
  394. my %image_method;
  395.  
  396. sub ImageMethod
  397. {
  398.  shift if (@_ & 1);
  399.  while (@_)
  400.   {
  401.    my ($name,$method) = splice(@_,0,2);
  402.    push(@image_types,$name);
  403.    $image_method{$name} = $method;
  404.   }
  405. }
  406.  
  407. sub Getimage
  408. {
  409.  my ($w, $name) = @_;
  410.  my $mw = $w->MainWindow;
  411.  croak "Usage \$widget->Getimage('name')" unless defined($name);
  412.  my $images = ($mw->{'__Images__'} ||= {});
  413.  
  414.  return $images->{$name} if $images->{$name};
  415.  
  416.  ImageMethod(xpm => 'Pixmap',
  417.     gif => 'Photo',
  418.     ppm => 'Photo',
  419.     xbm => 'Bitmap' ) unless @image_types;
  420.  
  421.  foreach my $type (@image_types)
  422.   {
  423.    my $method = $image_method{$type};
  424.    my $file = Tk->findINC( "$name.$type" );
  425.    next unless( $file && $method );
  426.    my $sub = $w->can($method);
  427.    unless (defined &$sub)
  428.     {
  429.      require Tk::widgets;
  430.      Tk::widgets->import($method);
  431.     }
  432.    $images->{$name} = $w->$method( -file => $file );
  433.    return $images->{$name};
  434.   }
  435.  
  436.  # Try built-in bitmaps
  437.  $images->{$name} = $w->Pixmap( -id => $name );
  438.  return $images->{$name};
  439. }
  440.  
  441. sub SaveGrabInfo
  442. {
  443.  my $w = shift;
  444.  $Tk::oldGrab = $w->grabCurrent;
  445.  if (defined $Tk::oldGrab)
  446.   {
  447.    $Tk::grabStatus = $Tk::oldGrab->grabStatus;
  448.   }
  449. }
  450.  
  451. sub grabSave
  452. {
  453.  my ($w) = @_;
  454.  my $grab = $w->grabCurrent;
  455.  return sub {} if (!defined $grab);
  456.  my $method = ($grab->grabStatus eq 'global') ? 'grabGlobal' : 'grab';
  457.  return sub { eval {local $SIG{'__DIE__'};  $grab->$method() } };
  458. }
  459.  
  460. sub focusCurrent
  461. {
  462.  my ($w) = @_;
  463.  $w->Tk::focus('-displayof');
  464. }
  465.  
  466. sub focusSave
  467. {
  468.  my ($w) = @_;
  469.  my $focus = $w->focusCurrent;
  470.  return sub {} if (!defined $focus);
  471.  return sub { eval {local $SIG{'__DIE__'};  $focus->focus } };
  472. }
  473.  
  474. # This is supposed to replicate Tk::after behaviour,
  475. # but does auto-cancel when widget is deleted.
  476. require Tk::After;
  477.  
  478. sub afterIdle
  479. {
  480.  my $w = shift;
  481.  return Tk::After->new($w,'idle','once',@_);
  482. }
  483.  
  484. sub afterCancel
  485. {
  486.  my ($w,$what) = @_;
  487.  if (defined $what)
  488.   {
  489.    return $what->cancel if ref($what);
  490.    carp "dubious cancel of $what" if 0 && $^W;
  491.    $w->Tk::after('cancel' => $what);
  492.   }
  493. }
  494.  
  495. sub after
  496. {
  497.  my $w = shift;
  498.  my $t = shift;
  499.  if (@_)
  500.   {
  501.    if ($t ne 'cancel')
  502.     {
  503.      require Tk::After;
  504.      return Tk::After->new($w,$t,'once',@_)
  505.     }
  506.    while (@_)
  507.     {
  508.      my $what = shift;
  509.      $w->afterCancel($what);
  510.     }
  511.   }
  512.  else
  513.   {
  514.    $w->Tk::after($t);
  515.   }
  516. }
  517.  
  518. sub repeat
  519. {
  520.  require Tk::After;
  521.  my $w = shift;
  522.  my $t = shift;
  523.  return Tk::After->new($w,$t,'repeat',@_);
  524. }
  525.  
  526. sub FindMenu
  527. {
  528.  # default FindMenu is that there is no menu.
  529.  return undef;
  530. }
  531.  
  532. sub XEvent { shift->{'_XEvent_'} }
  533.  
  534. sub propertyRoot
  535. {
  536.  my $w = shift;
  537.  return $w->property(@_,'root');
  538. }
  539.  
  540. # atom, atomname, containing, interps, pathname
  541. # don't work this way - there is no window arg
  542. # So we pretend there was an call the C versions from Tk.xs
  543.  
  544. sub atom       { shift->InternAtom(@_)  }
  545. sub atomname   { shift->GetAtomName(@_) }
  546. sub containing { shift->Containing(@_)  }
  547.  
  548. # interps not done yet
  549. # pathname not done yet
  550.  
  551. # walk and descendants adapted from Stephen's composite
  552. # versions as they only use core features they can go here.
  553. # hierachy is reversed in that descendants calls walk rather
  554. # than vice versa as this avoids building a list.
  555. # Walk should possibly be enhanced so allow early termination
  556. # like '-prune' of find.
  557.  
  558. sub Walk
  559. {
  560.  # Traverse a widget hierarchy while executing a subroutine.
  561.  my($cw, $proc, @args) = @_;
  562.  my $subwidget;
  563.  foreach $subwidget ($cw->children)
  564.   {
  565.    $subwidget->Walk($proc,@args);
  566.    &$proc($subwidget, @args);
  567.   }
  568. } # end walk
  569.  
  570. sub Descendants
  571. {
  572.  # Return a list of widgets derived from a parent widget and all its
  573.  # descendants of a particular class.
  574.  # If class is not passed returns the entire widget hierarchy.
  575.  
  576.  my($widget, $class) = @_;
  577.  my(@widget_tree)    = ();
  578.  
  579.  $widget->Walk(
  580.                sub { my ($widget,$list,$class) = @_;
  581.                      push(@$list, $widget) if  (!defined($class) or $class eq $widget->class);
  582.                    },
  583.                \@widget_tree, $class
  584.               );
  585.  return @widget_tree;
  586. }
  587.  
  588. sub Palette
  589. {
  590.  my $w = shift->MainWindow;
  591.  unless (exists $w->{_Palette_})
  592.   {
  593.    my %Palette = ();
  594.    my $c = $w->Checkbutton();
  595.    my $e = $w->Entry();
  596.    my $s = $w->Scrollbar();
  597.    $Palette{'activeBackground'}    = ($c->configure('-activebackground'))[3] ;
  598.    $Palette{'activeForeground'}    = ($c->configure('-activeforeground'))[3];
  599.    $Palette{'background'}          = ($c->configure('-background'))[3];
  600.    $Palette{'disabledForeground'}  = ($c->configure('-disabledforeground'))[3];
  601.    $Palette{'foreground'}          = ($c->configure('-foreground'))[3];
  602.    $Palette{'highlightBackground'} = ($c->configure('-highlightbackground'))[3];
  603.    $Palette{'highlightColor'}      = ($c->configure('-highlightcolor'))[3];
  604.    $Palette{'insertBackground'}    = ($e->configure('-insertbackground'))[3];
  605.    $Palette{'selectColor'}         = ($c->configure('-selectcolor'))[3];
  606.    $Palette{'selectBackground'}    = ($e->configure('-selectbackground'))[3];
  607.    $Palette{'selectForeground'}    = ($e->configure('-selectforeground'))[3];
  608.    $Palette{'troughColor'}         = ($s->configure('-troughcolor'))[3];
  609.    $c->destroy;
  610.    $e->destroy;
  611.    $s->destroy;
  612.    $w->{_Palette_} = \%Palette;
  613.   }
  614.  return $w->{_Palette_};
  615. }
  616.  
  617. # tk_setPalette --
  618. # Changes the default color scheme for a Tk application by setting
  619. # default colors in the option database and by modifying all of the
  620. # color options for existing widgets that have the default value.
  621. #
  622. # Arguments:
  623. # The arguments consist of either a single color name, which
  624. # will be used as the new background color (all other colors will
  625. # be computed from this) or an even number of values consisting of
  626. # option names and values. The name for an option is the one used
  627. # for the option database, such as activeForeground, not -activeforeground.
  628. sub setPalette
  629. {
  630.  my $w = shift->MainWindow;
  631.  my %new = (@_ == 1) ? (background => $_[0]) : @_;
  632.  my $priority = delete($new{'priority'}) || 'widgetDefault';
  633.  
  634.  # Create an array that has the complete new palette. If some colors
  635.  # aren't specified, compute them from other colors that are specified.
  636.  
  637.  die 'must specify a background color' if (!exists $new{background});
  638.  $new{'foreground'} = 'black' unless (exists $new{foreground});
  639.  my @bg = $w->rgb($new{'background'});
  640.  my @fg = $w->rgb($new{'foreground'});
  641.  my $darkerBg = sprintf('#%02x%02x%02x',9*$bg[0]/2560,9*$bg[1]/2560,9*$bg[2]/2560);
  642.  foreach my $i ('activeForeground','insertBackground','selectForeground','highlightColor')
  643.   {
  644.    $new{$i} = $new{'foreground'} unless (exists $new{$i});
  645.   }
  646.  unless (exists $new{'disabledForeground'})
  647.   {
  648.    $new{'disabledForeground'} = sprintf('#%02x%02x%02x',(3*$bg[0]+$fg[0])/1024,(3*$bg[1]+$fg[1])/1024,(3*$bg[2]+$fg[2])/1024);
  649.   }
  650.  $new{'highlightBackground'} = $new{'background'} unless (exists $new{'highlightBackground'});
  651.  
  652.  unless (exists $new{'activeBackground'})
  653.   {
  654.    my @light;
  655.    # Pick a default active background that is lighter than the
  656.    # normal background. To do this, round each color component
  657.    # up by 15% or 1/3 of the way to full white, whichever is
  658.    # greater.
  659.    foreach my $i (0, 1, 2)
  660.     {
  661.      $light[$i] = $bg[$i]/256;
  662.      my $inc1 = $light[$i]*15/100;
  663.      my $inc2 = (255-$light[$i])/3;
  664.      if ($inc1 > $inc2)
  665.       {
  666.        $light[$i] += $inc1
  667.       }
  668.      else
  669.       {
  670.        $light[$i] += $inc2
  671.       }
  672.      $light[$i] = 255 if ($light[$i] > 255);
  673.     }
  674.    $new{'activeBackground'} = sprintf('#%02x%02x%02x',@light);
  675.   }
  676.  $new{'selectBackground'} = $darkerBg unless (exists $new{'selectBackground'});
  677.  $new{'troughColor'} = $darkerBg unless (exists $new{'troughColor'});
  678.  $new{'selectColor'} = '#b03060' unless (exists $new{'selectColor'});
  679.  
  680.  # Before doing this, make sure that the Tk::Palette variable holds
  681.  # the default values of all options, so that tkRecolorTree can
  682.  # be sure to only change options that have their default values.
  683.  # If the variable exists, then it is already correct (it was created
  684.  # the last time this procedure was invoked). If the variable
  685.  # doesn't exist, fill it in using the defaults from a few widgets.
  686.  my $Palette = $w->Palette;
  687.  
  688.  # Walk the widget hierarchy, recoloring all existing windows.
  689.  $w->RecolorTree(\%new);
  690.  # Change the option database so that future windows will get the
  691.  # same colors.
  692.  foreach my $option (keys %new)
  693.   {
  694.    $w->option('add',"*$option",$new{$option},$priority);
  695.    # Save the options in the global variable Tk::Palette, for use the
  696.    # next time we change the options.
  697.    $Palette->{$option} = $new{$option};
  698.   }
  699. }
  700.  
  701. # tkRecolorTree --
  702. # This procedure changes the colors in a window and all of its
  703. # descendants, according to information provided by the colors
  704. # argument. It only modifies colors that have their default values
  705. # as specified by the Tk::Palette variable.
  706. #
  707. # Arguments:
  708. # w - The name of a window. This window and all its
  709. # descendants are recolored.
  710. # colors - The name of an array variable in the caller,
  711. # which contains color information. Each element
  712. # is named after a widget configuration option, and
  713. # each value is the value for that option.
  714. sub RecolorTree
  715. {
  716.  my ($w,$colors) = @_;
  717.  local ($@);
  718.  my $Palette = $w->Palette;
  719.  foreach my $dbOption (keys %$colors)
  720.   {
  721.    my $option = "-\L$dbOption";
  722.    my $value;
  723.    eval {local $SIG{'__DIE__'}; $value = $w->cget($option) };
  724.    if (defined $value)
  725.     {
  726.      if ($value eq $Palette->{$dbOption})
  727.       {
  728.        $w->configure($option,$colors->{$dbOption});
  729.       }
  730.     }
  731.   }
  732.  foreach my $child ($w->children)
  733.   {
  734.    $child->RecolorTree($colors);
  735.   }
  736. }
  737. # tkDarken --
  738. # Given a color name, computes a new color value that darkens (or
  739. # brightens) the given color by a given percent.
  740. #
  741. # Arguments:
  742. # color - Name of starting color.
  743. # perecent - Integer telling how much to brighten or darken as a
  744. # percent: 50 means darken by 50%, 110 means brighten
  745. # by 10%.
  746. sub Darken
  747. {
  748.  my ($w,$color,$percent) = @_;
  749.  my @l = $w->rgb($color);
  750.  my $red = $l[0]/256;
  751.  my $green = $l[1]/256;
  752.  my $blue = $l[2]/256;
  753.  $red = int($red*$percent/100);
  754.  $red = 255 if ($red > 255);
  755.  $green = int($green*$percent/100);
  756.  $green = 255 if ($green > 255);
  757.  $blue = int($blue*$percent/100);
  758.  $blue = 255 if ($blue > 255);
  759.  sprintf('#%02x%02x%02x',$red,$green,$blue)
  760. }
  761. # tk_bisque --
  762. # Reset the Tk color palette to the old "bisque" colors.
  763. #
  764. # Arguments:
  765. # None.
  766. sub bisque
  767. {
  768.  shift->setPalette('activeBackground' => '#e6ceb1',
  769.                'activeForeground' => 'black',
  770.                'background' => '#ffe4c4',
  771.                'disabledForeground' => '#b0b0b0',
  772.                'foreground' => 'black',
  773.                'highlightBackground' => '#ffe4c4',
  774.                'highlightColor' => 'black',
  775.                'insertBackground' => 'black',
  776.                'selectColor' => '#b03060',
  777.                'selectBackground' => '#e6ceb1',
  778.                'selectForeground' => 'black',
  779.                'troughColor' => '#cdb79e'
  780.               );
  781. }
  782.  
  783. sub PrintConfig
  784. {
  785.  require Tk::Pretty;
  786.  my ($w) = (@_);
  787.  my $c;
  788.  foreach $c ($w->configure)
  789.   {
  790.    print Tk::Pretty::Pretty(@$c),"\n";
  791.   }
  792. }
  793.  
  794. sub BusyRecurse
  795. {
  796.  my ($restore,$w,$cursor,$recurse,$top) = @_;
  797.  my $c = $w->cget('-cursor');
  798.  my @tags = $w->bindtags;
  799.  if ($top || defined($c))
  800.   {
  801.    push(@$restore, sub { return unless Tk::Exists($w); $w->configure(-cursor => $c); $w->bindtags(\@tags) });
  802.    $w->configure(-cursor => $cursor);
  803.   }
  804.  else
  805.   {
  806.    push(@$restore, sub { return unless Tk::Exists($w); $w->bindtags(\@tags) });
  807.   }
  808.  $w->bindtags(['Busy',@tags]);
  809.  if ($recurse)
  810.   {
  811.    foreach my $child ($w->children)
  812.     {
  813.      BusyRecurse($restore,$child,$cursor,1,0);
  814.     }
  815.   }
  816.  return $restore;
  817. }
  818.  
  819. sub Busy
  820. {
  821.  my ($w,%args) = @_;
  822.  return unless $w->viewable;
  823.  my $cursor  = delete $args{'-cursor'};
  824.  my $recurse = delete $args{'-recurse'};
  825.  $cursor  = 'watch' unless defined $cursor;
  826.  unless (exists $w->{'Busy'})
  827.   {
  828.    my @old = ($w->grabSave);
  829.    my $key;
  830.    my @config;
  831.    foreach $key (keys %args)
  832.     {
  833.      push(@config,$key => $w->Tk::cget($key));
  834.     }
  835.    if (@config)
  836.     {
  837.      push(@old, sub { $w->Tk::configure(@config) });
  838.      $w->Tk::configure(%args);
  839.     }
  840.    unless ($w->Tk::bind('Busy'))
  841.     {
  842.      $w->Tk::bind('Busy','<Any-KeyPress>',[_busy => 1]);
  843.      $w->Tk::bind('Busy','<Any-KeyRelease>',[_busy => 0]);
  844.      $w->Tk::bind('Busy','<Any-ButtonPress>',[_busy => 1]);
  845.      $w->Tk::bind('Busy','<Any-ButtonRelease>',[_busy => 0]);
  846.      $w->Tk::bind('Busy','<Any-Motion>',[_busy => 0]);
  847.     }
  848.    $w->{'Busy'} = BusyRecurse(\@old,$w,$cursor,$recurse,1);
  849.   }
  850.  my $g = $w->grabCurrent;
  851.  if (defined $g)
  852.   {
  853.    # warn "$g has the grab";
  854.    $g->grabRelease;
  855.   }
  856.  $w->update;
  857.  eval {local $SIG{'__DIE__'};  $w->grab };
  858.  $w->update;
  859. }
  860.  
  861. sub _busy
  862. {
  863.  my ($w,$f) = @_;
  864.  $w->bell if $f;
  865.  $w->break;
  866. }
  867.  
  868. sub Unbusy
  869. {
  870.  my ($w) = @_;
  871.  $w->update;
  872.  $w->grabRelease;
  873.  my $old = delete $w->{'Busy'};
  874.  if (defined $old)
  875.   {
  876.    local $SIG{'__DIE__'};
  877.    eval { &{pop(@$old)} } while (@$old);
  878.   }
  879.  $w->update;
  880. }
  881.  
  882. sub waitVisibility
  883. {
  884.  my ($w) = shift;
  885.  $w->tkwait('visibility',$w);
  886. }
  887.  
  888. sub waitVariable
  889. {
  890.  my ($w) = shift;
  891.  $w->tkwait('variable',@_);
  892. }
  893.  
  894. sub waitWindow
  895. {
  896.  my ($w) = shift;
  897.  $w->tkwait('window',$w);
  898. }
  899.  
  900. sub EventWidget
  901. {
  902.  my ($w) = @_;
  903.  return $w->{'_EventWidget_'};
  904. }
  905.  
  906. sub Popwidget
  907. {
  908.  my ($ew,$method,$w,@args) = @_;
  909.  $w->{'_EventWidget_'} = $ew;
  910.  $w->$method(@args);
  911. }
  912.  
  913. sub ColorOptions
  914. {
  915.  my ($w,$args) = @_;
  916.  my $opt;
  917.  $args = {} unless (defined $args);
  918.  foreach $opt (qw(-foreground -background -disabledforeground
  919.                   -activebackground -activeforeground
  920.               ))
  921.   {
  922.    $args->{$opt} = $w->cget($opt) unless (exists $args->{$opt})
  923.   }
  924.  return (wantarray) ? %$args : $args;
  925. }
  926.  
  927. sub XscrollBind
  928. {
  929.  my ($mw,$class) = @_;
  930.  $mw->bind($class,'<Left>',         ['xview','scroll',-1,'units']);
  931.  $mw->bind($class,'<Control-Left>', ['xview','scroll',-1,'pages']);
  932.  $mw->bind($class,'<Control-Prior>',['xview','scroll',-1,'pages']);
  933.  $mw->bind($class,'<Right>',        ['xview','scroll',1,'units']);
  934.  $mw->bind($class,'<Control-Right>',['xview','scroll',1,'pages']);
  935.  $mw->bind($class,'<Control-Next>', ['xview','scroll',1,'pages']);
  936.  
  937.  $mw->bind($class,'<Home>',         ['xview','moveto',0]);
  938.  $mw->bind($class,'<End>',          ['xview','moveto',1]);
  939. }
  940.  
  941. sub PriorNextBind
  942. {
  943.  my ($mw,$class) = @_;
  944.  $mw->bind($class,'<Next>',     ['yview','scroll',1,'pages']);
  945.  $mw->bind($class,'<Prior>',    ['yview','scroll',-1,'pages']);
  946. }
  947.  
  948. sub YscrollBind
  949. {
  950.  my ($mw,$class) = @_;
  951.  $mw->PriorNextBind($class);
  952.  $mw->bind($class,'<Up>',       ['yview','scroll',-1,'units']);
  953.  $mw->bind($class,'<Down>',     ['yview','scroll',1,'units']);
  954. }
  955.  
  956. sub XYscrollBind
  957. {
  958.  my ($mw,$class) = @_;
  959.  $mw->YscrollBind($class);
  960.  $mw->XscrollBind($class);
  961. }
  962.  
  963. sub ScrlListbox
  964. {
  965.  my $parent = shift;
  966.  return $parent->Scrolled('Listbox',-scrollbars => 'w', @_);
  967. }
  968.  
  969. sub AddBindTag
  970. {
  971.  my ($w,$tag) = @_;
  972.  my $t;
  973.  my @tags = $w->bindtags;
  974.  foreach $t (@tags)
  975.   {
  976.    return if $t eq $tag;
  977.   }
  978.  $w->bindtags([@tags,$tag]);
  979. }
  980.  
  981. sub Callback
  982. {
  983.  my $w = shift;
  984.  my $name = shift;
  985.  my $cb = $w->cget($name);
  986.  if (defined $cb)
  987.   {
  988.    return $cb->Call(@_) if (ref $cb);
  989.    return $w->$cb(@_);
  990.   }
  991.  return (wantarray) ? () : undef;
  992. }
  993.  
  994. sub packAdjust
  995. {
  996. # print 'packAdjust(',join(',',@_),")\n";
  997.  require Tk::Adjuster;
  998.  my ($w,%args) = @_;
  999.  my $delay = delete($args{'-delay'});
  1000.  $delay = 1 unless (defined $delay);
  1001.  $w->pack(%args);
  1002.  %args = $w->packInfo;
  1003.  my $adj = Tk::Adjuster->new($args{'-in'},
  1004.             -widget => $w, -delay => $delay, -side => $args{'-side'});
  1005.  $adj->packed($w,%args);
  1006.  return $w;
  1007. }
  1008.  
  1009. sub gridAdjust
  1010. {
  1011.  require Tk::Adjuster;
  1012.  my ($w,%args) = @_;
  1013.  my $delay = delete($args{'-delay'});
  1014.  $delay = 1 unless (defined $delay);
  1015.  $w->grid(%args);
  1016.  %args = $w->gridInfo;
  1017.  my $adj = Tk::Adjuster->new($args{'-in'},-widget => $w, -delay => $delay);
  1018.  $adj->gridded($w,%args);
  1019.  return $w;
  1020. }
  1021.  
  1022. sub place
  1023. {
  1024.  local $SIG{'__DIE__'} = \&Carp::croak;
  1025.  my $w = shift;
  1026.  if (@_ && $_[0] =~ /^(?:configure|forget|info|slaves)$/x)
  1027.   {
  1028.    $w->Tk::place(@_);
  1029.   }
  1030.  else
  1031.   {
  1032.    # Two things going on here:
  1033.    # 1. Add configure on the front so that we can drop leading '-'
  1034.    $w->Tk::place('configure',@_);
  1035.    # 2. Return the widget rather than nothing
  1036.    return $w;
  1037.   }
  1038. }
  1039.  
  1040. sub pack
  1041. {
  1042.  local $SIG{'__DIE__'} = \&Carp::croak;
  1043.  my $w = shift;
  1044.  if (@_ && $_[0] =~ /^(?:configure|forget|info|propagate|slaves)$/x)
  1045.   {
  1046.    # maybe array/scalar context issue with slaves
  1047.    $w->Tk::pack(@_);
  1048.   }
  1049.  else
  1050.   {
  1051.    # Two things going on here:
  1052.    # 1. Add configure on the front so that we can drop leading '-'
  1053.    $w->Tk::pack('configure',@_);
  1054.    # 2. Return the widget rather than nothing
  1055.    return $w;
  1056.   }
  1057. }
  1058.  
  1059. sub grid
  1060. {
  1061.  local $SIG{'__DIE__'} = \&Carp::croak;
  1062.  my $w = shift;
  1063.  if (@_ && $_[0] =~ /^(?:bbox|columnconfigure|configure|forget|info|location|propagate|rowconfigure|size|slaves)$/x)
  1064.   {
  1065.    my $opt = shift;
  1066.    Tk::grid($opt,$w,@_);
  1067.   }
  1068.  else
  1069.   {
  1070.    # Two things going on here:
  1071.    # 1. Add configure on the front so that we can drop leading '-'
  1072.    Tk::grid('configure',$w,@_);
  1073.    # 2. Return the widget rather than nothing
  1074.    return $w;
  1075.   }
  1076. }
  1077.  
  1078. sub form
  1079. {
  1080.  local $SIG{'__DIE__'} = \&Carp::croak;
  1081.  my $w = shift;
  1082.  if (@_ && $_[0] =~ /^(?:configure|check|forget|grid|info|slaves)$/x)
  1083.   {
  1084.    $w->Tk::form(@_);
  1085.   }
  1086.  else
  1087.   {
  1088.    # Two things going on here:
  1089.    # 1. Add configure on the front so that we can drop leading '-'
  1090.    $w->Tk::form('configure',@_);
  1091.    # 2. Return the widget rather than nothing
  1092.    return $w;
  1093.   }
  1094. }
  1095.  
  1096. sub Scrolled
  1097. {
  1098.  my ($parent,$kind,%args) = @_;
  1099.  # Find args that are Frame create time args
  1100.  my @args = Tk::Frame->CreateArgs($parent,\%args);
  1101.  my $name = delete $args{'Name'};
  1102.  push(@args,'Name' => $name) if (defined $name);
  1103.  my $cw = $parent->Frame(@args);
  1104.  @args = ();
  1105.  # Now remove any args that Frame can handle
  1106.  foreach my $k ('-scrollbars',map($_->[0],$cw->configure))
  1107.   {
  1108.    push(@args,$k,delete($args{$k})) if (exists $args{$k})
  1109.   }
  1110.  # Anything else must be for target widget - pass at widget create time
  1111.  my $w  = $cw->$kind(%args);
  1112.  # Now re-set %args to be ones Frame can handle
  1113.  %args = @args;
  1114.  $cw->ConfigSpecs('-scrollbars' => ['METHOD','scrollbars','Scrollbars','se'],
  1115.                   '-background' => [$w,'background','Background'],
  1116.                   '-foreground' => [$w,'foreground','Foreground'],
  1117.                  );
  1118.  $cw->AddScrollbars($w);
  1119.  $cw->Default("\L$kind" => $w);
  1120.  $cw->Delegates('bind' => $w, 'bindtags' => $w, 'menu' => $w);
  1121.  $cw->ConfigDefault(\%args);
  1122.  $cw->configure(%args);
  1123.  return $cw;
  1124. }
  1125.  
  1126. sub Populate
  1127. {
  1128.  my ($cw,$args) = @_;
  1129. }
  1130.  
  1131. sub ForwardEvent
  1132. {
  1133.  my $self = shift;
  1134.  my $to   = shift;
  1135.  $to->PassEvent($self->XEvent);
  1136. }
  1137.  
  1138. # Save / Return abstract event type as in Tix.
  1139. sub EventType
  1140. {
  1141.  my $w = shift;
  1142.  $w->{'_EventType_'} = $_[0] if @_;
  1143.  return $w->{'_EventType_'};
  1144. }
  1145.  
  1146. sub PostPopupMenu
  1147. {
  1148.  my ($w, $X, $Y) = @_;
  1149.  if (@_ < 3)
  1150.   {
  1151.    my $e = $w->XEvent;
  1152.    $X = $e->X;
  1153.    $Y = $e->Y;
  1154.   }
  1155.  my $menu = $w->menu;
  1156.  $menu->Post($X,$Y) if defined $menu;
  1157. }
  1158.  
  1159. sub FillMenu
  1160. {
  1161.  my ($w,$menu,@labels) = @_;
  1162.  foreach my $lab (@labels)
  1163.   {
  1164.    my $method = $lab.'MenuItems';
  1165.    $method =~ s/~//g;
  1166.    $method =~ s/[\s-]+/_/g;
  1167.    if ($w->can($method))
  1168.     {
  1169.      $menu->Menubutton(-label => $lab, -tearoff => 0, -menuitems => $w->$method());
  1170.     }
  1171.   }
  1172.  return $menu;
  1173. }
  1174.  
  1175. sub menu
  1176. {
  1177.  my ($w,$menu) = @_;
  1178.  if (@_ > 1)
  1179.   {
  1180.    $w->_OnDestroy('_MENU_') unless exists $w->{'_MENU_'};
  1181.    $w->{'_MENU_'} = $menu;
  1182.   }
  1183.  return unless defined wantarray;
  1184.  unless (exists $w->{'_MENU_'})
  1185.   {
  1186.    $w->_OnDestroy('_MENU_');
  1187.    $w->{'_MENU_'} = $menu = $w->Menu(-tearoff => 0);
  1188.    $w->FillMenu($menu,$w->MenuLabels);
  1189.   }
  1190.  return $w->{'_MENU_'};
  1191. }
  1192.  
  1193. sub MenuLabels
  1194. {
  1195.  return @DefaultMenuLabels;
  1196. }
  1197.  
  1198. sub FileMenuItems
  1199. {
  1200.  my ($w) = @_;
  1201.  return [ ["command"=>'E~xit', -command => [ $w, 'WmDeleteWindow']]];
  1202. }
  1203.  
  1204. sub WmDeleteWindow
  1205. {
  1206.  shift->toplevel->WmDeleteWindow
  1207. }
  1208.  
  1209. sub BalloonInfo
  1210. {
  1211.  my ($widget,$balloon,$X,$Y,@opt) = @_;
  1212.  foreach my $opt (@opt)
  1213.   {
  1214.    my $info = $balloon->GetOption($opt,$widget);
  1215.    return $info if defined $info;
  1216.   }
  1217. }
  1218.  
  1219.  
  1220.  
  1221. 1;
  1222. __END__
  1223.  
  1224. sub ASkludge
  1225. {
  1226.  my ($hash,$sense) = @_;
  1227.  foreach my $key (%$hash)
  1228.   {
  1229.    if ($key =~ /-.*variable/ && ref($hash->{$key}) eq 'SCALAR')
  1230.     {
  1231.      if ($sense)
  1232.       {
  1233.        my $val = ${$hash->{$key}};
  1234.        require Tie::Scalar;
  1235.        tie ${$hash->{$key}},'Tie::StdScalar';
  1236.        ${$hash->{$key}} = $val;
  1237.       }
  1238.      else
  1239.       {
  1240.        untie ${$hash->{$key}};
  1241.       }
  1242.     }
  1243.   }
  1244. }
  1245.  
  1246.  
  1247.  
  1248. # clipboardKeysyms --
  1249. # This procedure is invoked to identify the keys that correspond to
  1250. # the "copy", "cut", and "paste" functions for the clipboard.
  1251. #
  1252. # Arguments:
  1253. # copy - Name of the key (keysym name plus modifiers, if any,
  1254. # such as "Meta-y") used for the copy operation.
  1255. # cut - Name of the key used for the cut operation.
  1256. # paste - Name of the key used for the paste operation.
  1257. #
  1258. # This method is obsolete use clipboardOperations and abstract
  1259. # event types instead. See Clipboard.pm and Mainwindow.pm
  1260.  
  1261. sub clipboardKeysyms
  1262. {
  1263.  my @class = ();
  1264.  my $mw    = shift;
  1265.  if (ref $mw)
  1266.   {
  1267.    $mw = $mw->DelegateFor('bind');
  1268.   }
  1269.  else
  1270.   {
  1271.    push(@class,$mw);
  1272.    $mw = shift;
  1273.   }
  1274.  if (@_)
  1275.   {
  1276.    my $copy  = shift;
  1277.    $mw->Tk::bind(@class,"<$copy>",'clipboardCopy')   if (defined $copy);
  1278.   }
  1279.  if (@_)
  1280.   {
  1281.    my $cut   = shift;
  1282.    $mw->Tk::bind(@class,"<$cut>",'clipboardCut')     if (defined $cut);
  1283.   }
  1284.  if (@_)
  1285.   {
  1286.    my $paste = shift;
  1287.    $mw->Tk::bind(@class,"<$paste>",'clipboardPaste') if (defined $paste);
  1288.   }
  1289. }
  1290.  
  1291. sub pathname
  1292. {
  1293.  my ($w,$id) = @_;
  1294.  my $x = $w->winfo('pathname',-displayof  => oct($id));
  1295.  return $x->PathName;
  1296. }
  1297.  
  1298.  
  1299.