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