home *** CD-ROM | disk | FTP | other *** search
/ PC World 2003 March / PCWorld_2003-03_cd.bin / Software / Topware / activeperl / ActivePerl / Perl / site / lib / Tk.pm < prev    next >
Encoding:
Perl POD Document  |  2002-07-11  |  15.1 KB  |  697 lines
  1. #
  2. # Copyright (c) 1992-1994 The Regents of the University of California.
  3. # Copyright (c) 1994 Sun Microsystems, Inc.
  4. # Copyright (c) 1995-1999 Nick Ing-Simmons. All rights reserved.
  5. # This program is free software; you can redistribute it and/or
  6.  
  7. # modify it under the same terms as Perl itself, subject
  8. # to additional disclaimer in Tk/license.terms due to partial
  9. # derivation from Tk8.0 sources.
  10. #
  11. package Tk;
  12. require 5.00404;
  13. use     Tk::Event ();
  14. use     AutoLoader qw(AUTOLOAD);
  15. use     DynaLoader;
  16. use base qw(Exporter DynaLoader);
  17.  
  18. *fileevent = \&Tk::Event::IO::fileevent;
  19.  
  20. BEGIN {
  21.  if($^O eq 'cygwin')
  22.   {
  23.    require Tk::Config;
  24.    $Tk::platform = $Tk::Config::win_arch;
  25.    $Tk::platform = 'unix' if $Tk::platform eq 'x';
  26.   }
  27.  else
  28.   {
  29.    $Tk::platform = ($^O eq 'MSWin32') ? $^O : 'unix';
  30.   }
  31. };
  32.  
  33. $Tk::tearoff = 1 if ($Tk::platform eq 'unix');
  34.  
  35. @EXPORT    = qw(Exists Ev exit MainLoop DoOneEvent tkinit);
  36. @EXPORT_OK = qw(NoOp after *widget *event lsearch catch $XS_VERSION
  37.                 DONT_WAIT WINDOW_EVENTS  FILE_EVENTS TIMER_EVENTS
  38.                 IDLE_EVENTS ALL_EVENTS
  39.                 NORMAL_BG ACTIVE_BG SELECT_BG
  40.                 SELECT_FG TROUGH INDICATOR DISABLED BLACK WHITE);
  41. %EXPORT_TAGS = (eventtypes => [qw(DONT_WAIT WINDOW_EVENTS  FILE_EVENTS
  42.                                   TIMER_EVENTS IDLE_EVENTS ALL_EVENTS)],
  43.                 variables  => [qw(*widget *event)],
  44.                 colors     => [qw(NORMAL_BG ACTIVE_BG SELECT_BG SELECT_FG
  45.                                   TROUGH INDICATOR DISABLED BLACK WHITE)],
  46.                );
  47.  
  48. use strict;
  49.  
  50. use Carp;
  51.  
  52. # $tk_version and $tk_patchLevel are reset by pTk when a mainwindow
  53. # is created, $VERSION is checked by bootstrap
  54. $Tk::version     = '8.0';
  55. $Tk::patchLevel  = '8.0';
  56. $Tk::VERSION     = '800.024';
  57. $Tk::XS_VERSION  = $Tk::VERSION;
  58. $Tk::strictMotif = 0;
  59.  
  60. {($Tk::library) = __FILE__ =~ /^(.*)\.pm$/;}
  61. $Tk::library = Tk->findINC('.') unless (defined($Tk::library) && -d $Tk::library);
  62.  
  63. $Tk::widget  = undef;
  64. $Tk::event   = undef;
  65.  
  66. use vars qw($inMainLoop);
  67.  
  68. bootstrap Tk;
  69.  
  70. my $boot_time = timeofday();
  71.  
  72. # This is a workround for Solaris X11 locale handling
  73. Preload(DynaLoader::dl_findfile('-L/usr/openwin/lib','-lX11'))
  74.   if (NeedPreload() && -d '/usr/openwin/lib');
  75.  
  76. use Tk::Submethods ('option'    =>  [qw(add get clear readfile)],
  77.                     'clipboard' =>  [qw(clear append)]
  78.                    );
  79.  
  80. sub _backTrace
  81. {
  82.  my $w = shift;
  83.  my $i = 1;
  84.  my ($pack,$file,$line,$sub) = caller($i++);
  85.  while (1)
  86.   {
  87.    my $loc = "at $file line $line";
  88.    ($pack,$file,$line,$sub) = caller($i++);
  89.    last unless defined($sub);
  90.    return 1 if $sub eq '(eval)';
  91.    $w->AddErrorInfo("$sub $loc");
  92.   }
  93.  return 0;
  94. }
  95.  
  96. sub BackTrace
  97. {
  98.  my $w = shift;
  99.  return unless (@_ || $@);
  100.  my $mess = (@_) ? shift : "$@";
  101.  die "$mess\n" if $w->_backTrace;
  102.  # if we get here we are not in an eval so report now
  103.  $w->Fail($mess);
  104.  $w->idletasks;
  105.  die "$mess\n";
  106. }
  107.  
  108. #
  109. # This is a $SIG{__DIE__} handler which does not change the $@
  110. # string in the way 'croak' does, but rather add to Tk's ErrorInfo.
  111. # It stops at 1st enclosing eval on assumption that the eval
  112. # is part of Tk call process and will add its own context to ErrorInfo
  113. # and then pass on the error.
  114. #
  115. sub __DIE__
  116. {
  117.  my $mess = shift;
  118.  my $w = $Tk::widget;
  119.  # Note that if a __DIE__ handler returns it re-dies up the chain.
  120.  return unless defined $w;
  121.  return if $w->_backTrace;
  122.  # Not in an eval - should not happen
  123. }
  124.  
  125. sub XEvent::xy { shift->Info('xy') }
  126.  
  127. sub XEvent::AUTOLOAD
  128. {
  129.  my ($meth) = $XEvent::AUTOLOAD =~ /(\w)$/;
  130.  no strict 'refs';
  131.  *{$XEvent::AUTOLOAD} = sub { shift->Info($meth) };
  132.  goto &$XEvent::AUTOLOAD;
  133. }
  134.  
  135. sub NoOp  { }
  136.  
  137. sub Ev
  138. {
  139.  my @args = @_;
  140.  my $obj;
  141.  if (@args == 1)
  142.   {
  143.    my $arg = pop(@args);
  144.    $obj = (ref $arg) ? $arg : \$arg;
  145.   }
  146.  else
  147.   {
  148.    $obj = \@args;
  149.   }
  150.  return bless $obj,'Tk::Ev';
  151. }
  152.  
  153. sub InitClass
  154. {
  155.  my ($package,$parent) = @_;
  156.  croak "Unexpected type of parent $parent" unless(ref $parent);
  157.  croak "$parent is not a widget" unless($parent->IsWidget);
  158.  my $mw = $parent->MainWindow;
  159.  my $hash = $mw->TkHash('_ClassInit_');
  160.  unless (exists $hash->{$package})
  161.   {
  162.    $package->Install($mw);
  163.    $hash->{$package} = $package->ClassInit($mw);
  164.   }
  165. }
  166.  
  167. require Tk::Widget;
  168. require Tk::Image;
  169. require Tk::MainWindow;
  170.  
  171. sub Exists
  172. {my $w = shift;
  173.  return defined($w) && ref($w) && $w->IsWidget && $w->exists;
  174. }
  175.  
  176. sub Time_So_Far
  177. {
  178.  return timeofday() - $boot_time;
  179. }
  180.  
  181. # Selection* are not autoloaded as names are too long.
  182.  
  183. sub SelectionOwn
  184. {my $widget = shift;
  185.  selection('own',(@_,$widget));
  186. }
  187.  
  188. sub SelectionOwner
  189. {
  190.  selection('own','-displayof',@_);
  191. }
  192.  
  193. sub SelectionClear
  194. {
  195.  selection('clear','-displayof',@_);
  196. }
  197.  
  198. sub SelectionExists
  199. {
  200.  selection('exists','-displayof',@_);
  201. }
  202.  
  203. sub SelectionHandle
  204. {my $widget = shift;
  205.  my $command = pop;
  206.  selection('handle',@_,$widget,$command);
  207. }
  208.  
  209. sub SplitString
  210. {
  211.  local $_ = shift;
  212.  my (@arr, $tmp);
  213.  while (/\{([^{}]*)\}|((?:[^\s\\]|\\.)+)/gs) {
  214.    if (defined $1) { push @arr, $1 }
  215.    else { $tmp = $2 ; $tmp =~ s/\\([\s\\])/$1/g; push @arr, $tmp }
  216.  }
  217.  # carp '('.join(',',@arr).")";
  218.  return @arr;
  219. }
  220.  
  221. sub Methods
  222. {
  223.  my ($package) = caller;
  224.  no strict 'refs';
  225.  foreach my $meth (@_)
  226.   {
  227.    my $name = $meth;
  228.    *{$package."::$meth"} = sub { shift->WidgetMethod($name,@_) };
  229.   }
  230. }
  231.  
  232.  
  233. sub MessageBox {
  234.     my ($kind,%args) = @_;
  235.     require Tk::Dialog;
  236.     my $parent = delete $args{'-parent'};
  237.     my $args = \%args;
  238.  
  239.     $args->{-bitmap} = delete $args->{-icon} if defined $args->{-icon};
  240.     $args->{-text} = delete $args->{-message} if defined $args->{-message};
  241.     $args->{-type} = 'OK' unless defined $args->{-type};
  242.  
  243.     my $type;
  244.     if (defined($type = delete $args->{-type})) {
  245.     delete $args->{-type};
  246.     my @buttons = grep($_,map(ucfirst($_),
  247.                       split(/(abort|retry|ignore|yes|no|cancel|ok)/,
  248.                             lc($type))));
  249.     $args->{-buttons} = [@buttons];
  250.     $args->{-default_button} = delete $args->{-default} if
  251.         defined $args->{-default};
  252.     if (not defined $args->{-default_button} and scalar(@buttons) == 1) {
  253.        $args->{-default_button} = $buttons[0];
  254.     }
  255.         my $md = $parent->Dialog(%$args);
  256.         my $an = $md->Show;
  257.         $md->destroy;
  258.         return $an;
  259.     }
  260. } # end messageBox
  261.  
  262. sub messageBox
  263. {
  264.  my ($widget,%args) = @_;
  265.  $args{'-type'} = (exists $args{'-type'}) ? lc($args{'-type'}) : 'ok';
  266.  tk_messageBox(-parent => $widget, %args);
  267. }
  268.  
  269. sub getOpenFile
  270. {
  271.  tk_getOpenFile(-parent => shift,@_);
  272. }
  273.  
  274. sub getSaveFile
  275. {
  276.  tk_getSaveFile(-parent => shift,@_);
  277. }
  278.  
  279. sub chooseColor
  280. {
  281.  tk_chooseColor(-parent => shift,@_);
  282. }
  283.  
  284. sub DialogWrapper
  285. {
  286.  my ($method,$kind,%args) = @_;
  287.  my $created = 0;
  288.  my $w = delete $args{'-parent'};
  289.  if (defined $w)
  290.   {
  291.    $args{'-popover'} = $w;
  292.   }
  293.  else
  294.   {
  295.    $w = MainWindow->new;
  296.    $w->withdraw;
  297.    $created = 1;
  298.   }
  299.  my $mw = $w->MainWindow;
  300.  my $fs = $mw->{$kind};
  301.  unless (defined $fs)
  302.   {
  303.    $mw->{$kind} = $fs = $mw->$method(%args);
  304.   }
  305.  else
  306.   {
  307.    $fs->configure(%args);
  308.   }
  309.  my $val = $fs->Show;
  310.  $w->destroy if $created;
  311.  return $val;
  312. }
  313.  
  314. sub ColorDialog
  315. {
  316.  require Tk::ColorEditor;
  317.  DialogWrapper('ColorDialog',@_);
  318. }
  319.  
  320. sub FDialog
  321. {
  322.  require Tk::FBox;
  323.  my $cmd = shift;
  324.  if ($cmd =~ /Save/)
  325.   {
  326.    push @_, -type => 'save';
  327.   }
  328.  DialogWrapper('FBox', $cmd, @_);
  329. }
  330.  
  331. *MotifFDialog = \&FDialog;
  332.  
  333. sub MainLoop
  334. {
  335.  unless ($inMainLoop)
  336.   {
  337.    local $inMainLoop = 1;
  338.    while (Tk::MainWindow->Count)
  339.     {
  340.      DoOneEvent(0);
  341.     }
  342.   }
  343. }
  344.  
  345. sub tkinit { return MainWindow->new(@_) }
  346.  
  347. # a wrapper on eval which turns off user $SIG{__DIE__}
  348. sub catch (&)
  349. {
  350.  my $sub = shift;
  351.  eval {local $SIG{'__DIE__'}; &$sub };
  352. }
  353.  
  354. my $Home;
  355.  
  356. sub TranslateFileName
  357. {
  358.  local $_ = shift;
  359.  unless (defined $Home)
  360.   {
  361.    $Home = $ENV{'HOME'} || ($ENV{'HOMEDRIVE'}.$ENV{'HOMEPATH'});
  362.    $Home =~ s#\\#/#g;
  363.    $Home .= '/' unless $Home =~ m#/$#;
  364.   }
  365.  s#~/#$Home#g;
  366.  # warn $_;
  367.  return $_;
  368. }
  369.  
  370. sub findINC
  371. {
  372.  my $file = join('/',@_);
  373.  my $dir;
  374.  $file  =~ s,::,/,g;
  375.  foreach $dir (@INC)
  376.   {
  377.    my $path;
  378.    return $path if (-e ($path = "$dir/$file"));
  379.   }
  380.  return undef;
  381. }
  382.  
  383. sub idletasks
  384. {
  385.  shift->update('idletasks');
  386. }
  387.  
  388.  
  389. 1;
  390.  
  391. __END__
  392.  
  393. sub Error
  394. {my $w = shift;
  395.  my $error = shift;
  396.  if (Exists($w))
  397.   {
  398.    my $grab = $w->grab('current');
  399.    $grab->Unbusy if (defined $grab);
  400.   }
  401.  chomp($error);
  402.  warn "Tk::Error: $error\n " . join("\n ",@_)."\n";
  403. }
  404.  
  405. sub CancelRepeat
  406. {
  407.  my $w = shift->MainWindow;
  408.  my $id = delete $w->{_afterId_};
  409.  $w->after('cancel',$id) if (defined $id);
  410. }
  411.  
  412. sub RepeatId
  413. {
  414.  my ($w,$id) = @_;
  415.  $w = $w->MainWindow;
  416.  $w->CancelRepeat;
  417.  $w->{_afterId_} = $id;
  418. }
  419.  
  420.  
  421.  
  422. #----------------------------------------------------------------------------
  423. # focus.tcl --
  424. #
  425. # This file defines several procedures for managing the input
  426. # focus.
  427. #
  428. # @(#) focus.tcl 1.6 94/12/19 17:06:46
  429. #
  430. # Copyright (c) 1994 Sun Microsystems, Inc.
  431. #
  432. # See the file "license.terms" for information on usage and redistribution
  433. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  434.  
  435. sub FocusChildren { shift->children }
  436.  
  437. #
  438. # focusNext --
  439. # This procedure is invoked to move the input focus to the next window
  440. # after a given one. "Next" is defined in terms of the window
  441. # stacking order, with all the windows underneath a given top-level
  442. # (no matter how deeply nested in the hierarchy) considered except
  443. # for frames and toplevels.
  444. #
  445. # Arguments:
  446. # w - Name of a window: the procedure will set the focus
  447. # to the next window after this one in the traversal
  448. # order.
  449. sub focusNext
  450. {
  451.  my $w = shift;
  452.  my $cur = $w;
  453.  while (1)
  454.   {
  455.    # Descend to just before the first child of the current widget.
  456.    my $parent = $cur;
  457.    my @children = $cur->FocusChildren();
  458.    my $i = -1;
  459.    # Look for the next sibling that isn't a top-level.
  460.    while (1)
  461.     {
  462.      $i += 1;
  463.      if ($i < @children)
  464.       {
  465.        $cur = $children[$i];
  466.        next if ($cur->toplevel == $cur);
  467.        last
  468.       }
  469.      # No more siblings, so go to the current widget's parent.
  470.      # If it's a top-level, break out of the loop, otherwise
  471.      # look for its next sibling.
  472.      $cur = $parent;
  473.      last if ($cur->toplevel() == $cur);
  474.      $parent = $parent->parent();
  475.      @children = $parent->FocusChildren();
  476.      $i = lsearch(\@children,$cur);
  477.     }
  478.    if ($cur == $w || $cur->FocusOK)
  479.     {
  480.      $cur->tabFocus;
  481.      return;
  482.     }
  483.   }
  484. }
  485. # focusPrev --
  486. # This procedure is invoked to move the input focus to the previous
  487. # window before a given one. "Previous" is defined in terms of the
  488. # window stacking order, with all the windows underneath a given
  489. # top-level (no matter how deeply nested in the hierarchy) considered.
  490. #
  491. # Arguments:
  492. # w - Name of a window: the procedure will set the focus
  493. # to the previous window before this one in the traversal
  494. # order.
  495. sub focusPrev
  496. {
  497.  my $w = shift;
  498.  my $cur = $w;
  499.  my @children;
  500.  my $i;
  501.  my $parent;
  502.  while (1)
  503.   {
  504.    # Collect information about the current window's position
  505.    # among its siblings. Also, if the window is a top-level,
  506.    # then reposition to just after the last child of the window.
  507.    if ($cur->toplevel() == $cur)
  508.     {
  509.      $parent = $cur;
  510.      @children = $cur->FocusChildren();
  511.      $i = @children;
  512.     }
  513.    else
  514.     {
  515.      $parent = $cur->parent();
  516.      @children = $parent->FocusChildren();
  517.      $i = lsearch(\@children,$cur);
  518.     }
  519.    # Go to the previous sibling, then descend to its last descendant
  520.    # (highest in stacking order. While doing this, ignore top-levels
  521.    # and their descendants. When we run out of descendants, go up
  522.    # one level to the parent.
  523.    while ($i > 0)
  524.     {
  525.      $i--;
  526.      $cur = $children[$i];
  527.      next if ($cur->toplevel() == $cur);
  528.      $parent = $cur;
  529.      @children = $parent->FocusChildren();
  530.      $i = @children;
  531.     }
  532.    $cur = $parent;
  533.    if ($cur == $w || $cur->FocusOK)
  534.     {
  535.      $cur->tabFocus;
  536.      return;
  537.     }
  538.   }
  539.  
  540. }
  541.  
  542. sub FocusOK
  543. {
  544.  my $w = shift;
  545.  my $value;
  546.  catch { $value = $w->cget('-takefocus') };
  547.  if (!$@ && defined($value))
  548.   {
  549.    return 0 if ($value eq '0');
  550.    return $w->viewable if ($value eq '1');
  551.    $value = $w->$value();
  552.    return $value if (defined $value);
  553.   }
  554.  if (!$w->viewable)
  555.   {
  556.    return 0;
  557.   }
  558.  catch { $value = $w->cget('-state') } ;
  559.  if (!$@ && defined($value) && $value eq 'disabled')
  560.   {
  561.    return 0;
  562.   }
  563.  $value = grep(/Key|Focus/,$w->Tk::bind(),$w->Tk::bind(ref($w)));
  564.  return $value;
  565. }
  566.  
  567.  
  568. # focusFollowsMouse
  569. #
  570. # If this procedure is invoked, Tk will enter "focus-follows-mouse"
  571. # mode, where the focus is always on whatever window contains the
  572. # mouse. If this procedure isn't invoked, then the user typically
  573. # has to click on a window to give it the focus.
  574. #
  575. # Arguments:
  576. # None.
  577.  
  578. sub EnterFocus
  579. {
  580.  my $w  = shift;
  581.  my $Ev = $w->XEvent;
  582.  my $d  = $Ev->d;
  583.  $w->Tk::focus() if ($d eq 'NotifyAncestor' ||  $d eq 'NotifyNonlinear' ||  $d eq 'NotifyInferior');
  584. }
  585.  
  586. sub tabFocus
  587. {
  588.  shift->Tk::focus;
  589. }
  590.  
  591. sub focusFollowsMouse
  592. {
  593.  my $widget = shift;
  594.  $widget->bind('all','<Enter>','EnterFocus');
  595. }
  596.  
  597. # tkTraverseToMenu --
  598. # This procedure implements keyboard traversal of menus. Given an
  599. # ASCII character "char", it looks for a menubutton with that character
  600. # underlined. If one is found, it posts the menubutton's menu
  601. #
  602. # Arguments:
  603. # w - Window in which the key was typed (selects
  604. # a toplevel window).
  605. # char - Character that selects a menu. The case
  606. # is ignored. If an empty string, nothing
  607. # happens.
  608. sub TraverseToMenu
  609. {
  610.  my $w = shift;
  611.  my $char = shift;
  612.  return unless(defined $char && $char ne '');
  613.  $w = $w->toplevel->FindMenu($char);
  614. }
  615. # tkFirstMenu --
  616. # This procedure traverses to the first menubutton in the toplevel
  617. # for a given window, and posts that menubutton's menu.
  618. #
  619. # Arguments:
  620. # w - Name of a window. Selects which toplevel
  621. # to search for menubuttons.
  622. sub FirstMenu
  623. {
  624.  my $w = shift;
  625.  $w = $w->toplevel->FindMenu('');
  626. }
  627.  
  628. # These wrappers don't use method syntax so need to live
  629. # in same package as raw Tk routines are newXS'ed into.
  630.  
  631. sub Selection
  632. {my $widget = shift;
  633.  my $cmd    = shift;
  634.  croak 'Use SelectionOwn/SelectionOwner' if ($cmd eq 'own');
  635.  croak "Use Selection\u$cmd()";
  636. }
  637.  
  638. # If we have sub Clipboard in Tk then use base qw(Tk::Clipboard ....)
  639. # calls it when it does its eval "require $base"
  640. #sub Clipboard
  641. #{my $w = shift;
  642. # my $cmd    = shift;
  643. # croak "Use clipboard\u$cmd()";
  644. #}
  645.  
  646. sub Receive
  647. {
  648.  my $w = shift;
  649.  warn 'Receive(' . join(',',@_) .')';
  650.  die 'Tk rejects send(' . join(',',@_) .")\n";
  651. }
  652.  
  653. sub break
  654. {
  655.  die "_TK_BREAK_\n";
  656. }
  657.  
  658. sub updateWidgets
  659. {
  660.  my ($w) = @_;
  661.  while ($w->DoOneEvent(DONT_WAIT|IDLE_EVENTS|WINDOW_EVENTS))
  662.   {
  663.   }
  664.  $w;
  665. }
  666.  
  667. sub ImageNames
  668. {
  669.  image('names');
  670. }
  671.  
  672. sub ImageTypes
  673. {
  674.  image('types');
  675. }
  676.  
  677. sub interps
  678. {
  679.  my $w = shift;
  680.  return $w->winfo('interps','-displayof');
  681. }
  682.  
  683. sub lsearch
  684. {my $ar = shift;
  685.  my $x  = shift;
  686.  my $i;
  687.  for ($i = 0; $i < scalar @$ar; $i++)
  688.   {
  689.    return $i if ($$ar[$i] eq $x);
  690.   }
  691.  return -1;
  692. }
  693.  
  694.  
  695.  
  696.  
  697.