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