retriever.tcl

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

    set key ""

    if {${what} == ""} {
        set what ${sn_scopes}
    }\
    elseif {${what} == "all"} {
        set what ${sn_scopes}
    }
    if {${merge} != ""} {
        set what [merge ${what} ${merge}]
    }
    if {${mtype} == "-exact"} {
        set key ${pattern}
        if {${key} != ""} {
            if {[string first ${sn_sep} ${key}] != -1} {
                set comp_key [list "${key}${sn_sep}"]
            }
            set key [list "${key}${sn_sep}"]
        }
        set simple_res_flt ""
        set file_res_flt ""
        if {${comp_key} == "" && ${pattern} != ""} {
            set comp_res_flt [list -strstr "${sn_sep}${pattern}${sn_sep}"]
        } else {
            set comp_res_flt ""
        }
    } else {
        # It can be case sensitive.
        set key ""
        if {${pattern} != "*"} {
            set g_pat [Tree::nocase_glob_pattern ${pattern}]
            set comp_res_flt [list -result "${g_pat}\(*"]

	    # Note: the "*" added on the end of the pattern
	    # will enable patterns such as "*.h" to match
	    # foo.h, without it the pattern *.h doesn't match
	    # anything! (I don't know why it works like this.)
            set file_res_flt [list -result ${g_pat}*]
            set simple_res_flt ${comp_res_flt}
        } else {
            set mtype "-exact"
            set comp_res_flt ""
            set file_res_flt ""
            set simple_res_flt ""
        }
    }

    #file is given
    if {${file} != ""} {
        set file_flt "-end [list ${file}]"
    } else {
        set file_flt ""
    }

    foreach w ${what} {
        set res ""

        #verify if the retrieving process is broken
        if {${Retr_DbFetch_Canceled}} {
            break
        }

        #format of output:
        #0. Name
        #1. Class
        #2. Type
        #3. Parameters
        #4. File
        #5. File From Line
        #6. File To Line
        switch ${w} {
            "md" -
            "mi" -
            "fr" -
            "iv" {
                    #this group has method name
                    #view type and parameters by mi and md
                    if {${w} == "md" || ${w} == "mi"} {
                        set Op "("
                        set Cl ")\\t"
                    } else {
                        set Op ""
                        set Cl "\\t"
                    }
                    set col [list "1 \(${w}\)\\t" "0 \\t" "6 \\t${Op}"\
                      "7 \"${Cl}\"" "3 \\t" "2 \\t" "4"]
                    set patlen [llength [split ${pattern} ${sn_sep}]]
                    if {${patlen} > 1 && ${mtype} == "-exact"} {
                        if {!${inherit}} {
                            #if inherit not set, accept only the members of
                            #the actual class
                            catch {eval lappend res [paf_db_${w} seq\
                              -updatecommand retr_update -end ${file}\
                              -col ${col} "${pattern}${sn_sep}"]}
                        } else {

                            set sup_class [lindex ${pattern} 0]
                            set mbr [lindex ${pattern} 1]
                            #find out if the class has parent classes, if true
                            #accept there members and symbols
                            foreach c\
                              [sn_get_class_inheritance_chain ${sup_class}] {
                                catch {eval lappend res [paf_db_${w} seq\
                                  -updatecommand retr_update -end ${file}\
                                  -col ${col} "${c}${sn_sep}${mbr}${sn_sep}"]}
                            }
                        }
                    } else {
                        catch {set res [eval paf_db_${w} seq\
                          -updatecommand retr_update ${file_flt}\
                          ${comp_res_flt} -col [list ${col}] ${comp_key}]}
                    }
                }
            "lv" -
            "cov" {
                    #local variables and commen variales in fortran
                    catch {set res [eval paf_db_${w} seq\
                      -updatecommand retr_update ${file_flt} ${comp_res_flt}\
                      -col [list [list "1 \(${w}\)\\t" "0 \\t" "6 \\t\\t"\
                      "3 \\t" "2"]] ${comp_key}]}
                }
            "f" {
                    #read all symbols in a file
                    if {[info commands paf_db_fil] != ""} {
                        set res [paf_db_fil seq -updatecommand retr_update\
                          -col [list "3 \(" "4 \)\\t" "2 \\t\\t\(" "8 \)\\t"\
                          "0 \\t" "6 \\t" "7"] "${file}${sn_sep}"]
                    } else {
                        set res ""
                    }
                }
            "files" {
                    #read file names
                    if {[info commands paf_db_f] != ""} {
                        set res [eval paf_db_f seq -updatecommand retr_update\
                          ${file_flt} ${file_res_flt} -col [list [list\
                          "0 #\\t" "1 \\t\\t\\t\\t"]] ${key}]
                    } else {
                        set res ""
                    }
                }
            default {

                    #following types haven't class names
                    #View type and parameters by a class of those, that can\
                      have 
                    #parameters
                    if {[lsearch -exact {fd fu} ${w}] != -1} {
                        set Op "("
                        set Cl ")\\t"
                    } else {
                        set Op ""
                        set Cl "\\t"
                    }
                    catch {set res [eval paf_db_${w} seq\
                      -updatecommand retr_update ${file_flt} ${simple_res_flt}\
                      -col [list [list "0 \(${w}\)\\t\\t" "5 \\t${Op}"\
                      "6 \"${Cl}\"" "2 \\t" "1 \\t" "3"]] ${key}]}
                }
        }
        if {${res} != ""} {
            eval lappend cnt ${res}
        }
    }
    if {![info exists cnt]} {
        set cnt ""
    }

    if {${from} == ""} {
        set from -1
    }
    if {${to} == ""} {
        set to -1
    }
    #filter type and parameter if availiable
    if {${type} != "" || ${param} != "" || ${from} != -1 || ${to} != -1} {
        #use an interactive filter to speed up the filtering
        set cnt [retriever_services "" filter ${cnt} ${pattern} ${file}\
          ${type} ${param} ${from} ${to}]
    }

    #reenable DB-fetching
    incr Retr_DbFetch_Active -1

    #if offset is specified, return only one entry
    #DON'T sort the results before!
    if {${offset} > -1 && [llength $cnt] > 0} {
        set cnt [list [lindex ${cnt} ${offset}]]
    }

    if {${cls} != ""} {
        set cnt [lsort -command sn_compare ${cnt}]
        ${cls} setcontents ${cnt}
        return ${cnt}
    } else {
        return [lsort -command sn_compare ${cnt}]
    }
}

