home *** CD-ROM | disk | FTP | other *** search
/ CD Actual Thematic 7: Programming / CDAT7.iso / Share / Editores / Perl5 / perl / lib / site / Tk.pm < prev    next >
Encoding:
Perl POD Document  |  1997-08-10  |  12.4 KB  |  574 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-1997 Nick Ing-Simmons. All rights reserved.
  5. # This program is free software; you can redistribute it and/or
  6. # modify it under the same terms as Perl itself, subject 
  7. # to additional disclaimer in Tk/license.terms due to partial
  8. # derivation from Tk4.0 sources.
  9. #
  10. package Tk;
  11. require 5.004;
  12. use     AutoLoader qw(AUTOLOAD);
  13. use     DynaLoader;
  14. require Exporter;
  15. @Tk::ISA = qw(Exporter DynaLoader);
  16.  
  17.  
  18. @EXPORT    = qw(Exists Ev after exit MainLoop DoOneEvent tkinit);
  19. @EXPORT_OK = qw(NoOp *widget *event lsearch catch 
  20.                 DONT_WAIT WINDOW_EVENTS  FILE_EVENTS TIMER_EVENTS 
  21.                 IDLE_EVENTS ALL_EVENTS 
  22.                 NORMAL_BG ACTIVE_BG SELECT_BG 
  23.                 SELECT_FG TROUGH INDICATOR DISABLED BLACK WHITE);
  24. %EXPORT_TAGS = (eventtypes => [qw(DONT_WAIT WINDOW_EVENTS  FILE_EVENTS 
  25.                                   TIMER_EVENTS IDLE_EVENTS ALL_EVENTS)], 
  26.                 variables  => [qw(*widget *event)],
  27.                 colors     => [qw(NORMAL_BG ACTIVE_BG SELECT_BG SELECT_FG 
  28.                                   TROUGH INDICATOR DISABLED BLACK WHITE)],
  29.                );
  30.  
  31. use strict;
  32. use Symbol ();
  33.  
  34. use Carp;
  35.  
  36. # $tk_version and $tk_patchLevel are reset by pTk when a mainwindow
  37. # is created, $VERSION is checked by bootstrap
  38. $Tk::version     = "4.2";
  39. $Tk::patchLevel  = "4.2";
  40. $Tk::VERSION     = '402.002';
  41. $Tk::strictMotif = 0;
  42.                                    
  43. {($Tk::library) = __FILE__ =~ /^(.*)\.pm$/;}
  44. $Tk::library = Tk->findINC('.') unless (-d $Tk::library);
  45.  
  46. $Tk::widget  = undef;
  47. $Tk::event   = undef;
  48.  
  49. # Supress used once warnings on function table pointers 
  50. # How can we do this in the C code?
  51. use vars qw($TkVtab $TkintVtab $LangVtab $TkglueVtab $XlibVtab $TkoptionVtab);  
  52. use vars qw($TixVtab $TixintVtab $TiximgxpmVtab);
  53.  
  54. bootstrap Tk $Tk::VERSION;
  55.  
  56. {
  57.  no strict 'refs';
  58.  *{'exit'} = \&Exit;
  59. }
  60. my $boot_time = timeofday();
  61.  
  62. # This is a workround for Solaris X11 locale handling 
  63. Preload(DynaLoader::dl_findfile('-L/usr/openwin/lib','-lX11')) if (&NeedPreload && -d '/usr/openwin/lib');
  64.  
  65. use Tk::Submethods ('option'    =>  [qw(add get clear readfile)],
  66.                     'clipboard' =>  [qw(clear append)]
  67.                    );
  68.  
  69. sub BackTrace
  70. {
  71.  my $w = shift;
  72.  return unless (@_ || $@);
  73.  my $mess = (@_) ? shift : "$@";
  74.  my $i = 0;  
  75.  my ($pack,$file,$line,$sub) = caller($i++);
  76.  while (1)   
  77.   {          
  78.    my $loc = "at $file line $line";
  79.    ($pack,$file,$line,$sub) = caller($i++);
  80.    last if (!defined($sub) || $sub eq '(eval)');
  81.    $w->AddErrorInfo("$sub $loc");
  82.   }          
  83.  die "$mess\n";
  84. }
  85.  
  86. sub NoOp  { }
  87.  
  88. sub Ev
  89. {
  90.  my @args = @_;
  91.  my $obj;
  92.  if (@args == 1)
  93.   {
  94.    my $arg = pop(@args);
  95.    $obj = (ref $arg) ? $arg : \$arg;
  96.   }
  97.  else 
  98.   {
  99.    $obj = \@args;
  100.   }
  101.  return bless $obj,"Tk::Ev";
  102. }
  103.  
  104. sub InitClass
  105. {
  106.  my ($package,$parent) = @_;
  107.  croak "Unexpected type of parent $parent" unless(ref $parent);
  108.  croak "$parent is not a widget" unless($parent->IsWidget);
  109.  my $mw = $parent->MainWindow;
  110.  unless (exists $mw->{'_ClassInit_'}{$package})
  111.   {
  112.    $package->Install($mw);
  113.    $mw->{'_ClassInit_'}{$package} = $package->ClassInit($mw);
  114.   }
  115. }
  116.  
  117. require Tk::Widget;
  118. require Tk::Image;
  119. require Tk::MainWindow;
  120.  
  121. sub Exists
  122. {my $w = shift;
  123.  return defined($w) && ref($w) && $w->IsWidget && $w->exists;
  124. }
  125.  
  126. sub Time_So_Far
  127. {
  128.  return timeofday() - $boot_time;
  129. } 
  130.  
  131. # Selection* are not autoloaded as names are too long.
  132.  
  133. sub SelectionOwn
  134. {my $widget = shift;
  135.  selection('own',(@_,$widget));
  136. }
  137.  
  138. sub SelectionOwner
  139. {
  140.  selection('own',"-displayof",@_);
  141. }
  142.  
  143. sub SelectionClear
  144. {
  145.  selection('clear',"-displayof",@_);
  146. }
  147.  
  148. sub SelectionExists
  149. {
  150.  selection('exists',"-displayof",@_);
  151. }
  152.  
  153. sub SelectionHandle
  154. {my $widget = shift;
  155.  my $command = pop;
  156.  selection('handle',@_,$widget,$command);
  157. }
  158.  
  159. #
  160. # This is a $SIG{__DIE__} handler which does not change the $@
  161. # string in the way 'croak' does, but rather add to Tk's ErrorInfo.
  162. # It stops at 1st enclosing eval on assumption that the eval
  163. # is part of Tk call process and will add its own context to ErrorInfo
  164. # and then pass on the error.
  165. # 
  166. sub __DIE__
  167. {
  168.  my $mess = shift;
  169.  my $w = $Tk::widget;
  170.  if (defined $w)
  171.   {
  172.    my $i = 0;  
  173.    my ($pack,$file,$line,$sub) = caller($i++);
  174.    while (1)   
  175.     {          
  176.      my $loc = "at $file line $line";
  177.      ($pack,$file,$line,$sub) = caller($i++);
  178.      last if (!defined($sub) || $sub eq '(eval)');
  179.      $w->AddErrorInfo("$sub $loc");
  180.     }          
  181.   }
  182. }
  183.  
  184. sub fileevent
  185. {
  186.  require Tk::IO;
  187.  my ($obj,$file,$mode,$cb) = @_;
  188.  croak "Unknown mode '$mode'" unless $mode =~ /^(readable|writeable)$/;
  189.  unless (ref $file)
  190.   {
  191.    require IO::Handle;
  192.    no strict 'refs';
  193.    $file = Symbol::qualify($file,(caller)[0]);
  194.    $file = bless \*{$file},'IO::Handle';
  195.   }
  196.  if ($cb)
  197.   {
  198.    # Adding the handler
  199.    $cb = Tk::Callback->new($cb);
  200.    if ($mode eq 'readable')
  201.     {
  202.      Tk::IO::CreateReadHandler($file,$cb);
  203.     }
  204.    else
  205.     {
  206.      Tk::IO::CreateWriteHandler($file,$cb);
  207.     }
  208.   }
  209.  else
  210.   {
  211.    if ($mode eq 'readable')
  212.     {
  213.      Tk::IO::DeleteReadHandler($file);
  214.     }
  215.    else
  216.     {
  217.      Tk::IO::DeleteWriteHandler($file);
  218.     }
  219.   }
  220. }
  221.  
  222. sub SplitString
  223. {
  224.  local $_ = shift;
  225.  carp "SplitString '$_'";
  226.  my (@arr, $tmp);
  227.  while (/\{([^{}]*)\}|((?:[^\s\\]|\\.)+)/gs) {
  228.    if (defined $1) { push @arr, $1 }
  229.    else { $tmp = $2 ; $tmp =~ s/\\([\s\\])/$1/g; push @arr, $tmp }
  230.  }
  231.  return @arr;
  232.  #return split(/\s+/,$_);
  233. }
  234.  
  235.  
  236. 1;
  237.  
  238. __END__
  239. # provide an exit() to be exported if exit occurs 
  240. # before a MainWindow->new()
  241. sub exit { CORE::exit(@_);}
  242.  
  243. sub Exists
  244. {my $w = shift;
  245.  return defined($w) && ref($w) && $w->IsWidget && $w->exists;
  246. }
  247.  
  248. sub Error
  249. {my $w = shift;
  250.  my $error = shift;
  251.  if (Exists($w))
  252.   {
  253.    my $grab = $w->grab('current');  
  254.    $grab->Unbusy if (defined $grab);
  255.   }
  256.  chomp($error);
  257.  warn "Tk::Error: $error\n " . join("\n ",@_);
  258. }
  259.  
  260. sub tkinit
  261. {
  262.  return MainWindow->new(@_);
  263. }
  264.  
  265. sub CancelRepeat
  266. {
  267.  my $w = shift->MainWindow;
  268.  my $id = delete $w->{_afterId_};
  269.  $w->after('cancel',$id) if (defined $id);
  270. }
  271.  
  272. sub RepeatId
  273. {
  274.  my ($w,$id) = @_;
  275.  $w = $w->MainWindow;
  276.  $w->CancelRepeat;
  277.  $w->{_afterId_} = $id;
  278. }
  279.  
  280.  
  281.  
  282. #----------------------------------------------------------------------------
  283. # focus.tcl --
  284. #
  285. # This file defines several procedures for managing the input
  286. # focus.
  287. #
  288. # @(#) focus.tcl 1.6 94/12/19 17:06:46
  289. #
  290. # Copyright (c) 1994 Sun Microsystems, Inc.
  291. #
  292. # See the file "license.terms" for information on usage and redistribution
  293. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  294.  
  295. sub FocusChildren { shift->children }
  296.  
  297. #
  298. # focusNext --
  299. # This procedure is invoked to move the input focus to the next window
  300. # after a given one. "Next" is defined in terms of the window
  301. # stacking order, with all the windows underneath a given top-level
  302. # (no matter how deeply nested in the hierarchy) considered except
  303. # for frames and toplevels.
  304. #
  305. # Arguments:
  306. # w - Name of a window: the procedure will set the focus
  307. # to the next window after this one in the traversal
  308. # order.
  309. sub focusNext
  310. {
  311.  my $w = shift;
  312.  my $cur = $w;
  313.  while (1)
  314.   {
  315.    # Descend to just before the first child of the current widget.
  316.    my $parent = $cur;
  317.    my @children = $cur->FocusChildren();
  318.    my $i = -1;
  319.    # Look for the next sibling that isn't a top-level.
  320.    while (1)
  321.     {
  322.      $i += 1;
  323.      if ($i < @children)
  324.       {
  325.        $cur = $children[$i];
  326.        next if ($cur->toplevel == $cur);
  327.        last
  328.       }
  329.      # No more siblings, so go to the current widget's parent.
  330.      # If it's a top-level, break out of the loop, otherwise
  331.      # look for its next sibling.
  332.      $cur = $parent;
  333.      last if ($cur->toplevel() == $cur);
  334.      $parent = $parent->parent();
  335.      @children = $parent->FocusChildren();
  336.      $i = lsearch(\@children,$cur);
  337.     }
  338.    if ($cur == $w || $cur->FocusOK)
  339.     {
  340.      $cur->Tk::focus;
  341.      return;
  342.     }
  343.   }
  344. }
  345. # focusPrev --
  346. # This procedure is invoked to move the input focus to the previous
  347. # window before a given one. "Previous" is defined in terms of the
  348. # window stacking order, with all the windows underneath a given
  349. # top-level (no matter how deeply nested in the hierarchy) considered.
  350. #
  351. # Arguments:
  352. # w - Name of a window: the procedure will set the focus
  353. # to the previous window before this one in the traversal
  354. # order.
  355. sub focusPrev
  356. {
  357.  my $w = shift;
  358.  my $cur = $w;
  359.  my @children;
  360.  my $i;
  361.  my $parent;
  362.  while (1)
  363.   {
  364.    # Collect information about the current window's position
  365.    # among its siblings. Also, if the window is a top-level,
  366.    # then reposition to just after the last child of the window.
  367.    if ($cur->toplevel() == $cur)
  368.     {
  369.      $parent = $cur;
  370.      @children = $cur->FocusChildren();
  371.      $i = @children;
  372.     }
  373.    else
  374.     {
  375.      $parent = $cur->parent();
  376.      @children = $parent->FocusChildren();
  377.      $i = lsearch(\@children,$cur);
  378.     }
  379.    # Go to the previous sibling, then descend to its last descendant
  380.    # (highest in stacking order. While doing this, ignore top-levels
  381.    # and their descendants. When we run out of descendants, go up
  382.    # one level to the parent.
  383.    while ($i > 0)
  384.     {
  385.      $i--;
  386.      $cur = $children[$i];
  387.      next if ($cur->toplevel() == $cur);
  388.      $parent = $cur;
  389.      @children = $parent->FocusChildren();
  390.      $i = @children;
  391.     }
  392.    $cur = $parent;
  393.    if ($cur == $w || $cur->FocusOK)
  394.     {
  395.      $cur->Tk::focus;
  396.      return;
  397.     }
  398.   }
  399.  
  400. }
  401.  
  402. sub FocusOK
  403. {
  404.  my $w = shift;
  405.  my $value;
  406.  catch { $value = $w->cget('-takefocus') };
  407.  if (!$@ && defined($value))
  408.   {
  409.    return 0 if ($value eq '0');
  410.    return 1 if ($value eq '1');
  411.    $value = $w->$value();
  412.    return $value if (defined $value);
  413.   }
  414.  if (!$w->viewable)
  415.   {
  416.    return 0;
  417.   }
  418.  catch { $value = $w->cget('-state') } ;
  419.  if (!$@ && defined($value) && $value eq "disabled")
  420.   {
  421.    return 0;
  422.   }
  423.  $value = grep(/Key|Focus/,$w->Tk::bind(),$w->Tk::bind(ref($w)));
  424.  return $value;
  425. }
  426.  
  427.  
  428. # focusFollowsMouse
  429. #
  430. # If this procedure is invoked, Tk will enter "focus-follows-mouse"
  431. # mode, where the focus is always on whatever window contains the
  432. # mouse. If this procedure isn't invoked, then the user typically
  433. # has to click on a window to give it the focus.
  434. #
  435. # Arguments:
  436. # None.
  437.  
  438. sub EnterFocus
  439. {
  440.  my $w  = shift;
  441.  my $Ev = $w->XEvent;
  442.  my $d  = $Ev->d;
  443.  $w->Tk::focus() if ($d eq "NotifyAncestor" ||  $d eq "NotifyNonlinear" ||  $d eq "NotifyInferior");
  444. }
  445.  
  446. sub focusFollowsMouse
  447. {
  448.  my $widget = shift;
  449.  $widget->bind('all',"EnterFocus");
  450. }
  451.  
  452. # tkTraverseToMenu --
  453. # This procedure implements keyboard traversal of menus. Given an
  454. # ASCII character "char", it looks for a menubutton with that character
  455. # underlined. If one is found, it posts the menubutton's menu
  456. #
  457. # Arguments:
  458. # w - Window in which the key was typed (selects
  459. # a toplevel window).
  460. # char - Character that selects a menu. The case
  461. # is ignored. If an empty string, nothing
  462. # happens.
  463. sub TraverseToMenu
  464. {
  465.  my $w = shift;
  466.  my $char = shift;
  467.  return unless(defined $char && $char ne "");
  468.  $w = $w->toplevel->FindMenu($char);
  469.  $w->PostFirst() if (defined $w);
  470. }
  471. # tkFirstMenu --
  472. # This procedure traverses to the first menubutton in the toplevel
  473. # for a given window, and posts that menubutton's menu.
  474. #
  475. # Arguments:
  476. # w - Name of a window. Selects which toplevel
  477. # to search for menubuttons.
  478. sub FirstMenu
  479. {
  480.  my $w = shift;
  481.  $w = $w->toplevel->FindMenu("");
  482.  $w->PostFirst() if (defined $w);
  483. }
  484.  
  485. # These wrappers don't use method syntax so need to live
  486. # in same package as raw Tk routines are newXS'ed into.
  487.  
  488. sub Selection
  489. {my $widget = shift;
  490.  my $cmd    = shift;
  491.  croak "Use SelectionOwn/SelectionOwner" if ($cmd eq 'own');
  492.  croak "Use Selection\u$cmd()";
  493. }
  494.  
  495. sub Clipboard
  496. {my $w = shift;
  497.  my $cmd    = shift;
  498.  croak "Use clipboard\u$cmd()";
  499. }
  500.  
  501. sub Receive
  502. {
  503.  my $w = shift;
  504.  warn "Receive(" . join(',',@_) .")";
  505.  die "Tk rejects send(" . join(',',@_) .")\n";
  506. }
  507.  
  508. sub break
  509. {
  510.  die "_TK_BREAK_\n";
  511. }
  512.  
  513. sub idletasks
  514. {
  515.  shift->update('idletasks');
  516. }
  517.  
  518. sub updateWidgets
  519. {
  520.  my ($w) = @_;
  521.  while ($w->DoOneEvent(DONT_WAIT|IDLE_EVENTS|WINDOW_EVENTS))
  522.   {
  523.   }
  524.  $w;
  525. }
  526.  
  527. sub ImageNames
  528. {
  529.  image('names');
  530. }
  531.  
  532. sub ImageTypes
  533. {
  534.  image('types');
  535. }
  536.  
  537. sub interps
  538. {
  539.  my $w = shift;
  540.  return $w->winfo('interps','-displayof');
  541. }
  542.  
  543. sub findINC
  544. {
  545.  my $file = join('/',@_);
  546.  my $dir;
  547.  $file  =~ s,::,/,g;
  548.  foreach $dir (@INC)
  549.   {
  550.    my $path;
  551.    return $path if (-e ($path = "$dir/$file"));
  552.   }
  553.  return undef;
  554. }
  555.  
  556. sub lsearch
  557. {my $ar = shift;
  558.  my $x  = shift;
  559.  my $i;
  560.  for ($i = 0; $i < scalar @$ar; $i++)
  561.   {
  562.    return $i if ($$ar[$i] eq $x);
  563.   }
  564.  return -1;
  565. }
  566.  
  567. # a wrapper on eval which turns off user $SIG{__DIE__}
  568. sub catch (&)
  569. {
  570.  my $sub = shift;
  571.  eval {local $SIG{'__DIE__'}; &$sub };
  572. }
  573.  
  574.