tree.tcl

This Source-Navigator, an IDE for C/C++/Fortran/Java/Tcl/PHP/Python and a host of other languages.

# Copyright (c) 2000, Red Hat, Inc.
# 
# This file is part of Source-Navigator.
# 
# Source-Navigator is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License as published
# by the Free Software Foundation; either version 2, or (at your option)
# any later version.
# 
# Source-Navigator is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# General Public License for more details.
# 
# You should have received a copy of the GNU General Public License along
# with Source-Navigator; see the file COPYING.  If not, write to
# the Free Software Foundation, 59 Temple Place - Suite 330, Boston,
# MA 02111-1307, USA.

# # tree.tcl - A tree widget class with tab stop support.
# Copyright (C) 1998 Cygnus Solutions.

#we need to do this to make sure that other applications as
#Source-Navigator can use this tree tool
if {! [info exists sn_options(def,default-font)]} {
    set sn_options(def,default-font) ansi
    if {$tcl_platform(platform) == "windows"} {
	set sn_options(def,select-fg) SystemHighlightText
	set sn_options(def,select-bg) SystemHighlight
	set sn_options(def,bold-font) global/bold
    } else {
	set sn_options(def,select-fg) black
	set sn_options(def,select-bg) yellow
	set sn_options(def,bold-font) "-*-Courier-Bold-R-Normal--*-120-*-*-*-*-iso8859-1"
    }
}

