tree.tcl

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

    method Truncating_Methode {methode} {
	set truncatemethode $methode
	$tree config -truncatemethode $truncatemethode
    }

    #called to post the right-mose-option menu.
    #it's realy intelegent!!
    method tree_post_menu {m} {
	upvar #0 $tree-bestfit bf
	upvar #0 $tree-truncate tr
	upvar #0 $tree-splitlines sp
	
	set bf $bestfit
	set tr $truncate
	set sp $splitlines
	
	if {$when_post_menu != ""} {
	    eval $when_post_menu $m
	}
		
	#menu delete all column filters
	$m add command \
	    -label [get_indep String DeleteColumnFilters] \
	    -command "$this delete_column_filters"
	
	#if tabulators are enabled, view those as menu buttons
	#to sort on them or to view/hide them.
	if {$tabsize >= 0} {
	    global $thisTail-sort
	
	    $m add separator
	
	    #Add sort submenu to sort the contents on the
	    #availiable columns
	    set mk $m.sort
	    $m add cascade -label [get_indep String Sort]\
		-underline [get_indep Pos Sort]\
		-menu $mk
	    menu $mk -tearoff 0
	    for {set i 0} {$i <= $tabsize} {incr i} {
		$mk add radiobutton \
		    -label [lindex $labels $i] \
		    -variable $thisTail-sort \
		    -value $i \
		    -command "$this resort $i"
	    }
	    set mk $m.hide
	    $m add cascade -label [get_indep String Toggle]\
		-underline [get_indep Pos Toggle]\
		-menu $mk
	
	    #Add the submenu to view/hide the availiable columns
	    set mk $m.hide
	    menu $mk -tearoff 0
	    for {set i 0} {$i <= $tabsize} {incr i} {
		upvar #0 $thisTail-hide-$i x
		if {![info exists column_toggled($i)] || $column_toggled($i)} {
		    set x 1
		} else {
		    set x 0
		}
		$mk add checkbutton \
		    -label [lindex $labels $i] \
		    -variable $thisTail-hide-$i \
		    -onvalue 1 -offvalue 0 \
		    -command "$this toggle_column $i $thisTail-hide-$i"
	    }
	
	    #Add the sub menu to specify the alignments (left/right)
	    #for the columns
	    #Only if there is more than two columns
	    if {$tabsize >= 2} {
		set state normal
	    } else {
		set state disabled
	    }
	    set mk $m.align
	    $m add cascade -label [get_indep String Justify]\
		-underline [get_indep Pos Justify] \
		-menu $mk \
		-state $state
	    menu $mk -tearoff 0
	    set aligns [$tree cget -justify]
	    for {set i 0} {$i <= $tabsize} {incr i} {
		upvar #0 $thisTail-align-$i x
		set right [lindex $aligns $i]
		if {$right != "" && $right == 1} {
		    set x 1
		} else {
		    set x 0
		}
		
		#don't justify the first and the last column !!
		if {$i == 0 || $i == $tabsize} {
		    set state disabled
		} else {
		    set state normal
		}
		$mk add checkbutton \
		    -label [lindex $labels $i] \
		    -variable $thisTail-align-$i \
		    -onvalue 1 -offvalue 0 \
		    -command "$this justify_column $i $thisTail-align-$i" \
		    -state $state
	    }
	
	    #sub menu to choose the truncating methode (auto, prefix, suffix)
	    if {$enable_truncating_methode_submenu} {
		if {$tr} {
		    set state normal
		} else {
		    set state disabled
		}
		set mk $m.tm
		$m add cascade \
		    -label [get_indep String TruncatingMethode]\
		    -underline [get_indep Pos TruncatingMethode] \
		    -menu $mk \
		    -state $state
		menu $mk -tearoff 0
		
		$mk add radiobutton \
			-label "Auto" \
			-variable $thisTail-truncating_methode \
			-value "auto" \
			-command "$this Truncating_Methode auto"
		$mk add radiobutton \
			-label "Prefix" \
			-variable $thisTail-truncating_methode \
			-value "path" \
			-command "$this Truncating_Methode path"
		$mk add radiobutton \
			-label "Suffix" \
			-variable $thisTail-truncating_methode \
			-value "normal" \
			-command "$this Truncating_Methode normal"
		}
	}
	
	$m add separator
	
	#best fit
	$m add checkbutton \
	    -label [get_indep String TreeBestFit] \
	    -variable $tree-bestfit \
	    -onvalue 1 -offvalue 0 \
	    -command "$this toggle_bestfit"
	#truncate
	$m add checkbutton \
	    -label [get_indep String TreeTruncate] \
	    -variable $tree-truncate \
	    -onvalue 1 -offvalue 0 \
	    -command "$this toggle_truncate"
	#split lines
	$m add checkbutton \
	    -label [get_indep String TreeViewSplitLines] \
	    -variable $tree-splitlines \
	    -onvalue 1 -offvalue 0 \
	    -command "$this toggle_splitlines"
	
	$m add separator

	#view size and selected items at the top of the popup menu
	set sel_size [llength [$tree curselection]]
	$m add command \
	    -label [format [get_indep String  ListSize]\
	    [$tree size] $sel_size]
    }
    method post_commands {x y} {
	set m .sn_pop_menu_tree
	# It has to be destroyed because we might have problems with "tk_popup"!
	catch {::destroy $m}

	menu $m -tearoff 0\
		-postcommand "$this tree_post_menu $m"
	wm overrideredirect $m 1

	tk_popup $m $x $y
    }

    proc font_avg_width {w} {
	set fnt [$w cget -font]
	set text_avg_width [font measure $fnt "M"]

	return $text_avg_width
    }

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

    method start_motion {num x} {
	set x [expr {$x - [winfo rootx $lframe.size]}]
	if {$mframe == ""} {
	    set mframe $lframe.motion
	}
	set theight [expr {[winfo height $tree] + [winfo height $lframe.size]}]
	frame $mframe -relief raised \
		    -bd 0 \
		    -width 1 \
		    -bg black \
		    -height $theight \
		    -cursor sb_h_double_arrow
	place $mframe -x $x -y 0
    }
    method motion {num x} {
	if {$mframe == ""} {
	    start_motion $num $x
	}
	set x [expr {$x - [winfo rootx $lframe.size]}]
	place $lframe.motion -x $x -y 0
    }
    method end_motion {} {
	if {$mframe != ""} {
	    catch {destroy $mframe}
	    set mframe ""
	}
    }

    #do resizing the column width even when motion arround
    #the line, this happens when the pointer moves over
    #the near button where the resize-hit-button area is
    #set to be 12 or dependent on the current column size.
    method button_motion {btn num x} {
    	set ww [winfo width $btn]
	set range 12
	if {$range > [expr {$ww / 3}]} {
	    set range [expr {$ww / 3}]
	}
	if {$num > 0 && $x <= $range} {
	    $btn config -cursor sb_h_double_arrow
	    return -1
	} elseif {$num < $tabsize && [expr {$ww - $x}] < $range} {
	    $btn config -cursor sb_h_double_arrow
	    return 0
	} else {
	    $btn config -cursor {}
	    return 1
	}
    }

    method put_in_cutbuffer {} {
	set sel [$tree curselection]
	foreach l $sel {
	    lappend res [$tree get $l]
	}
	if {![info exists res]} {
	    bell
	    return
	}
	#clipboard clear -displayof $tree
	#clipboard append -displayof $tree -- $res
	clipboard clear
	clipboard append [join $res \n]
    }

    method print_dialog_box {{sub_tit ""}} {
	global sn_options
	global tcl_platform

	if {[winfo exists $print_dialog]} {
	    $print_dialog raise
	    return
	}
	set toplw [winfo toplevel $thisTail]

	set print_dialog [sourcenav::Window $toplw.prtdlg]

	$print_dialog transient $toplw

	sn_motif_buttons $print_dialog bottom 0 [get_indep String ok]\
		[get_indep String cancel]
	$print_dialog.button_0 config -command "$this print_it"
	$print_dialog.button_1 config -command "itcl::delete object $print_dialog"

	global $print_dialog-ptarget $print_dialog-cmd
	set $print_dialog-ptarget "all"
	
	set tit [wm title $toplw]
	if {$sub_tit != ""} {
	    append tit " " $sub_tit
	}
	set $print_dialog-cmd [format $sn_options(def,ascii-print-command) $tit]
	$print_dialog title [list [get_indep String Print] $tit]

	frame $print_dialog.txt
	frame $print_dialog.txt.lbls
	frame $print_dialog.txt.entries
	
	if {$tcl_platform(platform) != "windows"} {
	    label $print_dialog.txt.lbls.prompt\
		-text [get_indep String SQLPprintercmd]

	    entry $print_dialog.txt.entries.cmd -width 70\
		-textvariable $print_dialog-cmd
		
	    ::focus $print_dialog.txt.entries.cmd
	    ::bind $print_dialog.txt.entries.cmd <Any-Return> \
		"$print_dialog.button_0 invoke"
	}
	label $print_dialog.txt.lbls.label \
		-text [get_indep String Indent]
	entry $print_dialog.txt.entries.entry -width 5\
		-textvariable $print_dialog-indent

	# Clear the entry field before inserting a value.
	$print_dialog.txt.entries.entry delete 0 end
	$print_dialog.txt.entries.entry insert 0 "2"
	
	if {$tcl_platform(platform) != "windows"} {
	    pack $print_dialog.txt.lbls.prompt -side top -anchor e
	    pack $print_dialog.txt.entries.cmd -side top -padx 10 -fill x -expand y
	}
	pack $print_dialog.txt.lbls.label -side top -anchor e
	pack $print_dialog.txt.entries.entry -side top -padx 10 -anchor w
	pack $print_dialog.txt -side top -anchor w
	
	pack $print_dialog.txt.lbls -side left -expand y
	pack $print_dialog.txt.entries -side right -fill x -expand y
	pack $print_dialog.txt -side top -expand y
	
	radiobutton $print_dialog.marked -text [get_indep String Marked]\
	    -variable $print_dialog-ptarget -value marked

	radiobutton $print_dialog.all -text [get_indep String All]\
	    -variable $print_dialog-ptarget -value all

	pack $print_dialog.all -anchor w -padx 60 -side top
	pack $print_dialog.marked -anchor w -padx 60 -side top

	$print_dialog move_to_mouse
	catch {$print_dialog resizable no no}
	
	$print_dialog take_focus
    }

    method print_it {} {
	upvar #0 $print_dialog-ptarget target
	upvar #0 $print_dialog-cmd cmd
	upvar #0 $print_dialog-indent indent
	global sn_options

	if {[catch {set indent [expr $indent + 0]}]} {
	    set indent 2
	}
	
	set spaces "                                                          "
	
	switch -- $target {
	"all" {
		set i 0
		for {set size [$tree size]} {$i < $size} {incr i} {
		    set lvl [expr [$tree levels $i] * $indent]
		    set spaces ""
		    for {set j 0} {$j <= $lvl} {incr j} {
			set spaces " $spaces"
		    }
		    lappend lst "[string range $spaces 0 [expr $lvl - 1]][$tree get $i]"
		}
	    }
	"marked" -
	default {
		set sel [$lframe.tree curselection]
		if {$sel != ""} {
		    foreach i $sel {
			lappend lst "[string range $spaces 0 [expr [$tree levels $i] * $indent - 1]][$tree get $i]"
		    }
		}
	    }
	}
	
	if {![info exists lst]} {
	    set lst ""
	}
	set lst [join $lst \n]

	itcl::delete object $print_dialog

	set tmpf [sn_tmpFileName]
	set fd [open $tmpf "w+"]
	fconfigure $fd -encoding $sn_options(def,system-encoding) -blocking 0
	puts $fd $lst
	close $fd

	# Escape [] and $ in user input for eval in sn_print_file
	regsub -all {(\$|\[|\])} $cmd {\\&} cmd

	sn_print_file $cmd $tmpf

	file delete -- $tmpf

	set print_dialog ""

	catch {unset target}
	catch {unset cmd}
    }

    ##
    ##List_Box compatiblility
    ##
    # It is a 'proc' because the performance is better.
    method see {args} {
	return [eval $tree see $args]
    }
    method delete_tk {args} {
	return [eval $tree delete $args]
    }

    method treebind {args} {
	return [eval ::bind $tree $args]
    }

    method header {args} {
	if {[winfo exists $header]} {
	    return [eval $header $args]
	}
    }
    method index {args} {
	return [eval $tree index $args]
    }
    method activate {args} {
	return [eval $tree activate $args]
    }

    method nearest {args} {
	return [eval $tree nearest $args]
    }

    proc exchange {w y} {
	set sel [$w curselection]
	if {$sel == "" || [string compare $exchange ""] == 0} {
	    return
	}

	set y [$w nearest $y]

	set len [expr {[llength $sel] - 1}]
	set first [lindex $sel 0]
	set last  [lindex $sel $len]

	if {$y >= $first && $y <= $last} {
	    return
	}

	if {$first <= $y} {
	    set y [expr {$y - $len}]
	}
	if {$y < 0} {
	    return
	}
	$w delete $first $last
	eval $w insert $y $exchange
	$w selection clear 0 end
	$w selection set $y [expr {$y + $len}]
    }
    proc exchange_mark {w} {
	set sel [$w curselection]

	set exchange ""
	foreach s [$w curselection] {
	    lappend exchange [$w get $s]
	}
    }

    protected thisTail ""
    protected lframe ""
    protected tree ""
    protected oldnum -1
    protected oldfont ""
    protected actual_sortcolumn -1
    #an array of the items
    protected column_toggled
    protected entry ""
    protected widget {}
    protected frame_height 0
    protected col_height 0
    protected mframe ""
    protected print_dialog {}

    common resizing
    common exchange {}

    public withframe no

    public state {disabled} {
	#$tree config -state $state
    }
    public tabsize -1
    public tabs {} {
	if {[winfo exists $tree] && $tabsize != -1} {
	    $tree config -tabs $tabs
	}
    }
    public labels {""} {
	if {[winfo exists $lframe.size] && $tabsize != -1} {
	    for {set i 0} {$i <= $tabsize} {incr i} {
		$lframe.size.btn$i configure -text [lindex $labels $i]
	    }
	    resize 0 [lindex [$tree cget -tabs] 0] 0
	    view_tabs
	}
    }
    public justify {} {
	if {[winfo exists $lframe.btn0] && $tabsize != -1} {
	    resize 0 [lindex [$tree cget -tabs] 0] 0
	}
    }
    public selectmode "browse" {
	if {[winfo exists $tree]} {