utilities.tcl

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

# Copyright (c) 2000, 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.
# 
# utilities.tcl - Globals/parameters and useful Tcl procs.
# Copyright (C) 1998 Cygnus Solutions.

# get_userid
# Returns the real uid of the user running the application. 0 is
# returned if it cannot be obtained for some reason.  (This is
# safe--we cannot and do not use uid 0 for anything other than
# generating content for lock files).

proc get_userid {} {
    global tcl_platform

    if {$tcl_platform(platform) != "unix"} {
        return 0
    }

    # This assumes that id(1) returns a string roughly of the form:
    # uid=501(bje) gid=100(cygnus) groups=100(cygnus)

    catch {exec id} output
    if {[regexp {[0-9]+} ${output} uid] != 1} {
        return 0
    } else {
        return ${uid}
    }
}

# get_username
# Returns the login name of the user running the application.  If the
# USERNAME environment variable isn't set on Windows, we just make do.

proc get_username {} {
    global env tcl_platform

    switch -- $tcl_platform(platform) {
        "windows" {
                if {[info exists $env(USERNAME)]} {
                    return $env(USERNAME)
                } else {
                    return unknown
                }
            }
        "unix" {
                if {[catch {exec logname} username]} {
                    return unknown
                } else {
                    return ${username}
                }
            }
        default {
                return unknown
            }
    }
}

# lunique
# This procedure returns a list which contains only unique elements.
# The input list must be sorted.

proc lunique {sortedlist} {
    set first 1
    set prev {}
    set uniqlist {}
    foreach elt ${sortedlist} {
        if {[string compare ${elt} ${prev}]} {
            lappend uniqlist ${elt}
        }\
        elseif {${first}} {
            # Starting condition.
            lappend uniqlist ${elt}
        }
        #first must be set after the first step, regardless,
        #if we have empty string at the beginning
        set first 0
        set prev ${elt}
    }
    return ${uniqlist}
}

# sn_file_format
# Tests a file on its newline type and returns:
#  auto      file not found
#  lf        file contains NL (UNIX)
#  crlf      file contains NL and CR (Win32)
#  cr        file contains CR only

proc sn_file_format {filename} {
    if {![file isfile ${filename}] || [catch {set f [open ${filename}]}]} {
        return auto
    }

    fconfigure ${f} -translation binary -blocking 0
# FIXME: if the file being tested is really large, this could really be slow!
    set buffer [read ${f}]
    close ${f}

    # Look for carriage return/linefeed patterns in the buffer.

    if {[string first \x0a\x0d ${buffer}] != -1 || [string first \x0d\x0a\
      ${buffer}] != -1} {
        return crlf
    }
    if {[string first \x0a ${buffer}] != -1} {
        return lf
    }
    if {[string first \x0d ${buffer}] != -1} {
        return cr
    }
    return auto
}

# A `grep' equivalent for Tcl.  Returns a list of all list elements matching
# the given regular expression.

proc sn_lgrep {pattern text} {
    set result ""
    foreach line ${text} {
        if {[regexp ${pattern} ${line} ignore match] > 0} {
            lappend result ${match}
        }
    }
    return ${result}
}

# A search-and-replace mechanism for replacing text in a list of strings.
# The `replacements' argument should be a list of search/replace pairs, where
# a pair is defined to be a list of two elements (ie. {{a b} {c d}} will
# replace all a's with b's and c's with d's.  The result is placed in the
# variable `newtext' and the procedure always returns 0.

proc sn_search_replace {replacements text newtext} {
    upvar ${newtext} newText
    set t ${text}

    foreach pair ${replacements} {
        set search [lindex ${pair} 0]
        set replace [lindex ${pair} 1]

        regsub -all ${search} ${t} ${replace} t
    }
    set newText ${t}
    return 0
}