proc display_contents_x {cls cnt {parent -1} {resize "resize"}} {
    if {${cnt} == ""} {
        bell
        return 0
    }
    #delete old entries
    if {${parent} == -1} {
        ${cls}.tree delete 0 end
        set filter [${cls} getfilter]
    } else {
        set filter "*"
    }

    #add the items using C/Function
    if {${filter} == "" || ${filter} == "*"} {
        retriever_services ${cls}.tree insert ${cnt} ${parent}
    } else {
        retriever_services ${cls}.tree insert [Tree::filter ${cnt}\
          ${filter}] ${parent}
    }

    #change size of the window
    if {${resize} == "resize"} {
        set height [${cls} size]
        if {${height} > 20} {
            set height 20
        }
        if {${height} > 0} {
            ${cls} config -height ${height}
        }
    }

    return 1
}

proc display_contents {cls cnt {parent -1}} {
    #delete old entries
    if {${parent} == -1} {
        ${cls}.tree delete 0 end
        set filter [${cls} getfilter]
    } else {
        set filter "*"
    }

    #add the items using C/Function
    if {${filter} == "" || ${filter} == "*"} {
        retriever_services ${cls}.tree insert ${cnt} ${parent}
    } else {
        retriever_services ${cls}.tree insert [Tree::filter ${cnt}\
          ${filter}] ${parent}
    }

    $cls SyncTabs
    return ""
}

