misc.tcl

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

    global sn_arguments
    if {[info exists sn_arguments(nosplash)] && $sn_arguments(nosplash)} {
        return 1
    }
    return 0
}

#opens a project or displays the project list to select a project.
proc sn_process_gui {} {
    global sn_options
    global sn_arguments
    global ProcessingCancelled

    sn_log "sn_process_gui: [array names sn_arguments]"

    #create a new project, imports filenames from a file
    if {[info exists sn_arguments(new)] && $sn_arguments(new)} {
        set ret [sn_new_project_cb]
        #don't exit when user cancels project creation,
        #just popup the project selector (when batchmode is disabled)
        if {! ${ret} && [sn_batch_mode]} {
            return ${ret}
        }
    }\
    elseif {[info exists sn_arguments(projectfile)]} {
        #open a project
        switch -- [sn_read_project $sn_arguments(projectfile)] {
            "0" {
                    #Error.
                    db_close_files

                    #don't exit!
                    set ProcessingCancelled 1
                }
            "-1" {
                    # I'm already using the project!
                }
            default {
                    #project open success
                    if {[sn_batch_mode]} {
                        #exit
                        return 0
                    } else {
                        #proceed
                        return 1
                    }
                }
        }
    }

    if {${ProcessingCancelled}} {
        return 0
    }

    #batchmode? Exit
    if {[sn_batch_mode]} {
        sn_log -stderr "batch mode can be only enabled by creating new projects"
        return 0
    }

    #ok, no open/create project, we popup the project list dialog.
    #select a project, only when no other projects are started
    if {[info commands paf_db_proj] == "" && [number_interp] == 1} {
        return [sn_select_project]
    }

    if {${ProcessingCancelled}} {
        return 0
    }

    return 1
}

proc sn_load_xref {xfer_file cbrowser_xref} {
    global sn_options
    global sn_path ProcessingCancelled
    global SN_cross_pid
    global xref_cancelled

    if {${ProcessingCancelled} || ${xfer_file} == "" || ![file exists\
      ${xfer_file}]} {
        return
    }

    if {[file size ${xfer_file}] == 0} {
        file delete -- ${xfer_file}
        return
    }

    catch {paf_db_to close}
    catch {paf_db_by close}

    # Generate xref.
    #
    # The output of the cbrowser executable needs to
    # be processed again by cbrowser2 before piping
    # it to dbimp. If no C/C++ files have been
    # parsed then just pass the file name containing
    # xref output to dbimp.

    set cbr2_cmd [list [file join $sn_path(bindir) cbrowser2]]
    
    if {[string first "-l" $sn_options(sys,parser_switches)] != -1} {
        lappend cbr2_cmd -l
    }

    if {[info exists sn_options(macrofiles)] && $sn_options(macrofiles) != ""} {
        foreach mf $sn_options(macrofiles) {
            lappend cbr2_cmd -m ${mf}
        }
    }

    lappend cbr2_cmd -n $sn_options(db_files_prefix)
    lappend cbr2_cmd -c $sn_options(def,db_cachesize) \
        -C $sn_options(def,xref-db-cachesize)
    lappend cbr2_cmd ${xfer_file}

    set dbimp_cmd [list [file join $sn_path(bindir) dbimp] \
        -H [info hostname] \
        -P [pid] -c $sn_options(def,db_cachesize) \
        -C $sn_options(def,xref-db-cachesize)]

    if {$cbrowser_xref} {
        lappend dbimp_cmd $sn_options(db_files_prefix)
        set cmd [concat $cbr2_cmd | $dbimp_cmd]
    } else {
        lappend dbimp_cmd -f ${xfer_file}
        lappend dbimp_cmd $sn_options(db_files_prefix)
        set cmd $dbimp_cmd
    }

    sn_log "cross-ref command: ${cmd}"

    if {[catch {set fd [open "| ${cmd}" r]} err]} {
        sn_error_dialog ${err}
        return
    }

    set SN_cross_pid ${fd}
    set xref_cancelled 0
    fconfigure ${fd} \
        -encoding utf-8 \
        -blocking 0
    fileevent ${fd} readable [list load_xref_pipe ${fd} ${xfer_file}]
}

