utilities.tcl

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

            if {${f} != ""} {
                return ${f}
            }
        }
        return ${nn}
    }

    #it can be the first file in the project
    if {[info commands paf_db_f] != ""} {
        set f [paf_db_f get -col 0 -first ${name}]
        if {${f} != ""} {
            return ${f}
        }
    }

    set test [sn_truncate_path $sn_options(sys,project-dir) ${name}]
    if {[string compare ${name} ${test}] != 0} {
        #filename is included in the project directory
        set name ${test}
    } else {
        #look for the file with full path
        if {[info commands paf_db_f] != ""} {
            set file [paf_db_f seq -col 0 -first -glob "*${name}"]
            if {${file} != ""} {
                return ${file}
            }
        }

        #look for any file that match this file, but can be with different\
          pathes
        if {${any} != "" && ! [file exists ${name}]} {
            set f [file join * [file tail ${name}]]
            if {[info commands paf_db_f] != ""} {
                set file [paf_db_f seq -col 0 -first -glob ${f}]
                if {${file} != ""} {
                    return ${file}
                }
            }
        }
    }

    #something like "./foo.c" ==> "foo.c"
    if {[string index ${name} 0] == "." && [file dirname ${name}] == "."} {
        set name [string range ${name} 2 end]
    }

    return ${name}
}

# This proc starts a UNIX command and collects the contents of stdout.
# The only feature is that the x i/o events will be processed.
# If busy is set, then the input events are destroyed.
proc sn_exec_x_events {cmd {busy 1}} {
    global sn_options
    global errorInfo errorCode SN_x_exec_errMsg env sn_debug
    global tcl_platform

    if {$tcl_platform(platform) != "windows"} {
        set home $env(HOME)
        if {[string compare ${home} "/"] != 0} {
            append home "/"
        }
        set home [file nativename ${home}]
        regsub -all "~/" ${cmd} ${home} cmd
    }
    set cmd [string trim ${cmd}]
    sn_log "exec_x_events: ${cmd}"

    if {[catch {set execfd [open "| ${cmd}"]} errmsg]} {
        set e_inf ${errorInfo}
        set e_code ${errorCode}
        return -code error -errorinfo ${e_inf} -errorcode ${e_code} ${errmsg}
    }

    fconfigure ${execfd} -encoding $sn_options(def,system-encoding) -blocking 0
    set id [lindex [pid ${execfd}] 0]
    global Exec_Running_${id}
    global Exec_Results_${id}

    upvar #0 Exec_Results_${id} results
    upvar #0 Exec_Running_${id} running
    set results ""
    set running 1

    set errorInfo ""
    fileevent ${execfd} readable "event_exec_x_events_proc  ${execfd}\
      Exec_Running_${id}  Exec_Results_${id}"

    vwait Exec_Running_${id}

    set res ${results}

    set ran ${running}
    catch {unset Exec_Results_${id} Exec_Running_${id}}

    if {[string compare ${ran} "NONE"] != 0 && [string compare ${ran} ""] !=\
      0} {
        if {${sn_debug} > 1} {
            sn_error_dialog ${SN_x_exec_errMsg}
        }
        return -code error -errorcode ${ran} ${SN_x_exec_errMsg}
    }

    return ${res}
}

proc event_exec_x_events_proc {xeventfd run res} {
    global errorCode SN_x_exec_errMsg
    upvar #0 ${run} running
    upvar #0 ${res} results

    if {[eof ${xeventfd}]} {
        if {[catch {close ${xeventfd}} SN_x_exec_errMsg]} {
            set running ${errorCode}
        } else {
            set running NONE
        }
    } else {
        lappend results [gets ${xeventfd}]
    }
    update idletasks
}

# This function returns the number of lines can be shown on a page
# of a text widget.
proc text_page_num_lines w {
    set opix [winfo reqheight ${w}]
    set npix [winfo height ${w}]

    if {${npix} > ${opix}} {
        set epix ${npix}
    } else {
        set epix ${opix}
    }
    incr epix -3
    set top [${w} index "@0,0"]
    set bot [${w} index "@0,${epix}"]
    if {${top} == ${bot}} {
        return [${w} cget -height]
    }
    return [expr int(${bot}) - int(${top})]
}