itcl_class Tree {
    inherit itk::Widget
    
    global sn_options

    constructor {config} {
	global sn_options
	
	#set up a short name for accessing real name path
	set thisTail [namespace tail $this]
	
	if {$withframe} {
	    set lframe $thisTail.fr
	    ::frame $lframe -bd 2 -relief sunken
	} else {
	    set lframe $thisTail
	}

	if {$font == ""} {
	    set font $sn_options(def,default-font)
	}
	if {$selectforeground == ""} {
	    set selectforeground $sn_options(def,select-fg)
	}
	if {$selectbackground == ""} {
	    set selectbackground $sn_options(def,select-bg)
	}

	set tree $lframe.tree

	scrollbar $lframe.x \
    		-orient horiz \
		-command "$tree xview"
	scrollbar $lframe.y \
    		-command "$tree yview"

	treetable $tree \
	    -yscrollcommand "$lframe.y set" \
	    -xscrollcommand "$lframe.x set" \
            -takefocus 1 \
	    -exportselection $exportselection \
	    -fillselection $fillselection \
	    -selectmode $selectmode \
	    -sortedinsertion $sortedinsertion\
	    -nocase $sortnocase \
	    -col $sortcolumn \
	    -bitmapspace $bitmapspace \
	    -bestfit $bestfit \
	    -autofit $autofit \
	    -truncate $truncate \
	    -splitlines $splitlines \
	    -tabfreespace $tabfreespace \
	    -accelerator $accelerator \
	    -truncatemethode $truncatemethode \
	    -font $font \
	    -lineforeground $lineforeground \
	    -splitlineforeground $splitlineforeground \
	    -selectforeground $selectforeground \
	    -selectbackground $selectbackground \
	    -selectborderwidth $selectborderwidth \
	    -highlightwidth $highlightwidth \
	    -highlightthickness $highlightthickness \
	    -indentwidth $indentwidth \
	    -borderwidth $borderwidth \
	    -width $width \
	    -height $height\
            -resizecommand "$this SyncTabs"
	#    -geometry ${width}x${height}
	
	if {$hiddenbitmap != ""} {
	    $tree config -hiddenbitmap $hiddenbitmap
	}
	if {$hiddenimage != ""} {
	    $tree config -hiddenimage $hiddenimage
	}
	if {$plusimage != ""} {
	    $tree config -plusimage $plusimage
	}
	if {$minusimage != ""} {
	    $tree config -minusimage $minusimage
	}
	if {$unknownimage != ""} {
	    $tree config -unknownimage $unknownimage
	}
	if {$tabs != ""} {
	    $tree config -tabs $tabs
	}
	if {$justify != ""} {
	    $tree config -justify $justify
	}

	#printing
	::bind $tree <Control-p> "$this print_dialog_box; break"
	::bind $tree <Control-c> "$this put_in_cutbuffer; break"
	::bind $tree <F16> [bind $tree <Control-c>]

	#filter
	if {$filter != ""} {
	    frame $lframe.filter
	    label $lframe.filter.label -text [get_indep String Pattern]
	    set entry $lframe.filter.entry
	    entry $entry \
		    -relief sunken \
		    -exportselection 0 \
		    -width 3 \
		    -textvariable $thisTail-filter
	    global $thisTail-filter
	    set $thisTail-filter $filter
	    $entry icursor 0

	    ::bind $entry <Return> "$this fill"
	
	    #make binding ctrl-u/l/r for filtering
	    ::bind $tree <Control-u> "
			 $this config -filter \"*\"
			 $this fill
			 focus %W
			 break
		    "
	    ::bind $tree <Control-l> [::bind $tree <Control-u>]
	    ::bind $tree <Control-r> [::bind $tree <Control-u>]
	
	    pack $lframe.filter.label -side left
	    pack $entry -side left -fill x -expand y

	    if {$filter_window} {
		grid $lframe.filter \
		        -row 3 -column 0 -columnspan 2 -sticky ew
	    }
	}

	if {$withframe} {
	    pack $lframe -side top -fill both -expand yes
	}
	
	#now create the labels for columns
	if {$tabsize > -1} {
	    create_tabs
	    view_tabs
	    grid $lframe.size -row 0 -column 0 -columnspan 2 -sticky ew
	    resize 0 [lindex [$tree cget -tabs] 0] 0
	}

        grid $tree -row 1 -column 0 -sticky news
        grid $lframe.y -row 1 -column 1 -sticky ns
        grid $lframe.x -row 2 -column 0 -sticky ew

        grid rowconfigure $lframe 1 -weight 1
        grid columnconfigure $lframe 0 -weight 1

	focus $tree
	
	if {$tabsize > -1} {
	    ::bind $lframe.x <B1-ButtonRelease> "$this replace_buttons"
	
	    ::bind $tree <3> "$this post_commands %X %Y; break"
	}	
	#add contents to the list
	contents
	
	#propagate
	if {! $propagate} {
#FIXME: what is the following code doing?
# I am currently seeing an error in this callback because the toplevel window does not exist.
#	    after idle "update idletasks; pack propagate $top $propagate"
set top [winfo toplevel $tree]
after idle "update idletasks ; if \[winfo exists $top\] \{pack propagate $top\}"
	}
    }

    destructor {
	foreach v [::info globals "$thisTail-*"] {
	    catch {uplevel #0 unset $v}
	}
    }

    method Xview {x1 x2 {x3 ""}} {
	if {$x3 != ""} {
	    $tree xview $x1 $x2 $x3
	} else {
	    $tree xview $x1 $x2
	}
	if {$tabsize > -1} {
	    resize 0 [lindex [$tree cget -tabs] 0] 0
	}
    }

    method tree {} {
	return $tree
    }
    method insert {args} {
	set idx [lindex $args 0]
	set cnt [lindex $args 1]
	set args [lrange $args 2 end]
	::eval $lframe.tree insert $idx list [list $cnt] $args
    }

    method remove {from {to ""}} {
	if {$to == ""} {
	    set to $from
	}
	$lframe.tree delete $from $to
    }

    method search args {
	return [::eval $lframe.tree search $args]
    }

    method sort_refresh {} {
	if { $actual_sortcolumn != -1 } {
	    resort $actual_sortcolumn
	}
    }

    method resort {num {var ""}} {
	global sn_options
	global $thisTail-sort
	
	$tree config -cursor watch
	set fnt [$lframe.size.btn$num cget -font]
	
	#restore old font for the last sort column
	if {$oldnum != $num} {
	    if {$oldnum != -1} {
		$lframe.size.btn$oldnum configure -font $oldfont
	    }
	    set oldnum $num
	    set oldfont $fnt
	}
	
	#change actual column font to bold
	set fnt [split $fnt "-"]
	if {[llength $fnt] > 3} {
	    set fnt [join [lreplace $fnt 3 3 "bold"] "-"]
	} else {
	    set fnt $sn_options(def,bold-font)
	}

	$lframe.size.btn$num config -cursor watch -font $fnt
	update idletasks
	
	#call sort command to resort entries
	$tree sort -nocase -col $num
	
	$lframe.size.btn$num config -cursor {}
	$tree config -cursor {}
	set oldnum $num
	set actual_sortcolumn $num
	
	set $thisTail-sort $num
    }

    #select an entry by it's index number
    method selectnum {num} {
	$tree selection clear 0 end
	$tree selection set $num
	$tree see $num
    }

    method selection {args} {
	return [::eval $tree selection $args]
    }

    method cget {args} {
	return [::eval $tree cget $args]
    }

    method config {config} {
    }

    method xview {args} {
	return [::eval $tree xview $args]
    }

    method yview {args} {
	return [::eval $tree yview $args]
    }
    #an array of column filters
    protected col_filter ""
    protected colfilters
    public filterextension ""
    method edit_column_filter {w num X Y} {
	global $thisTail-filterentry
	if {![info exists colfilters($num)]} {
	    set colfilters($num) "*"
	}
	set $thisTail-filterentry $colfilters($num)

	#if there is no label, no filter
	if {[$w cget -text] == ""} {
	    bell; return
	}

	set x [winfo rootx $w]
	set y [winfo rooty $w]
	set h [expr [winfo height $w] + 1]
	set width [winfo width $w]
	set color white
	set m $thisTail-filter_menu
	catch {destroy $m}
	menu $m -tearoff 0
	wm overrideredirect $m 1
	wm withdraw $m
	wm geometry $m ${width}x${h}+$x+$y
	pack [entry $m.l \
		-bg $color \
		-bd 0 \
		-relief raised \
		-textvariable $thisTail-filterentry] -fill both -expand y
	::bind $m.l <Return> "$this set_column_filter $w $num; tkMenuUnpost $m; break"
	::bind $m.l <Escape> "tkMenuUnpost $m; break"
	
	raise $m
	wm deiconify $m
	tk_popup $m $x $y
	focus $m.l
    }

    method set_column_filter {w num} {
	upvar #0 $thisTail-filterentry fltentry
	
	#store column filter
	set colfilters($num) $fltentry
	
	#display filter into label
	set txt [lindex $labels $num]
	if {$fltentry == "*" || $fltentry == ""} {
	    set colfilters($num) "*"
	    #label without filter
	    $w config -text $txt
	} else {
	    $w config -text "${txt}($fltentry)"
	}
	
	calculate_column_filter
	
	fill
	
	unset fltentry
    }

    method calculate_column_filter {} {
	if {$tabsize == -1} {
	    return ""
	}
	set tabs [$tree cget -tabs]
	
	#build tree filter
	set col_filter ""
	set cmp ""
	for {set i 0} {$i <= $tabsize} {incr i} {
	
	    #if label is hidden, disable it's filter
	    if {[lindex $tabs $i] <= 0} {
		set flt "*"
	    } else {
		set flt $colfilters($i)
	    }
	    if {$col_filter == ""} {
		set col_filter $flt
		set cmp "*"
	    } else {
		append col_filter "\t$flt"
		append cmp "\t*"
	    }
	}
	
	#no column filter is specified
	if {$cmp == $col_filter} {
	    set col_filter ""
	} elseif {$filterextension != ""} {
	    append col_filter $filterextension
	}

	return $col_filter
    }

    method delete_column_filters {} {
	for {set i 0} {$i <= $tabsize} {incr i} {
	    if {$colfilters($i) != "*"} {
		set colfilters($i) "*"
		change_label $i [lindex $labels $i]
	    }
	}
	
	set old_col_filter $col_filter
	
	calculate_column_filter
	
	if {$col_filter != $old_col_filter} {
	    fill
	}
    }
	
    method change_label {num txt} {
	if {$txt != "" && $colfilters($num) != "*"} {
	    set txt "${txt}($colfilters($num))"
	}
	$lframe.size.btn$num config -text $txt
    }

    #modify the tabs, eventualy delete or add new tabs
    method change_tabs {size tbs lbls} {
	set tabsize $size
	set tabs $tbs
	set labels $lbls
	
	$tree config -tabs $tabs
	if {[winfo exists $lframe.size] && $tabsize != -1} {
	    for {set i 0} {$i <= $tabsize} {incr i} {
		$lframe.size.btn$i configure -text [lindex $labels $i]
	    }
	    view_tabs
	    resize 0 [lindex [$tree cget -tabs] 0] 0
	}
    }

    method toggle_column {num {var ""} {value -1}} {
	if {$value == -1} {
	    $tree column toggle $num
	} else {
	    if {$value} {
		set cmd view
	    } else {
		set cmd hide
	    }
	    $tree column $cmd $num
	}
	
	if {$value != -1} {
	    set column_toggled($num) $value
	} else {
	    if {![info exists column_toggled($num)] || $column_toggled($num)} {
		set column_toggled($num) 0
	    } else {
		set column_toggled($num) 1
	    }
	}
	if {$var != ""} {
	    upvar #0 $var v
	    set v $column_toggled($num)
	}
    }

    method justify_column {num {var ""}} {
	set aligns [$tree cget -justify]
	if {$aligns == ""} {
	    for {set i 0} {$i <= $tabsize} {incr i} {
		lappend aligns 0
	    }
	}
	
	upvar #0 $var v
	set aligns [lreplace $aligns $num $num $v]
	$tree config -justify $aligns
    }

    method toggle_splitlines {} {
	if {$splitlines} {
	    set splitlines 0
	} else {
	    set splitlines 1
	}
	if {[winfo exists $tree]} {
	    $tree config -splitlines $splitlines
	}
    }
    method propagate {} {
	return $propagate
    }

    method size {} {