home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _0d618c1fa311c96dd436b2422ef39bcb < prev    next >
Encoding:
Text File  |  2004-06-01  |  44.2 KB  |  1,654 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. # perl/Tk version:
  10. # Copyright (c) 1995-2004 Nick Ing-Simmons
  11. # Copyright (c) 1999 Greg London
  12. #
  13. # See the file "license.terms" for information on usage and redistribution
  14. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  15. package Tk::Text;
  16. use AutoLoader;
  17. use Carp;
  18. use strict;
  19.  
  20. use Text::Tabs;
  21.  
  22. use vars qw($VERSION);
  23. $VERSION = sprintf '4.%03d', q$Revision: #24 $ =~ /\D(\d+)\s*$/;
  24.  
  25. use Tk qw(Ev $XS_VERSION);
  26. use base  qw(Tk::Clipboard Tk::Widget);
  27.  
  28. Construct Tk::Widget 'Text';
  29.  
  30. bootstrap Tk::Text;
  31.  
  32. sub Tk_cmd { \&Tk::text }
  33.  
  34. sub Tk::Widget::ScrlText { shift->Scrolled('Text' => @_) }
  35.  
  36. Tk::Methods('bbox','compare','debug','delete','dlineinfo','dump','edit',
  37.             'get','image','index','insert','mark','scan','search',
  38.             'see','tag','window','xview','yview');
  39.  
  40. use Tk::Submethods ( 'mark'   => [qw(gravity names next previous set unset)],
  41.              'scan'   => [qw(mark dragto)],
  42.              'tag'    => [qw(add bind cget configure delete lower
  43.                      names nextrange prevrange raise ranges remove)],
  44.              'window' => [qw(cget configure create names)],
  45.              'image'  => [qw(cget configure create names)],
  46.              'xview'  => [qw(moveto scroll)],
  47.              'yview'  => [qw(moveto scroll)],
  48.                      'edit'   => [qw(modified redo reset separator undo)],
  49.              );
  50.  
  51. sub Tag;
  52. sub Tags;
  53.  
  54. sub bindRdOnly
  55. {
  56.  
  57.  my ($class,$mw) = @_;
  58.  
  59.  # Standard Motif bindings:
  60.  $mw->bind($class,'<Meta-B1-Motion>','NoOp');
  61.  $mw->bind($class,'<Meta-1>','NoOp');
  62.  $mw->bind($class,'<Alt-KeyPress>','NoOp');
  63.  $mw->bind($class,'<Escape>','unselectAll');
  64.  
  65.  $mw->bind($class,'<1>',['Button1',Ev('x'),Ev('y')]);
  66.  $mw->bind($class,'<B1-Motion>','B1_Motion' ) ;
  67.  $mw->bind($class,'<B1-Leave>','B1_Leave' ) ;
  68.  $mw->bind($class,'<B1-Enter>','CancelRepeat');
  69.  $mw->bind($class,'<ButtonRelease-1>','CancelRepeat');
  70.  $mw->bind($class,'<Control-1>',['markSet','insert',Ev('@')]);
  71.  
  72.  $mw->bind($class,'<Double-1>','selectWord' ) ;
  73.  $mw->bind($class,'<Triple-1>','selectLine' ) ;
  74.  $mw->bind($class,'<Shift-1>','adjustSelect' ) ;
  75.  $mw->bind($class,'<Double-Shift-1>',['SelectTo',Ev('@'),'word']);
  76.  $mw->bind($class,'<Triple-Shift-1>',['SelectTo',Ev('@'),'line']);
  77.  
  78.  $mw->bind($class,'<Left>',['SetCursor',Ev('index','insert-1c')]);
  79.  $mw->bind($class,'<Shift-Left>',['KeySelect',Ev('index','insert-1c')]);
  80.  $mw->bind($class,'<Control-Left>',['SetCursor',Ev('index','insert-1c wordstart')]);
  81.  $mw->bind($class,'<Shift-Control-Left>',['KeySelect',Ev('index','insert-1c wordstart')]);
  82.  
  83.  $mw->bind($class,'<Right>',['SetCursor',Ev('index','insert+1c')]);
  84.  $mw->bind($class,'<Shift-Right>',['KeySelect',Ev('index','insert+1c')]);
  85.  $mw->bind($class,'<Control-Right>',['SetCursor',Ev('index','insert+1c wordend')]);
  86.  $mw->bind($class,'<Shift-Control-Right>',['KeySelect',Ev('index','insert wordend')]);
  87.  
  88.  $mw->bind($class,'<Up>',['SetCursor',Ev('UpDownLine',-1)]);
  89.  $mw->bind($class,'<Shift-Up>',['KeySelect',Ev('UpDownLine',-1)]);
  90.  $mw->bind($class,'<Control-Up>',['SetCursor',Ev('PrevPara','insert')]);
  91.  $mw->bind($class,'<Shift-Control-Up>',['KeySelect',Ev('PrevPara','insert')]);
  92.  
  93.  $mw->bind($class,'<Down>',['SetCursor',Ev('UpDownLine',1)]);
  94.  $mw->bind($class,'<Shift-Down>',['KeySelect',Ev('UpDownLine',1)]);
  95.  $mw->bind($class,'<Control-Down>',['SetCursor',Ev('NextPara','insert')]);
  96.  $mw->bind($class,'<Shift-Control-Down>',['KeySelect',Ev('NextPara','insert')]);
  97.  
  98.  $mw->bind($class,'<Home>',['SetCursor','insert linestart']);
  99.  $mw->bind($class,'<Shift-Home>',['KeySelect','insert linestart']);
  100.  $mw->bind($class,'<Control-Home>',['SetCursor','1.0']);
  101.  $mw->bind($class,'<Control-Shift-Home>',['KeySelect','1.0']);
  102.  
  103.  $mw->bind($class,'<End>',['SetCursor','insert lineend']);
  104.  $mw->bind($class,'<Shift-End>',['KeySelect','insert lineend']);
  105.  $mw->bind($class,'<Control-End>',['SetCursor','end-1char']);
  106.  $mw->bind($class,'<Control-Shift-End>',['KeySelect','end-1char']);
  107.  
  108.  $mw->bind($class,'<Prior>',['SetCursor',Ev('ScrollPages',-1)]);
  109.  $mw->bind($class,'<Shift-Prior>',['KeySelect',Ev('ScrollPages',-1)]);
  110.  $mw->bind($class,'<Control-Prior>',['xview','scroll',-1,'page']);
  111.  
  112.  $mw->bind($class,'<Next>',['SetCursor',Ev('ScrollPages',1)]);
  113.  $mw->bind($class,'<Shift-Next>',['KeySelect',Ev('ScrollPages',1)]);
  114.  $mw->bind($class,'<Control-Next>',['xview','scroll',1,'page']);
  115.  
  116.  $mw->bind($class,'<Shift-Tab>', 'NoOp'); # Needed only to keep <Tab> binding from triggering; does not have to actually do anything.
  117.  $mw->bind($class,'<Control-Tab>','focusNext');
  118.  $mw->bind($class,'<Control-Shift-Tab>','focusPrev');
  119.  
  120.  $mw->bind($class,'<Control-space>',['markSet','anchor','insert']);
  121.  $mw->bind($class,'<Select>',['markSet','anchor','insert']);
  122.  $mw->bind($class,'<Control-Shift-space>',['SelectTo','insert','char']);
  123.  $mw->bind($class,'<Shift-Select>',['SelectTo','insert','char']);
  124.  $mw->bind($class,'<Control-slash>','selectAll');
  125.  $mw->bind($class,'<Control-backslash>','unselectAll');
  126.  
  127.  if (!$Tk::strictMotif)
  128.   {
  129.    $mw->bind($class,'<Control-a>',    ['SetCursor','insert linestart']);
  130.    $mw->bind($class,'<Control-b>',    ['SetCursor','insert-1c']);
  131.    $mw->bind($class,'<Control-e>',    ['SetCursor','insert lineend']);
  132.    $mw->bind($class,'<Control-f>',    ['SetCursor','insert+1c']);
  133.    $mw->bind($class,'<Meta-b>',       ['SetCursor','insert-1c wordstart']);
  134.    $mw->bind($class,'<Meta-f>',       ['SetCursor','insert wordend']);
  135.    $mw->bind($class,'<Meta-less>',    ['SetCursor','1.0']);
  136.    $mw->bind($class,'<Meta-greater>', ['SetCursor','end-1c']);
  137.  
  138.    $mw->bind($class,'<Control-n>',    ['SetCursor',Ev('UpDownLine',1)]);
  139.    $mw->bind($class,'<Control-p>',    ['SetCursor',Ev('UpDownLine',-1)]);
  140.  
  141.    $mw->bind($class,'<2>',['Button2',Ev('x'),Ev('y')]);
  142.    $mw->bind($class,'<B2-Motion>',['Motion2',Ev('x'),Ev('y')]);
  143.   }
  144.  $mw->bind($class,'<Destroy>','Destroy');
  145.  $mw->bind($class, '<3>', ['PostPopupMenu', Ev('X'), Ev('Y')]  );
  146.  $mw->YMouseWheelBind($class);
  147.  $mw->XMouseWheelBind($class);
  148.  
  149.  $mw->MouseWheelBind($class);
  150.  
  151.  return $class;
  152. }
  153.  
  154. sub selectAll
  155. {
  156.  my ($w) = @_;
  157.  $w->tagAdd('sel','1.0','end');
  158. }
  159.  
  160. sub unselectAll
  161. {
  162.  my ($w) = @_;
  163.  $w->tagRemove('sel','1.0','end');
  164. }
  165.  
  166. sub adjustSelect
  167. {
  168.  my ($w) = @_;
  169.  my $Ev = $w->XEvent;
  170.  $w->ResetAnchor($Ev->xy);
  171.  $w->SelectTo($Ev->xy,'char')
  172. }
  173.  
  174. sub selectLine
  175. {
  176.  my ($w) = @_;
  177.  my $Ev = $w->XEvent;
  178.  $w->SelectTo($Ev->xy,'line');
  179.  Tk::catch { $w->markSet('insert','sel.first') };
  180. }
  181.  
  182. sub selectWord
  183. {
  184.  my ($w) = @_;
  185.  my $Ev = $w->XEvent;
  186.  $w->SelectTo($Ev->xy,'word');
  187.  Tk::catch { $w->markSet('insert','sel.first') }
  188. }
  189.  
  190. sub ClassInit
  191. {
  192.  my ($class,$mw) = @_;
  193.  $class->SUPER::ClassInit($mw);
  194.  
  195.  $class->bindRdOnly($mw);
  196.  
  197.  $mw->bind($class,'<Tab>', 'insertTab');
  198.  $mw->bind($class,'<Control-i>', ['Insert',"\t"]);
  199.  $mw->bind($class,'<Return>', ['Insert',"\n"]);
  200.  $mw->bind($class,'<Delete>','Delete');
  201.  $mw->bind($class,'<BackSpace>','Backspace');
  202.  $mw->bind($class,'<Insert>', \&ToggleInsertMode ) ;
  203.  $mw->bind($class,'<KeyPress>',['InsertKeypress',Ev('A')]);
  204.  
  205.  $mw->bind($class,'<F1>', 'clipboardColumnCopy');
  206.  $mw->bind($class,'<F2>', 'clipboardColumnCut');
  207.  $mw->bind($class,'<F3>', 'clipboardColumnPaste');
  208.  
  209.  # Additional emacs-like bindings:
  210.  
  211.  if (!$Tk::strictMotif)
  212.   {
  213.    $mw->bind($class,'<Control-d>',['delete','insert']);
  214.    $mw->bind($class,'<Control-k>','deleteToEndofLine') ;
  215.    $mw->bind($class,'<Control-o>','openLine');
  216.    $mw->bind($class,'<Control-t>','Transpose');
  217.    $mw->bind($class,'<Meta-d>',['delete','insert','insert wordend']);
  218.    $mw->bind($class,'<Meta-BackSpace>',['delete','insert-1c wordstart','insert']);
  219.  
  220.    # A few additional bindings of my own.
  221.    $mw->bind($class,'<Control-h>','deleteBefore');
  222.    $mw->bind($class,'<ButtonRelease-2>','ButtonRelease2');
  223.   }
  224. #JD# $Tk::prevPos = undef;
  225.  return $class;
  226. }
  227.  
  228. sub insertTab
  229. {
  230.  my ($w) = @_;
  231.  $w->Insert("\t");
  232.  $w->focus;
  233.  $w->break
  234. }
  235.  
  236. sub deleteToEndofLine
  237. {
  238.  my ($w) = @_;
  239.  if ($w->compare('insert','==','insert lineend'))
  240.   {
  241.    $w->delete('insert')
  242.   }
  243.  else
  244.   {
  245.    $w->delete('insert','insert lineend')
  246.   }
  247. }
  248.  
  249. sub openLine
  250. {
  251.  my ($w) = @_;
  252.  $w->insert('insert',"\n");
  253.  $w->markSet('insert','insert-1c')
  254. }
  255.  
  256. sub Button2
  257. {
  258.  my ($w,$x,$y) = @_;
  259.  $w->scan('mark',$x,$y);
  260.  $Tk::x = $x;
  261.  $Tk::y = $y;
  262.  $Tk::mouseMoved = 0;
  263. }
  264.  
  265. sub Motion2
  266. {
  267.  my ($w,$x,$y) = @_;
  268.  $Tk::mouseMoved = 1 if ($x != $Tk::x || $y != $Tk::y);
  269.  $w->scan('dragto',$x,$y) if ($Tk::mouseMoved);
  270. }
  271.  
  272. sub ButtonRelease2
  273. {
  274.  my ($w) = @_;
  275.  my $Ev = $w->XEvent;
  276.  if (!$Tk::mouseMoved)
  277.   {
  278.    Tk::catch { $w->insert($Ev->xy,$w->SelectionGet) }
  279.   }
  280. }
  281.  
  282. sub InsertSelection
  283. {
  284.  my ($w) = @_;
  285.  Tk::catch { $w->Insert($w->SelectionGet) }
  286. }
  287.  
  288. sub Backspace
  289. {
  290.  my ($w) = @_;
  291.  my $sel = Tk::catch { $w->tag('nextrange','sel','1.0','end') };
  292.  if (defined $sel)
  293.   {
  294.    $w->delete('sel.first','sel.last');
  295.    return;
  296.   }
  297.  $w->deleteBefore;
  298. }
  299.  
  300. sub deleteBefore
  301. {
  302.  my ($w) = @_;
  303.  if ($w->compare('insert','!=','1.0'))
  304.   {
  305.    $w->delete('insert-1c');
  306.    $w->see('insert')
  307.   }
  308. }
  309.  
  310. sub Delete
  311. {
  312.  my ($w) = @_;
  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.  else
  319.   {
  320.    $w->delete('insert');
  321.    $w->see('insert')
  322.   }
  323. }
  324.  
  325. # Button1 --
  326. # This procedure is invoked to handle button-1 presses in text
  327. # widgets. It moves the insertion cursor, sets the selection anchor,
  328. # and claims the input focus.
  329. #
  330. # Arguments:
  331. # w - The text window in which the button was pressed.
  332. # x - The x-coordinate of the button press.
  333. # y - The x-coordinate of the button press.
  334. sub Button1
  335. {
  336.  my ($w,$x,$y) = @_;
  337.  $Tk::selectMode = 'char';
  338.  $Tk::mouseMoved = 0;
  339.  $w->SetCursor('@'.$x.','.$y);
  340.  $w->markSet('anchor','insert');
  341.  $w->focus() if ($w->cget('-state') eq 'normal');
  342. }
  343.  
  344. sub B1_Motion
  345. {
  346.  my ($w) = @_;
  347.  return unless defined $Tk::mouseMoved;
  348.  my $Ev = $w->XEvent;
  349.  $Tk::x = $Ev->x;
  350.  $Tk::y = $Ev->y;
  351.  $w->SelectTo($Ev->xy)
  352. }
  353.  
  354. sub B1_Leave
  355. {
  356.  my ($w) = @_;
  357.  my $Ev = $w->XEvent;
  358.  $Tk::x = $Ev->x;
  359.  $Tk::y = $Ev->y;
  360.  $w->AutoScan;
  361. }
  362.  
  363. # SelectTo --
  364. # This procedure is invoked to extend the selection, typically when
  365. # dragging it with the mouse. Depending on the selection mode (character,
  366. # word, line) it selects in different-sized units. This procedure
  367. # ignores mouse motions initially until the mouse has moved from
  368. # one character to another or until there have been multiple clicks.
  369. #
  370. # Arguments:
  371. # w - The text window in which the button was pressed.
  372. # index - Index of character at which the mouse button was pressed.
  373. sub SelectTo
  374. {
  375.  my ($w, $index, $mode)= @_;
  376.  $Tk::selectMode = $mode if defined ($mode);
  377.  my $cur = $w->index($index);
  378.  my $anchor = Tk::catch { $w->index('anchor') };
  379.  if (!defined $anchor)
  380.   {
  381.    $w->markSet('anchor',$anchor = $cur);
  382.    $Tk::mouseMoved = 0;
  383.   }
  384.  elsif ($w->compare($cur,'!=',$anchor))
  385.   {
  386.    $Tk::mouseMoved = 1;
  387.   }
  388.  $Tk::selectMode = 'char' unless (defined $Tk::selectMode);
  389.  $mode = $Tk::selectMode;
  390.  my ($first,$last);
  391.  if ($mode eq 'char')
  392.   {
  393.    if ($w->compare($cur,'<','anchor'))
  394.     {
  395.      $first = $cur;
  396.      $last = 'anchor';
  397.     }
  398.    else
  399.     {
  400.      $first = 'anchor';
  401.      $last = $cur
  402.     }
  403.   }
  404.  elsif ($mode eq 'word')
  405.   {
  406.    if ($w->compare($cur,'<','anchor'))
  407.     {
  408.      $first = $w->index("$cur wordstart");
  409.      $last = $w->index('anchor - 1c wordend')
  410.     }
  411.    else
  412.     {
  413.      $first = $w->index('anchor wordstart');
  414.      $last = $w->index("$cur wordend")
  415.     }
  416.   }
  417.  elsif ($mode eq 'line')
  418.   {
  419.    if ($w->compare($cur,'<','anchor'))
  420.     {
  421.      $first = $w->index("$cur linestart");
  422.      $last = $w->index('anchor - 1c lineend + 1c')
  423.     }
  424.    else
  425.     {
  426.      $first = $w->index('anchor linestart');
  427.      $last = $w->index("$cur lineend + 1c")
  428.     }
  429.   }
  430.  if ($Tk::mouseMoved || $Tk::selectMode ne 'char')
  431.   {
  432.    $w->tagRemove('sel','1.0',$first);
  433.    $w->tagAdd('sel',$first,$last);
  434.    $w->tagRemove('sel',$last,'end');
  435.    $w->idletasks;
  436.   }
  437. }
  438. # AutoScan --
  439. # This procedure is invoked when the mouse leaves a text window
  440. # with button 1 down. It scrolls the window up, down, left, or right,
  441. # depending on where the mouse is (this information was saved in
  442. # tkPriv(x) and tkPriv(y)), and reschedules itself as an 'after'
  443. # command so that the window continues to scroll until the mouse
  444. # moves back into the window or the mouse button is released.
  445. #
  446. # Arguments:
  447. # w - The text window.
  448. sub AutoScan
  449. {
  450.  my ($w) = @_;
  451.  if ($Tk::y >= $w->height)
  452.   {
  453.    $w->yview('scroll',2,'units')
  454.   }
  455.  elsif ($Tk::y < 0)
  456.   {
  457.    $w->yview('scroll',-2,'units')
  458.   }
  459.  elsif ($Tk::x >= $w->width)
  460.   {
  461.    $w->xview('scroll',2,'units')
  462.   }
  463.  elsif ($Tk::x < 0)
  464.   {
  465.    $w->xview('scroll',-2,'units')
  466.   }
  467.  else
  468.   {
  469.    return;
  470.   }
  471.  $w->SelectTo('@' . $Tk::x . ','. $Tk::y);
  472.  $w->RepeatId($w->after(50,['AutoScan',$w]));
  473. }
  474. # SetCursor
  475. # Move the insertion cursor to a given position in a text. Also
  476. # clears the selection, if there is one in the text, and makes sure
  477. # that the insertion cursor is visible.
  478. #
  479. # Arguments:
  480. # w - The text window.
  481. # pos - The desired new position for the cursor in the window.
  482. sub SetCursor
  483. {
  484.  my ($w,$pos) = @_;
  485.  $pos = 'end - 1 chars' if $w->compare($pos,'==','end');
  486.  $w->markSet('insert',$pos);
  487.  $w->unselectAll;
  488.  $w->see('insert');
  489. }
  490. # KeySelect
  491. # This procedure is invoked when stroking out selections using the
  492. # keyboard. It moves the cursor to a new position, then extends
  493. # the selection to that position.
  494. #
  495. # Arguments:
  496. # w - The text window.
  497. # new - A new position for the insertion cursor (the cursor has not
  498. # actually been moved to this position yet).
  499. sub KeySelect
  500. {
  501.  my ($w,$new) = @_;
  502.  my ($first,$last);
  503.  if (!defined $w->tag('ranges','sel'))
  504.   {
  505.    # No selection yet
  506.    $w->markSet('anchor','insert');
  507.    if ($w->compare($new,'<','insert'))
  508.     {
  509.      $w->tagAdd('sel',$new,'insert')
  510.     }
  511.    else
  512.     {
  513.      $w->tagAdd('sel','insert',$new)
  514.     }
  515.   }
  516.  else
  517.   {
  518.    # Selection exists
  519.    if ($w->compare($new,'<','anchor'))
  520.     {
  521.      $first = $new;
  522.      $last = 'anchor'
  523.     }
  524.    else
  525.     {
  526.      $first = 'anchor';
  527.      $last = $new
  528.     }
  529.    $w->tagRemove('sel','1.0',$first);
  530.    $w->tagAdd('sel',$first,$last);
  531.    $w->tagRemove('sel',$last,'end')
  532.   }
  533.  $w->markSet('insert',$new);
  534.  $w->see('insert');
  535.  $w->idletasks;
  536. }
  537. # ResetAnchor --
  538. # Set the selection anchor to whichever end is farthest from the
  539. # index argument. One special trick: if the selection has two or
  540. # fewer characters, just leave the anchor where it is. In this
  541. # case it does not matter which point gets chosen for the anchor,
  542. # and for the things like Shift-Left and Shift-Right this produces
  543. # better behavior when the cursor moves back and forth across the
  544. # anchor.
  545. #
  546. # Arguments:
  547. # w - The text widget.
  548. # index - Position at which mouse button was pressed, which determines
  549. # which end of selection should be used as anchor point.
  550. sub ResetAnchor
  551. {
  552.  my ($w,$index) = @_;
  553.  if (!defined $w->tag('ranges','sel'))
  554.   {
  555.    $w->markSet('anchor',$index);
  556.    return;
  557.   }
  558.  my $a = $w->index($index);
  559.  my $b = $w->index('sel.first');
  560.  my $c = $w->index('sel.last');
  561.  if ($w->compare($a,'<',$b))
  562.   {
  563.    $w->markSet('anchor','sel.last');
  564.    return;
  565.   }
  566.  if ($w->compare($a,'>',$c))
  567.   {
  568.    $w->markSet('anchor','sel.first');
  569.    return;
  570.   }
  571.  my ($lineA,$chA) = split(/\./,$a);
  572.  my ($lineB,$chB) = split(/\./,$b);
  573.  my ($lineC,$chC) = split(/\./,$c);
  574.  if ($lineB < $lineC+2)
  575.   {
  576.    my $total = length($w->get($b,$c));
  577.    if ($total <= 2)
  578.     {
  579.      return;
  580.     }
  581.    if (length($w->get($b,$a)) < $total/2)
  582.     {
  583.      $w->markSet('anchor','sel.last')
  584.     }
  585.    else
  586.     {
  587.      $w->markSet('anchor','sel.first')
  588.     }
  589.    return;
  590.   }
  591.  if ($lineA-$lineB < $lineC-$lineA)
  592.   {
  593.    $w->markSet('anchor','sel.last')
  594.   }
  595.  else
  596.   {
  597.    $w->markSet('anchor','sel.first')
  598.   }
  599. }
  600.  
  601. ########################################################################
  602. sub markExists
  603. {
  604.  my ($w, $markname)=@_;
  605.  my $mark_exists=0;
  606.  my @markNames_list = $w->markNames;
  607.  foreach my $mark (@markNames_list)
  608.   { if ($markname eq $mark) {$mark_exists=1;last;} }
  609.  return $mark_exists;
  610. }
  611.  
  612. ########################################################################
  613. sub OverstrikeMode
  614. {
  615.  my ($w,$mode) = @_;
  616.  
  617.  $w->{'OVERSTRIKE_MODE'} =0 unless exists($w->{'OVERSTRIKE_MODE'});
  618.  
  619.  $w->{'OVERSTRIKE_MODE'}=$mode if (@_ > 1);
  620.  
  621.  return $w->{'OVERSTRIKE_MODE'};
  622. }
  623.  
  624. ########################################################################
  625. # pressed the <Insert> key, just above 'Del' key.
  626. # this toggles between insert mode and overstrike mode.
  627. sub ToggleInsertMode
  628. {
  629.  my ($w)=@_;
  630.  $w->OverstrikeMode(!$w->OverstrikeMode);
  631. }
  632.  
  633. ########################################################################
  634. sub InsertKeypress
  635. {
  636.  my ($w,$char)=@_;
  637.  return unless length($char);
  638.  if ($w->OverstrikeMode)
  639.   {
  640.    my $current=$w->get('insert');
  641.    $w->delete('insert') unless($current eq "\n");
  642.   }
  643.  $w->Insert($char);
  644. }
  645.  
  646. ########################################################################
  647. sub GotoLineNumber
  648. {
  649.  my ($w,$line_number) = @_;
  650.  $line_number=~ s/^\s+|\s+$//g;
  651.  return if $line_number =~ m/\D/;
  652.  my ($last_line,$junk)  = split(/\./, $w->index('end'));
  653.  if ($line_number > $last_line) {$line_number = $last_line; }
  654.  $w->{'LAST_GOTO_LINE'} = $line_number;
  655.  $w->markSet('insert', $line_number.'.0');
  656.  $w->see('insert');
  657. }
  658.  
  659. ########################################################################
  660. sub GotoLineNumberPopUp
  661. {
  662.  my ($w)=@_;
  663.  my $popup = $w->{'GOTO_LINE_NUMBER_POPUP'};
  664.  
  665.  unless (defined($w->{'LAST_GOTO_LINE'}))
  666.   {
  667.    my ($line,$col) =  split(/\./, $w->index('insert'));
  668.    $w->{'LAST_GOTO_LINE'} = $line;
  669.   }
  670.  
  671.  ## if anything is selected when bring up the pop-up, put it in entry window.
  672.  my $selected;
  673.  eval { $selected = $w->SelectionGet(-selection => "PRIMARY"); };
  674.  unless ($@)
  675.   {
  676.    if (defined($selected) and length($selected))
  677.     {
  678.      unless ($selected =~ /\D/)
  679.       {
  680.        $w->{'LAST_GOTO_LINE'} = $selected;
  681.       }
  682.     }
  683.   }
  684.  unless (defined($popup))
  685.   {
  686.    require Tk::DialogBox;
  687.    $popup = $w->DialogBox(-buttons => [qw[Ok Cancel]],-title => "Goto Line Number", -popover => $w,
  688.                           -command => sub { $w->GotoLineNumber($w->{'LAST_GOTO_LINE'}) if $_[0] eq 'Ok'});
  689.    $w->{'GOTO_LINE_NUMBER_POPUP'}=$popup;
  690.    $popup->resizable('no','no');
  691.    my $frame = $popup->Frame->pack(-fill => 'x');
  692.    $frame->Label(-text=>'Enter line number: ')->pack(-side => 'left');
  693.    my $entry = $frame->Entry(-background=>'white', -width=>25,
  694.                              -textvariable => \$w->{'LAST_GOTO_LINE'})->pack(-side =>'left',-fill => 'x');
  695.    $popup->Advertise(entry => $entry);
  696.   }
  697.  $popup->Popup;
  698.  $popup->Subwidget('entry')->focus;
  699.  $popup->Wait;
  700. }
  701.  
  702. ########################################################################
  703.  
  704. sub getSelected
  705. {
  706.  shift->GetTextTaggedWith('sel');
  707. }
  708.  
  709. sub deleteSelected
  710. {
  711.  shift->DeleteTextTaggedWith('sel');
  712. }
  713.  
  714. sub GetTextTaggedWith
  715. {
  716.  my ($w,$tag) = @_;
  717.  
  718.  my @ranges = $w->tagRanges($tag);
  719.  my $range_total = @ranges;
  720.  my $return_text='';
  721.  
  722.  # if nothing selected, then ignore
  723.  if ($range_total == 0) {return $return_text;}
  724.  
  725.  # for every range-pair, get selected text
  726.  while(@ranges)
  727.   {
  728.   my $first = shift(@ranges);
  729.   my $last = shift(@ranges);
  730.   my $text = $w->get($first , $last);
  731.   if(defined($text))
  732.    {$return_text = $return_text . $text;}
  733.   # if there is more tagged text, separate with an end of line  character
  734.   if(@ranges)
  735.    {$return_text = $return_text . "\n";}
  736.   }
  737.  return $return_text;
  738. }
  739.  
  740. ########################################################################
  741. sub DeleteTextTaggedWith
  742. {
  743.  my ($w,$tag) = @_;
  744.  my @ranges = $w->tagRanges($tag);
  745.  my $range_total = @ranges;
  746.  
  747.  # if nothing tagged with that tag, then ignore
  748.  if ($range_total == 0) {return;}
  749.  
  750.  # insert marks where selections are located
  751.  # marks will move with text even as text is inserted and deleted
  752.  # in a previous selection.
  753.  for (my $i=0; $i<$range_total; $i++)
  754.   { $w->markSet('mark_tag_'.$i => $ranges[$i]); }
  755.  
  756.  # for every selected mark pair, insert new text and delete old text
  757.  for (my $i=0; $i<$range_total; $i=$i+2)
  758.   {
  759.   my $first = $w->index('mark_tag_'.$i);
  760.   my $last = $w->index('mark_tag_'.($i+1));
  761.  
  762.   my $text = $w->delete($first , $last);
  763.   }
  764.  
  765.  # delete the marks
  766.  for (my $i=0; $i<$range_total; $i++)
  767.   { $w->markUnset('mark_tag_'.$i); }
  768. }
  769.  
  770.  
  771. ########################################################################
  772. sub FindAll
  773. {
  774.  my ($w,$mode, $case, $pattern ) = @_;
  775.  ### 'sel' tags accumulate, need to remove any previous existing
  776.  $w->unselectAll;
  777.  
  778.  my $match_length=0;
  779.  my $start_index;
  780.  my $end_index = '1.0';
  781.  
  782.  while(defined($end_index))
  783.   {
  784.   if ($case eq '-nocase')
  785.    {
  786.    $start_index = $w->search(
  787.     $mode,
  788.     $case,
  789.     -count => \$match_length,
  790.     "--",
  791.     $pattern ,
  792.     $end_index,
  793.     'end');
  794.    }
  795.   else
  796.    {
  797.    $start_index = $w->search(
  798.     $mode,
  799.     -count => \$match_length,
  800.     "--",
  801.     $pattern ,
  802.     $end_index,
  803.     'end');
  804.    }
  805.  
  806.   unless(defined($start_index) && $start_index) {last;}
  807.  
  808.   my ($line,$col) = split(/\./, $start_index);
  809.   $col = $col + $match_length;
  810.   $end_index = $line.'.'.$col;
  811.   $w->tagAdd('sel', $start_index, $end_index);
  812.   }
  813. }
  814.  
  815. ########################################################################
  816. # get current selected text and search for the next occurrence
  817. sub FindSelectionNext
  818. {
  819.  my ($w) = @_;
  820.  my $selected;
  821.  eval {$selected = $w->SelectionGet(-selection => "PRIMARY"); };
  822.  return if($@);
  823.  return unless (defined($selected) and length($selected));
  824.  
  825.  $w->FindNext('-forward', '-exact', '-case', $selected);
  826. }
  827.  
  828. ########################################################################
  829. # get current selected text and search for the previous occurrence
  830. sub FindSelectionPrevious
  831. {
  832.  my ($w) = @_;
  833.  my $selected;
  834.  eval {$selected = $w->SelectionGet(-selection => "PRIMARY"); };
  835.  return if($@);
  836.  return unless (defined($selected) and length($selected));
  837.  
  838.  $w->FindNext('-backward', '-exact', '-case', $selected);
  839. }
  840.  
  841.  
  842.  
  843. ########################################################################
  844. sub FindNext
  845. {
  846.  my ($w,$direction, $mode, $case, $pattern ) = @_;
  847.  
  848.  ## if searching forward, start search at end of selected block
  849.  ## if backward, start search from start of selected block.
  850.  ## dont want search to find currently selected text.
  851.  ## tag 'sel' may not be defined, use eval loop to trap error
  852.  eval {
  853.   if ($direction eq '-forward')
  854.    {
  855.    $w->markSet('insert', 'sel.last');
  856.    $w->markSet('current', 'sel.last');
  857.    }
  858.   else
  859.    {
  860.    $w->markSet('insert', 'sel.first');
  861.    $w->markSet('current', 'sel.first');
  862.    }
  863.  };
  864.  
  865.  my $saved_index=$w->index('insert');
  866.  
  867.  # remove any previous existing tags
  868.  $w->unselectAll;
  869.  
  870.  my $match_length=0;
  871.  my $start_index;
  872.  
  873.  if ($case eq '-nocase')
  874.   {
  875.   $start_index = $w->search(
  876.    $direction,
  877.    $mode,
  878.    $case,
  879.    -count => \$match_length,
  880.    "--",
  881.    $pattern ,
  882.    'insert');
  883.   }
  884.  else
  885.   {
  886.   $start_index = $w->search(
  887.    $direction,
  888.    $mode,
  889.    -count => \$match_length,
  890.    "--",
  891.    $pattern ,
  892.    'insert');
  893.   }
  894.  
  895.  unless(defined($start_index)) { return 0; }
  896.  if(length($start_index) == 0) { return 0; }
  897.  
  898.  my ($line,$col) = split(/\./, $start_index);
  899.  $col = $col + $match_length;
  900.  my $end_index = $line.'.'.$col;
  901.  $w->tagAdd('sel', $start_index, $end_index);
  902.  
  903.  $w->see($start_index);
  904.  
  905.  if ($direction eq '-forward')
  906.   {
  907.   $w->markSet('insert', $end_index);
  908.   $w->markSet('current', $end_index);
  909.   }
  910.  else
  911.   {
  912.   $w->markSet('insert', $start_index);
  913.   $w->markSet('current', $start_index);
  914.   }
  915.  
  916.  my $compared_index = $w->index('insert');
  917.  
  918.  my $ret_val;
  919.  if ($compared_index eq $saved_index)
  920.   {$ret_val=0;}
  921.  else
  922.   {$ret_val=1;}
  923.  return $ret_val;
  924. }
  925.  
  926. ########################################################################
  927. sub FindAndReplaceAll
  928. {
  929.  my ($w,$mode, $case, $find, $replace ) = @_;
  930.  $w->markSet('insert', '1.0');
  931.  $w->unselectAll;
  932.  while($w->FindNext('-forward', $mode, $case, $find))
  933.   {
  934.   $w->ReplaceSelectionsWith($replace);
  935.   }
  936. }
  937.  
  938. ########################################################################
  939. sub ReplaceSelectionsWith
  940. {
  941.  my ($w,$new_text ) = @_;
  942.  
  943.  my @ranges = $w->tagRanges('sel');
  944.  my $range_total = @ranges;
  945.  
  946.  # if nothing selected, then ignore
  947.  if ($range_total == 0) {return};
  948.  
  949.  # insert marks where selections are located
  950.  # marks will move with text even as text is inserted and deleted
  951.  # in a previous selection.
  952.  for (my $i=0; $i<$range_total; $i++)
  953.   {$w->markSet('mark_sel_'.$i => $ranges[$i]); }
  954.  
  955.  # for every selected mark pair, insert new text and delete old text
  956.  my ($first, $last);
  957.  for (my $i=0; $i<$range_total; $i=$i+2)
  958.   {
  959.   $first = $w->index('mark_sel_'.$i);
  960.   $last = $w->index('mark_sel_'.($i+1));
  961.  
  962.   ##########################################################################
  963.   # eventually, want to be able to get selected text,
  964.   # support regular expression matching, determine replace_text
  965.   # $replace_text = $selected_text=~m/$new_text/  (or whatever would work)
  966.   # will have to pass in mode and case flags.
  967.   # this would allow a regular expression search and replace to be performed
  968.   # example, look for "line (\d+):" and replace with "$1 >" or similar
  969.   ##########################################################################
  970.  
  971.   $w->insert($last, $new_text);
  972.   $w->delete($first, $last);
  973.  
  974.   }
  975.  ############################################################
  976.  # set the insert cursor to the end of the last insertion mark
  977.  $w->markSet('insert',$w->index('mark_sel_'.($range_total-1)));
  978.  
  979.  # delete the marks
  980.  for (my $i=0; $i<$range_total; $i++)
  981.   { $w->markUnset('mark_sel_'.$i); }
  982. }
  983. ########################################################################
  984. sub FindAndReplacePopUp
  985. {
  986.  my ($w)=@_;
  987.  $w->findandreplacepopup(0);
  988. }
  989.  
  990. ########################################################################
  991. sub FindPopUp
  992. {
  993.  my ($w)=@_;
  994.  $w->findandreplacepopup(1);
  995. }
  996.  
  997. ########################################################################
  998.  
  999. sub findandreplacepopup
  1000. {
  1001.  my ($w,$find_only)=@_;
  1002.  
  1003.  my $pop = $w->Toplevel;
  1004.  $pop->transient($w->toplevel);
  1005.  if ($find_only)
  1006.   { $pop->title("Find"); }
  1007.  else
  1008.   { $pop->title("Find and/or Replace"); }
  1009.  my $frame =  $pop->Frame->pack(-anchor=>'nw');
  1010.  
  1011.  $frame->Label(-text=>"Direction:")
  1012.   ->grid(-row=> 1, -column=>1, -padx=> 20, -sticky => 'nw');
  1013.  my $direction = '-forward';
  1014.  $frame->Radiobutton(
  1015.   -variable => \$direction,
  1016.   -text => 'forward',-value => '-forward' )
  1017.   ->grid(-row=> 2, -column=>1, -padx=> 20, -sticky => 'nw');
  1018.  $frame->Radiobutton(
  1019.   -variable => \$direction,
  1020.   -text => 'backward',-value => '-backward' )
  1021.   ->grid(-row=> 3, -column=>1, -padx=> 20, -sticky => 'nw');
  1022.  
  1023.  $frame->Label(-text=>"Mode:")
  1024.   ->grid(-row=> 1, -column=>2, -padx=> 20, -sticky => 'nw');
  1025.  my $mode = '-exact';
  1026.  $frame->Radiobutton(
  1027.   -variable => \$mode, -text => 'exact',-value => '-exact' )
  1028.   ->grid(-row=> 2, -column=>2, -padx=> 20, -sticky => 'nw');
  1029.  $frame->Radiobutton(
  1030.   -variable => \$mode, -text => 'regexp',-value => '-regexp' )
  1031.   ->grid(-row=> 3, -column=>2, -padx=> 20, -sticky => 'nw');
  1032.  
  1033.  $frame->Label(-text=>"Case:")
  1034.   ->grid(-row=> 1, -column=>3, -padx=> 20, -sticky => 'nw');
  1035.  my $case = '-case';
  1036.  $frame->Radiobutton(
  1037.   -variable => \$case, -text => 'case',-value => '-case' )
  1038.   ->grid(-row=> 2, -column=>3, -padx=> 20, -sticky => 'nw');
  1039.  $frame->Radiobutton(
  1040.   -variable => \$case, -text => 'nocase',-value => '-nocase' )
  1041.   ->grid(-row=> 3, -column=>3, -padx=> 20, -sticky => 'nw');
  1042.  
  1043.  ######################################################
  1044.  my $find_entry = $pop->Entry(-width=>25);
  1045.  $find_entry->focus;
  1046.  
  1047.  my $donext = sub {$w->FindNext ($direction,$mode,$case,$find_entry->get())};
  1048.  
  1049.  $find_entry -> pack(-anchor=>'nw', '-expand' => 'yes' , -fill => 'x'); # autosizing
  1050.  
  1051.  ######  if any $w text is selected, put it in the find entry
  1052.  ######  could be more than one text block selected, get first selection
  1053.  my @ranges = $w->tagRanges('sel');
  1054.  if (@ranges)
  1055.   {
  1056.   my $first = shift(@ranges);
  1057.   my $last = shift(@ranges);
  1058.  
  1059.   # limit to one line
  1060.   my ($first_line, $first_col) = split(/\./,$first);
  1061.   my ($last_line, $last_col) = split(/\./,$last);
  1062.   unless($first_line == $last_line)
  1063.    {$last = $first. ' lineend';}
  1064.  
  1065.   $find_entry->insert('insert', $w->get($first , $last));
  1066.   }
  1067.  else
  1068.   {
  1069.   my $selected;
  1070.   eval {$selected=$w->SelectionGet(-selection => "PRIMARY"); };
  1071.   if($@) {}
  1072.   elsif (defined($selected))
  1073.    {$find_entry->insert('insert', $selected);}
  1074.   }
  1075.  
  1076.  $find_entry->icursor(0);
  1077.  
  1078.  my ($replace_entry,$button_replace,$button_replace_all);
  1079.  unless ($find_only)
  1080.   {
  1081.    $replace_entry = $pop->Entry(-width=>25);
  1082.  
  1083.   $replace_entry -> pack(-anchor=>'nw', '-expand' => 'yes' , -fill => 'x');
  1084.   }
  1085.  
  1086.  
  1087.  my $button_find = $pop->Button(-text=>'Find', -command => $donext, -default => 'active')
  1088.   -> pack(-side => 'left');
  1089.  
  1090.  my $button_find_all = $pop->Button(-text=>'Find All',
  1091.   -command => sub {$w->FindAll($mode,$case,$find_entry->get());} )
  1092.   ->pack(-side => 'left');
  1093.  
  1094.  unless ($find_only)
  1095.   {
  1096.    $button_replace = $pop->Button(-text=>'Replace', -default => 'normal',
  1097.    -command => sub {$w->ReplaceSelectionsWith($replace_entry->get());} )
  1098.    -> pack(-side =>'left');
  1099.    $button_replace_all = $pop->Button(-text=>'Replace All',
  1100.    -command => sub {$w->FindAndReplaceAll
  1101.     ($mode,$case,$find_entry->get(),$replace_entry->get());} )
  1102.    ->pack(-side => 'left');
  1103.   }
  1104.  
  1105.  
  1106.   my $button_cancel = $pop->Button(-text=>'Cancel',
  1107.   -command => sub {$pop->destroy()} )
  1108.   ->pack(-side => 'left');
  1109.  
  1110.   $find_entry->bind("<Return>" => [$button_find, 'invoke']);
  1111.   $find_entry->bind("<Escape>" => [$button_cancel, 'invoke']);
  1112.  
  1113.  $find_entry->bind("<Return>" => [$button_find, 'invoke']);
  1114.  $find_entry->bind("<Escape>" => [$button_cancel, 'invoke']);
  1115.  
  1116.  $pop->resizable('yes','no');
  1117.  return $pop;
  1118. }
  1119.  
  1120. # paste clipboard into current location
  1121. sub clipboardPaste
  1122. {
  1123.  my ($w) = @_;
  1124.  local $@;
  1125.  Tk::catch { $w->Insert($w->clipboardGet) };
  1126. }
  1127.  
  1128. ########################################################################
  1129. # Insert --
  1130. # Insert a string into a text at the point of the insertion cursor.
  1131. # If there is a selection in the text, and it covers the point of the
  1132. # insertion cursor, then delete the selection before inserting.
  1133. #
  1134. # Arguments:
  1135. # w - The text window in which to insert the string
  1136. # string - The string to insert (usually just a single character)
  1137. sub Insert
  1138. {
  1139.  my ($w,$string) = @_;
  1140.  return unless (defined $string && $string ne '');
  1141.  #figure out if cursor is inside a selection
  1142.  my @ranges = $w->tagRanges('sel');
  1143.  if (@ranges)
  1144.   {
  1145.    while (@ranges)
  1146.     {
  1147.      my ($first,$last) = splice(@ranges,0,2);
  1148.      if ($w->compare($first,'<=','insert') && $w->compare($last,'>=','insert'))
  1149.       {
  1150.        $w->ReplaceSelectionsWith($string);
  1151.        return;
  1152.       }
  1153.     }
  1154.   }
  1155.  # paste it at the current cursor location
  1156.  $w->insert('insert',$string);
  1157.  $w->see('insert');
  1158. }
  1159.  
  1160. # UpDownLine --
  1161. # Returns the index of the character one *display* line above or below the
  1162. # insertion cursor. There are two tricky things here. First,
  1163. # we want to maintain the original column across repeated operations,
  1164. # even though some lines that will get passed through do not have
  1165. # enough characters to cover the original column. Second, do not
  1166. # try to scroll past the beginning or end of the text.
  1167. #
  1168. # This may have some weirdness associated with a proportional font. Ie.
  1169. # the insertion cursor will zigzag up or down according to the width of
  1170. # the character at destination.
  1171. #
  1172. # Arguments:
  1173. # w - The text window in which the cursor is to move.
  1174. # n - The number of lines to move: -1 for up one line,
  1175. # +1 for down one line.
  1176. sub UpDownLine
  1177. {
  1178. my ($w,$n) = @_;
  1179. $w->see('insert');
  1180. my $i = $w->index('insert');
  1181.  
  1182. my ($line,$char) = split(/\./,$i);
  1183.  
  1184. my $testX; #used to check the "new" position
  1185. my $testY; #used to check the "new" position
  1186.  
  1187. (my $bx, my $by, my $bw, my $bh) = $w->bbox($i);
  1188. (my $lx, my $ly, my $lw, my $lh) = $w->dlineinfo($i);
  1189.  
  1190. if ( ($n == -1) and ($by <= $bh) )
  1191.   {
  1192.    #On first display line.. so scroll up and recalculate..
  1193.    $w->yview('scroll', -1, 'units');
  1194.    unless (($w->yview)[0]) {
  1195.      #first line of entire text - keep same position.
  1196.      return $i;
  1197.    }
  1198.    ($bx, $by, $bw, $bh) = $w->bbox($i);
  1199.    ($lx, $ly, $lw, $lh) = $w->dlineinfo($i);
  1200.   }
  1201. elsif ( ($n == 1) and
  1202.          ($ly + $lh) > ( $w->height - 2*$w->cget(-bd) - 2*$w->cget(-highlightthickness) ) )
  1203.   {
  1204.    #On last display line.. so scroll down and recalculate..
  1205.    $w->yview('scroll', 1, 'units');
  1206.    ($bx, $by, $bw, $bh) = $w->bbox($i);
  1207.    ($lx, $ly, $lw, $lh) = $w->dlineinfo($i);
  1208.   }
  1209.  
  1210. # Calculate the vertical position of the next display line
  1211. my $Yoffset = 0;
  1212. $Yoffset = $by - $ly + 1 if ($n== -1);
  1213. $Yoffset = $ly + $lh + 1 - $by if ($n == 1);
  1214. $Yoffset*=$n;
  1215. $testY = $by + $Yoffset;
  1216.  
  1217. # Save the original 'x' position of the insert cursor if:
  1218. # 1. This is the first time through -- or --
  1219. # 2. The insert cursor position has changed from the previous
  1220. #    time the up or down key was pressed -- or --
  1221. # 3. The cursor has reached the beginning or end of the widget.
  1222.  
  1223. if (not defined $w->{'origx'} or ($w->{'lastindex'} != $i) )
  1224.   {
  1225.    $w->{'origx'} = $bx;
  1226.   }
  1227.  
  1228. # Try to keep the same column if possible
  1229. $testX = $w->{'origx'};
  1230.  
  1231. # Get the coordinates of the possible new position
  1232. my $testindex = $w->index('@'.$testX.','.$testY );
  1233. $w->see($testindex);
  1234. my ($nx,$ny,$nw,$nh) = $w->bbox($testindex);
  1235.  
  1236. # Which side of the character should we position the cursor -
  1237. # mainly for a proportional font
  1238. if ($testX > $nx+$nw/2)
  1239.   {
  1240.    $testX = $nx+$nw+1;
  1241.   }
  1242.  
  1243. my $newindex = $w->index('@'.$testX.','.$testY );
  1244.  
  1245. if ( $w->compare($newindex,'==','end - 1 char') and ($ny == $ly ) )
  1246.   {
  1247.     # Then we are trying to the 'end' of the text from
  1248.     # the same display line - don't do that
  1249.     return $i;
  1250.   }
  1251.  
  1252. $w->{'lastindex'} = $newindex;
  1253. $w->see($newindex);
  1254. return $newindex;
  1255. }
  1256.  
  1257. # PrevPara --
  1258. # Returns the index of the beginning of the paragraph just before a given
  1259. # position in the text (the beginning of a paragraph is the first non-blank
  1260. # character after a blank line).
  1261. #
  1262. # Arguments:
  1263. # w - The text window in which the cursor is to move.
  1264. # pos - Position at which to start search.
  1265. sub PrevPara
  1266. {
  1267.  my ($w,$pos) = @_;
  1268.  $pos = $w->index("$pos linestart");
  1269.  while (1)
  1270.   {
  1271.    if ($w->get("$pos - 1 line") eq "\n" && $w->get($pos) ne "\n" || $pos eq '1.0' )
  1272.     {
  1273.      my $string = $w->get($pos,"$pos lineend");
  1274.      if ($string =~ /^(\s)+/)
  1275.       {
  1276.        my $off = length($1);
  1277.        $pos = $w->index("$pos + $off chars")
  1278.       }
  1279.      if ($w->compare($pos,'!=','insert') || $pos eq '1.0')
  1280.       {
  1281.        return $pos;
  1282.       }
  1283.     }
  1284.    $pos = $w->index("$pos - 1 line")
  1285.   }
  1286. }
  1287. # NextPara --
  1288. # Returns the index of the beginning of the paragraph just after a given
  1289. # position in the text (the beginning of a paragraph is the first non-blank
  1290. # character after a blank line).
  1291. #
  1292. # Arguments:
  1293. # w - The text window in which the cursor is to move.
  1294. # start - Position at which to start search.
  1295. sub NextPara
  1296. {
  1297.  my ($w,$start) = @_;
  1298.  my $pos = $w->index("$start linestart + 1 line");
  1299.  while ($w->get($pos) ne "\n")
  1300.   {
  1301.    if ($w->compare($pos,'==','end'))
  1302.     {
  1303.      return $w->index('end - 1c');
  1304.     }
  1305.    $pos = $w->index("$pos + 1 line")
  1306.   }
  1307.  while ($w->get($pos) eq "\n" )
  1308.   {
  1309.    $pos = $w->index("$pos + 1 line");
  1310.    if ($w->compare($pos,'==','end'))
  1311.     {
  1312.      return $w->index('end - 1c');
  1313.     }
  1314.   }
  1315.  my $string = $w->get($pos,"$pos lineend");
  1316.  if ($string =~ /^(\s+)/)
  1317.   {
  1318.    my $off = length($1);
  1319.    return $w->index("$pos + $off chars");
  1320.   }
  1321.  return $pos;
  1322. }
  1323. # ScrollPages --
  1324. # This is a utility procedure used in bindings for moving up and down
  1325. # pages and possibly extending the selection along the way. It scrolls
  1326. # the view in the widget by the number of pages, and it returns the
  1327. # index of the character that is at the same position in the new view
  1328. # as the insertion cursor used to be in the old view.
  1329. #
  1330. # Arguments:
  1331. # w - The text window in which the cursor is to move.
  1332. # count - Number of pages forward to scroll; may be negative
  1333. # to scroll backwards.
  1334. sub ScrollPages
  1335. {
  1336.  my ($w,$count) = @_;
  1337.  my @bbox = $w->bbox('insert');
  1338.  $w->yview('scroll',$count,'pages');
  1339.  if (!@bbox)
  1340.   {
  1341.    return $w->index('@' . int($w->height/2) . ',' . 0);
  1342.   }
  1343.  my $x = int($bbox[0]+$bbox[2]/2);
  1344.  my $y = int($bbox[1]+$bbox[3]/2);
  1345.  return $w->index('@' . $x . ',' . $y);
  1346. }
  1347.  
  1348. sub Contents
  1349. {
  1350.  my $w = shift;
  1351.  if (@_)
  1352.   {
  1353.    $w->delete('1.0','end');
  1354.    $w->insert('end',shift) while (@_);
  1355.   }
  1356.  else
  1357.   {
  1358.    return $w->get('1.0','end');
  1359.   }
  1360. }
  1361.  
  1362. sub Destroy
  1363. {
  1364.  my ($w) = @_;
  1365.  delete $w->{_Tags_};
  1366. }
  1367.  
  1368. sub Transpose
  1369. {
  1370.  my ($w) = @_;
  1371.  my $pos = 'insert';
  1372.  $pos = $w->index("$pos + 1 char") if ($w->compare($pos,'!=',"$pos lineend"));
  1373.  return if ($w->compare("$pos - 1 char",'==','1.0'));
  1374.  my $new = $w->get("$pos - 1 char").$w->get("$pos - 2 char");
  1375.  $w->delete("$pos - 2 char",$pos);
  1376.  $w->insert('insert',$new);
  1377.  $w->see('insert');
  1378. }
  1379.  
  1380. sub Tag
  1381. {
  1382.  my $w = shift;
  1383.  my $name = shift;
  1384.  Carp::confess('No args') unless (ref $w and defined $name);
  1385.  $w->{_Tags_} = {} unless (exists $w->{_Tags_});
  1386.  unless (exists $w->{_Tags_}{$name})
  1387.   {
  1388.    require Tk::Text::Tag;
  1389.    $w->{_Tags_}{$name} = 'Tk::Text::Tag'->new($w,$name);
  1390.   }
  1391.  $w->{_Tags_}{$name}->configure(@_) if (@_);
  1392.  return $w->{_Tags_}{$name};
  1393. }
  1394.  
  1395. sub Tags
  1396. {
  1397.  my ($w,$name) = @_;
  1398.  my @result = ();
  1399.  foreach $name ($w->tagNames(@_))
  1400.   {
  1401.    push(@result,$w->Tag($name));
  1402.   }
  1403.  return @result;
  1404. }
  1405.  
  1406. sub TIEHANDLE
  1407. {
  1408.  my ($class,$obj) = @_;
  1409.  return $obj;
  1410. }
  1411.  
  1412. sub PRINT
  1413. {
  1414.  my $w = shift;
  1415.  # Find out whether 'end' is displayed at the moment
  1416.  # Retrieve the position of the bottom of the window as
  1417.  # a fraction of the entire contents of the Text widget
  1418.  my $yview = ($w->yview)[1];
  1419.  
  1420.  # If $yview is 1.0 this means that 'end' is visible in the window
  1421.  my $update = 0;
  1422.  $update = 1 if $yview == 1.0;
  1423.  
  1424.  # Loop over all input strings
  1425.  while (@_)
  1426.   {
  1427.    $w->insert('end',shift);
  1428.   }
  1429.   # Move the window to see the end of the text if required
  1430.   $w->see('end') if $update;
  1431. }
  1432.  
  1433. sub PRINTF
  1434. {
  1435.  my $w = shift;
  1436.  $w->PRINT(sprintf(shift,@_));
  1437. }
  1438.  
  1439. sub WhatLineNumberPopUp
  1440. {
  1441.  my ($w)=@_;
  1442.  my ($line,$col) = split(/\./,$w->index('insert'));
  1443.  $w->messageBox(-type => 'Ok', -title => "What Line Number",
  1444.                 -message => "The cursor is on line $line (column is $col)");
  1445. }
  1446.  
  1447. sub MenuLabels
  1448. {
  1449.  return qw[~File ~Edit ~Search ~View];
  1450. }
  1451.  
  1452. sub SearchMenuItems
  1453. {
  1454.  my ($w) = @_;
  1455.  return [
  1456.     ['command'=>'~Find',          -command => [$w => 'FindPopUp']],
  1457.     ['command'=>'Find ~Next',     -command => [$w => 'FindSelectionNext']],
  1458.     ['command'=>'Find ~Previous', -command => [$w => 'FindSelectionPrevious']],
  1459.     ['command'=>'~Replace',       -command => [$w => 'FindAndReplacePopUp']]
  1460.    ];
  1461. }
  1462.  
  1463. sub EditMenuItems
  1464. {
  1465.  my ($w) = @_;
  1466.  my @items = ();
  1467.  foreach my $op ($w->clipEvents)
  1468.   {
  1469.    push(@items,['command' => "~$op", -command => [ $w => "clipboard$op"]]);
  1470.   }
  1471.  push(@items,
  1472.     '-',
  1473.     ['command'=>'Select All', -command   => [$w => 'selectAll']],
  1474.     ['command'=>'Unselect All', -command => [$w => 'unselectAll']],
  1475.   );
  1476.  return \@items;
  1477. }
  1478.  
  1479. sub ViewMenuItems
  1480. {
  1481.  my ($w) = @_;
  1482.  my $v;
  1483.  tie $v,'Tk::Configure',$w,'-wrap';
  1484.  return  [
  1485.     ['command'=>'Goto ~Line...', -command => [$w => 'GotoLineNumberPopUp']],
  1486.     ['command'=>'~Which Line?',  -command =>  [$w => 'WhatLineNumberPopUp']],
  1487.     ['cascade'=> 'Wrap', -tearoff => 0, -menuitems => [
  1488.       [radiobutton => 'Word', -variable => \$v, -value => 'word'],
  1489.       [radiobutton => 'Character', -variable => \$v, -value => 'char'],
  1490.       [radiobutton => 'None', -variable => \$v, -value => 'none'],
  1491.     ]],
  1492.   ];
  1493. }
  1494.  
  1495. ########################################################################
  1496. sub clipboardColumnCopy
  1497. {
  1498.  my ($w) = @_;
  1499.  $w->Column_Copy_or_Cut(0);
  1500. }
  1501.  
  1502. sub clipboardColumnCut
  1503. {
  1504.  my ($w) = @_;
  1505.  $w->Column_Copy_or_Cut(1);
  1506. }
  1507.  
  1508. ########################################################################
  1509. sub Column_Copy_or_Cut
  1510. {
  1511.  my ($w, $cut) = @_;
  1512.  my @ranges = $w->tagRanges('sel');
  1513.  my $range_total = @ranges;
  1514.  # this only makes sense if there is one selected block
  1515.  unless ($range_total==2)
  1516.   {
  1517.   $w->bell;
  1518.   return;
  1519.   }
  1520.  
  1521.  my $selection_start_index = shift(@ranges);
  1522.  my $selection_end_index = shift(@ranges);
  1523.  
  1524.  my ($start_line, $start_column) = split(/\./, $selection_start_index);
  1525.  my ($end_line,   $end_column)   = split(/\./, $selection_end_index);
  1526.  
  1527.  # correct indices for tabs
  1528.  my $string;
  1529.  $string = $w->get($start_line.'.0', $start_line.'.0 lineend');
  1530.  $string = substr($string, 0, $start_column);
  1531.  $string = expand($string);
  1532.  my $tab_start_column = length($string);
  1533.  
  1534.  $string = $w->get($end_line.'.0', $end_line.'.0 lineend');
  1535.  $string = substr($string, 0, $end_column);
  1536.  $string = expand($string);
  1537.  my $tab_end_column = length($string);
  1538.  
  1539.  my $length = $tab_end_column - $tab_start_column;
  1540.  
  1541.  $selection_start_index = $start_line . '.' . $tab_start_column;
  1542.  $selection_end_index   = $end_line   . '.' . $tab_end_column;
  1543.  
  1544.  # clear the clipboard
  1545.  $w->clipboardClear;
  1546.  my ($clipstring, $startstring, $endstring);
  1547.  my $padded_string = ' 'x$tab_end_column;
  1548.  for(my $line = $start_line; $line <= $end_line; $line++)
  1549.   {
  1550.   $string = $w->get($line.'.0', $line.'.0 lineend');
  1551.   $string = expand($string) . $padded_string;
  1552.   $clipstring = substr($string, $tab_start_column, $length);
  1553.   #$clipstring = unexpand($clipstring);
  1554.   $w->clipboardAppend($clipstring."\n");
  1555.  
  1556.   if ($cut)
  1557.    {
  1558.    $startstring = substr($string, 0, $tab_start_column);
  1559.    $startstring = unexpand($startstring);
  1560.    $start_column = length($startstring);
  1561.  
  1562.    $endstring = substr($string, 0, $tab_end_column );
  1563.    $endstring = unexpand($endstring);
  1564.    $end_column = length($endstring);
  1565.  
  1566.    $w->delete($line.'.'.$start_column,  $line.'.'.$end_column);
  1567.    }
  1568.   }
  1569. }
  1570.  
  1571. ########################################################################
  1572.  
  1573. sub clipboardColumnPaste
  1574. {
  1575.  my ($w) = @_;
  1576.  my @ranges = $w->tagRanges('sel');
  1577.  my $range_total = @ranges;
  1578.  if ($range_total)
  1579.   {
  1580.   warn " there cannot be any selections during clipboardColumnPaste. \n";
  1581.   $w->bell;
  1582.   return;
  1583.   }
  1584.  
  1585.  my $clipboard_text;
  1586.  eval
  1587.   {
  1588.   $clipboard_text = $w->SelectionGet(-selection => "CLIPBOARD");
  1589.   };
  1590.  
  1591.  return unless (defined($clipboard_text));
  1592.  return unless (length($clipboard_text));
  1593.  my $string;
  1594.  
  1595.  my $current_index = $w->index('insert');
  1596.  my ($current_line, $current_column) = split(/\./,$current_index);
  1597.  $string = $w->get($current_line.'.0', $current_line.'.'.$current_column);
  1598.  $string = expand($string);
  1599.  $current_column = length($string);
  1600.  
  1601.  my @clipboard_lines = split(/\n/,$clipboard_text);
  1602.  my $length;
  1603.  my $end_index;
  1604.  my ($delete_start_column, $delete_end_column, $insert_column_index);
  1605.  foreach my $line (@clipboard_lines)
  1606.   {
  1607.   if ($w->OverstrikeMode)
  1608.    {
  1609.    #figure out start and end indexes to delete, compensating for tabs.
  1610.    $string = $w->get($current_line.'.0', $current_line.'.0 lineend');
  1611.    $string = expand($string);
  1612.    $string = substr($string, 0, $current_column);
  1613.    $string = unexpand($string);
  1614.    $delete_start_column = length($string);
  1615.  
  1616.    $string = $w->get($current_line.'.0', $current_line.'.0 lineend');
  1617.    $string = expand($string);
  1618.    $string = substr($string, 0, $current_column + length($line));
  1619.    chomp($string);  # dont delete a "\n" on end of line.
  1620.    $string = unexpand($string);
  1621.    $delete_end_column = length($string);
  1622.  
  1623.  
  1624.  
  1625.    $w->delete(
  1626.               $current_line.'.'.$delete_start_column ,
  1627.               $current_line.'.'.$delete_end_column
  1628.              );
  1629.    }
  1630.  
  1631.   $string = $w->get($current_line.'.0', $current_line.'.0 lineend');
  1632.   $string = expand($string);
  1633.   $string = substr($string, 0, $current_column);
  1634.   $string = unexpand($string);
  1635.   $insert_column_index = length($string);
  1636.  
  1637.   $w->insert($current_line.'.'.$insert_column_index, unexpand($line));
  1638.   $current_line++;
  1639.   }
  1640.  
  1641. }
  1642.  
  1643. # Backward compatibility
  1644. sub GetMenu
  1645. {
  1646.  carp((caller(0))[3]." is deprecated") if $^W;
  1647.  shift->menu
  1648. }
  1649.  
  1650. 1;
  1651. __END__
  1652.  
  1653.  
  1654.