proc sn_search_file {file} {
    global sn_options
    global sn_path HOME

    foreach d [list $sn_options(sys,project-dir) $sn_options(profile_dir)\
      $sn_path(etcdir) $sn_options(both,db-directory)] {
        if {[file exists [file join ${d} ${file}]]} {
            sn_log "search file found: [file join ${d} ${file}]"
            return [file join ${d} ${file}]
        }
    }
    return ""
}

proc sn_print_ascii {file} {
    global sn_options

    # The contents of the file are plain ASCII, not
    # PostScript.  Turn them into a PostScript program, and then print.

    set outfname ${file}.ps
    set fontsize 11
    set font Courier
    set inch 72
    set pageheight [expr {11 * ${inch}}]
    set pagewidth [expr {8.5 * ${inch}}]
    set margin [expr {0.5 * ${inch}}]

    set outF [open ${outfname} w]
    fconfigure ${outF} -encoding $sn_options(def,system-encoding) -blocking 0

    # This piece of code writes a little header to the ASCII file
    # which will print the following ASCII text onto the printer.
    puts ${outF} "%!PS-Adobe-1.0"
    puts ${outF} "%%Creator: SN ASCII-to-PS converter"
    puts ${outF} "%%DocumentFonts: Courier"
    puts ${outF} "%%Pages: (atend)"
    puts ${outF} "/Courier findfont ${fontsize} scalefont setfont"
    puts ${outF} "/M{moveto}def"
    puts ${outF} "/S{show}def"
    set pages 1
    set y [expr {${pageheight}-${margin}-${fontsize}}]

    set G [open ${file} r]
    fconfigure ${fd} -encoding $sn_options(def,encoding) -blocking 0
    while {[gets ${G} str] != -1} {
        if {${y} < ${margin}} {
            puts ${outF} showpage
            incr pages
            set y [expr {${pageheight}-${margin}-${fontsize}}]
        }
        regsub -all {[()\\]} ${str} {\\&} str
        puts ${outF} "${margin} ${y} M (${str}) S"
        set y [expr {${y}-(${fontsize}+1)}]
    }
    close ${G}
    puts ${outF} showpage
    puts ${outF} "%%Pages: ${pages}"
    close ${outF}

    return ${outfname}
}

#print a given file
proc sn_print_file {cmd file {postscript "-nopostscript"}} {
    global tcl_platform

    sn_log "print file:${file}, cmd:${cmd}"

    if {$tcl_platform(platform) != "windows"} {
        if {${cmd} != ""} {
            #it's a pipe
            if {[string first "|" ${cmd}] > 0} {
                if {[catch {eval exec -- cat [list ${file}] | ${cmd}} err]} {
                    sn_error_dialog ${err}
                    return
                }
            } else {
                #pass the file to the command as an argument
                if {[catch {eval exec -- ${cmd} [list ${file}]} err]} {
                    sn_error_dialog ${err}
                    return
                }
            }
        }
    } else {
        if {${postscript} == "-nopostscript"} {
            #print's ASCII-files only
            sn_winprint_dialog ${file}
        } else {
            sn_winprint_dialog ${file} null postscript
        }
    }
}

#
# This function is used by sn_prompt_for_files.
proc sn_prompt_fileselector {ew {type ""}} {
    set file [string trim [${ew} get]]
    set dir [file dirname ${file}]

    if {${type} == "d"} {
        set file [Editor&::DirDialog [winfo toplevel ${ew}]\
          -initialdir ${dir}]
    } else {
        set file [Editor&::FileDialog [winfo toplevel ${ew}]\
          -initialdir ${dir}]
    }

    if {${file} != ""} {
        ${ew} delete 0 end
        ${ew} insert end ${file}
    }
}

