retriever.tcl

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

# Copyright (c) 2000, 2001, Red Hat, Inc.
# 
# This file is part of Source-Navigator.
# 
# Source-Navigator is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License as published
# by the Free Software Foundation; either version 2, or (at your option)
# any later version.
# 
# Source-Navigator is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# General Public License for more details.
# 
# You should have received a copy of the GNU General Public License along
# with Source-Navigator; see the file COPYING.  If not, write to
# the Free Software Foundation, 59 Temple Place - Suite 330, Boston,
# MA 02111-1307, USA.
# 
# retriever.tcl - The retriver with tab stop support.
# Copyright (C) 1998 Cygnus Solutions.

itcl_class Retriever& {
    constructor {config} {
        global sn_options

        #read matched contents from the db.
        if {${contents} == ""} {
            set contents [read_matched_from_db "" ${what} ${mtype} ${pattern}\
              ${type} ${param} ${file} ${from} ${to} ${inherit} ${offset}\
              ${merge}]
        } else {
            #contents are specified as an option (-contents)
        }

        if {${contents} == ""} {
            if {${bell}} {
                bell
            }

            set return_status 0
            change_variable
            return 0
        }

        #if it found only one item
        if {${edit_single} && [llength ${contents}] == 1} {
            goto_symbol "" ${contents} ${client_data} ${client_func}

            #change variable and exit, doesn't wait any way
            set return_status 1
            change_variable
            return ${return_status}
        } else {
            #by more than one element, view list to select one item
            display_retrieves
        }

        #if variable not empty wait to close the procedure.
        if {${variable} != ""} {
            global ${variable}
            update idletasks
            tkwait variable ${variable}
        } else {
            set return_status 1
        }

        return ${return_status}

    }

    proc goto_symbol {w cnt cldata {clproc "edit_symbol"}} {
        if {${clproc} != ""} {
            if {[catch {eval ${clproc} [list ${w}] [list [lindex ${cnt} 0]]\
              [list ${cldata}]}]} {
                bell
            }
        }
    }

    destructor {
        if {${window} != ""} {
	    ${this} window_deleted
	}

        foreach v [::info globals "${this}-*"] {
            catch {uplevel #0 unset ${v}}
        }
    }

    method change_variable {} {
        if {${variable} != ""} {
            upvar #0 ${variable} var
            set var "changed"
        }
    }

    public inherit 0 {
    }

    proc retr_cross_ref {w} {
        if {[catch {set sel [lindex [${w} curselection] 0]}] || ${sel} == ""} {
            bell
            return
        }
        set line [split [${w} get ${sel}] \t]
        set data [split [${w} itemcget ${sel} -data] \t]
        set key [lindex ${line} 0]
        set cls [lindex ${line} 1]
        set type [lindex ${line} 2]
        set param [lindex ${line} 3]
        set file [lindex ${data} 0]
        set from [lindex ${data} 1]
        set to [lindex ${data} 1]

        set type [lindex [split ${key} "("] end]
        set type [lindex [split ${type} ")"] 0]
        switch ${type} {
            "md" {
                    set type "mi"
                }
            "fd" {
                    set type "fu"
                }
        }

        set i [string last "(" ${key}]
        set key [string range ${key} 0 [expr ${i} - 1]]

        if {${cls} != ""} {
            set key "${cls}\:\:${key}"
        }

        sn_xref both ${key} ${type} ${file} ${from} ${to}
    }

    method toggle_hold {w} {
        upvar #0 ${this}-hold hold
        if {${hold}} {
            ${w} config -relief raised -image hold_off_image
            set hold 0
            set hold_window 0
        } else {
            ${w} config -relief sunken -image hold_on_image
            set hold 1
            set hold_window 1
        }
    }

    public hold_window 0 {
        if {[winfo exists ${window}.exp.hold]} {
            if {${hold_window}} {
                set hold_window 0
            } else {
                set hold_window 1
            }
            toggle_hold ${window}.exp.hold
        }
    }


# FIXME: this method is only called in the constructor, and it seems to create a new
# topleve. Beside the fact that it is completely broken, I can seem to figure out
# what sequence of steps would actually bring up this window! (is it another "secret window" ?)
    #view list to choose one item in the list
    method display_retrieves {} {
        global sn_options
        global tkeWinNumber

        #now we have found more than one match, if warning
        #is enabled, do it
        if {${warning} && $sn_options(donot_display) == 0} {
            warning_many_matches
        }

        #create new window
        incr tkeWinNumber
        set window ".sn-${window_prefix}-${tkeWinNumber}"

        #build title
        build_title

        sn_create_window ${window}
        ${window} withdraw
        ${window} on_close "${this} window_deleted"

        #hold/close window after choosing an item
        button ${window}.exp.hold -takefocus 0 -text [get_indep String\
          HoldWindow] -image hold_off_image -command "  "
        ::bind ${window}.exp.hold <Any-ButtonPress> "if {%b == 1}\
          {${this} toggle_hold ${window}.exp.hold}"
        balloon_bind_info ${window}.exp.hold [get_indep String HoldWindowINFO]
        upvar #0 ${this}-hold hold
        set hold ${hold_window}
        frame ${window}.exp.space -width 3
        pack ${window}.exp.hold -side left
        pack ${window}.exp.space -side left

        #print should be possible too
        sn_window_append_print ${window} "${window}.list print_dialog_box"

        #shows some icons
        sn_window_add_icons ${window} [list ctree xref class]
        ${window}.exp.tree configure -state normal \
		-command "Retriever&::goto_class ${window} ctree"
        ${window}.exp.class config -state normal \
		-command "Retriever&::goto_class ${window} class"
        ${window}.exp.cross configure -state normal \
		-command "Retriever&::retr_cross_ref ${window}.list"

        set height [llength ${contents}]
        if {${height} == "" || ${height} <= 0} {
            set height 1
        }
        if {${height} > 20} {
            set height 20
        }

        set cols 4

        #now we use the new widget "treetable"
        #darkgray = "#aaaaaa"
        Tree ${window}.list -fillselection 1 -selectmode browse\
          -exportselection 0 -font $sn_options(def,default-font) -bestfit 1\
          -truncate 1 -tabsize ${cols} -tabs {80 80 80 120 200} -labels [list\
          "[get_indep String Name]" "[get_indep String Class]"\
          "[get_indep String Type]" "[get_indep String Parameters]"\
          "[get_indep String File]"] -indentwidth 20 -filterextension "\t*\t*"\
          -width ${retrieve_width} -height ${height}\
          -fillcommand "display_contents" -propagate 1
        #	-hiddenimage type_cl+_image

# FIXME: all this binding code needs to be cleaned up, can't we provide some
# generic binding routines instead of cutting and pasting the code everywhere!
        ${window}.list treebind <ButtonRelease-1> "Retriever&::expand_classes\
          ${window} %x %y"
        ${window}.list treebind <space> [::bind ${window}.list <ButtonRelease-1>]
        ${window}.list treebind <Return> "Retriever&::handle_return ${this} %W;\
          break"
        ${window}.list treebind <space> "[${window}.list treebind <Return>]; break"
        ${window}.list treebind <Double-1> "Retriever&::handle_doubleclick\
          ${this} %W; break"

        pack ${window}.list -side top -fill both -expand y

        #if variable is set, we use a dialog style window
        if {${variable} != ""} {
            bind ${window}.list.tree <Destroy> "${this} change_variable"
            catch {${window} grab set}
        }

        #$window.list config  -width $width  -height $height

        #set found symbols to the tree class
        ${window}.list setcontents ${contents}

        #display the found contents width -data option
        display_contents_x ${window}.list ${contents} -1 "don't resize"

        #contents is then not more needed
        catch {unset contents}

        ${window} configure -title [list ${title}]
        ${window} configure -iconname "${icon_prefix} ${icon}"

        #after idle "focus [$window.list tree]; $window move_to_mouse"
        after idle "focus [${window}.list tree]; ${window} move_to_mouse"

        #call user client function
        catch {sn_rc_retrieve ${window} ${window}.menu ${window}.list}
    }

    proc goto_class {w tree_or_class} {
        set cls [${w}.list.tree curselection]
        if {${cls} != ""} {
            set cols [split [${w}.list.tree get [lindex ${cls} 0]] \t]
            set cls [lindex ${cols} 0]
            get_key_and_scope ${cls} cls scope
            if {${scope} != "cl" && ${scope} != "un"} {
                set cls [lindex ${cols} 1]
            }
        }
        if {${tree_or_class} == "class"} {
            sn_classbrowser ${cls}
        } else {
            sn_classtree ${cls}
        }
    }

    #Convert a tree entry into the following format:
    #symbol class type param file from to
    proc convert_to_line {w} {
        set sel [lindex [${w} curselection] 0]
        if {${sel} == ""} {
            return ""
        }
        set txt [split [${w} get ${sel}] \t]
        set data [split [${w} itemcget ${sel} -data] \t]
        set file [lindex ${data} 0]
        set from [lindex ${data} 1]
        set to [lindex ${data} 2]
        return "[lindex ${txt} 0]\t[lindex ${txt} 1]\t[lindex ${txt}\
          2]\t[lindex ${txt} 3]\t${file}\t${from}\t${to}"
    }

    proc expand_classes {cls x y {dspproc "display_contents_x"}} {
        global sn_options sn_sep
        set tree ${cls}.list.tree
        #no items
        if {[${tree} size] <= 0} {
            return ""
        }
        #verify if the icon of a sub tree is clicked
        set ret [${tree} identify ${x} ${y}]
        set idx [${tree} nearest ${y}]

        if {${ret} == "view" || ${ret} == "hide"} {
            ${tree} toggle @${x},${y}
            set img [${tree} itemcget ${idx} -image]
            if {[string first "file" ${img}] == 0} {
                if {${ret} == "view"} {
                    set img file_+_image
                } else {
                    set img file_-_image
                }
            } else {
                if {${ret} == "view"} {
                    set img type_cl+_image
                } else {
                    set img type_cl-_image
                }
            }
            ${tree} itemconfig ${idx} -image ${img}
            return ""
        }
        if {${ret} == "text"} {
            return "text"
        }
        set txt [lindex [${tree} get ${idx}] 0]
        get_key_and_scope ${txt} key scope

        #expand classes and files
        if {${scope} == "cl"} {
            set dat [split [${tree} itemcget ${idx} -data] \t]
            set file [lindex ${dat} 0]
            set from [string trimleft [lindex [split [lindex ${dat} 1] {.}] 0]\
              0]
            set to [string trimleft [lindex [split [lindex ${dat} 2] {.}] 0] 0]

            foreach w [list md mi iv fr] {
                if {[::info commands paf_db_${w}] == ""} {
                    continue
                }
                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 \"-${from}:${to}\""]
                set res [paf_db_${w} seq -end ${file} -col ${col}\
                  "${key}${sn_sep}"]
                if {${res} != ""} {
                    lappend cnt ${res}
                }
            }
            if {![info exists cnt]} {
                set cnt ""
            }
            ${dspproc} ${cls}.list [::lsort -command sn_compare\
              [::join ${cnt}]] ${idx}
            set num [${tree} itemcget ${idx} -children]
            if {${num} > 0} {
                ${tree} itemconfig ${idx} -image type_cl-_image
            }
        }\