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