1# This file converted to perltk using the tcl2perl script and much hand-editing. 2# jc 6/26/00 3# 4# table.tcl -- 5# 6# version align with tkTable 2.7, jeff.hobbs@acm.org 7# This file defines the default bindings for Tk table widgets 8# and provides procedures that help in implementing those bindings. 9# 10#-------------------------------------------------------------------------- 11# tkPriv elements used in this file: 12# 13# afterId - Token returned by "after" for autoscanning. 14# tablePrev - The last element to be selected or deselected 15# during a selection operation. 16# mouseMoved - Boolean to indicate whether mouse moved while 17# the button was pressed. 18# borderInfo - Boolean to know if the user clicked on a border 19# borderB1 - Boolean that set whether B1 can be used for the 20# interactiving resizing 21#-------------------------------------------------------------------------- 22## Interactive cell resizing, affected by -resizeborders option 23## 24package Tk::TableMatrix; 25 26use AutoLoader; 27use Carp; 28use strict; 29use vars( '%tkPriv', '$VERSION'); 30 31$VERSION = '1.26'; 32 33use Tk qw( Ev ); 34 35use base qw(Tk::Widget); 36 37Construct Tk::Widget 'TableMatrix'; 38 39bootstrap Tk::TableMatrix; 40 41sub Tk_cmd { \&Tk::tablematrix }; 42 43sub Tk::Widget::ScrlTableMatrix { shift->Scrolled('TableMatrix' => @_) } 44 45Tk::Methods("activate", "bbox", "border", "cget", "clear", "configure", 46 "curselection", "curvalue", "delete", "get", "rowHeight", 47 "hidden", "icursor", "index", "insert", 48 "postscript", 49 "reread", "scan", "see", "selection", "set", 50 "spans", "tag", "validate", "version", "window", "colWidth", 51 "xview", "yview"); 52 53use Tk::Submethods ( 'border' => [qw(mark dragto)], 54 'clear' => [qw(cache sizes tags all)], 55 'delete' => [qw(active cols rows)], 56 'insert' => [qw(active cols rows)], 57 'scan' => [qw(mark dragto)], 58 'selection'=> [qw(anchor clear includes set)], 59 'tag' => [qw(cell cget col configure delete exists 60 includes names row raise lower)], 61 'window' => [qw(cget configure delete move names)], 62 'xview' => [qw(moveto scroll)], 63 'yview' => [qw(moveto scroll)], 64 ); 65 66 67 68sub ClassInit 69{ 70 my ($class,$mw) = @_; 71 72$tkPriv{borderB1} = 1; # initialize borderB1 73 74$mw->bind($class,'<3>', 75 sub 76 { 77 my $w = shift; 78 my $Ev = $w->XEvent; 79 ## You might want to check for cell returned if you want to 80 ## restrict the resizing of certain cells 81 $w->border('mark',$Ev->x,$Ev->y); 82 } 83 ); 84 85 86 $mw->bind($class,'<B3-Motion>',['border','dragto',Ev('x'),Ev('y')]); 87 $mw->bind($class,'<1>', 88 sub 89 { 90 my $w = shift; 91 my $Ev = $w->XEvent; 92 $w->Button1($Ev->x,$Ev->y); 93 } 94 ); 95 $mw->bind($class,'<B1-Motion>', 96 sub 97 { 98 my $w = shift; 99 my $Ev = $w->XEvent; 100 $w->B1Motion($Ev->x,$Ev->y); 101 102 } 103 ); 104 $mw->bind($class,'<ButtonRelease-1>', 105 sub 106 { 107 my $w = shift; 108 my $Ev = $w->XEvent; 109 $tkPriv{borderInfo} = ""; 110 if ($w->exists) 111 { 112 $w->CancelRepeat; 113 $w->activate('@' . $Ev->x.",".$Ev->y); 114 } 115 } 116 ); 117 $mw->bind($class,'<Shift-1>', 118 sub 119 { 120 my $w = shift; 121 my $Ev = $w->XEvent; 122 $w->BeginExtend( $w->index('@' . $Ev->x.",".$Ev->y)); 123 } 124 ); 125 126 127 $mw->bind($class,'<Control-1>', 128 sub 129 { 130 my $w = shift; 131 my $Ev = $w->XEvent; 132 $w->BeginToggle($w->index('@' . $Ev->x.",".$Ev->y)); 133 } 134 ); 135 $mw->bind($class,'<B1-Enter>','CancelRepeat'); 136 $mw->bind($class,'<B1-Leave>', 137 sub 138 { 139 my $w = shift; 140 my $Ev = $w->XEvent; 141 if( !$tkPriv{borderInfo} ){ 142 $tkPriv{x} = $Ev->x; $tkPriv{y} = $Ev->y; 143 $w->AutoScan; 144 } 145 } 146 ); 147 $mw->bind($class,'<2>', 148 sub 149 { 150 my $w = shift; 151 my $Ev = $w->XEvent; 152 $w->scan('mark',$Ev->x,$Ev->y); 153 $tkPriv{x} = $Ev->x; $tkPriv{y} = $Ev->y; 154 $tkPriv{'mouseMoved'} = 0; 155 } 156 ); 157 $mw->bind($class,'<B2-Motion>', 158 sub 159 { 160 my $w = shift; 161 my $Ev = $w->XEvent; 162 $tkPriv{'mouseMoved'} = 1 if ($Ev->x ne $tkPriv{'x'} || $Ev->y ne $tkPriv{'y'}); 163 $w->scan('dragto',$Ev->x,$Ev->y) if ($tkPriv{'mouseMoved'}); 164 } 165 ); 166 $mw->bind($class,'<ButtonRelease-2>', 167 sub 168 { 169 my $w = shift; 170 my $Ev = $w->XEvent; 171 $w->Paste($w->index('@' . $Ev->x.",".$Ev->y)) unless ($tkPriv{'mouseMoved'}); 172 } 173 ); 174 175 176 177 ClipboardKeysyms( $mw, $class, qw/ <Copy> <Cut> <Paste> /); 178 ClipboardKeysyms( $mw, $class, 'Control-c', 'Control-x', 'Control-v'); 179 180############################ 181 182 183 $mw->bind($class,'<<Table_Commit>>', 184 sub 185 { 186 my $w = shift; 187 my $Ev = $w->XEvent; 188 eval 189 { 190 $w->activate('active'); 191 } 192 ; 193 } 194 ); 195 196# Remove this if you don't want cell commit to occur on every Leave for 197# the table (via mouse) or FocusOut (loss of focus by table). 198$mw->eventAdd( qw[ <<Table_Commit>> <Leave> <FocusOut> ]); 199 200 $mw->bind($class,'<Shift-Up>',['ExtendSelect',-1,0]); 201 $mw->bind($class,'<Shift-Down>',['ExtendSelect',1,0]); 202 $mw->bind($class,'<Shift-Left>',['ExtendSelect',0,-1]); 203 $mw->bind($class,'<Shift-Right>',['ExtendSelect',0,1]); 204 $mw->bind($class,'<Prior>', 205 sub 206 { 207 my $w = shift; 208 my $Ev = $w->XEvent; 209 $w->yview('scroll',-1,'pages'); 210 $w->activate('@0,0'); 211 } 212 ); 213 $mw->bind($class,'<Next>', 214 sub 215 { 216 my $w = shift; 217 my $Ev = $w->XEvent; 218 $w->yview('scroll',1,'pages'); 219 $w->activate('@0,0'); 220 } 221 ); 222 $mw->bind($class,'<Control-Prior>',['xview','scroll',-1,'pages']); 223 $mw->bind($class,'<Control-Next>',['xview','scroll',1,'pages']); 224 $mw->bind($class,'<Home>',['see','origin']); 225 $mw->bind($class,'<End>',['see','end']); 226 $mw->bind($class,'<Control-Home>', 227 sub 228 { 229 my $w = shift; 230 my $Ev = $w->XEvent; 231 $w->selection('clear','all'); 232 $w->activate('origin'); 233 $w->selection('set','active'); 234 $w->see('active'); 235 } 236 ); 237 $mw->bind($class,'<Control-End>', 238 sub 239 { 240 my $w = shift; 241 my $Ev = $w->XEvent; 242 $w->selection('clear','all'); 243 $w->activate('end'); 244 $w->selection('set','active'); 245 $w->see('active'); 246 } 247 ); 248 $mw->bind($class,'<Shift-Control-Home>',['DataExtend','origin']); 249 $mw->bind($class,'<Shift-Control-End>',['DataExtend','end']); 250 $mw->bind($class,'<Select>',['BeginSelect',Ev('index','active')]); 251 $mw->bind($class,'<Shift-Select>',['BeginExtend',Ev('index','active')]); 252 $mw->bind($class,'<Control-slash>','SelectAll'); 253 $mw->bind($class,'<Control-backslash>', 254 sub 255 { 256 my $w = shift; 257 my $Ev = $w->XEvent; 258 $w->selection('clear','all') if ($w->cget(-selectmode) =~ /browse/); 259 } 260 ); 261 $mw->bind($class,'<Up>',['MoveCell',-1,0]); 262 $mw->bind($class,'<Down>',['MoveCell',1,0]); 263 $mw->bind($class,'<Left>',['MoveCell',0,-1]); 264 $mw->bind($class,'<Right>',['MoveCell',0,1]); 265 $mw->bind($class,'<KeyPress>',['TableInsert',Ev('A')]); 266 267 $mw->bind($class,'<BackSpace>',['BackSpace']); 268 269 $mw->bind($class,'<Delete>',['delete','active','insert']); 270 $mw->bind($class,'<Escape>','reread'); 271 $mw->bind($class,'<Return>',['TableInsert',"\n"]); 272 $mw->bind($class,'<Control-Left>', 273 sub 274 { 275 my $w = shift; 276 my $Ev = $w->XEvent; 277 my $posn = $w->icursor; 278 $w->icursor($posn - 1); 279 } 280 ); 281 282 $mw->bind($class,'<Control-Right>', 283 sub 284 { 285 my $w = shift; 286 my $Ev = $w->XEvent; 287 my $posn = $w->icursor; 288 $w->icursor($posn + 1); 289 } 290 ); 291 292 $mw->bind($class,'<Control-e>',['icursor','end']); 293 $mw->bind($class,'<Control-a>',['icursor',0]); 294 $mw->bind($class,'<Control-k>',['delete','active','insert','end']); 295 $mw->bind($class,'<Control-equal>',['ChangeWidth','active',1]); 296 $mw->bind($class,'<Control-minus>',['ChangeWidth','active',-1]); 297 298# Ignore all Alt, Meta, and Control keypresses unless explicitly bound. 299# Otherwise, if a widget binding for one of these is defined, the 300# <KeyPress> class binding will also fire and insert the character, 301# which is wrong. Ditto for Tab. 302 303 304 $mw->bind($class,'<Alt-KeyPress>', 305 sub 306 { 307 my $w = shift; 308 my $Ev = $w->XEvent; 309 # nothing 310 } 311 ); 312 $mw->bind($class,'<Meta-KeyPress>', 313 sub 314 { 315 my $w = shift; 316 my $Ev = $w->XEvent; 317 # nothing 318 319 } 320 ); 321 $mw->bind($class,'<Control-KeyPress>', 322 sub 323 { 324 my $w = shift; 325 my $Ev = $w->XEvent; 326 # 327 } 328 ); 329 $mw->bind($class,'<Any-Tab>', 330 sub 331 { 332 my $w = shift; 333 my $Ev = $w->XEvent; 334 # 335 } 336 ); 337 338 339 340} 341 342 343 344# ::tk::table::GetSelection -- 345# This tries to obtain the default selection. On Unix, we first try 346# and get a UTF8_STRING, a type supported by modern Unix apps for 347# passing Unicode data safely. We fall back on the default STRING 348# type otherwise. On Windows, only the STRING type is necessary. 349# Arguments: 350# w The widget for which the selection will be retrieved. 351# Important for the -displayof property. 352# sel The source of the selection (PRIMARY or CLIPBOARD) 353# Results: 354# Returns the selection, or an error if none could be found 355# 356sub GetSelection{ 357 358 my $w = shift; 359 my $sel = shift; 360 $sel ||= 'PRIMARY'; 361 362 my $txt; 363 if( $Tk::platform eq 'unix'){ 364 eval{ $txt = $w->SelectionGet( -selection => $sel) }; 365 366 if( $@){ 367 warn("Could not find default selection\n"); 368 return undef; 369 } 370 371 return $txt; 372 373 } 374 else{ 375 376 eval{ $txt = $w->SelectionGet( -selection => $sel) }; 377 378 if( $@){ 379 warn("Could not find default selection\n"); 380 return undef; 381 } 382 383 return $txt; 384 385 } 386} 387 388 389 390# ClipboardKeysyms -- 391# This procedure is invoked to identify the keys that correspond to 392# the "copy", "cut", and "paste" functions for the clipboard. 393# 394# Arguments: 395# copy - Name of the key (keysym name plus modifiers, if any, 396# such as "Meta-y") used for the copy operation. 397# cut - Name of the key used for the cut operation. 398# paste - Name of the key used for the paste operation. 399 400sub ClipboardKeysyms 401{ 402 my $mw = shift; 403 my $class = shift; 404 my $copy = shift; 405 my $cut = shift; 406 my $paste = shift; 407 $mw->bind($class,"<$copy>",'Copy'); 408 $mw->bind($class,"<$cut>",'Cut'); 409 $mw->bind($class,"<$paste>",'Paste'); 410 411} 412# TableInsert -- 413# 414# Insert into the active cell 415# 416# Arguments: 417# w - the table widget 418# s - the string to insert 419# Results: 420# Returns nothing 421# 422 423sub TableInsert 424{ 425 my $w = shift; 426 my $s = shift; 427 $w->insert('active','insert',$s) if ($s ne '' ) ; 428} 429# ::tk::table::BackSpace -- 430# 431# BackSpace in the current cell 432# 433# Arguments: 434# w - the table widget 435# Results: 436# Returns nothing 437# 438sub BackSpace{ 439 440 my $w = shift; 441 my $Ev = $w->XEvent; 442 my $posn = $w->icursor; 443 $w->delete('active',$posn - 1) if( $posn > -1); 444} 445 446# Button1 -- 447# 448# This procedure is called to handle selecting with mouse button 1. 449# It will distinguish whether to start selection or mark a border. 450# 451# Arguments: 452# w - the table widget 453# x - x coord 454# y - y coord 455# Results: 456# Returns nothing 457# 458sub Button1 { 459 460 my $w = shift; 461 my ( $x, $y ) = @_; 462 463 # borderInfo is null if the user did not click on a border 464 if ( $tkPriv{borderB1} == 1 ) { 465 $tkPriv{borderInfo} = $w->borderMark( $x, $y ); 466 } 467 else { 468 $tkPriv{borderInfo} = ""; 469 } 470 471 if ( ! $tkPriv{borderInfo} ) { 472 473 # 474 # Only do this when a border wasn't selected 475 # 476 if ( $w->exists ) { 477 $w->BeginSelect( $w->index( '@' . "$x,$y" ) ); 478 $w->focus; 479 } 480 $tkPriv{x} = $x; 481 $tkPriv{y} = $y; 482 $tkPriv{mouseMoved} = 0; 483 } 484} 485 486# B1Motion -- 487# 488# This procedure is called to start processing mouse motion events while 489# button 1 moves while pressed. It will distinguish whether to change 490# the selection or move a border. 491# 492# Arguments: 493# w - the table widget 494# x - x coord 495# y - y coord 496# Results: 497# Returns nothing 498# 499sub B1Motion { 500 501 my $w = shift; 502 503 my ( $x, $y ) = @_; 504 505 # If we already had motion, or we moved more than 1 pixel, 506 # then we start the Motion routine 507 508 if ( $tkPriv{borderInfo} ) { 509 510 # 511 # If the motion is on a border, drag it and skip the rest 512 # of this binding. 513 # 514 $w->borderDragto( $x, $y ); 515 516 } 517 else { 518 519 # 520 # If we already had motion, or we moved more than 1 pixel, 521 # then we start the Motion routine 522 # 523 if ( $tkPriv{mouseMoved} 524 || abs( $x - $tkPriv{x} ) > 1 525 || abs( $y - $tkPriv{y} ) > 1 ) { 526 527 $tkPriv{mouseMoved} = 1; 528 } 529 if ( $tkPriv{mouseMoved} ) { 530 $w->Motion( $w->index( '@' . "$x,$y" ) ); 531 } 532 } 533} 534# BeginSelect -- 535# 536# This procedure is typically invoked on button-1 presses. It begins 537# the process of making a selection in the table. Its exact behavior 538# depends on the selection mode currently in effect for the table; 539# see the Motif documentation for details. 540# 541# Arguments: 542# w - The table widget. 543# el - The element for the selection operation (typically the 544# one under the pointer). Must be in row,col form. 545 546sub BeginSelect 547{ 548 my $w = shift; 549 my $el = shift; 550 my $r; 551 my $c; 552 my $inc; 553 my $el2; 554 return unless( scalar( ($r,$c) = split(",",$el)) ==2); # Get Rol Col or return 555 my $selectmode = $w->cget('-selectmode'); 556 if ($selectmode eq 'multiple') 557 { 558 if ($w->tag('includes','title',$el)) 559 { 560 ## in the title area 561 if ($r < ($w->cget('-titlerows') + $w->cget('-roworigin')) ) 562 { 563 ## We're in a column header 564 if ($c < ( $w->cget('-titlecols') + $w->cget('-colorigin'))) 565 { 566 ## We're in the topleft title area 567 $inc = 'topleft'; 568 $el2 = 'end'; 569 } 570 else 571 { 572 $inc = $w->index('topleft','row').",$c"; 573 $el2 = $w->index('end','row').",$c"; 574 } 575 } 576 else 577 { 578 ## We're in a row header 579 $inc = "$r,".$w->index('topleft','col'); 580 $el2 = "$r,".$w->index('end','col'); 581 } 582 } 583 else 584 { 585 $inc = $el; 586 $el2 = $el; 587 } 588 if ($w->selection('includes',$inc)) 589 { 590 $w->selection('clear',$el,$el2); 591 } 592 else 593 { 594 $w->selection('set',$el,$el2); 595 } 596 } 597 elsif ($selectmode eq 'extended') 598 { 599 $w->selection('clear','all'); 600 if ($w->tag('includes','title',$el)) 601 { 602 if ($r < ($w->cget('-titlerows') + $w->cget('-roworigin'))) 603 { 604 ## We're in a column header 605 if ($c < ( $w->cget('-titlecols') + $w->cget('-colorigin')) ) 606 { 607 $w->selection('set',$el,'end'); 608 } 609 else 610 { 611 $w->selection('set',$el,$w->index('end','row').",$c"); 612 } 613 } 614 else 615 { 616 ## We're in a row header 617 $w->selection('set',$el,"$r,".$w->index('end','col')); 618 } 619 } 620 else 621 { 622 $w->selection('set',$el); 623 } 624 $w->selection('anchor',$el); 625 $tkPriv{'tablePrev'} = $el; 626 } 627 elsif ($selectmode eq 'default') 628 { 629 unless ($w->tag('includes','title',$el)) 630 { 631 $w->selection('clear','all'); 632 $w->selection('set',$el); 633 $tkPriv{'tablePrev'} = $el; 634 } 635 $w->selection('anchor',$el); 636 } 637} 638# Motion -- 639# 640# This procedure is called to process mouse motion events while 641# button 1 is down. It may move or extend the selection, depending 642# on the table's selection mode. 643# 644# Arguments: 645# w - The table widget. 646# el - The element under the pointer (must be in row,col form). 647 648sub Motion 649{ 650 my $w = shift; 651 my $el = shift; 652 my $r; 653 my $c; 654 my $elc; 655 my $elr; 656 unless (exists($tkPriv{'tablePrev'})) 657 { 658 $tkPriv{'tablePrev'} = $el; 659 return; 660 } 661 return if ($tkPriv{'tablePrev'} eq $el ); 662 my $selectmode = $w->cget('-selectmode'); 663 if ($selectmode eq 'browse') 664 { 665 $w->selection('clear','all'); 666 $w->selection('set',$el); 667 $tkPriv{'tablePrev'} = $el; 668 } 669 elsif ($selectmode eq 'extended') 670 { 671 # avoid tables that have no anchor index yet. 672 my $indexAnchor; 673 eval{ $indexAnchor = $w->index('anchor') }; 674 return if( $@ || !$indexAnchor); 675 676 ($r,$c) = split(",",$tkPriv{tablePrev}); 677 ($elr,$elc) = split(",",$el); 678 679 if ($w->tag('includes','title',$el)) 680 { 681 if ($r < ($w->cget('-titlerows') + $w->cget('-roworigin')) ) 682 { 683 ## We're in a column header 684 if ($c < ( $w->cget('-titlecols') + $w->cget('-colorigin')) ) 685 { 686 ## We're in the topleft title area 687 $w->selection('clear','anchor','end'); 688 } 689 else 690 { 691 $w->selection('clear','anchor',$w->index('end','row').",$c"); 692 } 693 ##### perltk: Removed comma 694 $w->selection('set','anchor',$w->index('end','row').",$elc"); 695 } 696 else 697 { 698 ## We're in a row header 699 $w->selection('clear','anchor',"$r,".$w->index('end','col')); 700 $w->selection('set','anchor',"$elr,".$w->index('end','col')); 701 } 702 } 703 else 704 { 705 $w->selection('clear','anchor',$tkPriv{'tablePrev'}); 706 $w->selection('set','anchor',$el); 707 } 708 $tkPriv{'tablePrev'} = $el; 709 } 710} 711# BeginExtend -- 712# 713# This procedure is typically invoked on shift-button-1 presses. It 714# begins the process of extending a selection in the table. Its 715# exact behavior depends on the selection mode currently in effect 716# for the table; see the Motif documentation for details. 717# 718# Arguments: 719# w - The table widget. 720# el - The element for the selection operation (typically the 721# one under the pointer). Must be in numerical form. 722 723sub BeginExtend 724{ 725 my $w = shift; 726 my $el = shift; 727 $w->Motion($el) if ($w->cget(-selectmode) eq 'extended' && $w->selectionIncludes('anchor')); 728} 729# BeginToggle -- 730# 731# This procedure is typically invoked on control-button-1 presses. It 732# begins the process of toggling a selection in the table. Its 733# exact behavior depends on the selection mode currently in effect 734# for the table; see the Motif documentation for details. 735# 736# Arguments: 737# w - The table widget. 738# el - The element for the selection operation (typically the 739# one under the pointer). Must be in numerical form. 740 741sub BeginToggle 742{ 743 my $w = shift; 744 my $el = shift; 745 my $r; 746 my $c; 747 my $end; 748 if ( $w->cget( -selectmode ) =~ /extended/i ) 749 { 750 $tkPriv{'tablePrev'} = $el; 751 $w->selection('anchor',$el); 752 if ($w->tag('includes','title',$el)) 753 { 754 # scan $el %d,%d r c 755 ($r,$c) = split( ",",$el); 756 if ($r < ($w->cget('-titlerows') + $w->cget('-roworigin')) ) 757 { 758 ## We're in a column header 759 if ($c < ($w->cget('-titlecols') + $w->cget('-colorigin'))) 760 { 761 ## We're in the topleft title area 762 $end = 'end'; 763 } 764 else 765 { 766 $end = $w->index('end','row'); 767 } 768 } 769 else 770 { 771 ## We're in a row header 772 $end = "$r,".$w->index('end','row'); 773 } 774 } 775 else 776 { 777 ## We're in a non-title cell 778 $end = $el; 779 } 780 if ($w->selection('includes',$end)) 781 { 782 $w->selection('clear',$el,$end); 783 } 784 else 785 { 786 $w->selection('set',$el,$end); 787 } 788 } 789} 790# AutoScan -- 791# This procedure is invoked when the mouse leaves an table window 792# with button 1 down. It scrolls the window up, down, left, or 793# right, depending on where the mouse left the window, and reschedules 794# itself as an "after" command so that the window continues to scroll until 795# the mouse moves back into the window or the mouse button is released. 796# 797# Arguments: 798# w - The table window. 799 800sub AutoScan 801{ 802 my $w = shift; 803 my $x; 804 my $y; 805 806 return unless ($w->exists); 807 $x = $tkPriv{'x'}; 808 $y = $tkPriv{'y'}; 809 810 if ($y >= $w->SUPER::height) # we don't want our height here, we want the 811 # actual height of the window 812 { 813 $w->yview('scroll',1,'units'); 814 } 815 elsif ($y < 0) 816 { 817 $w->yview('scroll',-1,'units'); 818 } 819 elsif ($x >= $w->SUPER::width) 820 { 821 $w->xview('scroll',1,'units'); 822 } 823 elsif ($x < 0) 824 { 825 $w->xview('scroll',-1,'units'); 826 } 827 else 828 { 829 return; 830 } 831 $w->Motion($w->index('@' . $x.','.$y)); 832 $tkPriv{'afterId'} = $w->after(50,[$w,'AutoScan']); 833} 834# MoveCell -- 835# 836# Moves the location cursor (active element) by the specified number 837# of cells and changes the selection if we're in browse or extended 838# selection mode. If the new cell is "hidden", we skip to the next 839# visible cell if possible, otherwise just abort. 840# 841# Arguments: 842# w - The table widget. 843# x - +1 to move down one cell, -1 to move up one cell. 844# y - +1 to move right one cell, -1 to move left one cell. 845 846sub MoveCell 847{ 848 849 850 my $w = shift; 851 my $x = shift; 852 my $y = shift; 853 my $c; 854 my $cell; 855 my $r; 856 my $true; 857 eval { $r = $w->index('active','row') }; return if( $@); 858 859 $c = $w->index('active','col'); 860 # set cell [$w index [incr r $x],[incr c $y]] 861 $cell = $w->index(($r += $x).",".($c += $y)); 862 while ( ($true = $w->index('active')) eq '') 863 { 864 # The cell is in some way hidden 865 if ($true eq $w->index('active')) 866 { 867 # The span cell wasn't the previous cell, so go to that 868 $cell = $true; 869 last; 870 } 871 if ($x > 0) 872 { 873 ++ $r; 874 } 875 elsif ($x < 0) 876 { 877 $r += -1; 878 } 879 if ($y > 0) 880 { 881 ++ $c; 882 } 883 elsif ($y < 0) 884 { 885 $c += -1; 886 } 887 if ($cell eq $w->index($r.",".$c)) 888 { 889 $cell = $w->index("$r,$c"); 890 } 891 else 892 { 893 # We couldn't find a non-hidden cell, just don't move 894 return; 895 } 896 } 897 $w->activate($cell); 898 $w->see('active'); 899 if ($w->cget('-selectmode') eq 'browse') 900 { 901 $w->selection('clear','all'); 902 $w->selection('set','active'); 903 } 904 elsif ($w->cget('-selectmode') eq 'extended') 905 { 906 $w->selection('clear','all'); 907 $w->selection('set','active'); 908 $w->selection('anchor','active'); 909 $tkPriv{'tablePrev'} = $w->index('active'); 910 } 911} 912# ExtendSelect -- 913# 914# Does nothing unless we're in extended selection mode; in this 915# case it moves the location cursor (active element) by the specified 916# number of cells, and extends the selection to that point. 917# 918# Arguments: 919# w - The table widget. 920# x - +1 to move down one cell, -1 to move up one cell. 921# y - +1 to move right one cell, -1 to move left one cell. 922 923sub ExtendSelect 924{ 925 my $w = shift; 926 my $x = shift; 927 my $y = shift; 928 my $c; 929 my $r; 930 #### Perltk notes: (should be 'ne' instead of 'eq' ??? 931 return unless ( $w->cget(-selectmode) eq 'extended'); 932 eval { $r = $w->index('active','row'); }; return if($@); 933 $c = $w->index('active','col'); 934 $w->activate( ($r += $x).",".($c += $y)); 935 $w->see('active'); 936 $w->Motion($w->index('active')); 937} 938# DataExtend 939# 940# This procedure is called for key-presses such as Shift-KEndData. 941# If the selection mode isnt multiple or extend then it does nothing. 942# Otherwise it moves the active element to el and, if we're in 943# extended mode, extends the selection to that point. 944# 945# Arguments: 946# w - The table widget. 947# el - An integer cell number. 948 949sub DataExtend 950{ 951 my $w = shift; 952 my $el = shift; 953 my $mode; 954 $mode = $w->cget('-selectmode'); 955 if ($mode =~ /extended/i ) 956 { 957 $w->activate($el); 958 $w->see($el); 959 $w->Motion($el) if ($w->selection('includes','anchor')); 960 } 961 elsif ($mode =~ /multiple/i) 962 { 963 $w->activate($el); 964 $w->see($el); 965 } 966} 967# SelectAll 968# 969# This procedure is invoked to handle the "select all" operation. 970# For single and browse mode, it just selects the active element. 971# Otherwise it selects everything in the widget. 972# 973# Arguments: 974# w - The table widget. 975 976sub SelectAll 977{ 978 my $w = shift; 979 if ( $w->cget(-selectmode) =~ /^(single|browse)$/) 980 { 981 $w->selection('clear','all'); 982 $w->selection('set','active'); 983 $w->TableMatrixHandleType($w->index('active')); 984 } 985 else 986 { 987 $w->selection('set','origin','end'); 988 } 989} 990# ChangeWidth -- 991# Adjust the widget of the specified cell by $a. 992# 993# Arguments: 994# w - The table widget. 995# i - cell index 996# a - amount to adjust by 997 998sub ChangeWidth 999{ 1000 my $w = shift; 1001 my $i = shift; 1002 my $a = shift; 1003 my $tmp; 1004 my $width; 1005 $tmp = $w->index($i,'col'); 1006 if (($width = $w->colWidth($tmp)) >= 0) 1007 { 1008 $w->colWidth($tmp,$width += $a); 1009 } 1010 else 1011 { 1012 $w->colWidth($tmp,$width += -$a); 1013 } 1014} 1015# Copy -- 1016# This procedure copies the selection from a table widget into the 1017# clipboard. 1018# 1019# Arguments: 1020# w - Name of a table widget. 1021 1022sub Copy 1023{ 1024 my $w = shift; 1025 if ($w->SelectionOwner() eq $w) 1026 { 1027 $w->clipboardClear; 1028 eval 1029 { 1030 $w->clipboardAppend($w->GetSelection); 1031 } 1032 ; 1033 } 1034} 1035# Cut -- 1036# This procedure copies the selection from a table widget into the 1037# clipboard, then deletes the selection (if it exists in the given 1038# widget). 1039# 1040# Arguments: 1041# w - Name of a table widget. 1042 1043sub Cut 1044{ 1045 my $w = shift; 1046 if ($w->SelectionOwner() eq $w) 1047 { 1048 $w->clipboardClear; 1049 eval 1050 { 1051 $w->clipboardAppend($w->GetSelection); 1052 $w->curselection('');# Clear whatever is selected 1053 $w->selectionClear(); 1054 } 1055 ; 1056 } 1057} 1058# Paste -- 1059# This procedure pastes the contents of the clipboard to the specified 1060# cell (active by default) in a table widget. 1061# 1062# Arguments: 1063# w - Name of a table widget. 1064# cell - Cell to start pasting in. 1065 1066sub Paste 1067{ 1068 my $w = shift; 1069 my $cell = shift || ''; ## Perltk not sure if translated correctly 1070 my $data; 1071 if ($cell ne '') 1072 { 1073 eval{ $data = $w->GetSelection(); }; return if($@); 1074 } 1075 else 1076 { 1077 eval{ $data = $w->GetSelection('CLIPBOARD'); }; return if($@); 1078 $cell = 'active'; 1079 } 1080 $w->PasteHandler($w->index($cell),$data); 1081 $w->focus if ($w->cget('-state') eq 'normal'); 1082} 1083# PasteHandler -- 1084# This procedure handles how data is pasted into the table widget. 1085# This handles data in the default table selection form. 1086# NOTE: this allows pasting into all cells, even those with -state disabled 1087# 1088# Arguments: 1089# w - Name of a table widget. 1090# cell - Cell to start pasting in. 1091 1092sub PasteHandler 1093{ 1094 1095 my $w = shift; 1096 my $cell = shift; 1097 my $data = shift; 1098 # 1099 # Don't allow pasting into the title cells 1100 # 1101 return if( $w->tagIncludes('title', $cell)); 1102 my $rows; 1103 my $cols; 1104 my $r; 1105 my $c; 1106 my $rsep; 1107 my $csep; 1108 my $row; 1109 my $line; 1110 my $col; 1111 my $item; 1112 $rows = $w->cget('-rows') - $w->cget('-roworigin'); 1113 $cols = $w->cget('-cols') - $w->cget('-colorigin'); 1114 $r = $w->index($cell,'row'); 1115 $c = $w->index($cell,'col'); 1116 $rsep = $w->cget('-rowseparator'); 1117 $csep = $w->cget('-colseparator'); 1118 ## Assume separate rows are split by row separator if specified 1119 ## If you were to want multi-character row separators, you would need: 1120 # regsub -all $rsep $data <newline> data 1121 # set data [join $data <newline>] 1122 my @data; 1123 @data = split($rsep,$data) if ($rsep ne ''); 1124 $row = $r; 1125 foreach $line (@data) 1126 { 1127 last if ($row > $rows); 1128 $col = $c; 1129 ## Assume separate cols are split by col separator if specified 1130 ## Unless a -separator was specified 1131 my @line = split($csep, $line) if ($csep ne ''); 1132 ## If you were to want multi-character col separators, you would need: 1133 # regsub -all $csep $line <newline> line 1134 # set line [join $line <newline>] 1135 foreach $item (@line) 1136 { 1137 last if ($col > $cols); 1138 $w->set("$row,$col",$item); 1139 ++ $col; 1140 } 1141 ++ $row; 1142 } 1143} 1144 1145 1146############################################################# 1147## CancelRepeat 1148# This procedure is invoked to cancel an auto-repeat action described 1149# by $Tk::TableMatrix::tkPriv{afterId}. It's used by several widgets to auto-scroll 1150# the widget when the mouse is dragged out of the widget with a 1151# button pressed. 1152 1153 1154sub CancelRepeat{ 1155 my $w = shift; 1156 1157 my $id = delete $tkPriv{'afterId'}; 1158 $w->afterCancel($id) if($id); 1159 1160} 1161 1162 1163 11641; 1165 1166__END__ 1167