projects / OpenSPARC-T2-DV / blame
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Initial commit of OpenSPARC T2 design and verification files.
[OpenSPARC-T2-DV] / tools / perl-5.8.0 / lib / site_perl / 5.8.0 / sun4-solaris / Tk / Text.pm
CommitLineData
86530b38
AT		 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.
15package Tk::Text;
16use AutoLoader;
17use Carp;
18use strict;
19
20use Text::Tabs;
21
22use vars qw($VERSION);
23$VERSION = '3.044'; # $Id: //depot/Tk8/Text/Text.pm#44 $
24
25use Tk qw(Ev $XS_VERSION);
26use base qw(Tk::Clipboard Tk::Widget);
27
28Construct Tk::Widget 'Text';
29
30bootstrap Tk::Text;
31
32sub Tk_cmd { \&Tk::text }
33
34sub Tk::Widget::ScrlText { shift->Scrolled('Text' => @_) }
35
36Tk::Methods('bbox','compare','debug','delete','dlineinfo','dump',
37 'get','image','index','insert','mark','scan','search',
38 'see','tag','window','xview','yview');
39
40use 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
50sub Tag;
51sub Tags;
52
53sub 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
149sub selectAll
150{
151 my ($w) = @_;
152 $w->tagAdd('sel','1.0','end');
153}
154
155sub unselectAll
156{
157 my ($w) = @_;
158 $w->tagRemove('sel','1.0','end');
159}
160
161sub adjustSelect
162{
163 my ($w) = @_;
164 my $Ev = $w->XEvent;
165 $w->ResetAnchor($Ev->xy);
166 $w->SelectTo($Ev->xy,'char')
167}
168
169sub 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
177sub 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
185sub 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
223sub insertTab
224{
225 my ($w) = @_;
226 $w->Insert("\t");
227 $w->focus;
228 $w->break
229}
230
231sub 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
244sub openLine
245{
246 my ($w) = @_;
247 $w->insert('insert',"\n");
248 $w->markSet('insert','insert-1c')
249}
250
251sub 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
260sub 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
267sub 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
277sub InsertSelection
278{
279 my ($w) = @_;
280 Tk::catch { $w->Insert($w->SelectionGet) }
281}
282
283sub 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
295sub 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
305sub 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.
329sub 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
339sub 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
349sub 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.
368sub 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.
443sub 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.
477sub 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).
494sub 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.
545sub 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########################################################################
597sub 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########################################################################
608sub 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.
622sub ToggleInsertMode
623{
624 my ($w)=@_;
625 $w->OverstrikeMode(!$w->OverstrikeMode);
626}
627
628########################################################################
629sub 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########################################################################
641sub 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########################################################################
654sub 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
698sub getSelected
699{
700 shift->GetTextTaggedWith('sel');
701}
702
703sub deleteSelected
704{
705 shift->DeleteTextTaggedWith('sel');
706}
707
708sub 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########################################################################
735sub 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########################################################################
766sub 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
811sub 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
824sub 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########################################################################
838sub 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########################################################################
921sub 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########################################################################
933sub 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########################################################################
978sub FindAndReplacePopUp
979{
980 my ($w)=@_;
981 $w->findandreplacepopup(0);
982}
983
984########################################################################
985sub FindPopUp
986{
987 my ($w)=@_;
988 $w->findandreplacepopup(1);
989}
990
991########################################################################
992
993sub 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
1107sub 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)
1123sub 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.
1158sub 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
1176sub 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.
1213sub 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.
1243sub 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.
1282sub 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
1296sub 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
1310sub Destroy
1311{
1312 my ($w) = @_;
1313 delete $w->{_Tags_};
1314}
1315
1316sub 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
1328sub 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
1343sub 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
1354sub TIEHANDLE
1355{
1356 my ($class,$obj) = @_;
1357 return $obj;
1358}
1359
1360sub 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
1381sub PRINTF
1382{
1383 my $w = shift;
1384 $w->PRINT(sprintf(shift,@_));
1385}
1386
1387sub 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
1395sub MenuLabels
1396{
1397 return qw[~File ~Edit ~Search ~View];
1398}
1399
1400sub 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
1411sub 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
1427sub 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########################################################################
1444sub clipboardColumnCopy
1445{
1446 my ($w) = @_;
1447 $w->Column_Copy_or_Cut(0);
1448}
1449
1450sub clipboardColumnCut
1451{
1452 my ($w) = @_;
1453 $w->Column_Copy_or_Cut(1);
1454}
1455
1456########################################################################
1457sub 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
1521sub 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
1592sub GetMenu
1593{
1594 carp((caller(0))[3]." is deprecated") if $^W;
1595 shift->menu
1596}
1597
15981;
1599__END__
1600
Full OpenSPARC design & verification tarball including full HDL.