# Save the contents of a specified text widget into a specified file
# The previous contents of the file is saved to a ".bak" file before being 
# overwritten.
#
proc sn_save_file {w file} {
    global sn_options
    global tcl_platform

    #try to save the file in it's original format, if user
    #wants to
    if {$sn_options(def,edit-file-translation) == "keep"} {
        set file_format [sn_file_format ${file}]
    } else {
        set file_format $sn_options(def,edit-file-translation)
    }
    sn_log "file OS-format: <${file_format}>"

    if {[file exists ${file}]} {
        if {$tcl_platform(platform) != "windows"} {
            set perm [file attributes ${file} -permission]
        }
        if {$sn_options(def,edit-create-bak) == 1} {
            # Rename the file!
            catch {file rename -force ${file} ${file}.bak}
        }
        set ideevent file-changed
    } else {
        set ideevent file-created
        set perm ""
    }

    if {[catch {set savefd [eval open [list ${file}] "w+"]} err]} {
        sn_error_dialog ${err}

        return 0
    }

    #set translation flag and encoding
    fconfigure ${savefd} -translation "auto ${file_format}"\
      -encoding $sn_options(def,encoding) \
      -blocking 0

    puts -nonewline ${savefd} [${w} get 1.0 end]
    close ${savefd}

    if {$tcl_platform(platform) != "windows" && ${perm} != ""} {
        catch {file attributes ${file} -permission ${perm}}
    }

    maybe_ide_event post ${ideevent} ${file}

    return 1
}

