retriever.tcl

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

        elseif {${scope} == ""} {
            set pars [split [${tree} get ${idx}] \t]
            set f [lindex ${pars} 0]
            set d [lindex ${pars} 1]
            if {${d} != ""} {
                set f [file join ${d} ${f}]
            }
            ${dspproc} ${cls}.list [read_matched_from_db "" f -exact "" ""\
              "" ${f}] ${idx}
            set num [${tree} itemcget ${idx} -children]
            if {${num} > 0} {
                ${tree} itemconfig ${idx} -image file_-_image
            } else {
                ${tree} itemconfig ${idx} -image file_image
            }
        }
        return ""
    }

    proc handle_doubleclick {cls w} {
        catch {${cls} select_item ${w}}
    }

    proc handle_return {cls w} {
        ${w} selection clear 0 end
        ${w} selection set [${w} index active]
        update idletasks
        catch {${cls} select_item ${w}}
    }

    method select_item {w} {
        #an item is choosen
        set return_status 1

        #call user function
        eval ${client_func} ${w} [list ""] [list ${client_data}]

        if {${terminate}} {
            if {${call_before_terminate} != ""} {
                set ret [eval ${call_before_terminate} ${window}\
                  [list ${client_data}]]
                if {${ret} != ""} {
                    return
                }
            }
            change_variable
        }\
        elseif {! ${hold_window}} {
            #delete window after selection
            itcl::delete object ${this}
        }
    }

    method window_deleted {} {
        itcl::delete object ${window}
        set window ""
        set return_status -1
    }

    method config {config} {
    }

    #pattern to search an item
    public pattern "" {
        set pattern [pattern ${pattern}]
    }

    #converts the pattern to a correct form
    proc pattern {prn} {
        global sn_sep
        #verify if the pattern has C++ format
        set i [string first "\:\:" ${prn}]
        if {${i} != -1} {
            set prn [split ${prn} "\:\:"]
            set prn "[lindex ${prn} 0]${sn_sep}[lindex ${prn} end]"
        }
        return [string trim ${prn} " ${sn_sep}"]
    }
    method build_title {} {
        global sn_options

        if {${titlename} == ""} {
            set titlename [string trim [get_indep String Retriever] "."]
        }

        if {${title} == ""} {
            if {${pattern} != ""} {
                set t " : ${pattern}"
            }\
            elseif {${file} != ""} {
                set t " : ${file}"
            } else {
                set t ""
            }
            set title [sn_title ${titlename}${t}]
        }
        if {${icon} == ""} {
            set icon ${titlename}
        }
    }

    proc add_donot_call_checkbutton {w} {
        global sn_options
        # FIXME : this delete object if already exists stuff is ugly, need more generic solution
        if {[itcl::find object ${w}.checkbtns] == "${w}.checkbtns"} {
            itcl::delete object ${w}.checkbtns
        }
        CheckButton& ${w}.checkbtns -labels [list [get_indep String\
          DonotDisplay]] -balloons [list [get_indep String DoNotDisplayINFO]]\
          -variables [list sn_options(donot_display)] -label ""
        pack ${w}.checkbtns -in ${w}.top -side bottom -fill x -padx 10m -pady 3m
    }
    proc warning_many_matches {} {
        tk_dialog_with_widgets .retr-info [get_indep String ManyMatchesTitle]\
          [get_indep String ManyMatchesINFO] info_image 0 "Retriever& ::\
          add_donot_call_checkbutton" [get_indep String Ok]
    }

    #search item with following prototype
    public type ""
    #search item with following parameters
    public param ""
    public what "" {
        global sn_scopes
        if {${what} == ""} {
            set what all
        }
        if {${what} == "all"} {
            set what ${sn_scopes}
        }
    }
    public merge "" {
    }

    #file name in witch the item is to find
    public file ""

    #define range in witch the item is to find
    public from -1 {
        if {[string first "." ${from}] != -1} {
            set from [lindex [split ${from} "."] 0]
        }
        set from [string trimleft ${from} "0"]
    }
    public to -1 {
        if {${to} != -1 && ${from} == -1} {
            set from 0
        }
        if {[string first "." ${to}] != -1} {
            set to [lindex [split ${to} "."] 0]
        }
        set to [string trimleft ${to} "0"]
    }

    public mtype "-exact"
    public offset -1
    public edit_single 1
    public bell 1
    public client_func "edit_symbol" {
        if {${client_func} == ""} {
            set client_func edit_symbol
        }
    }
    #this is called when more than one match is found
    public warning 1
    public client_data ""
    public contents ""
    public window ""
    public titlename ""
    public title "" {
        build_title
    }
    public terminate 0
    public call_before_terminate ""
    public variable ""
    public watch 1
    public return_status 0
    public icon "" {
        build_title
    }
    public icon_prefix "" {
        if {${icon_prefix} == ""} {
            set icon_prefix ${pattern}
        }
    }

    public window_prefix "retr"

    common retrieve_width 70

    method return_status {} {
        return ${return_status}
    }
}

