classpane.tcl

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

        ${topw} configure -title [Title] -iconname [Icon]
    }

    #don't change the status of overridden/overloaded
    proc classbrowser_switch {frm fnc} {
        foreach fr {mem flags further} {
            foreach w [winfo children ${frm}.${fr}] {
                if {[winfo class ${w}] == "Checkbutton" && [string first\
                  "further.and" ${w}] == -1} {
                    if {[${w} cget -state] != "disabled"} {
                        ${w} ${fnc}
                    }
                }
            }
        }
    }
    method mixer {} {
        global sn_options
        global mixer_status
        set t $itk_component(hull)-mixer
        if {[winfo exists ${t}]} {
            ${t} raise
            return
        }
        sourcenav::Window ${t}
        ${t} on_close "${t}.button_0 invoke"
        ${t} withdraw
        set title [string trimright [get_indep String Mixer] "."]
        ${t} title ${title}
        ${t} configure -iconname ${title}
        sn_motif_buttons ${t} bottom 0 [get_indep String ok]
        ${t}.button_0 config -command "itcl::delete object ${t}"
        ${t} bind_tk <Return> "${t}.button_0 invoke"
        frame ${t}.chk

        #Buttons ALL,NONE,AND
        set chkfr ${t}.chk.btns
        frame ${chkfr}
        button ${chkfr}.all -text [get_indep String All] -under [get_indep Pos\
          All] -command "
                Class&::classbrowser_switch ${t}.chk select
                ${this} refresh
            "
        balloon_bind_info ${chkfr}.all [get_indep String ClassAllINFO]
        button ${chkfr}.none -text [get_indep String None] -under\
          [get_indep Pos None] -command "
                Class&::classbrowser_switch ${t}.chk deselect
                ${this} refresh
            "
        balloon_bind_info ${chkfr}.none [get_indep String ClassNoneINFO]
        grid ${chkfr}.all - ${chkfr}.none -padx 10 -pady 10 -sticky w
        pack ${chkfr} -fill x -expand y -pady 10

        #Member flags PUBLIC,PROTECTED,PRIVATE
        set chkfr ${t}.chk.mem
        frame ${chkfr}
        global ${t}-methods
        checkbutton ${chkfr}.methods -text [get_indep String Methods]\
          -under [get_indep Pos Methods] -variable ${t}-methods -onvalue "1"\
          -offvalue "0" -command " ${this} refresh " -state normal
        global ${t}-instvar
        checkbutton ${chkfr}.instvar -text [get_indep String ClassVars]\
          -under [get_indep Pos ClassVars] -variable ${t}-instvar -onvalue "1"\
          -offvalue "0" -command " ${this} refresh " -state normal
        global ${t}-friends
        checkbutton ${chkfr}.friends -text [get_indep String Friends]\
          -under [get_indep Pos Friends] -variable ${t}-friends -onvalue "1"\
          -offvalue "0" -command " ${this} refresh " -state normal
        grid ${chkfr}.methods ${chkfr}.instvar ${chkfr}.friends -padx 10\
          -sticky w
        pack ${chkfr} -fill x -expand y -pady 10

        frame ${t}.chk.line1 -relief sunken -bd 2 -height 2 -width 300
        pack ${t}.chk.line1 -fill x -expand y

        set widgets ""

        #Member FLAGS
        set chkfr ${t}.chk.flags
        frame ${chkfr}
        foreach p [lrange ${mixer_vars} 3 5] {
            global ${t}-${p}
            lappend widgets [checkbutton ${chkfr}.${p} -text ${p}\
              -variable ${t}-${p} -onvalue "1" -offvalue "0" -command\
              " ${this} refresh " -state normal]
        }
        pack ${chkfr} -fill x -expand y -pady 10
        frame ${t}.chk.line2 -relief sunken -bd 2 -height 2 -width 300
        pack ${t}.chk.line2 -fill x -expand y

        #Member Further flags
        set chkfr ${t}.chk.further
        frame ${chkfr}
        checkbutton ${chkfr}.and -text [get_indep String And]\
		-under [get_indep Pos And] -variable ${and} -onvalue "1"\
		-offvalue "0" -command " ${this} refresh " -state normal
        balloon_bind_info ${chkfr}.and [get_indep String AndINFO]
        foreach p [lrange ${mixer_vars} 6 10] {
            global ${t}-${p}
            lappend widgets [checkbutton ${chkfr}.${p} -text ${p}\
              -variable ${t}-${p} -onvalue "1" -offvalue "0" -command\
              " ${this} refresh " -state normal]
        }
        pack ${chkfr} -fill x -expand y -pady 10
        frame ${t}.chk.line3 -relief sunken -bd 2 -height 2 -width 300
        pack ${t}.chk.line3 -fill x -expand y

        #Group flags OVERRIDE,OVERLOADED
        set chkfr ${t}.chk.groups
        frame ${chkfr}
        foreach p [lrange ${mixer_vars} 11 end] {
            global ${t}-${p}
            lappend widgets [checkbutton ${chkfr}.${p} -text ${p}\
              -variable ${t}-${p} -onvalue "1" -offvalue "0" -command\
              " ${this} refresh " -state normal]
        }
        pack ${chkfr} -fill x -expand y -pady 10

        eval grid [lrange ${widgets} 0 2] -padx 10 -sticky w
        grid ${t}.chk.further.and -column 1 -padx 10 -sticky w
        eval grid [lrange ${widgets} 3 5] -padx 10 -sticky w
        eval grid [lrange ${widgets} 6 7] -padx 10 -sticky w
        eval grid [lrange ${widgets} 8 end] -padx 10 -sticky w

        pack ${t}.chk -anchor w -padx 10 -pady 10

        ${t} resizable no no
        focus ${t}
        ${t} centerOnScreen
	${t} raise
    }

    method tree_get {tr y} {
        set v [${tr} get ${y}]

        set off [string first {<} ${v}]
        if {${off} > 0} {
            set v [string range ${v} 0 [expr ${off} - 1]]
        }
        return ${v}
    }

    method tree_select {target} {
        if {[$itk_component(classtree) size] <= 0} {
            bell
            return
        }

        set off [string first {<} ${target}]
        if {${off} > 0} {
            set target [string range ${target} 0 [expr ${off} - 1]]
        }

        set plus_b enabled_image
        set minus_b undefined_image

        if {${target} == "-all"} {
            set base_classes ""

            $itk_component(classtree) selection clear 0 end

            $itk_component(classtree) itemconfig 0 -image ${plus_b}
            for {set i 1; set num [$itk_component(classtree) size]} {${i} < ${num}} {incr i} {
                set bitm [lindex [$itk_component(classtree) itemconfig ${i} -image] 4]
                if {[string first "unvisited" ${bitm}] == -1} {
                    set cls [tree_get $itk_component(classtree) ${i}]
                    lappend base_classes ${cls}
                    set class_viewed(${cls}) 1
                    $itk_component(classtree) itemconfig ${i} -image ${plus_b}
                }
            }
            set base_classes [::lunique [::lsort -command sn_compare\
              ${base_classes}]]
        } else {
            set cls [tree_get $itk_component(classtree) 0]
            if {${cls} == ${target}} {
                set base_classes ""
                $itk_component(classtree) itemconfig 0 -image ${plus_b}
            } else {
                set base_classes ${target}
                $itk_component(classtree) itemconfig 0 -image ${minus_b}
            }
            for {set i 1; set num [$itk_component(classtree) size]} {${i} < ${num}} {incr i} {
                set bitm [lindex [$itk_component(classtree) itemconfig ${i} -image] 4]
                if {[string first "unvisited" ${bitm}] == -1} {
                    set cls [tree_get $itk_component(classtree) ${i}]
                    if {${cls} == ${target}} {
                        set class_viewed(${cls}) 1
                        $itk_component(classtree) itemconfig ${i} -image ${plus_b}
                    } else {
                        set class_viewed(${cls}) 0
                        $itk_component(classtree) itemconfig ${i} -image ${minus_b}
                    }
                }
            }
        }

        ${this} refresh
    }

    method toggle_class {y} {
        set bitm [lindex [$itk_component(classtree) itemconfigure ${y} -image] 4]

        if {[string first "unvisited" ${bitm}] != -1} {
            return
            # Not defined class.
        }

        set cls [tree_get $itk_component(classtree) ${y}]

        if {[string first "enabled" ${bitm}] != -1} {
            set bitm undefined_image

            #hide members of this class
            if {${y} != 0} {
                set class_viewed(${cls}) 0
                set off [lsearch -exact ${base_classes} ${cls}]
                set base_classes [lreplace ${base_classes} ${off} ${off}]
            }
        } else {
            set bitm enabled_image

            #view members of this class
            if {${y} != 0} {
                set class_viewed(${cls}) 1
                lappend base_classes ${cls}
                set base_classes [::lunique [::lsort -command sn_compare\
                  ${base_classes}]]
            }
        }
        if {${y} == 0} {
            $itk_component(classtree) itemconfig ${y} -image ${bitm}
        } else {
            #Now, it gets a little complicated. Because in case of multiple
            #inheritance, it can happen that a base class has been included\
              twice
            #and we have to update all the appropiate bitmaps.
            for {set s [$itk_component(classtree) size]; set i 0} {${i} < ${s}} {incr i} {
                if {[tree_get $itk_component(classtree) ${i}] == ${cls}} {
                    $itk_component(classtree) itemconfig ${i} -image ${bitm}
                }
            }
        }

        ${this} refresh
    }

    method edit_class {w {y ""}} {
        if {${class_doubleclickcommand} == ""} {
            return
        }
        if {${y} == -1} {
            return
        }
        if {${y} == ""} {
            set y [lindex [${w} curselection] 0]
            if {${y} == ""} {
                return
            }
        }
        set bitm [lindex [${w} itemconfig ${y} -image] 4]
        if {[string first "unvisited" ${bitm}] != -1} {
            bell
            return
            # Not defined class.
        }
        set cls [${w} get ${y}]

        ::eval ${class_doubleclickcommand} ${cls}
    }

    proc convert_sym_to_bit {sym} {
        global SN_Scope_Bits

        set bits 0
        foreach s ${sym} {
            if {${s} != ""} {
                set bits [expr ${bits} | $SN_Scope_Bits(${s})]
            }
        }
        return ${bits}
    }

    method get_class_hier {sub_classes parent} {
        global sn_options sn_sep
        global SN_Scope_Bits

        #build the tree of the class structure
        foreach c ${sub_classes} {
            set attr $base_class_in(${c})
            foreach t [list public protected private] {
                if {[expr ${attr} & $SN_Scope_Bits(${t})]} {
                    break
                }
            }
            set cls_inf [paf_db_cl seq -data -col 0 "${c}${sn_sep}"]
            if {${cls_inf} == ""} {
                set bt unvisited_image
            } else {
                set bt enabled_image
            }

            $itk_component(classtree) insert end -text ${c}$base_class_templ(${c})\
              -parent ${parent} -image ${bt} -font $sn_options(def,${t}-font)

            if {[lsearch -exact ${base_classes} ${c}] == -1} {
                lappend base_classes ${c}
            }
            set base_class_in(${c}) ${attr}

            set sub_cls_l ""
            foreach sc [paf_db_in seq -uniq -col {1 5 8} "${c}${sn_sep}"] {
                set cls [lindex ${sc} 0]

                #verify if class refer itself
                if {${cls} == ${c}} {
                    continue
                }
                lappend sub_cls_l ${cls}
                set base_class_in(${cls}) [lindex ${sc} 1]
                set base_class_templ(${cls}) [lindex ${sc} 2]

                #this class have "c" as sub class
                set sub_classes_of(${cls}) ${c}
            }

            #this class have base classes
            set base_classes_of(${c}) ${sub_cls_l}

            #call this procedure recursively to build all parent classes
            if {${sub_cls_l} != ""} {
                get_class_hier [::lunique [::lsort -command sn_compare\
                  ${sub_cls_l}]] [expr [$itk_component(classtree) size] - 1]
            }
        }
    }

    method get_subclasses {cname file beg_line end_line} {
        global sn_options sn_sep
        set cls_name ${cname}
        #get the parent classes of the base classes
        set base_classes ""
        catch {unset base_class_in}
        catch {unset base_class_templ}
        set sub_cls ""
        if {[::info commands paf_db_in] != ""} {
            foreach i [::lunique [::lsort -command sn_compare [paf_db_in seq\
              -col [list 1 5 "2 -${beg_line}:${end_line}" 8] -end ${file}\
              "${cls_name}${sn_sep}"]]] {

                set cls [lindex ${i} 0]

                if {${cls} != ${cname}} {
                    set base_class_in(${cls}) [lindex ${i} 1]
                    set base_class_templ(${cls}) [lindex ${i} 3]
                    lappend sub_cls ${cls}
                }
            }
        }

        #add the first class on the top
        catch {$itk_component(classtree) remove 0}
        set bitm enabled_image
        $itk_component(classtree) insert end -text ${cname} -image ${bitm}

        #display the parent classes of the base class as subtree
        set base_classes_of(${cname}) ${sub_cls}
        foreach c ${sub_cls} {
            set sub_classes_of(${c}) ${cname}
        }
        get_class_hier ${sub_cls} 0