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