proc sn_load_pixmaps {} {
    global sn_options
    global sn_path
    global errorInfo errorCode

    set pixmap "pixmap"
    set xpm "xpm"

    sn_log -l 2 "PIXMAP: ${pixmap}, xpm: ${xpm}"
    set bitd $sn_path(bitmapdir)

    if {[catch {
        # FIXME: This is a terrible name for an arrow xpm!
        image create ${pixmap} add_image -file ${bitd}/add.${xpm}
        image create ${pixmap} addall_image -file ${bitd}/addall.${xpm}
        image create ${pixmap} arrow_image -file ${bitd}/arrow.${xpm}
        image create ${pixmap} browse_image -file ${bitd}/browse.${xpm}
        image create ${pixmap} classes_image -file ${bitd}/classes.${xpm}
        image create ${pixmap} compile_image -file ${bitd}/compile.${xpm}
        image create ${pixmap} copy_image -file ${bitd}/copy.${xpm}
        image create ${pixmap} crossref_image -file ${bitd}/crossref.${xpm}
        image create ${pixmap} cut_image -file ${bitd}/cut.${xpm}
        image create ${pixmap} del_image -file ${bitd}/del.${xpm}
        image create ${pixmap} delall_image -file ${bitd}/delall.${xpm}
        image create ${pixmap} down_image -file ${bitd}/down.${xpm}
        image create ${pixmap} files_image -file ${bitd}/files.${xpm}
        image create ${pixmap} find_image -file ${bitd}/find.${xpm}
        image create ${pixmap} find_image -file ${bitd}/find.${xpm}
        image create ${pixmap} function_image -file ${bitd}/function.${xpm}
        image create ${pixmap} go_image -file ${bitd}/go.${xpm}
        image create ${pixmap} grep_image -file ${bitd}/grep.${xpm}
        image create ${pixmap} include_image -file ${bitd}/include.${xpm}
        image create ${pixmap} left_image -file ${bitd}/left.${xpm}
        image create ${pixmap} method_image -file ${bitd}/method.${xpm}
        image create ${pixmap} new_image -file ${bitd}/new.${xpm}
        image create ${pixmap} next_image -file ${bitd}/next.${xpm}
        image create ${pixmap} open_image -file ${bitd}/open.${xpm}
        image create ${pixmap} paste_image -file ${bitd}/paste.${xpm}
        image create ${pixmap} print_image -file ${bitd}/print.${xpm}
        image create ${pixmap} rebuild_image -file ${bitd}/build.${xpm}
        image create ${pixmap} right_image -file ${bitd}/right.${xpm}
        image create ${pixmap} save_image -file ${bitd}/save.${xpm}
        image create ${pixmap} search_image -file ${bitd}/search.${xpm}
        image create ${pixmap} sign_image -file ${bitd}/sign.${xpm}
        image create ${pixmap} stree_image -file ${bitd}/stree.${xpm}
        image create ${pixmap} tree_image -file ${bitd}/tree.${xpm}
        image create ${pixmap} undo_image -file ${bitd}/undo.${xpm}
        image create ${pixmap} waste_image -file ${bitd}/waste.${xpm}
        image create ${pixmap} watch_image -file ${bitd}/watch.${xpm}

        image create ${pixmap} enabled_image -file ${bitd}/enabled.${xpm}
        image create ${pixmap} unvisited_image -file ${bitd}/unvisited.${xpm}
        image create ${pixmap} undefined_image -file ${bitd}/undef.${xpm}

        #browser images
        image create ${pixmap} cls_br__image -file ${bitd}/clsbr.${xpm}
        image create ${pixmap} cls_br_v_image -file ${bitd}/clsbr_v.${xpm}
        image create ${pixmap} cls_br_v+_image -file ${bitd}/clsbr_v+.${xpm}
        image create ${pixmap} cls_br_v+-_image -file ${bitd}/clsbr_v+-.${xpm}
        image create ${pixmap} cls_br_v-_image -file ${bitd}/clsbr_v-.${xpm}
        image create ${pixmap} cls_br_+_image -file ${bitd}/clsbr_+.${xpm}
        image create ${pixmap} cls_br_+-_image -file ${bitd}/clsbr_+-.${xpm}
        image create ${pixmap} cls_br_-_image -file ${bitd}/clsbr_-.${xpm}
        image create ${pixmap} cls_br_s_image -file ${bitd}/clsbr_s.${xpm}
        image create ${pixmap} cls_br_s+_image -file ${bitd}/clsbr_s+.${xpm}
        image create ${pixmap} cls_br_s-_image -file ${bitd}/clsbr_s-.${xpm}
        image create ${pixmap} cls_br_s+-_image -file ${bitd}/clsbr_s+-.${xpm}
        image create ${pixmap} cls_br_ps_image -file ${bitd}/clsbr_s.${xpm}
        image create ${pixmap} cls_br_p_image -file ${bitd}/clsbr_p.${xpm}
        image create ${pixmap} cls_br_pv_image -file ${bitd}/clsbr_pv.${xpm}
        image create ${pixmap} cls_br_pv+_image -file ${bitd}/clsbr_pv+.${xpm}
        image create ${pixmap} cls_br_pv+-_image -file ${bitd}/clsbr_pv+-.${xpm}
        image create ${pixmap} cls_br_pv-_image -file ${bitd}/clsbr_pv-.${xpm}
        image create ${pixmap} cls_br_p+_image -file ${bitd}/clsbr_p+.${xpm}
        image create ${pixmap} cls_br_p+-_image -file ${bitd}/clsbr_p+-.${xpm}
        image create ${pixmap} cls_br_p-_image -file ${bitd}/clsbr_p-.${xpm}
        image create ${pixmap} cls_br_private_image -file ${bitd}/clsbr_private.${xpm}

        #retriever images
        image create ${pixmap} type_cl_image -file ${bitd}/type_cl.${xpm}
        image create ${pixmap} type_cl+_image -file ${bitd}/type_cl+.${xpm}
        image create ${pixmap} type_cl-_image -file ${bitd}/type_cl-.${xpm}
        image create ${pixmap} type_com_image -file ${bitd}/type_com.${xpm}
        image create ${pixmap} type_con_image -file ${bitd}/type_con.${xpm}
        image create ${pixmap} type_cov_image -file ${bitd}/type_cov.${xpm}
        image create ${pixmap} type_ec_image -file ${bitd}/type_ec.${xpm}
        image create ${pixmap} type_e_image -file ${bitd}/type_e.${xpm}
        image create ${pixmap} type_fr_image -file ${bitd}/type_fr.${xpm}
        image create ${pixmap} type_fd_image -file ${bitd}/type_fd.${xpm}
        image create ${pixmap} type_fu_image -file ${bitd}/type_fu.${xpm}
        image create ${pixmap} type_gv_image -file ${bitd}/type_gv.${xpm}
        image create ${pixmap} type_iv_image -file ${bitd}/type_iv.${xpm}
        image create ${pixmap} type_lv_image -file ${bitd}/type_lv.${xpm}
        image create ${pixmap} type_ma_image -file ${bitd}/type_ma.${xpm}
        image create ${pixmap} type_mi_image -file ${bitd}/type_mi.${xpm}
        image create ${pixmap} type_md_image -file ${bitd}/type_md.${xpm}
        image create ${pixmap} type_su_image -file ${bitd}/type_su.${xpm}
        image create ${pixmap} type_t_image -file ${bitd}/type_t.${xpm}
        image create ${pixmap} type_un_image -file ${bitd}/type_un.${xpm}
        image create ${pixmap} type_ud_image -file ${bitd}/type_ud.${xpm}

        #cross reference images
        image create ${pixmap} cross_browse_to_image\
          -file ${bitd}/cross_to.${xpm}
        image create ${pixmap} cross_browse_by_image\
          -file ${bitd}/cross_by.${xpm}
        image create ${pixmap} cross_boxes_image -file ${bitd}/boxes.${xpm}
        image create ${pixmap} cross_param_image\
          -file ${bitd}/cross_param.${xpm}
        image create ${pixmap} cross_static_image\
          -file ${bitd}/cross_static.${xpm}
        image create ${pixmap} cross_disp_param_image\
          -file ${bitd}/cross_dispparam.${xpm}

        #image for retriever to store or close retriever window after selection
        image create ${pixmap} hold_image -file ${bitd}/hold.${xpm}
        image create ${pixmap} hold_on_image -file ${bitd}/hold_on.${xpm}
        image create ${pixmap} hold_off_image -file ${bitd}/hold_off.${xpm}

        image create ${pixmap} dir_image -file ${bitd}/dir.xpm
        image create ${pixmap} dir+_image -file ${bitd}/dir_+.xpm
        image create ${pixmap} dir-_image -file ${bitd}/dir_-.xpm
        image create ${pixmap} file_image -file ${bitd}/file.xpm
        image create ${pixmap} file_s_image -file ${bitd}/file_s.xpm
        image create ${pixmap} file_b_image -file ${bitd}/file_b.xpm
        image create ${pixmap} file_h_image -file ${bitd}/file_h.xpm
        image create ${pixmap} file_d_image -file ${bitd}/file_d.xpm
        image create ${pixmap} file_+_image -file ${bitd}/file_+.xpm
        image create ${pixmap} file_-_image -file ${bitd}/file_-.xpm
        image create ${pixmap} parent_image -file ${bitd}/parent.${xpm}
        image create ${pixmap} filter_image -file ${bitd}/filter.${xpm}

        image create ${pixmap} next2_image -file ${bitd}/next2.${xpm}
        image create ${pixmap} prev_image -file ${bitd}/prev.${xpm}

        # Company logo
        image create ${pixmap} company_image -file ${bitd}/shadowman.${xpm}

        #images for the new treetable
        image create ${pixmap} plus_image -file ${bitd}/plus.${xpm}
        image create ${pixmap} minus_image -file ${bitd}/minus.${xpm}
        image create ${pixmap} unknown_image -file ${bitd}/unknown.${xpm}

        #images for textual class hierarchy display
        image create ${pixmap} play_image -file ${bitd}/play.${xpm}
        image create ${pixmap} rplay_image -file ${bitd}/rplay.${xpm}

        #create image for the Tk/file dialog box
        global tkPriv
        set tkPriv(updirImage) [image create pixmap tkPriv(updirImage)\
          -file [file join ${bitd} updir.xpm]]
        set tkPriv(folderImage) dir_image
        set tkPriv(fileImage) file_image
    } errmsg]} {
        set e_inf ${errorInfo}
        set e_code ${errorCode}

        sn_log "${errorCode},${errorInfo}"

        return -code error -errorinfo ${e_inf} -errorcode ${e_code} ${errmsg}
    }
}

proc sn_get_symbol_and_scope {symm} {
    global sn_all_scopes

    regsub -all "\[ \t\]+" ${symm} { } sym

    # Check .e.g operator() !
    if {[string match {*()*} ${sym}]} {
        regsub -all {\(\)} ${sym} {%%} sym
    }

    if {![regsub -all {\(|\)} ${sym} { } sym]} {
        return ""
    }
    regsub -all {%%} ${sym} {()} sym

    if {[llength ${sym}] == 3} {
        set name "[lindex ${sym} 2] [lindex ${sym} 0]"
        set scope [lindex ${sym} 1]
    } else {