#this procedure is called, when xref process finished 
proc load_xref_pipe {xreffd xfer_file} {
    global sn_options
    global SN_cross_pid sn_debug
    global xref_cancelled
    global xref_termometer

    #xref terminated
    if {${xref_cancelled} || [eof ${xreffd}]} {
        sn_log "cross-ref file \"${xfer_file}\" has been loaded"

        # It has to be called before sn_db_open_files!
        catch {unset SN_cross_pid}

# FIXME : Tcl fails to raise an error
# during a call to the close command
# when the program on the other end
# of a non-blocking pipe crashes.
# We work around this by putting the
# pipe back in blocking mode.
        fconfigure ${xreffd} -blocking 1

        set err ""
        set status [catch {close ${xreffd}} err]
        sn_log "xref pipe close-exit status: ${status}, ${err}"

        if {$status &&
                ([string match "*child killed*" $err] ||
                 [string match "*abnormal program termination*" $err] ||
                 [string match "*child process exited abnormally*" $err])} {
            set crashed 1
        } else {
            set crashed 0
        }

        # If dbimp or a second stage parser crashed, then
        # display an error. If a warning was generated
        # on stderr, just log it and continue. Don't
        # report an error if the user canceled.

        if {(($status && $sn_debug) || ${crashed}) && !${xref_cancelled}} {
            set errstring "Error: ${err}"
            if {[info exists xref_termometer(lastfile)] &&\
              $xref_termometer(lastfile) != ""} {
                set filestring "During xref-generation for:\
                  $xref_termometer(lastfile)\n"
            } else {
                set filestring ""
            }
            sn_error_dialog "${errstring}\n${filestring}\n[get_indep String\
              XRefHasBeenCrashed]"
        }

        #make sure we stay in project directory (different interpeters).
        catch {cd $sn_options(sys,project-dir)}

        #delete the lock file, so that the project isn't
        #reparsed by next load
        if {${status} || ${xref_cancelled}} {
            catch {[file delete -- $sn_options(db_files_prefix).lck]}
        }

        if {!${sn_debug}} {
            file delete -- ${xfer_file}
        }

        db_close_files 0

        #if xref has been cancelled, delete the related files
        if {${xref_cancelled}} {
            catch {file delete -- $sn_options(db_files_prefix).to}
            catch {file delete -- $sn_options(db_files_prefix).by}
            catch {file delete -- $sn_options(db_files_prefix).xfi}
        }

        #don't exist if xref db crashed, tell only the message
        set ret [sn_db_open_files 1 0]

        #delete termometers from views
        xref_delete_termometers

        #refresh windows after cross-ref end
        SN_Refresh_XRef_Windows

        if {${ret} != 1} {
            update idletasks
            return
        }

        if {$sn_options(def,xref-bell)} {
            bell
        }
    } else {
        set line [gets ${xreffd}]

        sn_log "Cross-ref PIPE: ${line}"

        #actualize termometer

        set scanning "Status: Scanning: "
        if {[string first $scanning ${line}] == 0} {
            set file [string range $line [string length $scanning] end]
            xref_termometer_disp $file 0
        }

        set deleting "Status: Deleting: "
        if {[string first $deleting ${line}] == 0} {
            set file [string range $line [string length $deleting] end]
            xref_termometer_disp $file 1
        }
    }

    update idletasks
}