#edit the marked symbol in the retriever or class browser
proc edit_member {w {what "md"} {go ""}} {
    global sn_options sn_sep
    set cols [get_cols_and_offset ${w} file pos]
    if {${cols} == ""} {
        bell
        return
    }

    #It can be a file name entry
    if {${file} != "1"} {
        set off 0
        set lst [split [lindex ${cols} 0] \(]
        set method [lindex ${lst} 0]
        if {${what} == "md"} {
            set what [lindex [split [lindex ${lst} 1] \)] 0]
        }
        set name [lindex ${lst} 0]
        set class [lindex ${cols} 1]
        # If we search for method implementation we have to check the input\
          parameter list.
        if {${go} == "mi"} {
            #search for implementation
            if {[::info commands paf_db_mi] != ""} {
                set md_list [paf_db_mi seq\
                  -list "${class}${sn_sep}${method}${sn_sep}"]
            }
            #no implementation found?
            if {${md_list} != ""} {
                set md_list [lindex ${md_list} ${off}]
                set pos [lindex ${md_list} 2]
                set file [lindex ${md_list} 3]
            } else {
                set file ""
                set pos ""
            }
        }
        set name [list ${class} ${method}]

        if {${file} == ""} {
            sn_log "Method not found: ${class} ${method}(${what})"
            bell
        } else {
            sn_log "Found method: ${class} ${method}(${what})"

            #find offset to be possible to retrieve the same symbol in a\
              modified
            #file
            set off [sn_find_symbol_offset ${class} ${method} ${what} ${file}\
              ${pos}]

            set edname [list ${off} [string trim "${class} ${method} ${what}"]]
            sn_edit_file ${edname} ${file} ${pos}
            #sn_add_history $what [list $what $name $off $file]\
              [sn_make_history_title edit $what "$class $method"]
        }
    } else {
        #File name is restored in 'Name' and directory in 'Class'
        set file [lindex ${cols} 1]
        if {${file} == ""} {
            set file [lindex ${cols} 0]
        } else {
            set file [file join ${file} [lindex ${cols} 0]]
        }

        sn_edit_file f ${file}
        #sn_add_history f [list $file ""] [sn_make_history_title edit f $file]
    }
}

proc get_cols_and_offset {w filename filepos} {
    upvar ${filename} file
    upvar ${filepos} pos

    set y [lindex [${w} curselection] 0]
    if {${y} == ""} {
        return ""
    }

    #set up variables
    set data [split [${w} itemcget ${y} -data] \t]
    set file [lindex ${data} 0]
    set pos [lindex ${data} 1]

    #return columns as a tcl/list
    set pat [${w} get ${y}]
    return [split ${pat} \t]
}

#look for the offset of the symbol in the file, this is important
#to go to the correct symbol when the edited file is modified
proc sn_find_symbol_offset {class sym scope file line} {
    set cnt [read_matched_from_db "" ${scope} -exact [string trim\
      "${class} ${sym}"] "" "" ${file}]
    set off [lsearch -glob ${cnt}\
      "${sym}(${scope})\t${class}\t*\t*\t${file}\t${line}\t*"]
    if {${off} < 0} {
        set off 0
    }
    return ${off}
}

proc merge {what merge} {
    #by cross reference retriever it's not correct to view declaration
    #and implementation on the same time.
    #What we do hier, is deleting the declaration scopes from
    #the scope list.
    #merge md==mi and fd=fu
    foreach m ${merge} {
        set decl [lindex ${m} 0]
        set impl [lindex ${m} 1]

        if {[lsearch -exact ${what} ${impl}] != -1 || [lsearch -exact ${what}\
          ${decl}] != -1} {
            set idx [lsearch -exact ${what} ${decl}]
            if {${idx} != -1} {
                set what [lreplace ${what} ${idx} ${idx}]
            }
            if {[lsearch -exact ${what} ${impl}] == -1} {
                lappend what ${impl}
            }
        }
    }
    return ${what}
}

proc retr_cancel_fetching {} {
    global Retr_DbFetch_Canceled
    set Retr_DbFetch_Canceled 1
}

proc retr_update {} {
    global Retr_DbFetch_Canceled

    update
    update idletasks
    update

    if {${Retr_DbFetch_Canceled}} {
        #fetching canceled
        return 0
    }
    return 1
}


#######################################################################
#
#
# General procedure to fetch for symbol matches in the DB.
#
#
#######################################################################
#global variables to synchronize DB-fetches
global Retr_DbFetch_Active
set Retr_DbFetch_Active 0
global Retr_DbFetch_Canceled
set Retr_DbFetch_Canceled 0
proc read_matched_from_db {cls what mtype {pattern ""} {type ""} {param ""}\
  {file ""} {from -1} {to -1} {inherit 0} {offset -1} {merge ""}} {
    global sn_options sn_sep sn_scopes

    #Don't proceed if a DB-fetch is active.
    global Retr_DbFetch_Active
    if {${Retr_DbFetch_Active}} {
        bell
        sn_error_dialog [get_indep String CannotProceed] [get_indep String\
          Retriever]
        return ""
    }
    incr Retr_DbFetch_Active

    #reset cancel global variable
    global Retr_DbFetch_Canceled
    set Retr_DbFetch_Canceled 0

    #puts stdout "read_matched_from_db (cls:$cls, what:$what, mtype:$mtype,\
      pattern:$pattern, type:$type, param:$param, file:$file, from:$from,\
      to:$to, inh:$inherit, offs:$offset, merge:$merge)"

    set result ""
    set comp_key ""
    # Useful for simple queries.