Tk Library Source Code

#==============================================================================
# Contains utility procedures for mega-widgets.
#
# Structure of the module:
#   - Namespace initialization
#   - Public utility procedures
#
# Copyright (c) 2000-2016  Csaba Nemethi (E-mail: [email protected])
#==============================================================================

package require Tcl 8
package require Tk  8

#
# Namespace initialization

#!/usr/bin/env wish

#==============================================================================
# Creates new versions of the files "tablelistWidget.tcl", "tablelistBind.tcl",
# "tablelistConfig.tcl", "tablelistEdit.tcl", "tablelistMove.tcl",
# "tablelistSort.tcl", and "tablelistUtil.tcl" by defining the procedure
# "arrElemExists" and replacing all invocations of "[info exists
# <array>(<name>)]" with "[arrElemExists <array> <name>]".  This works around a
# bug in Tcl versions 8.2, 8.3.0 - 8.3.2, and 8.4a1 (fixed in Tcl 8.3.3 and
# 8.4a2), which causes excessive memory use when calling "info exists" on
# non-existent array elements.
#
# Copyright (c) 2001-2016  Csaba Nemethi (E-mail: [email protected])
#==============================================================================

set procDef {
    #
    # The following procedure returns 1 if arrName($name) exists and
    # 0 otherwise.  It is a (partial) replacement for [info exists
    # arrName($name)], which -- due to a bug in Tcl versions 8.2,

#==============================================================================
# Contains public and private procedures used in tablelist bindings.
#
# Structure of the module:
#   - Public helper procedures
#   - Binding tag Tablelist
#   - Binding tag TablelistWindow
#   - Binding tag TablelistBody
#   - Binding tags TablelistLabel, TablelistSubLabel, and TablelistArrow
#
# Copyright (c) 2000-2016  Csaba Nemethi (E-mail: [email protected])
#==============================================================================

#
# Public helper procedures
# ========================
#

    #
    # Delete the bitmaps displaying the sort ranks
    # and the images used to display the sort arrows
    #
    for {set rank 1} {$rank < 10} {incr rank} {
	image delete sortRank$rank$win
    }
    set imgNames [image names]
    for {set col 0} {$col < $data(colCount)} {incr col} {
	set w $data(hdrTxtFrCanv)$col
	foreach shape {triangleUp darkLineUp lightLineUp
		       triangleDn darkLineDn lightLineDn} {
	    if {[lsearch -exact $imgNames $shape$w] >= 0} {
		image delete $shape$w
	    }
	}
    }

    destroy $data(corner)

    namespace delete ::tablelist::ns$win
    catch {rename ::$win ""}

    unset data(sourceRow)
    unset data(sourceEndRow)
    unset data(sourceDescCount)
    unset data(sourceParentKey)
    unset data(sourceParentRow)
    unset data(sourceParentEndRow)
    if {[info exists data(targetRow)]} {
	unset data(targetRow)
    }
    if {[info exists data(targetChildIdx)]} {
	unset data(targetChildIdx)
    }
    bind [winfo toplevel $win] <Escape> $data(topEscBinding)
    $data(body) configure -cursor $data(-cursor)
    place forget $data(rowGap)
}

