xrefpane.tcl

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

                set accept_param 0
            } else {
                if {${w} != ""} {
                    ${w} config -relief sunken
                }
                set param 1
            }
        }
        set accept_param ${param}
        #save the parameter for next usage
        set sn_options(both,xref-accept-param) ${param}

        redisplay_root
    }

    method toggle_static {{w ""}} {
        global sn_options
        upvar #0 ${this}-accept_static static

        if {[sn_processes_running]} {
            bell
            return
        }
        if {${w} != "m"} {
            if {${static}} {
                if {${w} != ""} {
                    ${w} config -relief raised
                }
                set static 0
            } else {
                if {${w} != ""} {
                    ${w} config -relief sunken
                }
                set static 1
            }
        }
        set accept_static ${static}
        #save the parameter for next usage
        set sn_options(both,xref-accept-static) ${static}

        redisplay_root
    }

    method redisplay_root {} {
        if {[sn_processes_running]} {
            return
        }
        set id [${can} find withtag %root%]
        if {${id} == ""} {
            return
        }
        set line [convert_data_to_line ${id}]
        remove ${id}
        #delete the root item
        eval graph ${can} remove ${id}
        eval ${can} delete ${id}
        references both x ${line}
    }

    #view cross ref. of item by viewing it at root
    #delete old entries!
    method make_selection_to_root {} {
        if {[sn_processes_running]} {
            bell
            return
        }
        set id [${can} select item]
        if {${id} == ""} {
            return
        }

        #item and root are the same, don't do any thing.
        if {${id} == ${root}} {
            return
        }
        #remove all id's excepting "id" and it's sub tree
        remove ${root} ${id}

        #delete the root item
        eval graph ${can} remove ${root}
        eval ${can} delete ${root}
        graph_new_layout 1
        control_buttons
        see_item ${id}

        #add root tag to it's tags
        set tags [${can} itemcget ${id} -tags]
        ${can} itemconfig ${id} -tags "%root% ${tags}"
        #save id as root id
        set root ${id}

        #display root in the root entry
        set key [lindex $xinfos(${id}) ${item1_pos}]
        set what [lindex $xinfos(${id}) ${what1_pos}]
        set cls [lindex $xinfos(${id}) ${class1_pos}]
        if {${cls} == "#"} {
            set cls ""
        }
        set lbl [string trim "${key}(${what}) ${cls}"]
        upvar #0 ${this}-root_symbol_entry root_symbol_entry
        set root_symbol_entry ${lbl}
    }

    method list_selection_to_root {line procedure} {
        global tkeWinNumber sn_sep

        if {[sn_processes_running]} {
            bell
            return
        }

        if {${line} == ""} {
            bell
            return
        }

        #Verify if the procedure called by the Text entry
        if {[string first "\t" ${line}] == -1 || [string first "\:\:" ${line}]\
          != -1} {
            set i [string first "\:\:" ${line}]
            if {${i} != -1} {
                set class [string range ${line} 0 [expr ${i} - 1]]
                set key [string range ${line} [expr ${i} + 2] end]
                set line [list ${key} ${class}]
            } else {
                set line [split ${line}]
            }
            #the procedure called from treetable
        } else {
            set line [split ${line} \t]
        }

        set key [lindex ${line} 0]
        set class [lindex ${line} 1]

        #split string to key and type, like fu, fd, ...
        get_key_and_scope ${key} key scope

        #get parameter list and delete the brackes "(...)" from the list
        set param [lindex ${line} 2]
        if {${param} != ""} {
            set plen [string length ${param}]
            set param [string range ${param} 1 [expr ${plen} - 2]]
        }

        #Use the separator ansted of the blank character
        set class [string trim ${class}]
        set key [string trim ${key}]
        if {${class} != ""} {
            set pattern "${class}${sn_sep}${key}"
        } else {
            set pattern ${key}
        }

        if {${scope} != "ud"} {
            #retrieve the symbol by accepting the parameter list
            incr tkeWinNumber
            set win "crossrootretriever-${tkeWinNumber}"
            Retriever& ${win} -pattern ${pattern} -what ${scope}\
              -param ${param} -merge {{md mi} {fd fu} {fr fu}}\
              -titlename [get_indep String CrossRetriever]\
              -client_func ${procedure} -client_data "" -terminate 1\
              -variable ${this}-Wait -bell 0
# FIXME: stuff like this should use itcl::local !
            set ret [${win} return_status]
            itcl::delete object ${win}
            if {${ret} != 0} {
                return
            }

            #if we still don't find anything, find any with all scopes
            #and without merging declaration and implementation
            Retriever& ${win} -pattern ${pattern} -what "" -merge {{md mi}\
              {fd fu} {fr fu}} -titlename [get_indep String CrossRetriever]\
              -client_func ${procedure} -client_data "" -terminate 1\
              -variable ${this}-Wait -bell 0
            set ret [${win} return_status]
            itcl::delete object ${win}
            if {${ret} != 0} {
                return
            }
            #if we still don't find anything, find any with all scopes
            #and without merging declaration and implementation
            Retriever& ${win} -pattern ${pattern} -what ""\
              -titlename [get_indep String CrossRetriever]\
              -client_func ${procedure} -client_data "" -terminate 1\
              -variable ${this}-Wait -bell 0
            set ret [${win} return_status]
            itcl::delete object ${win}
            if {${ret} != 0} {
                return
            }

            #the symbol does not exist any where, also list it
            #as is. "symbol(ud)..."
            #add to line the type field as empty field.
            if {${scope} == ""} {
                set line [lreplace ${line} 0 0 "${key}(ud)"]
            }
        }
        set line [linsert ${line} 2 ""]
        eval ${procedure} [list ""] [list ${line}] 1

        catch {mark_item ${root}}
    }

    method recall_make_selection_to_root {w {target ""} {client_data ""}} {
        if {${w} != ""} {
            if {[catch {set sel [${w} curselection]}] || ${sel} == ""} {
                return
            }
            set target [${w} get [lindex ${sel} 0]]
            set data [${w} itemcget [lindex ${sel} 0] -data]
        } else {
            set data ""
        }
        if {[string first \t ${target}] == -1} {
            set target [join ${target} \t]
        }

        #on this position we have all the information what we need
        #about the object to view it's references
        set target [string trim ${target}]

        references both "x" ${target} ${data}
    }

    #display all the known informations from the cross reference
    #accepting the seted filter
    #all == -1: disable all filter flags
    #all == 1: enable all filter flags
    #all == 0: current state of filter flags
    private method fill {{all 0}} {
        global combobox_editor_scopes

        if {$itk_option(-symbols) == "" || ${all} == -2 ||
                [::info commands paf_db_to] == ""} {
            return
        }

        if {$itk_option(-symbols_filter) != ""} {
            upvar #0 $itk_option(-symbols_filter)-related related
            set qry ""
            foreach s [array names combobox_editor_scopes] {
                upvar #0 $itk_option(-symbols_filter)-${s} value
                if {${all} == -1} {
                    uplevel #0 "set $itk_option(-symbols_filter)-${s} off"
                    continue
                }
                if {${all} ||([info exists value] && ${value} != "off")} {
                    foreach db $combobox_editor_scopes(${s}) {
                        if {[::info commands paf_db_${db}] != ""} {
                            uplevel #0 "set $itk_option(-symbols_filter)-${s} ${s}"
                            lappend qry ${db}
                        }
                    }
                }
            }
            #undefined scopes
            upvar #0 $itk_option(-symbols_filter)-ud value
            if {${all} == -1} {
                uplevel #0 "set $itk_option(-symbols_filter)-ud off"
            }\
            elseif {${all}} {
                uplevel #0 "set $itk_option(-symbols_filter)-ud ud"
                lappend qry ud
            }\
            elseif {[info exists value] && ${value} != "off"} {
                lappend qry ud
            }
        } else {
            set qry ""
            set related 1
        }

        if {${qry} == ""} {
            $itk_option(-symbols) configure -contents ""
        } else {
            ${topw} configure -cursor watch
            update idletasks
            # We need to do some simple caching or we're not
            # going very responsive if we got to do a big lookup.
            if {$qry != $lastupdate} {
                set xref_sym_cache [lunique [lsort\
                                      [paf_db_to seq -strstr $qry -cross]]]
                set lastupdate $qry
            }
            $itk_option(-symbols) configure -contents $xref_sym_cache
            ${topw} configure -cursor ""
        }
    }

    method update_post_menu {} {
    }

    proc all_children {can pids result {skip ""}} {
        upvar ${result} res

        #select all children of a symbol, there are:
        #references to
        #references by
        #Tree to
        #Tree by
        foreach i ${pids} {

            set ids [${can} find withtag "to%${i}"]
            eval lappend ids [${can} find withtag "by%${i}"]
            eval lappend ids [${can} find withtag "browse_to%${i}"]
            eval lappend ids [${can} find withtag "browse_by%${i}"]

            if {${skip} != ""} {
                set j [lsearch -exact ${ids} ${skip}]
                if {${j} != -1} {
                    set ids [lreplace ${ids} ${j} ${j}]
                }
            }

            if {${ids} != ""} {
                eval lappend res ${ids}
                all_children ${can} ${ids} res ${skip}
            }
        }
    }

    proc resize {frm can x y id} {
        set coords [${can} coords ${id}]
        set fx [winfo rootx ${frm}]
        set fy [winfo rooty ${frm}]

        set w [expr ${x} - ${fx}]
        set h [expr ${y} - ${fy}]
        ${can} itemconfig ${id} -width ${w} -height ${h}
    }

    # This methods deletes the subnodes of a node.
    method remove {{id ""} {skip ""}} {
        if {${id} == ""} {
            set id [${can} select item]
            if {${id} == ""} {
                control_buttons
                return
            }
        }
        set children_ids ""
        all_children ${can} ${id} children_ids ${skip}

        if {${children_ids} == ""} {
            return
        }

        foreach c ${children_ids} {

            #delete depeneded variables or array entries
            catch {unset xinfos(${c})}

            if {[${can} type ${c}] == "window"} {
                set frm [${can} itemcget ${c} -window]

                ${frm}.sel delete

                destroy ${frm}
            }
        }
        eval graph ${can} remove ${children_ids}
        eval ${can} delete ${children_ids}

        graph_new_layout 1

        control_buttons

        see_item ${id}
    }

    method print {} {
        global sn_options tcl_platform