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