#------------------------------------------------------------------------------
# tablelist::beginExtend

		#
		if {$targetCol == $col || $targetCol == $col + 1 ||
		    ($data(-protecttitlecolumns) &&
		     (($col >= $data(-titlecolumns) &&
		       $targetCol < $data(-titlecolumns)) ||
		      ($col < $data(-titlecolumns) &&
		       $targetCol > $data(-titlecolumns))))} {
		    if {[info exists data(targetCol)]} {
			unset data(targetCol)
		    }
		    configLabel $w -cursor $data(-cursor)
		    $data(hdrTxtFrCanv)$col configure -cursor $data(-cursor)
		    place forget $data(colGap)
		} else {
		    set data(targetCol) $targetCol
		    set data(master) $master
		    set data(relx) $relx

	configLabel $w -cursor $data(-cursor)
	$data(hdrTxtFrCanv)$col configure -cursor $data(-cursor)
	if {[winfo exists $data(focus)]} {
	    focus $data(focus)
	}
	bind [winfo toplevel $win] <Escape> $data(topEscBinding)
	place forget $data(colGap)
	if {[info exists data(targetCol)]} {
	    unset data(targetCol)
	}
	if {[info exists data(X)]} {
	    unset data(X)
	    after cancel $data(afterId)
	    set data(afterId) ""
	}
	set data(labelClicked) 0
    }

    #
    # Extend some elements of the array configSpecs
    #
    lappend configSpecs(-acceptchildcommand)	{}
    lappend configSpecs(-acceptdropcommand)	{}
    lappend configSpecs(-activestyle)		frame
    lappend configSpecs(-autofinishediting)	0
    lappend configSpecs(-autoscan)		1
    lappend configSpecs(-collapsecommand)	{}
    lappend configSpecs(-colorizecommand)	{}
    lappend configSpecs(-columns)		{}
    lappend configSpecs(-columntitles)		{}
    lappend configSpecs(-customdragsource)	0
    lappend configSpecs(-editendcommand)	{}

			foreach col $data(arrowColList) {
			    raiseArrow $win $col
			    lappend whichWidths l$col
			}
			adjustColumns $win $whichWidths 1
		    }
		}
		-autofinishediting -
		-autoscan -
		-customdragsource -
		-forceeditendcommand -
		-instanttoggle -
		-movablecolumns -
		-movablerows -
		-protecttitlecolumns -

	    $name-putValueCmd	{set [%W cget -textvariable] %T} \
	    $name-getValueCmd	"%W cget -text" \
	    $name-putTextCmd	{set [%W cget -textvariable] %T} \
	    $name-getTextCmd	"%W cget -text" \
	    $name-putListCmd	"" \
	    $name-getListCmd	"" \
	    $name-selectCmd	"" \
	    $name-invokeCmd	"event generate %W <Button-1>" \
	    $name-fontOpt	-font \
	    $name-useFormat	1 \
	    $name-useReqWidth	0 \
	    $name-usePadX	1 \
	    $name-isEntryLike	0 \
	    $name-focusWin	%W \
	    $name-reservedKeys	{} \

	    $name-putValueCmd	{set [%W cget -textvariable] %T} \
	    $name-getValueCmd	"%W cget -text" \
	    $name-putTextCmd	{set [%W cget -textvariable] %T} \
	    $name-getTextCmd	"%W cget -text" \
	    $name-putListCmd	"" \
	    $name-getListCmd	"" \
	    $name-selectCmd	"" \
	    $name-invokeCmd	"event generate %W <Button-1>" \
	    $name-fontOpt	"" \
	    $name-useFormat	1 \
	    $name-useReqWidth	0 \
	    $name-usePadX	1 \
	    $name-isEntryLike	0 \
	    $name-focusWin	%W \
	    $name-reservedKeys	{} \

    #
    # The style of the tile entry widget should have -borderwidth
    # 2 and -padding 1.  For those themes that don't honor the
    # -borderwidth 2 setting, set the padding to another value.
    #
    set win [getTablelistPath $w]
    switch -- [getCurrentTheme] {
	aqua {
	    set padding {0 0 0 -1}
	}

	tileqt {
	    set padding 3
	}

    #
    # The style of the tile entry widget should have -borderwidth
    # 2 and -padding 1.  For those themes that don't honor the
    # -borderwidth 2 setting, set the padding to another value.
    #
    set win [getTablelistPath $w]
    switch -- [getCurrentTheme] {
	aqua {
	    set padding {0 0 0 -1}
	}

	tileqt {
	    set padding 3
	}

	}
    }

    #
    # Adjust the dimensions of the tile checkbutton's parent
    # and manage the checkbutton, depending on the current theme
    #
    switch -- $currentTheme {
	aqua {
	    [winfo parent $w] configure -width 16 -height 16
	    place $w -x -3 -y -3
	}

	Aquativo {
	    [winfo parent $w] configure -width 14 -height 14

		return ""
	    }

	    catch {
		eval [strMap {"%W" "$w"  "%T" "$text"} \
		      $editWin($name-putValueCmd)]
	    }
	}

	if {$isMenubtn} {
	    set menu [$w cget -menu]
	    set last [$menu index last]
	    if {[string compare $last "none"] != 0} {
		set varName [$w cget -textvariable]
		for {set idx 0} {$idx <= $last} {incr idx} {
		    if {[string compare [$menu type $idx] "radiobutton"] == 0} {

			$menu entryconfigure $idx -variable $varName

		    }
		}
	    }
	}

	#
	# Save the edit window's text again

	    } else {
		focus $comp
		$comp icursor end
		$comp selection range 0 end
	    }
	}
    }

    if {$data(-autofinishediting)} {
	#
	# Make sure that selecting a combobox or menu
	# entry will automatically finish the editing
	#
	switch $class {
	    TCombobox {
		bind $w <<ComboboxSelected>> \
		    {+ [tablelist::getTablelistPath %W] finishediting}
	    }

	    ComboBox {					;# BWidget
		set cmd [$w cget -modifycmd]
		$w configure -modifycmd [format {
		    eval [list %s]
		    after 0 [list %s finishediting]
		} $cmd $win]
	    }

	    Combobox {					;# IWidgets or Oakley
		if {[catch {$w cget -selectioncommand} cmd] == 0} {  ;# IWidgets
		    set cmd [$w cget -selectioncommand]
		    $w configure -selectioncommand [format {
			eval [list %s]
			after 0 [list %s finishediting]
		    } $cmd $win]
		} elseif {[catch {$w cget -command} cmd] == 0} {     ;# Oakley
		    if {[string length $cmd] == 0} {
			proc ::tablelist::comboboxCmd {w val} [format {
			    after 0 [list %s finishediting]
			} $win]
		    } else {
			proc ::tablelist::comboboxCmd {w val} [format {
			    eval [list %s $w $val]
			    after 0 [list %s finishediting]
			} $cmd $win]
		    }
		    $w configure -command ::tablelist::comboboxCmd
		}
	    }

	    Menubutton -
	    TMenubutton {
		set menu [$w cget -menu]
		set last [$menu index last]
		if {[string compare $last "none"] != 0} {
		    for {set idx 0} {$idx <= $last} {incr idx} {
			if {[regexp {^(command|checkbutton|radiobutton)$} \
			     [$menu type $idx]]} {
			    set cmd [$menu entrycget $idx -command]
			    $menu entryconfigure $idx -command [format {
				eval [list %s]
				after 0 [list %s finishediting]
			    } $cmd $win]
			}
		    }
		}
	    }
	}
    }

    #
    # Adjust the frame's height
    #
    if {$isText} {
	if {[string compare [$w cget -wrap] "none"] == 0 ||
	    $::tk_version < 8.5} {

#==============================================================================
# Contains the implementation of the tablelist move and movecolumn subcommands.
#
# Copyright (c) 2003-2016  Csaba Nemethi (E-mail: [email protected])
#==============================================================================

#------------------------------------------------------------------------------
# tablelist::moveRow
#
# Processes the 1st form of the tablelist move subcommand.
#------------------------------------------------------------------------------

	set target $data(itemCount)
    } elseif {$target < 0} {
	set target 0
    }

    set sourceItem [lindex $data(itemList) $source]
    set sourceKey [lindex $sourceItem end]
    if {$target == [nodeRow $win $sourceKey end] || $target == $source} {
	return ""
    }






    set parentKey $data($sourceKey-parent)
    set parentEndRow [nodeRow $win $parentKey end]
    if {($target <= [keyToRow $win $parentKey] || $target > $parentEndRow)} {
	return -code error \
	       "cannot move item with index \"$source\" outside its parent"
    }

    if {$target == [nodeRow $win $sourceKey end] && $withDescendants} {
	return ""
    }

    set sourceParentKey $data($sourceKey-parent)
    if {[string compare $targetParentKey $sourceParentKey] == 0 &&
	$target == $source && $withDescendants} {
	return ""

    }

    set sourceDescCount [descCount $win $sourceKey]
    if {$target > $source && $target <= $source + $sourceDescCount &&
	$withDescendants} {
	return -code error \
	       "cannot move item with index \"$source\"\

    if {$data(isDisabled)} {
	return ""
    }

    #
    # Check the indices
    #
    if {$target == $source || $target == $source + 1} {



	return ""
    }

    if {[winfo viewable $win]} {
	purgeWidgets $win
	update idletasks
	if {![array exists ::tablelist::ns${win}::data]} {

#==============================================================================
# Contains the implementation of the tablelist::sortByColumn and
# tablelist::addToSortColumns commands, as well as of the tablelist sort,
# sortbycolumn, and sortbycolumnlist subcommands.
#
# Structure of the module:
#   - Public procedures related to sorting
#   - Private procedures implementing the sorting
#
# Copyright (c) 2000-2016  Csaba Nemethi (E-mail: [email protected])
#==============================================================================

#
# Public procedures related to sorting
# ====================================
#

    array set configSpecs {
	-acceptchildcommand	 {acceptChildCommand	  AcceptChildCommand  w}
	-acceptdropcommand	 {acceptDropCommand	  AcceptDropCommand   w}
	-activestyle		 {activeStyle		  ActiveStyle	      w}
	-arrowcolor		 {arrowColor		  ArrowColor	      w}
	-arrowdisabledcolor	 {arrowDisabledColor	  ArrowDisabledColor  w}
	-arrowstyle		 {arrowStyle		  ArrowStyle	      w}
	-autofinishediting	 {autoFinishEditing	  AutoFinishEditing   w}
	-autoscan		 {autoScan		  AutoScan	      w}
	-background		 {background		  Background	      b}
	-bg			 -background
	-borderwidth		 {borderWidth		  BorderWidth	      f}
	-bd			 -borderwidth
	-collapsecommand	 {collapseCommand	  CollapseCommand     w}
	-colorizecommand	 {colorizeCommand	  ColorizeCommand     w}

	{$fromLine > $first} {set toLine $fromLine; incr fromLine -50} {
	$w delete [expr {double($fromLine)}] [expr {double($toLine)}]
    }
    set rest [expr {$count % 50}]
    $w delete [expr {double($first + 1)}] [expr {double($first + $rest + 1)}]

    if {$last == $data(lastRow)} {
	#
	# Delete the newline character that ends
	# the line preceding the first deleted one
	#
	$w delete $first.end

	#
	# Work around a peculiarity of the text widget:  Hide
	# the newline character that ends the line preceding
	# the first deleted one if it was hidden before
	#
	set textIdx [expr {double($first)}]
	foreach tag {elidedRow hiddenRow} {