home *** CD-ROM | disk | FTP | other *** search
/ CD Actual Thematic 7: Programming / CDAT7.iso / Share / Editores / Perl5 / perl / lib / site / Tk / Text.pm < prev    next >
Encoding:
Text File  |  1997-08-10  |  21.3 KB  |  836 lines
  1. # text.tcl --
  2. #
  3. # This file defines the default bindings for Tk text widgets.
  4. #
  5. # @(#) text.tcl 1.18 94/12/17 16:05:26
  6. #
  7. # Copyright (c) 1992-1994 The Regents of the University of California.
  8. # Copyright (c) 1994 Sun Microsystems, Inc.
  9. #
  10. # See the file "license.terms" for information on usage and redistribution
  11. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  12.  
  13. require Tk;
  14. package Tk::Text; 
  15. use AutoLoader;
  16. use Carp;
  17.  
  18. @ISA = qw(Tk::Widget);
  19.  
  20. Construct Tk::Widget 'Text';
  21.  
  22. bootstrap Tk::Text $Tk::VERSION;
  23.  
  24. sub Tk_cmd { \&Tk::text }
  25.  
  26. import Tk qw(Ev);
  27.  
  28. sub Tk::Widget::ScrlText { shift->Scrolled('Text' => @_) }
  29.  
  30. use Tk::Submethods ( 'mark' => [qw(gravity names set unset)],
  31.                      'scan' => [qw(mark dragto)],
  32.                      'tag'  => [qw(add bind cget configure delete lower 
  33.                                names  nextrange raise ranges remove)],
  34.                      'window' => [qw(cget configure create)]
  35.                    );
  36.  
  37. sub Tag;
  38. sub Tags;
  39.  
  40. 1;
  41.  
  42. __END__
  43.  
  44.  
  45. sub bindRdOnly
  46. {
  47.  require Tk::Clipboard;
  48.  
  49.  my ($class,$mw) = @_;
  50.  
  51.  # Standard Motif bindings:
  52.  $mw->bind($class,"<1>",['Button1',Ev('x'),Ev('y')]);
  53.  $mw->bind($class,"<Meta-B1-Motion>",'NoOp');
  54.  $mw->bind($class,"<Meta-1>",'NoOp');
  55.  
  56.  $mw->bind($class,"<B1-Motion>",
  57.             sub
  58.             {
  59.              my $w = shift;
  60.              my $Ev = $w->XEvent;
  61.              $Tk::x = $Ev->x;
  62.              $Tk::y = $Ev->y;
  63.              $w->SelectTo($Ev->xy)
  64.             }
  65.            )
  66.  ;
  67.  $mw->bind($class,"<Double-1>",
  68.             sub
  69.             {
  70.              my $w = shift;
  71.              my $Ev = $w->XEvent;
  72.              $w->SelectTo($Ev->xy,"word");
  73.              Tk::catch { $w->mark("set","insert","sel.first") }
  74.             }
  75.            )
  76.  ;
  77.  $mw->bind($class,"<Triple-1>",
  78.             sub
  79.             {
  80.              my $w = shift;
  81.              my $Ev = $w->XEvent;
  82.              $w->SelectTo($Ev->xy,"line");
  83.              Tk::catch { $w->mark("set","insert","sel.first") };
  84.             }
  85.            )
  86.  ;
  87.  $mw->bind($class,"<Shift-1>",
  88.             sub
  89.             {
  90.              my $w = shift;
  91.              my $Ev = $w->XEvent;
  92.              $w->ResetAnchor($Ev->xy);
  93.              $w->SelectTo($Ev->xy,"char")
  94.             }
  95.            )
  96.  ;
  97.  $mw->bind($class,"<Double-Shift-1>",['SelectTo',Ev('@'),"word"]);
  98.  $mw->bind($class,"<Triple-Shift-1>",['SelectTo',Ev('@'),"line"]);
  99.  
  100.  $mw->bind($class,"<B1-Leave>",
  101.             sub
  102.             {
  103.              my $w = shift;
  104.              my $Ev = $w->XEvent;
  105.              $Tk::x = $Ev->x;
  106.              $Tk::y = $Ev->y;
  107.              $w->AutoScan;
  108.             }
  109.            )
  110.  ;
  111.  
  112.  $mw->bind($class,"<B1-Enter>",'CancelRepeat');
  113.  $mw->bind($class,"<ButtonRelease-1>",'CancelRepeat');
  114.  $mw->bind($class,"<Control-1>",["mark","set","insert",Ev('@')]);
  115.  $mw->bind($class,"<Left>",['SetCursor',Ev("index","insert-1c")]);
  116.  $mw->bind($class,"<Shift-Left>",['KeySelect',Ev("index","insert-1c")]);
  117.  $mw->bind($class,"<Right>",['SetCursor',Ev("index","insert+1c")]);
  118.  $mw->bind($class,"<Shift-Right>",['KeySelect',Ev("index","insert+1c")]);
  119.  $mw->bind($class,"<Up>",['SetCursor',Ev('UpDownLine',-1)]);
  120.  $mw->bind($class,"<Shift-Up>",['KeySelect',Ev('UpDownLine',-1)]);
  121.  $mw->bind($class,"<Down>",['SetCursor',Ev('UpDownLine',1)]);
  122.  $mw->bind($class,"<Shift-Down>",['KeySelect',Ev('UpDownLine',1)]);
  123.  $mw->bind($class,"<Control-Left>",['SetCursor',Ev("index","insert-1c wordstart")]);
  124.  $mw->bind($class,"<Control-Right>",['SetCursor',Ev("index","insert+1c wordend")]);
  125.  $mw->bind($class,"<Control-Up>",['SetCursor',Ev('PrevPara',"insert")]);
  126.  $mw->bind($class,"<Control-Down>",['SetCursor',Ev('NextPara',"insert")]);
  127.  $mw->bind($class,"<Shift-Control-Left>",['KeySelect',Ev("index","insert-1c wordstart")]);
  128.  $mw->bind($class,"<Shift-Control-Right>",['KeySelect',Ev("index","insert wordend")]);
  129.  $mw->bind($class,"<Shift-Control-Up>",['KeySelect',Ev('PrevPara',"insert")]);
  130.  $mw->bind($class,"<Shift-Control-Down>",['KeySelect',Ev('NextPara',"insert")]);
  131.  $mw->bind($class,"<Prior>",['SetCursor',Ev('ScrollPages',-1)]);
  132.  $mw->bind($class,"<Shift-Prior>",['KeySelect',Ev('ScrollPages',-1)]);
  133.  $mw->bind($class,"<Next>",['SetCursor',Ev('ScrollPages',1)]);
  134.  $mw->bind($class,"<Shift-Next>",['KeySelect',Ev('ScrollPages',1)]);
  135.  $mw->bind($class,"<Control-Prior>",["xview","scroll",-1,"page"]);
  136.  $mw->bind($class,"<Control-Next>",["xview","scroll",1,"page"]);
  137.  $mw->bind($class,"<Home>",['SetCursor',"insert linestart"]);
  138.  $mw->bind($class,"<Shift-Home>",['KeySelect',"insert","linestart"]);
  139.  $mw->bind($class,"<End>",['SetCursor',"insert lineend"]);
  140.  $mw->bind($class,"<Shift-End>",['KeySelect',"insert","lineend"]);
  141.  $mw->bind($class,"<Control-Home>",['SetCursor',"1.0"]);
  142.  $mw->bind($class,"<Control-Shift-Home>",['KeySelect',"1.0"]);
  143.  $mw->bind($class,"<Control-End>",['SetCursor',"end-1char"]);
  144.  $mw->bind($class,"<Control-Shift-End>",['KeySelect',"end-1char"]);
  145.  
  146.  $mw->bind($class,"<Shift-Tab>", 'NoOp'); # Needed only to keep <Tab> binding from triggering; does not have to actually do anything.
  147.  $mw->bind($class,"<Control-Tab>",'focusNext');
  148.  $mw->bind($class,"<Control-Shift-Tab>",'focusPrev');
  149.  
  150.  $mw->bind($class,"<Control-space>",["mark","set","anchor","insert"]);
  151.  $mw->bind($class,"<Select>",["mark","set","anchor","insert"]);
  152.  $mw->bind($class,"<Control-Shift-space>",['SelectTo',"insert","char"]);
  153.  $mw->bind($class,"<Shift-Select>",['SelectTo',"insert","char"]);
  154.  $mw->bind($class,"<Control-slash>",["tag","add","sel","1.0","end"]);
  155.  $mw->bind($class,"<Control-backslash>",["tag","remove","sel","1.0","end"]);
  156.  
  157.  if (!$Tk::strictMotif)
  158.   {
  159.    $mw->bind($class,"<Control-a>",    ['SetCursor',"insert linestart"]);
  160.    $mw->bind($class,"<Control-b>",    ['SetCursor',"insert-1c"]);
  161.    $mw->bind($class,"<Control-e>",    ['SetCursor',"insert lineend"]);
  162.    $mw->bind($class,"<Control-f>",    ['SetCursor',"insert+1c"]);
  163.    $mw->bind($class,"<Meta-b>",       ['SetCursor',"insert-1c wordstart"]);
  164.    $mw->bind($class,"<Meta-f>",       ['SetCursor',"insert wordend"]);
  165.    $mw->bind($class,"<Meta-less>",    ['SetCursor',"1.0"]);
  166.    $mw->bind($class,"<Meta-greater>", ['SetCursor',"end-1c"]);
  167.  
  168.    $mw->bind($class,"<Control-n>",    ['SetCursor',Ev('UpDownLine',1)]);
  169.    $mw->bind($class,"<Control-p>",    ['SetCursor',Ev('UpDownLine',-1)]);
  170.  
  171.    $mw->bind($class,"<2>",['Button2',Ev('x'),Ev('y')]);
  172.    $mw->bind($class,"<B2-Motion>",['Motion2',Ev('x'),Ev('y')]);
  173.  
  174.   }
  175.  $mw->bind($class,"<Destroy>",'Destroy');
  176.  return $class;
  177. }
  178.  
  179.  
  180. sub Motion2
  181. {
  182.  my ($w,$x,$y) = @_;
  183.  $Tk::mouseMoved = 1 if ($x != $Tk::x || $y != $Tk::y);
  184.  $w->scan("dragto",$x,$y) if ($Tk::mouseMoved);
  185. }
  186.  
  187. sub Button2
  188. {
  189.  my ($w,$x,$y) = @_;
  190.  $w->scan("mark",$x,$y);
  191.  $Tk::x = $x;
  192.  $Tk::y = $y;
  193.  $Tk::mouseMoved = 0;
  194. }
  195.                                          
  196.  
  197. sub ClassInit
  198. {
  199.  my ($class,$mw) = @_;
  200.  
  201.  $class->bindRdOnly($mw);
  202.  
  203.  $mw->bind($class,"<Tab>", sub { my $w = shift; $w->Insert("\t"); $w->focus; $w->break});
  204.  
  205.  $mw->bind($class,"<Control-i>", ['Insert',"\t"]);
  206.  $mw->bind($class,"<Return>", ['Insert',"\n"]);
  207.  $mw->bind($class,"<Delete>",'Delete');
  208.  $mw->bind($class,"<BackSpace>",'Backspace');
  209.  
  210.  $class->clipboardKeysyms($mw,"F16","F20","F18");
  211.  
  212.  $mw->bind($class,"<Insert>",
  213.             sub
  214.             {
  215.              my $w = shift;
  216.              Tk::catch { $w->Insert($w->SelectionGet) }
  217.             }
  218.            )
  219.  ;
  220.  $mw->bind($class,"<KeyPress>",['Insert',Ev('A')]);
  221.  # Additional emacs-like bindings:
  222.  
  223.  if (!$Tk::strictMotif)
  224.   {
  225.  
  226.    $mw->bind($class,"<Control-d>",['delete','insert']);
  227.    $mw->bind($class,"<Control-k>",
  228.               sub
  229.               {
  230.                my $w = shift;
  231.                if ($w->compare("insert","==","insert lineend"))
  232.                 {
  233.                  $w->delete("insert")
  234.                 }
  235.                else
  236.                 {
  237.                  $w->delete("insert","insert lineend")
  238.                 }
  239.               }
  240.              )
  241.    ;
  242.    $mw->bind($class,"<Control-o>",
  243.               sub
  244.               {
  245.                my $w = shift;
  246.                $w->insert("insert","\n");
  247.                $w->mark("set","insert","insert-1c")
  248.               }
  249.              )
  250.    ;
  251.    $mw->bind($class,"<Control-t>",'Transpose');
  252.    $mw->bind($class,"<Meta-d>",['delete','insert','insert wordend']);
  253.    $mw->bind($class,"<Meta-BackSpace>",['delete','insert-1c wordstart','insert']);
  254.  
  255.    $class->clipboardKeysyms($mw,"Meta-w","Control-w","Control-y");
  256.    # A few additional bindings of my own.
  257.    $mw->bind($class,"<Control-h>",
  258.               sub
  259.               {
  260.                my $w = shift;
  261.                if ($w->compare("insert","!=","1.0"))
  262.                 {
  263.                  $w->delete("insert-1c");
  264.                  $w->see("insert")
  265.                 }
  266.               }
  267.              )
  268.    ;
  269.    $mw->bind($class,"<Control-v>",
  270.               sub
  271.               {
  272.                my $w = shift;
  273.                Tk::catch
  274.                 {
  275.                  $w->insert("insert",$w->SelectionGet);
  276.                  $w->see("insert")
  277.                 }
  278.               }
  279.              )
  280.    ;
  281.    $mw->bind($class,"<Control-x>",
  282.               sub
  283.               {
  284.                my $w = shift;
  285.                Tk::catch { $w->delete("sel.first","sel.last") }
  286.               }
  287.              )
  288.    ;
  289.    $mw->bind($class,"<ButtonRelease-2>",
  290.               sub
  291.               {
  292.                my $w = shift;
  293.                my $Ev = $w->XEvent;
  294.                if (!$Tk::mouseMoved)
  295.                 {
  296.                  Tk::catch
  297.                   {
  298.                    $w->insert($Ev->xy,$w->SelectionGet);
  299.                   }
  300.                 }
  301.               }
  302.              )
  303.  
  304.  
  305.   }
  306.  $Tk::prevPos = undef;
  307.  return $class;
  308. }
  309.  
  310. sub Backspace
  311. {
  312.  my $w = shift;
  313.  my $sel = Tk::catch { $w->tag("nextrange","sel","1.0","end") };
  314.  if (defined $sel)
  315.   {
  316.    $w->delete("sel.first","sel.last")
  317.   }
  318.  elsif ($w->compare("insert","!=","1.0"))
  319.   {
  320.    $w->delete("insert-1c");
  321.    $w->see("insert")
  322.   }
  323. }
  324.  
  325. sub Delete
  326. {
  327.  my $w = shift;
  328.  my $sel = Tk::catch { $w->tag("nextrange","sel","1.0","end") };
  329.  if (defined $sel)
  330.   {
  331.    $w->delete("sel.first","sel.last")
  332.   }
  333.  else
  334.   {
  335.    $w->delete("insert");
  336.    $w->see("insert")
  337.   }
  338. }
  339.  
  340. # Button1 --
  341. # This procedure is invoked to handle button-1 presses in text
  342. # widgets. It moves the insertion cursor, sets the selection anchor,
  343. # and claims the input focus.
  344. #
  345. # Arguments:
  346. # w - The text window in which the button was pressed.
  347. # x - The x-coordinate of the button press.
  348. # y - The x-coordinate of the button press.
  349. sub Button1
  350. {
  351.  my $w = shift;
  352.  my $x = shift;
  353.  my $y = shift;
  354.  $Tk::selectMode = "char";
  355.  $Tk::mouseMoved = 0;
  356.  $w->mark("set","insert","@".$x.",".$y);
  357.  $w->mark("set","anchor","insert");
  358.  if ($w->cget("-state") eq "normal")
  359.   {
  360.    $w->focus()
  361.   }
  362.  $w->tag("remove","sel","0.0","end");
  363. }
  364. # SelectTo --
  365. # This procedure is invoked to extend the selection, typically when
  366. # dragging it with the mouse. Depending on the selection mode (character,
  367. # word, line) it selects in different-sized units. This procedure
  368. # ignores mouse motions initially until the mouse has moved from
  369. # one character to another or until there have been multiple clicks.
  370. #
  371. # Arguments:
  372. # w - The text window in which the button was pressed.
  373. # index - Index of character at which the mouse button was pressed.
  374. sub SelectTo
  375. {
  376.  my $w = shift;
  377.  my $index = shift;
  378.  $Tk::selectMode = shift if (@_);
  379.  my $cur = $w->index($index);
  380.  my $anchor = Tk::catch { $w->index("anchor") };
  381.  if (!defined $anchor)
  382.   {
  383.    $w->mark("set","anchor",$anchor = $cur);
  384.    $Tk::mouseMoved = 0;
  385.   }
  386.  elsif ($w->compare($cur,"!=",$anchor))
  387.   {
  388.    $Tk::mouseMoved = 1;
  389.   }
  390.  $Tk::selectMode = 'char' unless (defined $Tk::selectMode);
  391.  my $mode = $Tk::selectMode;
  392.  my ($first,$last);
  393.  if ($mode eq "char")
  394.   {
  395.    if ($w->compare($cur,"<","anchor"))
  396.     {
  397.      $first = $cur;
  398.      $last = "anchor";
  399.     }
  400.    else
  401.     {
  402.      $first = "anchor";
  403.      $last = $cur
  404.     }
  405.   }
  406.  elsif ($mode eq "word")
  407.   {
  408.    if ($w->compare($cur,"<","anchor"))
  409.     {
  410.      $first = $w->index("$cur wordstart");
  411.      $last = $w->index("anchor - 1c wordend")
  412.     }
  413.    else
  414.     {
  415.      $first = $w->index("anchor wordstart");
  416.      $last = $w->index("$cur wordend")
  417.     }
  418.   }
  419.  elsif ($mode eq "line")
  420.   {
  421.    if ($w->compare($cur,"<","anchor"))
  422.     {
  423.      $first = $w->index("$cur linestart");
  424.      $last = $w->index("anchor - 1c lineend + 1c")
  425.     }
  426.    else
  427.     {
  428.      $first = $w->index("anchor linestart");
  429.      $last = $w->index("$cur lineend + 1c")
  430.     }
  431.   }
  432.  if ($Tk::mouseMoved || $Tk::selectMode ne "char")
  433.   {
  434.    $w->tag("remove","sel","0.0",$first);
  435.    $w->tag("add","sel",$first,$last);
  436.    $w->tag("remove","sel",$last,"end");
  437.    $w->idletasks;
  438.   }
  439. }
  440. # AutoScan --
  441. # This procedure is invoked when the mouse leaves a text window
  442. # with button 1 down. It scrolls the window up, down, left, or right,
  443. # depending on where the mouse is (this information was saved in
  444. # tkPriv(x) and tkPriv(y)), and reschedules itself as an "after"
  445. # command so that the window continues to scroll until the mouse
  446. # moves back into the window or the mouse button is released.
  447. #
  448. # Arguments:
  449. # w - The text window.
  450. sub AutoScan
  451. {
  452.  my $w = shift;
  453.  if ($Tk::y >= $w->height)
  454.   {
  455.    $w->yview("scroll",2,"units")
  456.   }
  457.  elsif ($Tk::y < 0)
  458.   {
  459.    $w->yview("scroll",-2,"units")
  460.   }
  461.  elsif ($Tk::x >= $w->width)
  462.   {
  463.    $w->xview("scroll",2,"units")
  464.   }
  465.  elsif ($Tk::x < 0)
  466.   {
  467.    $w->xview("scroll",-2,"units")
  468.   }
  469.  else
  470.   {
  471.    return;
  472.   }
  473.  $w->SelectTo("@" . $Tk::x . ",". $Tk::y);
  474.  $w->RepeatId($w->after(50,"AutoScan",$w));
  475. }
  476. # SetCursor
  477. # Move the insertion cursor to a given position in a text. Also
  478. # clears the selection, if there is one in the text, and makes sure
  479. # that the insertion cursor is visible.
  480. #
  481. # Arguments:
  482. # w - The text window.
  483. # pos - The desired new position for the cursor in the window.
  484. sub SetCursor
  485. {
  486.  my $w = shift;
  487.  my $pos = shift;
  488.  $pos = "end - 1 chars" if $w->compare($pos,"==","end");
  489.  $w->mark("set","insert",$pos);
  490.  $w->tag("remove","sel","1.0","end");
  491.  $w->see("insert")
  492. }
  493. # KeySelect
  494. # This procedure is invoked when stroking out selections using the
  495. # keyboard. It moves the cursor to a new position, then extends
  496. # the selection to that position.
  497. #
  498. # Arguments:
  499. # w - The text window.
  500. # new - A new position for the insertion cursor (the cursor has not
  501. # actually been moved to this position yet).
  502. sub KeySelect
  503. {
  504.  my $w = shift;
  505.  my $new = shift;
  506.  my ($first,$last);
  507.  if (!defined $w->tag("nextrange","sel","1.0","end"))
  508.   {
  509.    if ($w->compare($new,"<","insert"))
  510.     {
  511.      $w->tag("add","sel",$new,"insert")
  512.     }
  513.    else
  514.     {
  515.      $w->tag("add","sel","insert",$new)
  516.     }
  517.   }
  518.  else
  519.   {
  520.    if ($w->compare($new,"<","anchor"))
  521.     {
  522.      $first = $new;
  523.      $last = "anchor"
  524.     }
  525.    else
  526.     {
  527.      $first = "anchor";
  528.      $last = $new
  529.     }
  530.    $w->tag("remove","sel","1.0",$first);
  531.    $w->tag("add","sel",$first,$last);
  532.    $w->tag("remove","sel",$last,"end")
  533.   }
  534.  $w->mark("set","insert",$new);
  535.  $w->see("insert");
  536.  $w->idletasks;
  537. }
  538. # ResetAnchor --
  539. # Set the selection anchor to whichever end is farthest from the
  540. # index argument. One special trick: if the selection has two or
  541. # fewer characters, just leave the anchor where it is. In this
  542. # case it does not matter which point gets chosen for the anchor,
  543. # and for the things like Shift-Left and Shift-Right this produces
  544. # better behavior when the cursor moves back and forth across the
  545. # anchor.
  546. #
  547. # Arguments:
  548. # w - The text widget.
  549. # index - Position at which mouse button was pressed, which determines
  550. # which end of selection should be used as anchor point.
  551. sub ResetAnchor
  552. {
  553.  my $w = shift;
  554.  my $index = shift;
  555.  if (!defined $w->tag("ranges","sel"))
  556.   {
  557.    $w->mark("set","anchor",$index);
  558.    return;
  559.   }
  560.  my $a = $w->index($index);
  561.  my $b = $w->index("sel.first");
  562.  my $c = $w->index("sel.last");
  563.  if ($w->compare($a,"<",$b))
  564.   {
  565.    $w->mark("set","anchor","sel.last");
  566.    return;
  567.   }
  568.  if ($w->compare($a,">",$c))
  569.   {
  570.    $w->mark("set","anchor","sel.first");
  571.    return;
  572.   }
  573.  my ($lineA,$chA) = split(/\./,$a);
  574.  my ($lineB,$chB) = split(/\./,$b);
  575.  my ($lineC,$chC) = split(/\./,$c);
  576.  if ($lineB < $lineC+2)
  577.   {
  578.    $total = length($w->get($b,$c));
  579.    if ($total <= 2)
  580.     {
  581.      return;
  582.     }
  583.    if (length($w->get($b,$a)) < $total/2)
  584.     {
  585.      $w->mark("set","anchor","sel.last")
  586.     }
  587.    else
  588.     {
  589.      $w->mark("set","anchor","sel.first")
  590.     }
  591.    return;
  592.   }
  593.  if ($lineA-$lineB < $lineC-$lineA)
  594.   {
  595.    $w->mark("set","anchor","sel.last")
  596.   }
  597.  else
  598.   {
  599.    $w->mark("set","anchor","sel.first")
  600.   }
  601. }
  602. # Insert --
  603. # Insert a string into a text at the point of the insertion cursor.
  604. # If there is a selection in the text, and it covers the point of the
  605. # insertion cursor, then delete the selection before inserting.
  606. #
  607. # Arguments:
  608. # w - The text window in which to insert the string
  609. # s - The string to insert (usually just a single character)
  610. sub Insert
  611. {
  612.  my $w = shift;
  613.  my $s = shift;
  614.  return unless (defined $s && $s ne "");
  615.  Tk::catch
  616.   {
  617.    if ($w->compare("sel.first","<=","insert") && 
  618.        $w->compare("sel.last",">=","insert"))
  619.      {
  620.       $w->delete("sel.first","sel.last")
  621.      }
  622.   };
  623.  $w->insert("insert",$s);
  624.  $w->see("insert")
  625. }
  626. # UpDownLine --
  627. # Returns the index of the character one line above or below the
  628. # insertion cursor. There are two tricky things here. First,
  629. # we want to maintain the original column across repeated operations,
  630. # even though some lines that will get passed through do not have
  631. # enough characters to cover the original column. Second, do not
  632. # try to scroll past the beginning or end of the text.
  633. #
  634. # Arguments:
  635. # w - The text window in which the cursor is to move.
  636. # n - The number of lines to move: -1 for up one line,
  637. # +1 for down one line.
  638. sub UpDownLine
  639. {
  640.  my $w = shift;
  641.  my $n = shift;
  642.  my $i = $w->index("insert");
  643.  my ($line,$char) = split(/\./,$i);
  644.  if (!defined $Tk::prevPos || ($Tk::prevPos cmp $i) != 0)
  645.   {
  646.    $Tk::char = $char
  647.   }
  648.  my $new = $w->index($line+$n . "." . $Tk::char);
  649.  if ($w->compare($new,"==","end") || $w->compare($new,"==","insert linestart"))
  650.   {
  651.    $new = $i
  652.   }
  653.  $Tk::prevPos = $new;
  654.  return $new;
  655. }
  656. # PrevPara --
  657. # Returns the index of the beginning of the paragraph just before a given
  658. # position in the text (the beginning of a paragraph is the first non-blank
  659. # character after a blank line).
  660. #
  661. # Arguments:
  662. # w - The text window in which the cursor is to move.
  663. # pos - Position at which to start search.
  664. sub PrevPara
  665. {
  666.  my $w = shift;
  667.  my $pos = shift;
  668.  $pos = $w->index("$pos linestart");
  669.  while (1)
  670.   {
  671.    if ($w->get("$pos - 1 line") eq "\n" && $w->get($pos) ne "\n" || $pos eq "1.0" )
  672.     {
  673.      my $string = $w->get($pos,"$pos lineend");
  674.      if ($string =~ /^(\s)+/)
  675.       {
  676.        my $off = length($1);
  677.        $pos = $w->index("$pos + $off chars")
  678.       }
  679.      if ($w->compare($pos,"!=","insert") || $pos eq "1.0")
  680.       {
  681.        return $pos;
  682.       }
  683.     }
  684.    $pos = $w->index("$pos - 1 line")
  685.   }
  686. }
  687. # NextPara --
  688. # Returns the index of the beginning of the paragraph just after a given
  689. # position in the text (the beginning of a paragraph is the first non-blank
  690. # character after a blank line).
  691. #
  692. # Arguments:
  693. # w - The text window in which the cursor is to move.
  694. # start - Position at which to start search.
  695. sub NextPara
  696. {
  697.  my $w = shift;
  698.  my $start = shift;
  699.  $pos = $w->index("$start linestart + 1 line");
  700.  while ($w->get($pos) ne "\n")
  701.   {
  702.    if ($w->compare($pos,"==","end"))
  703.     {
  704.      return $w->index("end - 1c");
  705.     }
  706.    $pos = $w->index("$pos + 1 line")
  707.   }
  708.  while ($w->get($pos) eq "\n" )
  709.   {
  710.    $pos = $w->index("$pos + 1 line");
  711.    if ($w->compare($pos,"==","end"))
  712.     {
  713.      return $w->index("end - 1c");
  714.     }
  715.   }
  716.  my $string = $w->get($pos,"$pos lineend");
  717.  if ($string =~ /^(\s+)/)
  718.   {
  719.    my $off = length($1);
  720.    return $w->index("$pos + $off chars");
  721.   }
  722.  return $pos;
  723. }
  724. # ScrollPages --
  725. # This is a utility procedure used in bindings for moving up and down
  726. # pages and possibly extending the selection along the way. It scrolls
  727. # the view in the widget by the number of pages, and it returns the
  728. # index of the character that is at the same position in the new view
  729. # as the insertion cursor used to be in the old view.
  730. #
  731. # Arguments:
  732. # w - The text window in which the cursor is to move.
  733. # count - Number of pages forward to scroll; may be negative
  734. # to scroll backwards.
  735. sub ScrollPages
  736. {
  737.  my $w = shift;
  738.  my $count = shift;
  739.  my @bbox = $w->bbox("insert");
  740.  $w->yview("scroll",$count,"pages");
  741.  if (!@bbox)
  742.   {
  743.    return $w->index("@" . int($w->height/2) . "," . 0);
  744.   }
  745.  $x = int($bbox[0]+$bbox[2]/2);
  746.  $y = int($bbox[1]+$bbox[3]/2);
  747.  return $w->index("@" . $x . "," . $y);
  748. }
  749.  
  750. sub Contents
  751. {
  752.  my $w = shift;
  753.  if (@_)
  754.   {
  755.    $w->delete('1.0','end');
  756.    $w->insert('end',shift);
  757.   }
  758.  else
  759.   {
  760.    return $w->get('1.0','end');
  761.   }
  762. }
  763.  
  764. sub Destroy
  765. {
  766.  my $w = shift;
  767.  delete $w->{_Tags_};
  768. }
  769.  
  770. sub Transpose
  771. {
  772.  my ($w) = @_;
  773.  my $pos = 'insert';
  774.  $pos = $w->index("$pos + 1 char") if ($w->compare($pos,'!=',"$pos lineend"));
  775.  return if ($w->compare("$pos - 1 char",'==','1.0'));
  776.  my $new = $w->get("$pos - 1 char").$w->get("$pos - 2 char");
  777.  $w->delete("$pos - 2 char",$pos);
  778.  $w->insert('insert',$new); 
  779.  $w->see('insert');
  780. }
  781.  
  782. sub deleteSelected
  783. {
  784.  shift->delete("sel.first","sel.last")
  785. }
  786.  
  787. sub Tag
  788. {
  789.  my $w = shift;
  790.  my $name = shift;
  791.  Carp::confess("No args") unless (ref $w and defined $name);
  792.  $w->{_Tags_} = {} unless (exists $w->{_Tags_});
  793.  unless (exists $w->{_Tags_}{$name})
  794.   {
  795.    require Tk::Text::Tag;
  796.    $w->{_Tags_}{$name} = 'Tk::Text::Tag'->new($w,$name);
  797.   }
  798.  $w->{_Tags_}{$name}->configure(@_) if (@_); 
  799.  return $w->{_Tags_}{$name};
  800. }
  801.  
  802. sub Tags
  803. {
  804.  my $w = shift;
  805.  my $name;
  806.  my @result = ();
  807.  foreach $name ($w->tagNames(@_))
  808.   {
  809.    push(@result,$w->Tag($name));
  810.   }
  811.  return @result;
  812. }
  813.  
  814. sub TIEHANDLE
  815. {
  816.  my ($class,$obj) = @_;
  817.  return $obj;
  818. }
  819.  
  820. sub PRINT
  821. {
  822.  my $w = shift;
  823.  while (@_)
  824.   {
  825.    $w->insert('end',shift);
  826.   }
  827. }
  828.  
  829. sub PRINTF
  830. {
  831.  my $w = shift;
  832.  $w->PRINT(sprintf(shift,@_));
  833. }
  834.  
  835.  
  836.