# Parameters contains list with sublist.
# The first element of a sublist is a label the second
# is a suggested value.
# This function returns the contents of the entry boxes in a list.
proc sn_prompt_for_files {title pars} {
    set w [sourcenav::Window [sourcenav::Window::next_window_name]]

    ${w} configure -title ${title}

    sn_motif_buttons ${w} bottom 0 [get_indep String ok] [get_indep String\
      cancel]

    ${w}.button_0 configure -command " set ${w}-select_status ok "

    ${w}.button_1 configure -command " set ${w}-select_status cancel "

    pack [frame ${w}.browsers] -side left

    set width 7
    foreach p ${pars} {
        set l [lindex ${p} 0]
        if {[string length ${l}] > ${width}} {
            set width [expr [string length ${l}] * 2]
        }
    }
    set cou 0
    foreach p ${pars} {
        set l [lindex ${p} 0]
        set e [lindex ${p} 1]
        set b [lindex ${p} 2]

        set fr ${w}.entrys-${cou}
        pack [frame ${fr}] -side left -side top -fill x -expand y
        pack [label ${fr}.l -text ${l} -width ${width}] -anchor w -side left

        set ew [entry ${fr}.e -width 60]
        pack ${ew} -fill x -expand y -padx 10 -side left
        ${ew} insert end ${e}

        bind ${ew} <Return> "${w}.button_0 invoke; break"
        bind ${ew} <Escape> "${w}.button_1 invoke; break"

        if {${b} != "n"} {
            pack [button ${fr}.b -text [get_indep String Choose] -command\
              " sn_prompt_fileselector ${ew} ${b} "] -side left
        }
        incr cou
    }

    ${w} move_to_mouse
    ${w} take_focus ${w}.entrys-0.e

    catch {${w} resizable yes no}
    catch {${w} grab set}

    update idletasks
    set geom [split [lindex [split [${w} geometry] "+"] 0] "x"]
    ${w} minsize [lindex ${geom} 0] [lindex ${geom} 1]

    tkwait variable ${w}-select_status

    upvar #0 ${w}-select_status sel

    if {${sel} == "cancel"} {
        itcl::delete object ${w}
        return ""
    }

    set res ""
    set cou 0
    foreach p ${pars} {
        set ew ${w}.entrys-${cou}.e
        lappend res [string trim [${ew} get]]
        incr cou
    }
    itcl::delete object ${w}

    return ${res}
}

proc sn_get_class_inheritance_chain_intern {cls_name} {
    global sn_options sn_sep

    upvar #0 sn_get_class_inheritance_chain cls_arr

    set cls ${cls_name}

    if {[info commands paf_db_in] == ""} {
        return ${cls}
    }

    foreach sc [paf_db_in seq -uniq -col [list 1] "${cls_name}${sn_sep}"] {
        set c [lindex ${sc} 0]
        if {![info exists cls_arr(${c})]} {
            set cls_arr(${c}) 1
            eval lappend cls [sn_get_class_inheritance_chain_intern ${c}]
        }
    }
    return ${cls}
}

proc sn_get_class_inheritance_chain {cls_name} {
    global sn_get_class_inheritance_chain

    catch {unset sn_get_class_inheritance_chain}
    set classes [sn_get_class_inheritance_chain_intern ${cls_name}]
    catch {unset sn_get_class_inheritance_chain}

    return ${classes}
}

#functions to choose a file/directory
proc sn_choose_cb {entry variable txt} {
    set txt [file nativename ${txt}]
    if {${entry} != ""} {
        ${entry} delete 0 end
        ${entry} insert 0 ${txt}
    }
    if {${variable} != ""} {
        upvar #0 ${variable} var
        set var ${txt}
    }
    return 0
}

proc sn_choose_dir {entry {variable ""}} {
    Editor&::DirDialog ${entry} -title [get_indep String Open] -script\
      [list sn_choose_cb ${entry} ${variable}] -prefix sn_choose_dir
    return 0
}

proc sn_choose_file {entry {variable ""} {defext ""}} {
    Editor&::FileDialog ${entry} -title [get_indep String Open]\
      -script [list sn_choose_cb ${entry} ${variable}] -prefix sn_choose_file\
      -defaultextension ${defext}
    return 0
}