#read the project list and resort it, so that a list
#of existing projects is built
proc sn_update_project_hotlist {} {
    global sn_options
    global sn_projects_list

    set exist_projs [sn_read_exist_projects]
    set proj_name $sn_options(sys,project-file)

    set off [lsearch -exact ${exist_projs} ${proj_name}]

    switch -exact -- ${off} {
        0 {
                return
            }
        -1 {
                set exist_projs [linsert ${exist_projs} 0 ${proj_name}]
            }
        default {
                set exist_projs [lreplace ${exist_projs} ${off} ${off}]
                set exist_projs [linsert ${exist_projs} 0 ${proj_name}]
            }
    }

    # Write it back!
    set pf $sn_projects_list(filename)

    if {[catch {set hlstfd [open ${pf} w+]} err]} {
        sn_error_dialog ${err}
        return 0
    } else {
        fconfigure ${hlstfd} \
            -encoding $sn_options(def,system-encoding) \
            -blocking 0
        puts ${hlstfd} [join ${exist_projs} "\n"]
        close ${hlstfd}
    }
}

proc sn_exit {} {
    if {[sn_quit]} {
        catch {destroy .}
        exit 0
    }
}

proc sn_quit {{exit ""}} {
    global sn_options
    global sn_emacs_socket

    #no project is availiable (while creating a new project)
    #so don't try to save the project
    if {[info commands paf_db_proj] == ""} {
        return 1
    }

    #verify if xref is running in the background
    if {${exit} == "" && [sn_processes_running]} {
        set answer [tk_dialog auto [sn_title [get_indep String Exit]]\
          "[get_indep String XRefIsRunning], [get_indep String ProjExit]"\
          question_image 0 [get_indep String Yes] [get_indep String No]]
        if {${answer} != 0} {
            return 0
        }
    }

    #verify if all windows can be closed.
    if {! [MultiWindow&::CloseAll]} {
        return 0
    }

    catch {close ${sn_emacs_socket}}
    sn_save_project
    sn_stop_process

    # Cancel the timer events!
    set ids [after info]
    if {${ids} != ""} {
        foreach id ${ids} {
            after cancel ${id}
        }
    }

    # Delete all opened windows
    foreach obj [itcl::find objects] {
        if {[winfo exists ${obj}]} {
            itcl::delete object ${obj}
        }
    }

    # Close the database after deleting all
    # the object otherwise objects can't save
    # settings to the db.  (Make class for one).
    db_close_files

    return 1
}

proc sn_copy_with_relative_paths {rel_dir files} {
    set dirs [list]
    set proj_len [string length ${rel_dir}]
    foreach d ${files} {
        set d [string trim ${d}]
        if {${rel_dir} == [string range ${d} 0 [expr ${proj_len} - 1]]} {
            lappend dirs [string range ${d} [expr ${proj_len} + 1] end]
        } else {
            lappend dirs ${d}
        }
    }
    return ${dirs}
}

proc sn_build_project_filename {dir {name ""}} {
    if {${name} == ""} {
        set name [file tail ${dir}]
    }
    if {[file extension ${name}] == ".proj"} {
        set name ${name}
    } else {
        set name "${name}.proj"
    }
    return [file join ${dir} ${name}]
}

proc generate_pathes {files} {
    set pdirs ""
    set od ""
    foreach f ${files} {
        set d [file dirname ${f}]
        if {${d} != ${od}} {
            lappend pdirs ${d}
            set od ${d}
        }
    }
    return [lunique [lsort ${pdirs}]]
}

proc choose_project_dir_cb {cls dir} {
    ${cls} configure -value ${dir}
}

proc choose_project_dir {cls} {
    Editor&::DirDialog ${cls} -script "choose_project_dir_cb ${cls}"\
      -prefix choose_project_dir
}

#Add a new Entry for a directory
proc add_more_cb {dirfr} {
    global tkeWinNumber
    global sn_newargs

    incr tkeWinNumber
    set lblwidth 20
    set newdir ${dirfr}.dir-${tkeWinNumber}
    set sn_newargs(add,$tkeWinNumber) ""

    set obj ${newdir}
    if {[itcl::find object $obj] == $obj} {
        itcl::delete object $obj
    }
    LabelEntryButton& ${newdir} -text [get_indep String AddDirectory]\
      -labelwidth ${lblwidth} -directory 1 -anchor nw -width 40 \
      -variable sn_newargs(add,$tkeWinNumber) -native 1\
      -buttonballoon [get_indep String ChooseINFO]\
      -state $sn_newargs(have-import-file)