proc edit_symbol {w {target ""} {client_data ""}} {
    if {${w} != ""} {
        edit_member ${w}
        return ""
    }

    if {${target} == ""} {
        return
    }
    set target [string trim ${target}]
    set pars [split ${target} "\t"]

    set file [lindex ${pars} 4]
    set pos [lindex ${pars} 5]

    set trg [join [lrange ${pars} 0 1] "\t"]
    set sym [sn_get_symbol_and_scope ${trg}]
    set type [lindex ${sym} 1]
    set name [lindex ${sym} 0]

    if {${type} == "" || ${name} == ""} {
        return
    }

    #if we have already the file and position, goto the item directly
    if {${file} != "" && ${pos} != ""} {
        sn_edit_file "" ${file} ${pos}
        #sn_add_history $type [list $type $name 0 $file]\
          [sn_make_history_title edit $type $name]
    } else {
        #We have here a file entry
        #format: 'foo.c \t sources/project/x \t c++'
        set file [lindex ${pars} 1]
        if {${file} == ""} {
            set file [lindex ${pars} 0]
        } else {
            set file [file join ${file} [lindex ${pars} 1]]
        }
        sn_edit_file "" ${file}
        #sn_add_history f [list $file] [sn_make_history_title edit f $file]
    }
}

proc sn_retrieve_symbol {pat what {file ""} {mtype -glob} {edit_single 1}\
  {bell 1} {client_func edit_symbol} {client_data ""} {type ""} {param ""}\
  {filter "*"} {offset -1} {merge ""}} {
    global sn_options
    global tkeWinNumber

    #find reusable window
    set window [find_reusable_window "retr-" 0]
    if {${window} == ""} {
        incr tkeWinNumber
        set win ".sn-retr-${tkeWinNumber}"
        #we use now a class
        Retriever& ${win} -pattern ${pat} -what ${what} -file ${file}\
          -type ${type} -param ${param} -mtype ${mtype}\
          -edit_single ${edit_single} -bell ${bell} -title "" -icon ""\
          -icon_prefix "" -offset ${offset} -client_func ${client_func}\
          -client_data ${client_data} -merge ${merge}

        if {[catch {set ret [${win} return_status]}]} {
            return 0
        }
        
        if {${ret} == 0} {
            itcl::delete object ${win}
        }
    } else {
        set pat [Retriever&::pattern ${pat}]
        set cnt [read_matched_from_db "" ${what} ${mtype} ${pat} ${type}\
          ${param} ${file} -1 -1 0 ${offset} ${merge}]
        if {[llength ${cnt}] == 1} {
            Retriever&::goto_symbol "" ${cnt} ${client_data} ${client_func}
            set ret 1
        } else {
            ${window}.list setcontents ${cnt}
            set ret [display_contents_x ${window}.list ${cnt}]
            if {${ret}} {
                if {[wm state ${window}] != "normal"} {
                    wm deiconify ${window}
                } else {
                    raise ${window}
                }
            }
        }
    }

    #Add only the history for retrieving without
    #a client function, because when the function
    #depeneds on an existing object (itcl class)
    #it will fail in the next call when this object
    #doesn't more exist
    if {(${client_func} == "edit_symbol" || ${client_func} == "") &&\
      ${client_data} == ""} {
        sn_add_history retr [list ${pat} ${what} ${file} ${mtype}\
          ${edit_single} ${bell} ${client_func} ${client_data} ${type}\
          ${param} ${filter}] [sn_make_history_title retr "" ${pat}]\
          sn_retrieve_symbol
    }
    return ${ret}
}

proc retriever_what_to_qry {var_prefix} {

    # Remove the namespace, since a fully qualified
    # var name will problably not match any thing
    # in the for loop below.
    set var_prefix [namespace tail $var_prefix]

    set res ""
    foreach v [info globals "${var_prefix}-sc-*"] {
        upvar #0 ${v} val
        if {${val} != ""} {
            lappend res ${val}
        }
    }
    return ${res}
}