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