projmng.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.
# 
# projmng.tcl - Implement several operations on projects.
# Copyright (C) 1998 Cygnus Solutions.

# FIXME: these procs ought to become methods of a Project class.

# This function reads the name of the used and still existing
# project file names.
proc sn_read_exist_projects {{truncate 0}} {
    global sn_history
    global sn_projects_list
    global sn_options
    global tcl_platform

    if {![info exists sn_history(project_size)]} {
        set sn_history(project_size) 10
    }

    set pf $sn_projects_list(filename)

    if {[info exists sn_projects_list(mtime)] && $sn_projects_list(mtime) ==\
      [file mtime ${pf}]} {
        if {${truncate}} {
            return [lrange $sn_projects_list(names) 0 $sn_history(project_size)]
        }
        return $sn_projects_list(names)
    }

    #read projects from the project file
    if {[catch {set prjfd [open ${pf}]}]} {
        return ""
    }
    fconfigure ${prjfd} -encoding $sn_options(def,system-encoding) -blocking 0
    set projs [split [read -nonewline ${prjfd}] "\n"]
    close ${prjfd}

    set sn_projects_list(mtime) [file mtime ${pf}]

    set exist_projs ""
    catch {unset scaned}
    foreach pr ${projs} {
        if {[file isfile ${pr}] && [file readable ${pr}]} {
            #make sure that the project file hasn't been added to the list,
            #this could happen, when files are stored with different roots
            #on windows  "C:/foo" and "C:\foo"
            set f [file nativename ${pr}]

            if {$tcl_platform(platform) == "windows"} {
                set scanf [string tolower ${f}]
            } else {
                set scanf ${f}
            }
            if {[info exists scaned(${scanf})]} {
                continue
            }
            #append original file
            lappend exist_projs ${f}
            set scaned(${scanf}) 1
        }
    }
    catch {unset scaned}

    set sn_projects_list(names) ${exist_projs}

    # Truncate if neceassary!
    if {${truncate}} {
        set exist_projs [lrange ${exist_projs} 0 $sn_history(project_size)]
    }

    return ${exist_projs}
}


