tree.tcl

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

	if {[winfo exists $tree]} {
	    return [$tree size]
	}
	return 0
    }

    method curselection {} {
	return [$tree curselection]
    }

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

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

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

    #we need this procedure to sort the contents by using
    #the flags in the class to insert the contents in the list
    method sortcontents {lst} {
	if {$sort != ""} {
	    if {$nocase} {
		if {$uniq} {
		    set lst [::lunique [::lsort $sort -command sn_compare $lst]]
		} else {
		    set lst [::lsort $sort -command sn_compare $lst]
		}
	    } elseif {$uniq} {
		set lst [::lunique [::lsort $sort $lst]]
	    } else {
		set lst [::lsort $sort $lst]
	    }
	}
	return $lst
    }

    method setcontents {cnt} {
	set contents $cnt
    }

    method getcontents {} {
	return $contents
    }

    method contents {} {
	if {![winfo exists $tree]} {
	    return
	}
	if {$sort != ""} {
	    if {$nocase} {
		if {$uniq} {
		    set contents [::lunique [::lsort $sort -command sn_compare $contents]]
		} else {
		    set contents [::lsort $sort -command sn_compare $contents]
		}
	    } elseif {$uniq} {
		set contents [lunique [::lsort $sort $contents]]
	    } else {
		set contents [::lsort $sort $contents]
	    }
	}

	fill
    }

    method setfilter {flt} {
	filter $contents $flt
    }

    method filter_state {state} {
	if {![winfo exists $entry]} {
	    return
	}
	if {$state == "disabled"} {
	    global $thisTail-filter
	    set $thisTail-filter "*"
	}
	$entry config -state $state
    }

    #filter and sort the contents of the tree, this command is usefull
    #to use by external 'fill' commands (See Retriever').
    proc filter {cnt {filter_str ""} {nocase 1}} {

	if {$filter_str == ""} {
	    set filter_str "*"
	}
	
	if {$filter_str == "*" || $cnt == ""} {
	    return $cnt
	}

	if {$nocase} {
	    set flt [nocase_glob_pattern $filter_str]
	} else {
	    set flt $filter_str
	}
	
	return [lmatch $cnt $flt]
    }

    method fill {{bsy 0}} {

	if {$fillcommand != ""} {
	    set res [::eval $fillcommand $this [list $contents]]
	    return $res
	}
	
	#set frst [$tree index @0,0]
	#if {$frst == ""} {
	#    set frst 0
	#}
	#set y [lindex [$tree yview] 0]
	
	set filter [getfilter]

	#delete old entries
	$tree delete 0 end

	if {$contents == ""} {
	    return
	}

	if {$filter != "*" && $filter != ""} {
	    if {$nocase} {
		set flt [nocase_glob_pattern $filter]
	    } else {
		set flt $filter
	    }
	} else {
		set flt "*"
	}
	
	if {$flt != "*"} {
	    $tree insert end list [lmatch $contents $flt]
	} else {
	    $tree insert end list $contents
	}
	
	$tree see -top 0
	#$tree yview moveto $y
    }

    method getfilter {} {
	upvar #0 $thisTail-filter flt
	
	#calculate filter always
	calculate_column_filter
	
	if {$col_filter != ""} {
	    return $col_filter
	}
	if {[winfo exists $entry]} {
	    set filter $flt
	} else {
	    set filter "*"
	}
	if {$filter == ""} {
	    set filter "*"
	
	    set $thisTail-filter "*"
	    $entry icursor 0
	}

	return $filter
    }

    #get selected entries or selected positions
    method marked {{str 1}} {
	set sel [$this curselection]
	if {$str} {
	    set val ""
	    foreach s $sel {
		lappend val [$lframe.tree get $s]
	    }
	    return $val
	} else {
	    return $sel
	}
    }

    #convert filter to usable filter for string matching
    proc nocase_glob_pattern {flt} {
	if {[string compare $flt "*"] == 0} {
	    return $flt
	}
        for {set c 0; set brace_lev 0; set m ""; set glb_pat "";\
	    set flt [string tolower $flt]} \
	    {$c < [string length $flt]} {incr c} {

	    set ch [string index $flt $c]
	    switch -glob -- $ch {
	    {[A-Za-z]} {
		if {$brace_lev <= 0} {
		    append m \[ [string tolower $ch] \
			[string toupper $ch] \]
		} else {
		    append glb_pat $ch
		}
	        }
	    {\[}    {
		append m \[
		set glb_pat ""
		incr brace_lev
	        }
	    {\]}    {
		for {set k 0} {$k < [string length $glb_pat]} \
		    {incr k} {
		    set cc [string index $glb_pat $k]
		    set nc [string index $glb_pat [expr $k + 1]]
		    append m [string tolower $cc]
		    if {[string compare $nc "-"] == 0} {
		    incr k 2
		    set nc [string index $glb_pat $k]
		    append m "-" [string tolower $nc] \
		        [string toupper $cc] "-" [string toupper $nc]
		    } else {
		    append m [string toupper $cc]
		    }
		}
		set glb_pat ""
		append m \]
		incr brace_lev -1
	    }
	    {\\}    {
		incr c
		append m "\\" [string index $flt $c]
	        }
	    default {
		if {$brace_lev <= 0} {
		    append m $ch
		} else {
		    append glb_pat $ch
		}
	        }
	    }
	}
	return $m
    }

    method SyncTabs {} {
        resize 0 [lindex [$tree cget -tabs] 0] 0
    }

    public splitwidth 1

    #this brings the split lines from the tree and the lines
    #from this class to be displayed in one line
    protected correction_factor 3

    #function is called to synchronize the widget labels with
    #the tabulators defined in the treetable.
    #it doesn't display the labels for hidden columns/tabs
    method resize {num x {realy 1}} {
	if {![winfo exists $lframe.size] || $x == ""} {
	    return
	}
	
	#end motion process
	end_motion
	
	set twidth  [winfo width $tree]
	if {$twidth <= 1} {
	    set twidth [winfo reqwidth $tree]
	}
	set frheight [winfo height $lframe.size]
	if {$frheight <= 1} {
	    set frheight [winfo reqheight $lframe.size]
	}
	if {$frheight <= 1} {
	    set frheight [winfo reqheight $lframe.size.btn0]
	}
	set xoffset [expr [$tree xoffset] - $correction_factor]
	set oldtabs $tabs
	set tabs [$tree cget -tabs]
	if {$realy} {
	    set x [expr $x - [winfo rootx $lframe.size] + $xoffset]
	}
	
	set ox 0
	set tx 0
	for {set i 0} {$i <= $tabsize} {incr i} {
	    if {$i < $tabsize} {
		if {$x >= 0 && $num == $i} {
		    set mx $ox
		    if {$x < $mx} {
			set x $mx
		    }
		    set tab  [lindex $tabs $i]
		    set diff [expr $x - [expr $tx + $tab]]
		    set tab  [expr $tab + $diff]
		    set tabs [lreplace $tabs $i $i $tab]
		    set tx $x
		} else {
		    set tx [expr $tx + [lindex $tabs $i]]
		}
		set width [lindex $tabs $i]
		if {$width == 0} {
		    #column hidden
		    place forget $lframe.size.col$i
		} else {
		    place $lframe.size.col$i \
			-y 1 \
			-x [expr $tx - $xoffset]
		}
	    } else {
		#take the rest of the window size
		set tx [expr $tx + $width]
		set width [expr $twidth - $ox + $xoffset + 20]
	    }
	    if {$width == 0} {
		#column hidden
		place forget $lframe.size.btn$i
	    } else {
		if {$i == 0} {
		    place $lframe.size.btn$i \
			-y 1 \
			-x [expr $ox - $xoffset - $correction_factor] \
			-width [expr $width + $correction_factor] \
			-height $frheight
		} else {
		    place $lframe.size.btn$i \
			-y 1 \
			-x [expr $ox - $xoffset + 1] \
			-width [expr $width - 1] \
			-height $frheight
		}
	    }
	    set ox $tx
	}

	if {$oldtabs != $tabs} {
	    $tree config -tabs $tabs
	}

	#set up height correctly for size frame and columns
	set hh [winfo reqheight $lframe.size.btn0]
	if {$frame_height != $hh} {
	    $lframe.size config -height [expr $hh + 2]
	    set frame_height $hh
	}
	if {$col_height != $hh} {
	    for {set i 0} {$i < $tabsize} {incr i} {
		$lframe.size.col$i config -height $hh
		set col_height $hh
	    }
	}
    }

    method create_tabs {} {
	global $thisTail-sort
	
	#create widgets
	::frame $lframe.size -bd 0 -relief raised -bg black
	
	#-height 30
	for {set i 0} {$i <= $tabsize} {incr i} {
	    if {$labels == ""} {
		set lbl col$i
	    } else {
		set lbl [lindex $labels $i]
	    }
	    #label and button for columns
	    if {$justify != "" && [lindex $justify $i] == "1"} {
		set anchor e
	    } else {
		set anchor w
	    }
	
	    #label filter
	    set colfilters($i) "*"
	
	    ::button $lframe.size.btn$i \
		-bd 1 \
		-text $lbl \
		-anchor $anchor \
		-relief raised \
		-command "$this resort $i"
	    ::bind $lframe.size.btn$i <B3-ButtonRelease> \
		"$this edit_column_filter %W $i %X %Y"
	
	    #if bestfit or autofit is enabled, store the button widths
	    #as default tab size for the tab stops.
	    if {$bestfit || $autofit} {
		set bwidth  [winfo width $lframe.size.btn$i]
		if {$bwidth <= 1} {
		    set bwidth [winfo reqwidth $lframe.size.btn$i]
		}
		set tabs [lreplace $tabs $i $i $bwidth]
	    }
	    balloon_bind_info $lframe.size.btn$i [get_indep String TreeButton]
	    
	    ::bind $lframe.size.btn$i <Motion> "$this button_motion %W $i %x"
	    ::bind $lframe.size.btn$i <1> "
			set $thisTail-motion \[$this button_motion %W $i %x\]
			if {\${$thisTail-motion} <= 0} {
			    $this start_motion \[expr {$i + \${$thisTail-motion}}\] %X
			    break
			} else {
			    catch {unset $thisTail-motion}
			}
			"
	    ::bind $lframe.size.btn$i <B1-Motion> "
			if {\[info exists $thisTail-motion\]} {
			    $this motion \[expr {$i + \${$thisTail-motion}}\] %X
			    break
			}
			"
	    ::bind $lframe.size.btn$i <B1-ButtonRelease> "
			if {\[info exists $thisTail-motion\]} {
			    $this resize \[expr {$i + \${$thisTail-motion}}\] %X
			    catch {unset $thisTail-motion}
			    break
			}
			"

	    if {$i < $tabsize} {
		::frame $lframe.size.col$i \
		    -relief raised \
		    -width $splitwidth \
		    -height 7 \
		    -cursor    sb_h_double_arrow
		balloon_bind_info $lframe.size.col$i [get_indep String TreeColumn]
		
		#start motion process
		::bind $lframe.size.col$i <1> "$this start_motion $i %X"
		
		#motion process
		::bind $lframe.size.col$i <B1-Motion> "$this motion $i %X"
		
		#end motion process and place the columns correctly
		::bind $lframe.size.col$i <B1-ButtonRelease>\
			"$this resize $i %X"
		
		#enable/disable split lines displaying
		::bind $lframe.size.col$i <3> "$this toggle_splitlines"
	    }
	}
	
	if {$bestfit || $autofit} {
	    $lframe.tree config -deftabs $tabs
	}
    }

    method view_tabs {} {
	set tabs [$tree cget -tabs]
	set cnt [llength $tabs]
	set last [lindex $tabs end]
	set modified 0
	
	if {$cnt > 1} {
	    set size [lindex $tabs end]
	} else {
	    set size [lindex $tabs 0]
	}
	if {$last == ""} {
	    set last [expr [font_avg_width $tree] * 8]
	}
	
	#expand tab list to count of columns
	for {set i $cnt} {$i < $tabsize} {incr i} {
	    lappend tabs $last
	    set modified 1
	}
	for {set i 0; set x 0} {$i < $tabsize} {incr i} {
	    place config $lframe.size.col$i -x $x
	    set x [expr $x + [lindex $tabs $i]]
	}
	if {$modified} {
	    $tree config -tabs $tabs
	}
	for {set $i $tabsize} {$i < 10} {incr i} {
	    if {[winfo exists $lframe.size.col$i]} {
		catch {place forget $lframe.size.col$i}
		catch {place forget $lframe.size.btn[expr $i + 1]}
	    } else {
		#no need to continue
		break
	    }
	}
    }

    method toggle_bestfit {} {
	if {$bestfit} {
	    set bestfit 0
	} else {
	    set bestfit 1
	}
	if {[winfo exists $tree]} {
	    $tree config -bestfit $bestfit
	}
    }

    method toggle_truncate {} {
	if {$truncate} {
	    set truncate 0
	} else {
	    set truncate 1
	}
	if {[winfo exists $tree]} {
	    $tree config -truncate $truncate
	}
    }