home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _36a00ddd2baab829a68f9644c7e2a011 < prev    next >
Encoding:
Text File  |  2004-06-01  |  16.2 KB  |  616 lines
  1. package Tk::Entry;
  2.  
  3. # Converted from entry.tcl --
  4. #
  5. # This file defines the default bindings for Tk entry widgets.
  6. #
  7. # @(#) entry.tcl 1.22 94/12/17 16:05:14
  8. #
  9. # Copyright (c) 1992-1994 The Regents of the University of California.
  10. # Copyright (c) 1994 Sun Microsystems, Inc.
  11. # Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
  12. # This program is free software; you can redistribute it and/or
  13.  
  14. use vars qw($VERSION);
  15. use strict;
  16. $VERSION = sprintf '4.%03d',q$Revision: #17 $ =~ /#(\d+)/;
  17.  
  18. # modify it under the same terms as Perl itself, subject
  19. # to additional disclaimer in license.terms due to partial
  20. # derivation from Tk4.0 sources.
  21.  
  22. use Tk::Widget ();
  23. use Tk::Clipboard ();
  24. use base  qw(Tk::Clipboard Tk::Widget);
  25.  
  26. import Tk qw(Ev $XS_VERSION);
  27.  
  28. Construct Tk::Widget 'Entry';
  29.  
  30. bootstrap Tk::Entry;
  31.  
  32. sub Tk_cmd { \&Tk::entry }
  33.  
  34. Tk::Methods('bbox','delete','get','icursor','index','insert','scan',
  35.             'selection','validate','xview');
  36.  
  37. use Tk::Submethods ( 'selection' => [qw(clear range adjust present to from)],
  38.              'xview'     => [qw(moveto scroll)],
  39.                    );
  40.  
  41. sub wordstart
  42. {my ($w,$pos) = @_;
  43.  my $string = $w->get;
  44.  $pos = $w->index('insert')-1 unless(defined $pos);
  45.  $string = substr($string,0,$pos);
  46.  $string =~ s/\S*$//;
  47.  length $string;
  48. }
  49.  
  50. sub wordend
  51. {my ($w,$pos) = @_;
  52.  my $string = $w->get;
  53.  my $anc = length $string;
  54.  $pos = $w->index('insert') unless(defined $pos);
  55.  $string = substr($string,$pos);
  56.  $string =~ s/^(?:((?=\s)\s*|(?=\S)\S*))//x;
  57.  $anc - length($string);
  58. }
  59.  
  60. sub deltainsert
  61. {
  62.  my ($w,$d) = @_;
  63.  return $w->index('insert')+$d;
  64. }
  65.  
  66. #
  67. # Bind --
  68. # This procedure is invoked the first time the mouse enters an
  69. # entry widget or an entry widget receives the input focus. It creates
  70. # all of the class bindings for entries.
  71. #
  72. # Arguments:
  73. # event - Indicates which event caused the procedure to be invoked
  74. # (Enter or FocusIn). It is used so that we can carry out
  75. # the functions of that event in addition to setting up
  76. # bindings.
  77. sub ClassInit
  78. {
  79.  my ($class,$mw) = @_;
  80.  
  81.  $class->SUPER::ClassInit($mw);
  82.  
  83.  # <<Cut>>, <<Copy>> and <<Paste>> defined in Tk::Clipboard
  84.  $mw->bind($class,'<<Clear>>' => sub {
  85.            my $w = shift;
  86.            $w->delete("sel.first", "sel.last");
  87.        });
  88.  $mw->bind($class,'<<PasteSelection>>' => [sub {
  89.            my($w, $x) = @_;
  90.            # XXX logic in Tcl/Tk version screwed up?
  91.            if (!$Tk::strictMotif && !$Tk::mouseMoved) {
  92.            $w->Paste($x);
  93.            }
  94.        }, Ev('x')]);
  95.  
  96.  # Standard Motif bindings:
  97.  # The <Escape> binding is different from the Tcl/Tk version:
  98.  $mw->bind($class,'<Escape>','selectionClear');
  99.  
  100.  $mw->bind($class,'<1>',['Button1',Ev('x'),Ev('y')]);
  101.  $mw->bind($class,'<ButtonRelease-1>',['Button1Release',Ev('x'),Ev('y')]);
  102.  $mw->bind($class,'<B1-Motion>',['Motion',Ev('x'),Ev('y')]);
  103.  
  104.  $mw->bind($class,'<Double-1>',['MouseSelect',Ev('x'),'word','sel.first']);
  105.  $mw->bind($class,'<Double-Shift-1>',['MouseSelect',Ev('x'),'word']);
  106.  $mw->bind($class,'<Triple-1>',['MouseSelect',Ev('x'),'line',0]);
  107.  $mw->bind($class,'<Triple-Shift-1>',['MouseSelect',Ev('x'),'line']);
  108.  
  109.  $mw->bind($class,'<Shift-1>','Shift_1');
  110.  
  111.  
  112.  $mw->bind($class,'<B1-Leave>',['AutoScan',Ev('x')]);
  113.  $mw->bind($class,'<B1-Enter>','CancelRepeat');
  114.  $mw->bind($class,'<Control-1>','Control_1');
  115.  $mw->bind($class,'<Left>', ['SetCursor',Ev('deltainsert',-1)]);
  116.  $mw->bind($class,'<Right>',['SetCursor',Ev('deltainsert',1)]);
  117.  $mw->bind($class,'<Shift-Left>',['KeySelect',Ev('deltainsert',-1)]);
  118.  $mw->bind($class,'<Shift-Right>',['KeySelect',Ev('deltainsert',1)]);
  119.  $mw->bind($class,'<Control-Left>',['SetCursor',Ev(['wordstart'])]);
  120.  $mw->bind($class,'<Control-Right>',['SetCursor',Ev(['wordend'])]);
  121.  $mw->bind($class,'<Shift-Control-Left>',['KeySelect',Ev(['wordstart'])]);
  122.  $mw->bind($class,'<Shift-Control-Right>',['KeySelect',Ev(['wordend'])]);
  123.  $mw->bind($class,'<Home>',['SetCursor',0]);
  124.  $mw->bind($class,'<Shift-Home>',['KeySelect',0]);
  125.  $mw->bind($class,'<End>',['SetCursor','end']);
  126.  $mw->bind($class,'<Shift-End>',['KeySelect','end']);
  127.  $mw->bind($class,'<Delete>','Delete');
  128.  
  129.  $mw->bind($class,'<BackSpace>','Backspace');
  130.  
  131.  $mw->bind($class,'<Control-space>',['selectionFrom','insert']);
  132.  $mw->bind($class,'<Select>',['selectionFrom','insert']);
  133.  $mw->bind($class,'<Control-Shift-space>',['selectionAdjust','insert']);
  134.  $mw->bind($class,'<Shift-Select>',['selectionAdjust','insert']);
  135.  
  136.  $mw->bind($class,'<Control-slash>',['selectionRange',0,'end']);
  137.  $mw->bind($class,'<Control-backslash>','selectionClear');
  138.  
  139.  # $class->clipboardOperations($mw,qw[Copy Cut Paste]);
  140.  
  141.  $mw->bind($class,'<KeyPress>', ['Insert',Ev('A')]);
  142.  
  143.  # Ignore all Alt, Meta, and Control keypresses unless explicitly bound.
  144.  # Otherwise, if a widget binding for one of these is defined, the
  145.  # <KeyPress> class binding will also fire and insert the character,
  146.  # which is wrong.  Ditto for Return, and Tab.
  147.  
  148.  $mw->bind($class,'<Alt-KeyPress>' ,'NoOp');
  149.  $mw->bind($class,'<Meta-KeyPress>' ,'NoOp');
  150.  $mw->bind($class,'<Control-KeyPress>' ,'NoOp');
  151.  $mw->bind($class,'<Return>' ,'NoOp');
  152.  $mw->bind($class,'<KP_Enter>' ,'NoOp');
  153.  $mw->bind($class,'<Tab>' ,'NoOp');
  154.  if ($mw->windowingsystem =~ /^(?:classic|aqua)$/)
  155.   {
  156.    $mw->bind($class,'<Command-KeyPress>', 'NoOp');
  157.   }
  158.  
  159.  # On Windows, paste is done using Shift-Insert.  Shift-Insert already
  160.  # generates the <<Paste>> event, so we don't need to do anything here.
  161.  if ($Tk::platform ne 'MSWin32')
  162.   {
  163.    $mw->bind($class,'<Insert>','InsertSelection');
  164.   }
  165.  
  166.  if (!$Tk::strictMotif)
  167.   {
  168.    # Additional emacs-like bindings:
  169.    $mw->bind($class,'<Control-a>',['SetCursor',0]);
  170.    $mw->bind($class,'<Control-b>',['SetCursor',Ev('deltainsert',-1)]);
  171.    $mw->bind($class,'<Control-d>',['delete','insert']);
  172.    $mw->bind($class,'<Control-e>',['SetCursor','end']);
  173.    $mw->bind($class,'<Control-f>',['SetCursor',Ev('deltainsert',1)]);
  174.    $mw->bind($class,'<Control-h>','Backspace');
  175.    $mw->bind($class,'<Control-k>',['delete','insert','end']);
  176.  
  177.    $mw->bind($class,'<Control-t>','Transpose');
  178.  
  179.    # XXX The original Tcl/Tk bindings use NextWord/PreviousWord instead
  180.    $mw->bind($class,'<Meta-b>',['SetCursor',Ev(['wordstart'])]);
  181.    $mw->bind($class,'<Meta-d>',['delete','insert',Ev(['wordend'])]);
  182.    $mw->bind($class,'<Meta-f>',['SetCursor',Ev(['wordend'])]);
  183.    $mw->bind($class,'<Meta-BackSpace>',['delete',Ev(['wordstart']),'insert']);
  184.    $mw->bind($class,'<Meta-Delete>',['delete',Ev(['wordstart']),'insert']);
  185.  
  186.    # A few additional bindings from John Ousterhout.
  187. # XXX conflicts with <<Copy>>:  $mw->bind($class,'<Control-w>',['delete',Ev(['wordstart']),'insert']);
  188.    $mw->bind($class,'<2>','Button_2');
  189.    $mw->bind($class,'<B2-Motion>','B2_Motion');
  190. # XXX superseded by <<PasteSelection>>: $mw->bind($class,'<ButtonRelease-2>','ButtonRelease_2');
  191.   }
  192.  return $class;
  193. }
  194.  
  195.  
  196. sub Shift_1
  197. {
  198.  my $w = shift;
  199.  my $Ev = $w->XEvent;
  200.  $Tk::selectMode = 'char';
  201.  $w->selectionAdjust('@' . $Ev->x)
  202. }
  203.  
  204.  
  205. sub Control_1
  206. {
  207.  my $w = shift;
  208.  my $Ev = $w->XEvent;
  209.  $w->icursor('@' . $Ev->x)
  210. }
  211.  
  212.  
  213. sub Delete
  214. {
  215.  my $w = shift;
  216.  if ($w->selectionPresent)
  217.  {
  218.  $w->deleteSelected
  219.  }
  220.  else
  221.  {
  222.  $w->delete('insert')
  223.  }
  224. }
  225.  
  226.  
  227. sub InsertSelection
  228. {
  229.  my $w = shift;
  230.  eval {local $SIG{__DIE__}; $w->Insert($w->GetSelection)}
  231. }
  232.  
  233.  
  234. # Original is ::tk::EntryScanMark
  235. sub Button_2
  236. {
  237.  my $w = shift;
  238.  my $Ev = $w->XEvent;
  239.  $w->scan('mark',$Ev->x);
  240.  $Tk::x = $Ev->x;
  241.  $Tk::y = $Ev->y;
  242.  $Tk::mouseMoved = 0
  243. }
  244.  
  245.  
  246. # Original is ::tk::EntryScanDrag
  247. sub B2_Motion
  248. {
  249.  my $w = shift;
  250.  my $Ev = $w->XEvent;
  251.  # Make sure these exist, as some weird situations can trigger the
  252.  # motion binding without the initial press.  [Tcl/Tk Bug #220269]
  253.  if (!defined $Tk::x) { $Tk::x = $Ev->x }
  254.  if (abs(($Ev->x-$Tk::x)) > 2)
  255.  {
  256.  $Tk::mouseMoved = 1
  257.  }
  258.  $w->scan('dragto',$Ev->x)
  259. }
  260.  
  261.  
  262. # XXX Not needed anymore
  263. sub ButtonRelease_2
  264. {
  265.  my $w = shift;
  266.  my $Ev = $w->XEvent;
  267.  if (!$Tk::mouseMoved)
  268.  {
  269.  eval
  270.  {local $SIG{__DIE__};
  271.  $w->insert('insert',$w->SelectionGet);
  272.  $w->SeeInsert;
  273.  }
  274.  }
  275. }
  276.  
  277. sub Button1Release
  278. {
  279.  shift->CancelRepeat;
  280. }
  281.  
  282. # ::tk::EntryClosestGap --
  283. # Given x and y coordinates, this procedure finds the closest boundary
  284. # between characters to the given coordinates and returns the index
  285. # of the character just after the boundary.
  286. #
  287. # Arguments:
  288. # w -           The entry window.
  289. # x -           X-coordinate within the window.
  290. sub ClosestGap
  291. {
  292.  my($w, $x) = @_;
  293.  my $pos = $w->index('@'.$x);
  294.  my @bbox = $w->bbox($pos);
  295.  if ($x - $bbox[0] < $bbox[2] / 2)
  296.   {
  297.    return $pos;
  298.   }
  299.  $pos + 1;
  300. }
  301.  
  302. # Button1 --
  303. # This procedure is invoked to handle button-1 presses in entry
  304. # widgets. It moves the insertion cursor, sets the selection anchor,
  305. # and claims the input focus.
  306. #
  307. # Arguments:
  308. # w - The entry window in which the button was pressed.
  309. # x - The x-coordinate of the button press.
  310. sub Button1
  311. {
  312.  my $w = shift;
  313.  my $x = shift;
  314.  $Tk::selectMode = 'char';
  315.  $Tk::mouseMoved = 0;
  316.  $Tk::pressX = $x;
  317.  $w->icursor($w->ClosestGap($x));
  318.  $w->selectionFrom('insert');
  319.  $w->selectionClear;
  320.  if ($w->cget('-state') ne 'disabled')
  321.   {
  322.    $w->focus()
  323.   }
  324. }
  325.  
  326. sub Motion
  327. {
  328.  my ($w,$x,$y) = @_;
  329.  $Tk::x = $x; # XXX ?
  330.  $w->MouseSelect($x);
  331. }
  332.  
  333. # MouseSelect --
  334. # This procedure is invoked when dragging out a selection with
  335. # the mouse. Depending on the selection mode (character, word,
  336. # line) it selects in different-sized units. This procedure
  337. # ignores mouse motions initially until the mouse has moved from
  338. # one character to another or until there have been multiple clicks.
  339. #
  340. # Arguments:
  341. # w - The entry window in which the button was pressed.
  342. # x - The x-coordinate of the mouse.
  343. sub MouseSelect
  344. {
  345.  
  346.  my $w = shift;
  347.  my $x = shift;
  348.  return if UNIVERSAL::isa($w, 'Tk::Spinbox') and $w->{_element} ne 'entry';
  349.  $Tk::selectMode = shift if (@_);
  350.  my $cur = $w->index($w->ClosestGap($x));
  351.  return unless defined $cur;
  352.  my $anchor = $w->index('anchor');
  353.  return unless defined $anchor;
  354.  $Tk::pressX ||= $x; # XXX Better use "if !defined $Tk::pressX"?
  355.  if (($cur != $anchor) || (abs($Tk::pressX - $x) >= 3))
  356.   {
  357.    $Tk::mouseMoved = 1
  358.   }
  359.  my $mode = $Tk::selectMode;
  360.  return unless $mode;
  361.  if ($mode eq 'char')
  362.   {
  363.    # The Tcl version uses selectionRange here XXX
  364.    if ($Tk::mouseMoved)
  365.     {
  366.      if ($cur < $anchor)
  367.       {
  368.        $w->selectionTo($cur)
  369.       }
  370.      else
  371.       {
  372.        $w->selectionTo($cur+1)
  373.       }
  374.     }
  375.   }
  376.  elsif ($mode eq 'word')
  377.   {
  378.    # The Tcl version uses tcl_wordBreakBefore/After here XXX
  379.    if ($cur < $w->index('anchor'))
  380.     {
  381.      $w->selectionRange($w->wordstart($cur),$w->wordend($anchor-1))
  382.     }
  383.    else
  384.     {
  385.      $w->selectionRange($w->wordstart($anchor),$w->wordend($cur))
  386.     }
  387.   }
  388.  elsif ($mode eq 'line')
  389.   {
  390.    $w->selectionRange(0,'end')
  391.   }
  392.  if (@_)
  393.   {
  394.    my $ipos = shift;
  395.    eval {local $SIG{__DIE__}; $w->icursor($ipos) };
  396.   }
  397.  $w->idletasks;
  398. }
  399. # ::tk::EntryPaste --
  400. # This procedure sets the insertion cursor to the current mouse position,
  401. # pastes the selection there, and sets the focus to the window.
  402. #
  403. # Arguments:
  404. # w -           The entry window.
  405. # x -           X position of the mouse.
  406. sub Paste
  407. {
  408.  my($w, $x) = @_;
  409.  $w->icursor($w->ClosestGap($x));
  410.  eval { local $SIG{__DIE__};
  411.     $w->insert("insert", $w->GetSelection);
  412.     $w->SeeInsert; # Perl/Tk extension
  413.       };
  414.  if ($w->cget(-state) ne 'disabled')
  415.   {
  416.    $w->focus;
  417.   }
  418. }
  419. # AutoScan --
  420. # This procedure is invoked when the mouse leaves an entry window
  421. # with button 1 down.  It scrolls the window left or right,
  422. # depending on where the mouse is, and reschedules itself as an
  423. # 'after' command so that the window continues to scroll until the
  424. # mouse moves back into the window or the mouse button is released.
  425. #
  426. # Arguments:
  427. # w - The entry window.
  428. # x - The x-coordinate of the mouse when it left the window.
  429. sub AutoScan
  430. {
  431.  my $w = shift;
  432.  my $x = shift;
  433.  return if !Tk::Exists($w);
  434.  if ($x >= $w->width)
  435.   {
  436.    $w->xview('scroll',2,'units')
  437.   }
  438.  elsif ($x < 0)
  439.   {
  440.    $w->xview('scroll',-2,'units')
  441.   }
  442.  else
  443.   {
  444.    return;
  445.   }
  446.  $w->MouseSelect($x);
  447.  $w->RepeatId($w->after(50,['AutoScan',$w,$x]))
  448. }
  449. # KeySelect
  450. # This procedure is invoked when stroking out selections using the
  451. # keyboard. It moves the cursor to a new position, then extends
  452. # the selection to that position.
  453. #
  454. # Arguments:
  455. # w - The entry window.
  456. # new - A new position for the insertion cursor (the cursor hasn't
  457. # actually been moved to this position yet).
  458. sub KeySelect
  459. {
  460.  my $w = shift;
  461.  my $new = shift;
  462.  if (!$w->selectionPresent)
  463.   {
  464.    $w->selectionFrom('insert');
  465.    $w->selectionTo($new)
  466.   }
  467.  else
  468.   {
  469.    $w->selectionAdjust($new)
  470.   }
  471.  $w->icursor($new);
  472.  $w->SeeInsert;
  473. }
  474. # Insert --
  475. # Insert a string into an entry at the point of the insertion cursor.
  476. # If there is a selection in the entry, and it covers the point of the
  477. # insertion cursor, then delete the selection before inserting.
  478. #
  479. # Arguments:
  480. # w - The entry window in which to insert the string
  481. # s - The string to insert (usually just a single character)
  482. sub Insert
  483. {
  484.  my $w = shift;
  485.  my $s = shift;
  486.  return unless (defined $s && $s ne '');
  487.  eval
  488.   {local $SIG{__DIE__};
  489.    my $insert = $w->index('insert');
  490.    if ($w->index('sel.first') <= $insert && $w->index('sel.last') >= $insert)
  491.     {
  492.      $w->deleteSelected
  493.     }
  494.   };
  495.  $w->insert('insert',$s);
  496.  $w->SeeInsert
  497. }
  498. # Backspace --
  499. # Backspace over the character just before the insertion cursor.
  500. #
  501. # Arguments:
  502. # w - The entry window in which to backspace.
  503. sub Backspace
  504. {
  505.  my $w = shift;
  506.  if ($w->selectionPresent)
  507.   {
  508.    $w->deleteSelected
  509.   }
  510.  else
  511.   {
  512.    my $x = $w->index('insert')-1;
  513.    $w->delete($x) if ($x >= 0);
  514.    # XXX Missing repositioning part from Tcl/Tk source
  515.   }
  516. }
  517. # SeeInsert
  518. # Make sure that the insertion cursor is visible in the entry window.
  519. # If not, adjust the view so that it is.
  520. #
  521. # Arguments:
  522. # w - The entry window.
  523. sub SeeInsert
  524. {
  525.  my $w = shift;
  526.  my $c = $w->index('insert');
  527. #
  528. # Probably a bug in your version of tcl/tk (I've not this problem
  529. # when I test Entry in the widget demo for tcl/tk)
  530. # index('\@0') give always 0. Consequence :
  531. #    if you make <Control-E> or <Control-F> view is adapted
  532. #    but with <Control-A> or <Control-B> view is not adapted
  533. #
  534.  my $left = $w->index('@0');
  535.  if ($left > $c)
  536.   {
  537.    $w->xview($c);
  538.    return;
  539.   }
  540.  my $x = $w->width;
  541.  while ($w->index('@' . $x) <= $c && $left < $c)
  542.   {
  543.    $left += 1;
  544.    $w->xview($left)
  545.   }
  546. }
  547. # SetCursor
  548. # Move the insertion cursor to a given position in an entry. Also
  549. # clears the selection, if there is one in the entry, and makes sure
  550. # that the insertion cursor is visible.
  551. #
  552. # Arguments:
  553. # w - The entry window.
  554. # pos - The desired new position for the cursor in the window.
  555. sub SetCursor
  556. {
  557.  my $w = shift;
  558.  my $pos = shift;
  559.  $w->icursor($pos);
  560.  $w->selectionClear;
  561.  $w->SeeInsert;
  562. }
  563. # Transpose
  564. # This procedure implements the 'transpose' function for entry widgets.
  565. # It tranposes the characters on either side of the insertion cursor,
  566. # unless the cursor is at the end of the line.  In this case it
  567. # transposes the two characters to the left of the cursor.  In either
  568. # case, the cursor ends up to the right of the transposed characters.
  569. #
  570. # Arguments:
  571. # w - The entry window.
  572. sub Transpose
  573. {
  574.  my $w = shift;
  575.  my $i = $w->index('insert');
  576.  $i++ if ($i < $w->index('end'));
  577.  my $first = $i-2;
  578.  return if ($first < 0);
  579.  my $str = $w->get;
  580.  my $new = substr($str,$i-1,1) . substr($str,$first,1);
  581.  $w->delete($first,$i);
  582.  $w->insert('insert',$new);
  583.  $w->SeeInsert;
  584. }
  585.  
  586. sub tabFocus
  587. {
  588.  my $w = shift;
  589.  $w->selectionRange(0,'end');
  590.  $w->icursor('end');
  591.  $w->SUPER::tabFocus;
  592. }
  593.  
  594. # ::tk::EntryGetSelection --
  595. #
  596. # Returns the selected text of the entry with respect to the -show option.
  597. #
  598. # Arguments:
  599. # w -         The entry window from which the text to get
  600. sub getSelected
  601. {
  602.  my $w = shift;
  603.  return undef unless $w->selectionPresent;
  604.  my $str = $w->get;
  605.  my $show = $w->cget('-show');
  606.  $str = $show x length($str) if (defined $show);
  607.  my $s = $w->index('sel.first');
  608.  my $e = $w->index('sel.last');
  609.  return substr($str,$s,$e-$s);
  610. }
  611.  
  612.  
  613. 1;
  614.  
  615. __END__
  616.