#delete a SN project, given by project name
proc sn_delete_project {prjname {ask ""}} {
    global sn_options

    if {${ask} != ""} {
        set answer [tk_dialog auto [get_indep String ProjectDelete]\
          "[get_indep String DeleteProjectQuestion] \"${prjname}\" ?"\
          question_image 0 [get_indep String Yes] [get_indep String No]]
        if {${answer} != 0} {
            return -1
        }
    }

    sn_log "delete project <${prjname}>"

    #open the project file
    set prj_error [catch {set prj_descr [dbopen prj_db ${prjname} RDONLY\
      [sn_db_perms] hash]}]

    #init some error/debug routines
    set delerr 0
    set err ""

    #change to the project directory
    if {! ${prj_error}} {
        set prjDir [file dirname ${prjname}]
        catch {cd ${prjDir}}

        #read database filename prefix
        set db_prefix [sn_project_database_prefix prj_db]

        sn_log "database prefix <${db_prefix}>"

        #read symbol database directory
        set wd [sn_project_database_dir prj_db]

        if {${wd} == "" || ${db_prefix} == "" || [file pathtype ${wd}] !=\
          "absolute"} {
            set wd ""
        }

        #check wether the database is locked
        set ret [sn_is_project_busy ${prjname} in user host port pid]
# FIXME: This would allow the delete of locked project files!
        set ret 0

        switch -- ${ret} {
            "othersystem" {
                    sn_error_dialog [format \
                        [get_indep String ProjAlreadyOpenedOtherSystem] \
                        ${user} ${prjname} ${host}]
                    set ret 1
            }
            "thisprocess" {
                    sn_error_dialog [format \
                        [get_indep String ProjAlreadyOpenedThisProcess] \
                        ${prjname}]
                    set ret 1
            }
            "thisuser" {
                    sn_error_dialog [format \
                        [get_indep String ProjAlreadyOpenedThisUser] \
                        ${prjname} ${pid}] 
                    set ret 1
            }
            "thissystem" {
	            sn_error_dialog [format \
                        [get_indep String ProjAlreadyOpenedThisSystem] \
                        ${user} ${prjname} ${pid}]
                    set ret 1
            }
            "error" {
                    # ignore error
            }
        }

        #project can't be deleted
        if {${ret}} {
            sn_log "project can't be deleted"
            return 0
        }

        #open db files
        set prj_db_error [catch {set prj_f_descr [dbopen prj_db_f\
          ${db_prefix}.f RDONLY [sn_db_perms] btree]}]
        if {!${prj_db_error}} {
            #delete highlighting files
            if {![catch {set fls [prj_db_f seq -col 3\
              -result {*[a-zA-Z0-9_]*}]}]} {
                sn_log "delete related files <${fls}>"
                catch {eval file delete -- ${fls}}
            } else {
                sn_log "no database files found"
            }

            #close filenames database
            ${prj_f_descr} close
        }

        #delete temporary files
        if {${wd} != ""} {
            set fls [glob -nocomplain [file join ${wd} *.html] [file join\
              ${wd} dbimp_*] [file join ${wd} tmp_*]]
            if {${fls} != ""} {
                sn_log "delete temporary files <${fls}>"
                catch {eval file delete -- ${fls}}
            }
        }

        #delete all project related files (database files)
        set del_fls [glob -nocomplain ${db_prefix}.*]
        if {${del_fls} != ""} {
            sn_log "delete project database files <${del_fls}>"
            set delerr [catch {eval file delete -- ${del_fls}} err]
        } else {
            sn_log "no project database files found!"
            set delerr 0
        }

        if {${wd} != ""} {
            sn_log "try to delete database directory (if empty) <${wd}>"
            catch {file delete -- ${wd}}
            # It might not be empty.
        }

        #close the project file
        ${prj_descr} close

        #change to the current project directory
        catch {cd $sn_options(sys,project-dir)}
    }

    sn_log "delete project file <${prjname}>"

    #delete the project file itself.
    set prjdelerr [catch {file delete -- ${prjname}} prjerr]

    if {${delerr}} {
        sn_error_dialog ${err}
    }\
    elseif {${prjdelerr}} {
        sn_error_dialog ${prjerr}
    }

    sn_log "project <${prjname}> deleted"

    return 1
}

proc sn_delete_project_cb {btns t} {
    set idx [${t} curselection]
    if {${idx} == ""} {
        return
    }
    set prj [${t} get ${idx}]
    if {${prj} == ""} {
        bell
        return
    }
    set ret [sn_delete_project ${prj} ask_to_delete]
    if {${ret} == -1} {
        return
    }
    if {${ret} == 0} {
        sn_error_dialog [get_indep String CannotDeleteProject]
        return
    }

    #delete entry from the list
    ${t} delete ${idx}

    ${btns}.open config -state disabled
    ${btns}.delete config -state disabled
}

proc sn_new_project {} {
    create_interp {
        wm withdraw .
	sn_start_new_session --create
    }
}

#starts the project selector in a new interpreter, the
#interpreter is deleted, when the user cancels selection
#the selector is only called, when no other interp. are
#started.
proc sn_projectmanager {} {
    global tkeWinNumber
    global proj_selector_status
    if {[number_interp] == 1} {
        #create an interpreter and return immediatly to proceed
        #with the existing interpreter
        create_interp {
				wm withdraw .
				if {[sn_select_project nowait] == 0} {
				        sn_log "deleting interp because sn_select_project \
					    returned 0, in sn_projectmanager"
					delete_interp
				}
	}
    }
}

#waits for xref to be built
proc sn_is_waiting_for_xref {} {
    global sn_wait_xref_flag

    if {! [sn_processes_running]} {
        set sn_wait_xref_flag "finished"
        return
    }
    update idletasks

    after 1000 sn_is_waiting_for_xref
}

#create a new project
proc sn_new_project_cb {{t ""}} {
    global sn_options