1#============================================================================== 2# Contains the implementation of the tablelist::sortByColumn and 3# tablelist::addToSortColumns commands, as well as of the tablelist sort, 4# sortbycolumn, and sortbycolumnlist subcommands. 5# 6# Structure of the module: 7# - Public procedures related to sorting 8# - Private procedures implementing the sorting 9# 10# Copyright (c) 2000-2010 Csaba Nemethi (E-mail: csaba.nemethi@t-online.de) 11#============================================================================== 12 13# 14# Public procedures related to sorting 15# ==================================== 16# 17 18#------------------------------------------------------------------------------ 19# tablelist::sortByColumn 20# 21# Sorts the contents of the tablelist widget win by its col'th column. Returns 22# the sort order (increasing or decreasing). 23#------------------------------------------------------------------------------ 24proc tablelist::sortByColumn {win col} { 25 # 26 # Check the arguments 27 # 28 if {![winfo exists $win]} { 29 return -code error "bad window path name \"$win\"" 30 } 31 if {[string compare [winfo class $win] "Tablelist"] != 0} { 32 return -code error "window \"$win\" is not a tablelist widget" 33 } 34 if {[catch {::$win columnindex $col} result] != 0} { 35 return -code error $result 36 } 37 if {$result < 0 || $result >= [::$win columncount]} { 38 return -code error "column index \"$col\" out of range" 39 } 40 set col $result 41 if {[::$win columncget $col -showlinenumbers]} { 42 return "" 43 } 44 45 # 46 # Determine the sort order 47 # 48 if {[set idx [lsearch -exact [::$win sortcolumnlist] $col]] >= 0 && 49 [string compare [lindex [::$win sortorderlist] $idx] "increasing"] 50 == 0} { 51 set sortOrder decreasing 52 } else { 53 set sortOrder increasing 54 } 55 56 # 57 # Sort the widget's contents based on the given column 58 # 59 if {[catch {::$win sortbycolumn $col -$sortOrder} result] == 0} { 60 event generate $win <<TablelistColumnSorted>> 61 return $sortOrder 62 } else { 63 return -code error $result 64 } 65} 66 67#------------------------------------------------------------------------------ 68# tablelist::addToSortColumns 69# 70# Adds the col'th column of the tablelist widget win to the latter's list of 71# sort columns and sorts the contents of the widget by the modified column 72# list. Returns the specified column's sort order (increasing or decreasing). 73#------------------------------------------------------------------------------ 74proc tablelist::addToSortColumns {win col} { 75 # 76 # Check the arguments 77 # 78 if {![winfo exists $win]} { 79 return -code error "bad window path name \"$win\"" 80 } 81 if {[string compare [winfo class $win] "Tablelist"] != 0} { 82 return -code error "window \"$win\" is not a tablelist widget" 83 } 84 if {[catch {::$win columnindex $col} result] != 0} { 85 return -code error $result 86 } 87 if {$result < 0 || $result >= [::$win columncount]} { 88 return -code error "column index \"$col\" out of range" 89 } 90 set col $result 91 if {[::$win columncget $col -showlinenumbers]} { 92 return "" 93 } 94 95 # 96 # Update the lists of sort columns and orders 97 # 98 set sortColList [::$win sortcolumnlist] 99 set sortOrderList [::$win sortorderlist] 100 if {[set idx [lsearch -exact $sortColList $col]] >= 0} { 101 if {[string compare [lindex $sortOrderList $idx] "increasing"] == 0} { 102 set sortOrder decreasing 103 } else { 104 set sortOrder increasing 105 } 106 set sortOrderList [lreplace $sortOrderList $idx $idx $sortOrder] 107 } else { 108 lappend sortColList $col 109 lappend sortOrderList increasing 110 set sortOrder increasing 111 } 112 113 # 114 # Sort the widget's contents according to the 115 # modified lists of sort columns and orders 116 # 117 if {[catch {::$win sortbycolumnlist $sortColList $sortOrderList} result] 118 == 0} { 119 event generate $win <<TablelistColumnsSorted>> 120 return $sortOrder 121 } else { 122 return -code error $result 123 } 124} 125 126# 127# Private procedures implementing the sorting 128# =========================================== 129# 130 131#------------------------------------------------------------------------------ 132# tablelist::sortItems 133# 134# Processes the tablelist sort, sortbycolumn, and sortbycolumnlist subcommands. 135#------------------------------------------------------------------------------ 136proc tablelist::sortItems {win parentKey sortColList sortOrderList} { 137 variable canElide 138 variable snipSides 139 upvar ::tablelist::ns${win}::data data 140 141 set sortAllItems [expr {[string compare $parentKey "root"] == 0}] 142 if {[winfo viewable $win] && $sortAllItems} { 143 purgeWidgets $win 144 update idletasks 145 if {![winfo exists $win]} { ;# because of update idletasks 146 return "" 147 } 148 } 149 150 # 151 # Make sure sortOrderList has the same length as sortColList 152 # 153 set sortColCount [llength $sortColList] 154 set sortOrderCount [llength $sortOrderList] 155 if {$sortOrderCount < $sortColCount} { 156 for {set n $sortOrderCount} {$n < $sortColCount} {incr n} { 157 lappend sortOrderList increasing 158 } 159 } else { 160 set sortOrderList [lrange $sortOrderList 0 [expr {$sortColCount - 1}]] 161 } 162 163 # 164 # Save the keys corresponding to anchorRow and activeRow, 165 # as well as the indices of the selected cells 166 # 167 foreach type {anchor active} { 168 set ${type}Key [lindex $data(keyList) $data(${type}Row)] 169 } 170 set selCells [curCellSelection $win 1] 171 172 # 173 # Save some data of the edit window if present 174 # 175 if {[set editCol $data(editCol)] >= 0} { 176 set editKey $data(editKey) 177 saveEditData $win 178 } 179 180 # 181 # Update the sort info and sort the item list 182 # 183 set descItemList {} 184 if {[llength $sortColList] == 1 && [lindex $sortColList 0] == -1} { 185 if {[string compare $data(-sortcommand) ""] == 0} { 186 return -code error "value of the -sortcommand option is empty" 187 } 188 189 set order [lindex $sortOrderList 0] 190 191 if {$sortAllItems} { 192 # 193 # Update the sort info 194 # 195 for {set col 0} {$col < $data(colCount)} {incr col} { 196 set data($col-sortRank) 0 197 set data($col-sortOrder) "" 198 } 199 set data(sortColList) {} 200 set data(arrowColList) {} 201 set data(sortOrder) $order 202 } 203 204 # 205 # Sort the child item list 206 # 207 sortChildren $win $parentKey [list lsort -$order -command \ 208 $data(-sortcommand)] descItemList 209 } else { ;# sorting by a column (list) 210 # 211 # Check the specified column indices 212 # 213 set sortColCount2 $sortColCount 214 foreach col $sortColList { 215 if {$data($col-showlinenumbers)} { 216 incr sortColCount2 -1 217 } 218 } 219 if {$sortColCount2 == 0} { 220 return "" 221 } 222 223 if {$sortAllItems} { 224 # 225 # Update the sort info 226 # 227 for {set col 0} {$col < $data(colCount)} {incr col} { 228 set data($col-sortRank) 0 229 set data($col-sortOrder) "" 230 } 231 set rank 1 232 foreach col $sortColList order $sortOrderList { 233 if {$data($col-showlinenumbers)} { 234 continue 235 } 236 237 set data($col-sortRank) $rank 238 set data($col-sortOrder) $order 239 incr rank 240 } 241 makeSortAndArrowColLists $win 242 } 243 244 # 245 # Sort the child item list based on the specified columns 246 # 247 for {set idx [expr {$sortColCount - 1}]} {$idx >= 0} {incr idx -1} { 248 set col [lindex $sortColList $idx] 249 if {$data($col-showlinenumbers)} { 250 continue 251 } 252 253 set descItemList {} 254 set order [lindex $sortOrderList $idx] 255 if {[string compare $data($col-sortmode) "command"] == 0} { 256 if {![info exists data($col-sortcommand)]} { 257 return -code error "value of the -sortcommand option for\ 258 column $col is missing or empty" 259 } 260 261 sortChildren $win $parentKey [list lsort -$order -index $col \ 262 -command $data($col-sortcommand)] descItemList 263 } elseif {[string compare $data($col-sortmode) "asciinocase"] 264 == 0} { 265 if {$::tk_version < 8.5} { 266 sortChildren $win $parentKey [list lsort -$order \ 267 -index $col -command compareNoCase] descItemList 268 } else { 269 sortChildren $win $parentKey [list lsort -$order \ 270 -index $col -ascii -nocase] descItemList 271 } 272 } else { 273 sortChildren $win $parentKey [list lsort -$order -index $col \ 274 -$data($col-sortmode)] descItemList 275 } 276 } 277 } 278 279 if {$sortAllItems} { 280 # 281 # Cancel the execution of all delayed 282 # redisplay and redisplayCol commands 283 # 284 foreach name [array names data *redispId] { 285 after cancel $data($name) 286 unset data($name) 287 } 288 289 set canvasWidth $data(arrowWidth) 290 if {[llength $data(arrowColList)] > 1} { 291 incr canvasWidth 6 292 } 293 foreach col $data(arrowColList) { 294 # 295 # Make sure the arrow will fit into the column 296 # 297 set idx [expr {2*$col}] 298 set pixels [lindex $data(colList) $idx] 299 if {$pixels == 0 && $data($col-maxPixels) > 0 && 300 $data($col-reqPixels) > $data($col-maxPixels) && 301 $data($col-maxPixels) < $canvasWidth} { 302 set data($col-maxPixels) $canvasWidth 303 set data($col-maxwidth) -$canvasWidth 304 } 305 if {$pixels != 0 && $pixels < $canvasWidth} { 306 set data(colList) \ 307 [lreplace $data(colList) $idx $idx $canvasWidth] 308 set idx [expr {3*$col}] 309 set data(-columns) \ 310 [lreplace $data(-columns) $idx $idx -$canvasWidth] 311 } 312 } 313 314 # 315 # Adjust the columns; this will also place the 316 # canvas widgets into the corresponding labels 317 # 318 adjustColumns $win allLabels 1 319 } 320 321 if {[llength $descItemList] == 0} { 322 return "" 323 } 324 325 set parentRow [keyToRow $win $parentKey] 326 set firstDescRow [expr {$parentRow + 1}] 327 set lastDescRow [expr {$parentRow + [descCount $win $parentKey]}] 328 set firstDescLine [expr {$firstDescRow + 1}] 329 set lastDescLine [expr {$lastDescRow + 1}] 330 331 # 332 # Update the line numbers (if any) 333 # 334 for {set col 0} {$col < $data(colCount)} {incr col} { 335 if {!$data($col-showlinenumbers)} { 336 continue 337 } 338 339 set newDescItemList {} 340 set line $firstDescLine 341 foreach item $descItemList { 342 set item [lreplace $item $col $col $line] 343 lappend newDescItemList $item 344 set key [lindex $item end] 345 if {![info exists data($key-hide)]} { 346 incr line 347 } 348 } 349 set descItemList $newDescItemList 350 } 351 352 set data(itemList) [eval [list lreplace $data(itemList) \ 353 $firstDescRow $lastDescRow] $descItemList] 354 355 # 356 # Replace the contents of the list variable if present 357 # 358 condUpdateListVar $win 359 360 # 361 # Delete the items from the body text widget and insert the sorted ones. 362 # Interestingly, for a large number of items it is much more efficient 363 # to empty each line individually than to invoke a global delete command. 364 # 365 set w $data(body) 366 $w tag remove hiddenRow $firstDescLine.0 $lastDescLine.end 367 for {set line $firstDescLine} {$line <= $lastDescLine} {incr line} { 368 $w delete $line.0 $line.end 369 } 370 set snipStr $data(-snipstring) 371 set rowTagRefCount $data(rowTagRefCount) 372 set cellTagRefCount $data(cellTagRefCount) 373 set isSimple [expr {$data(imgCount) == 0 && $data(winCount) == 0 && 374 $data(indentCount) == 0}] 375 set padY [expr {[$w cget -spacing1] == 0}] 376 set descKeyList {} 377 for {set row $firstDescRow; set line $firstDescLine} \ 378 {$row <= $lastDescRow} {set row $line; incr line} { 379 set item [lindex $data(itemList) $row] 380 set key [lindex $item end] 381 lappend descKeyList $key 382 set data($key-row) $row 383 set dispItem [lrange $item 0 $data(lastCol)] 384 if {$data(hasFmtCmds)} { 385 set dispItem [formatItem $win $key $row $dispItem] 386 } 387 388 # 389 # Clip the elements if necessary and 390 # insert them with the corresponding tags 391 # 392 if {$rowTagRefCount == 0} { 393 set hasRowFont 0 394 } else { 395 set hasRowFont [info exists data($key-font)] 396 } 397 set col 0 398 if {$isSimple} { 399 set insertArgs {} 400 set multilineData {} 401 foreach text [strToDispStr $dispItem] \ 402 colFont $data(colFontList) \ 403 colTags $data(colTagsList) \ 404 {pixels alignment} $data(colList) { 405 if {$data($col-hide) && !$canElide} { 406 incr col 407 continue 408 } 409 410 # 411 # Build the list of tags to be applied to the cell 412 # 413 if {$hasRowFont} { 414 set cellFont $data($key-font) 415 } else { 416 set cellFont $colFont 417 } 418 set cellTags $colTags 419 if {$cellTagRefCount != 0} { 420 if {[info exists data($key,$col-font)]} { 421 set cellFont $data($key,$col-font) 422 lappend cellTags cell-font-$data($key,$col-font) 423 } 424 foreach opt {-background -foreground} { 425 if {[info exists data($key,$col$opt)]} { 426 lappend cellTags cell$opt-$data($key,$col$opt) 427 } 428 } 429 } 430 431 # 432 # Clip the element if necessary 433 # 434 set multiline [string match "*\n*" $text] 435 if {$pixels == 0} { ;# convention: dynamic width 436 if {$data($col-maxPixels) > 0} { 437 if {$data($col-reqPixels) > $data($col-maxPixels)} { 438 set pixels $data($col-maxPixels) 439 } 440 } 441 } 442 if {$pixels != 0} { 443 incr pixels $data($col-delta) 444 445 if {$data($col-wrap) && !$multiline} { 446 if {[font measure $cellFont -displayof $win $text] > 447 $pixels} { 448 set multiline 1 449 } 450 } 451 452 set snipSide \ 453 $snipSides($alignment,$data($col-changesnipside)) 454 if {$multiline} { 455 set list [split $text "\n"] 456 if {$data($col-wrap)} { 457 set snipSide "" 458 } 459 set text [joinList $win $list $cellFont \ 460 $pixels $snipSide $snipStr] 461 } else { 462 set text [strRange $win $text $cellFont \ 463 $pixels $snipSide $snipStr] 464 } 465 } 466 467 if {$multiline} { 468 lappend insertArgs "\t\t" $cellTags 469 lappend multilineData $col $text $colFont $pixels $alignment 470 } else { 471 lappend insertArgs "\t$text\t" $cellTags 472 } 473 474 incr col 475 } 476 477 # 478 # Insert the item into the body text widget 479 # 480 if {[llength $insertArgs] != 0} { 481 eval [list $w insert $line.0] $insertArgs 482 } 483 484 # 485 # Embed the message widgets displaying multiline elements 486 # 487 foreach {col text font pixels alignment} $multilineData { 488 findTabs $win $line $col $col tabIdx1 tabIdx2 489 set msgScript [list ::tablelist::displayText $win $key \ 490 $col $text $font $pixels $alignment] 491 $w window create $tabIdx2 -pady $padY -create $msgScript 492 } 493 494 } else { 495 foreach text [strToDispStr $dispItem] \ 496 colFont $data(colFontList) \ 497 colTags $data(colTagsList) \ 498 {pixels alignment} $data(colList) { 499 if {$data($col-hide) && !$canElide} { 500 incr col 501 continue 502 } 503 504 # 505 # Build the list of tags to be applied to the cell 506 # 507 if {$hasRowFont} { 508 set cellFont $data($key-font) 509 } else { 510 set cellFont $colFont 511 } 512 set cellTags $colTags 513 if {$cellTagRefCount != 0} { 514 if {[info exists data($key,$col-font)]} { 515 set cellFont $data($key,$col-font) 516 lappend cellTags cell-font-$data($key,$col-font) 517 } 518 foreach opt {-background -foreground} { 519 if {[info exists data($key,$col$opt)]} { 520 lappend cellTags cell$opt-$data($key,$col$opt) 521 } 522 } 523 } 524 525 # 526 # Insert the text and the label or window 527 # (if any) into the body text widget 528 # 529 appendComplexElem $win $key $row $col $text $pixels \ 530 $alignment $snipStr $cellFont $cellTags $line 531 532 incr col 533 } 534 } 535 536 if {$rowTagRefCount != 0} { 537 foreach opt {-background -foreground -font} { 538 if {[info exists data($key$opt)]} { 539 $w tag add row$opt-$data($key$opt) $line.0 $line.end 540 } 541 } 542 } 543 544 if {[info exists data($key-hide)]} { 545 $w tag add hiddenRow $line.0 $line.end+1c 546 } 547 } 548 549 set data(keyList) [eval [list lreplace $data(keyList) \ 550 $firstDescRow $lastDescRow] $descKeyList] 551 552 if {$sortAllItems} { 553 # 554 # Validate the key -> row mapping 555 # 556 set data(keyToRowMapValid) 1 557 if {[info exists data(mapId)]} { 558 after cancel $data(mapId) 559 unset data(mapId) 560 } 561 } 562 563 # 564 # Invalidate the list of row indices indicating the non-hidden rows 565 # 566 set data(nonHiddenRowList) {-1} 567 568 # 569 # Select the cells that were selected before 570 # 571 foreach {key col} $selCells { 572 set row [keyToRow $win $key] 573 cellSelection $win set $row $col $row $col 574 } 575 576 # 577 # Disable the body text widget if it was disabled before 578 # 579 if {$data(isDisabled)} { 580 $w tag add disabled 1.0 end 581 $w tag configure select -borderwidth 0 582 } 583 584 # 585 # Update anchorRow and activeRow 586 # 587 foreach type {anchor active} { 588 upvar 0 ${type}Key key2 589 if {[string compare $key2 ""] != 0} { 590 set data(${type}Row) [keyToRow $win $key2] 591 } 592 } 593 594 # 595 # Bring the "most important" row into view if appropriate 596 # 597 if {$editCol >= 0} { 598 set editRow [keyToRow $win $editKey] 599 if {$editRow >= $firstDescRow && $editRow <= $lastDescRow} { 600 doEditCell $win $editRow $editCol 1 601 } 602 } else { 603 set selRows [curSelection $win] 604 if {[llength $selRows] == 1} { 605 set selRow [lindex $selRows 0] 606 if {$selRow >= $firstDescRow && $selRow <= $lastDescRow} { 607 seeRow $win $selRow 608 } 609 } elseif {[string compare [focus -lastfor $w] $w] == 0} { 610 if {$data(activeRow) >= $firstDescRow && 611 $data(activeRow) <= $lastDescRow} { 612 seeRow $win $data(activeRow) 613 } 614 } 615 } 616 617 # 618 # Adjust the elided text and restore the stripes in the body text widget 619 # 620 adjustElidedText $win 621 makeStripes $win 622 updateColorsWhenIdle $win 623 adjustSepsWhenIdle $win 624 updateVScrlbarWhenIdle $win 625 626 # 627 # Work around a Tk bug on Mac OS X Aqua 628 # 629 variable winSys 630 if {[string compare $winSys "aqua"] == 0} { 631 foreach col $data(arrowColList) { 632 set canvas [list $data(hdrTxtFrCanv)$col] 633 after idle "lower $canvas; raise $canvas" 634 } 635 } 636 637 return "" 638} 639 640#------------------------------------------------------------------------------ 641# tablelist::sortChildren 642# 643# Sorts the children of a given parent within the tablelist widget win, 644# recursively. 645#------------------------------------------------------------------------------ 646proc tablelist::sortChildren {win parentKey sortProc itemListName} { 647 upvar $itemListName itemList ::tablelist::ns${win}::data data 648 649 set childKeyList $data($parentKey-children) 650 if {[llength $childKeyList] == 0} { 651 return "" 652 } 653 654 # 655 # Build and sort the list of child items 656 # 657 set childItemList {} 658 foreach childKey $childKeyList { 659 lappend childItemList [lindex $data(itemList) [keyToRow $win $childKey]] 660 } 661 set childItemList [eval $sortProc [list $childItemList]] 662 663 # 664 # Update the lists and invoke the procedure recursively for the children 665 # 666 set data($parentKey-children) {} 667 foreach item $childItemList { 668 lappend itemList $item 669 set childKey [lindex $item end] 670 lappend data($parentKey-children) $childKey 671 672 sortChildren $win $childKey $sortProc itemList 673 } 674} 675 676#------------------------------------------------------------------------------ 677# tablelist::sortList 678# 679# Sorts the specified list by the current sort columns of the tablelist widget 680# win, using their current sort orders. 681#------------------------------------------------------------------------------ 682proc tablelist::sortList {win list} { 683 upvar ::tablelist::ns${win}::data data 684 set sortColList $data(sortColList) 685 set sortOrderList {} 686 foreach col $sortColList { 687 lappend sortOrderList $data($col-sortOrder) 688 } 689 690 if {[llength $sortColList] == 1 && [lindex $sortColList 0] == -1} { 691 if {[string compare $data(-sortcommand) ""] == 0} { 692 return -code error "value of the -sortcommand option is empty" 693 } 694 695 # 696 # Sort the list 697 # 698 set order [lindex $sortOrderList 0] 699 return [lsort -$order -command $data(-sortcommand) $list] 700 } else { 701 # 702 # Sort the list based on the specified columns 703 # 704 set sortColCount [llength $sortColList] 705 for {set idx [expr {$sortColCount - 1}]} {$idx >= 0} {incr idx -1} { 706 set col [lindex $sortColList $idx] 707 set order [lindex $sortOrderList $idx] 708 709 if {[string compare $data($col-sortmode) "command"] == 0} { 710 if {![info exists data($col-sortcommand)]} { 711 return -code error "value of the -sortcommand option for\ 712 column $col is missing or empty" 713 } 714 715 set list [lsort -$order -index $col -command \ 716 $data($col-sortcommand) $list] 717 } elseif {[string compare $data($col-sortmode) "asciinocase"] 718 == 0} { 719 if {$::tk_version < 8.5} { 720 set list [lsort -$order -index $col -command \ 721 compareNoCase $list] 722 } else { 723 set list [lsort -$order -index $col -ascii -nocase $list] 724 } 725 } else { 726 set list [lsort -$order -index $col -$data($col-sortmode) $list] 727 } 728 } 729 730 return $list 731 } 732} 733 734#------------------------------------------------------------------------------ 735# tablelist::compareNoCase 736# 737# Compares the given strings in a case-insensitive manner. 738#------------------------------------------------------------------------------ 739proc tablelist::compareNoCase {str1 str2} { 740 return [string compare [string tolower $str1] [string tolower $str2]] 741} 742