sninit.tcl

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

            "-i" {
                    #-import: import file
                    incr idx
                    set sn_arguments(import-file) [lindex ${argv} ${idx}]
                    if {[catch {set fd [open $sn_arguments(import-file)]}\
                      err]} {
                        if {[sn_batch_mode]} {
                            puts stderr ${err}
                        } else {
                            sn_error_dialog ${err}
                        }
                        exit 1
                    } else {
                        catch {close ${fd}}
                        set sn_arguments(new) 1
                    }
                }
            "--noxref" -
            "-x" {
                    set sn_options(both,xref-create) ""
                }
            "--nosplash" {
                    set sn_arguments(nosplash) 1
                }
            "--def" -
            "-D" -
            "--define" {
                    incr idx
                    set pair [lindex ${argv} ${idx}]
                    set i [string first "=" ${pair}]
                    if {${i} <= 0} {
                        puts stderr "invalid option format \"${pair}\", usage:\
                          option=value"
                        puts stderr "use \"--avail-options\" to see all avail.\
                          options."
                        exit 1
                    }
                    set var [string range ${pair} 0 [expr {${i} - 1}]]
                    set value [string range ${pair} [expr {${i} + 1}] end]
                    #sn_modify_option $var $value
                    #execute those later, especially afer the user profile
                    #is read to have more priority
                    lappend sn_arguments(--define) ${var} ${value}
                }
            "--avail-opt" -
            "-o" -
            "--avail-options" {
                    set sn_arguments(help) [sn_list_options]
                    break
                }
            "--help" -
            "-h" {
                    set sn_arguments(help) "valid parameters:
    -b, --batchmode:   create a new project using batch mode
    -p, --projectname: specifies the name for a new project
    -c, --create:      creates a new project
    -d, --databasedir: specifies the directory to store the project databases
                       default is (.snprj)
    -i, --import:      imports the project list from a file
    -x, --noxref:      disables creating cross-reference information
    -o, --avail-options: lists all availiable options that can be set using\
                      \"--define\"
    -D, --define option=value
                       Defines an option, see \"--avail-options\"
    --nosplash:        disables splash screen
    --debug:           enables debugging mode
    --home:            installation directory"

                    break
                }
            default {
                    set sn_arguments(projectfile) ${arg}
                }
        }
    }
    return 1
}

proc sn_make_font {{family ""} {type ""} {size 0} {slant "R"}} {
    global sn_options
    global tcl_platform

    if {${family} == ""} {
        set family Helvetica
    }
    if {${type} == ""} {
        set type Medium
    }
    if {${size} == 0} {
        set size [expr $sn_options(def,desktop-font-size) * 10]
    } else {
        append size 0
    }

    if {$tcl_platform(platform) == "windows"} {
        switch -glob -- ${family} {
            "*ourier*" {
                    set family {Courier New}
                    # if we're using very small font sizes, choose a more
                    # readable option
                    if {${size} <= 80} {
                        set family {Lucida Console}
                    }
                }
            "*elvetica*" {
                    set family {Times New Roman}
                }
        }
    }

    if {$tcl_platform(platform) == "windows"} {
        set cls "-*"
    } else {
        if {[string tolower ${slant}] == "i"} {
            set slant "o"
        }
        set cls "-${family}"
    }
    set font [format "%s-%s-%s-%s-Normal--*-%s%s" ${cls} ${family} ${type}\
      ${slant} ${size} "-*-*-*-*-iso8859-1"]

    if {$tcl_platform(platform) == "windows"} {
        # set up a mapping for this font, so that when we print we
        # are able to switch to Courier or Helvetica.
        global print_fontmap
        if {${family} == "Courier New" || ${family} == "Lucida Console"} {
            set fontname Courier
        } else {
            set fontname Helvetica
        }
        set tfont ${font}
        # We map the X fonts into a slightly smaller Windows font to
        # ensure text fits into boxes during printing.
        set size [expr ${size}/10 - 1]
        set print_fontmap(${tfont}) [list ${fontname} ${size}]
        set tfont [join [lreplace [split ${tfont} "-"] 4 4 o] "-"]
        set print_fontmap(${tfont}) [list "${fontname}-Oblique" ${size}]
        set tfont [join [lreplace [split ${tfont} "-"] 3 3 bold] "-"]
        set print_fontmap(${tfont}) [list "${fontname}-BoldOblique" ${size}]
        set tfont [join [lreplace [split ${tfont} "-"] 4 4 r] "-"]
        set print_fontmap(${tfont}) [list "${fontname}" ${size}]
    }

    sn_log -l 2 "Font: ${font}"

    return ${font}
}

proc sn_load_rc_file {file} {
    global sn_options
    global sn_debug HOME sn_path

    foreach file [list [file join $sn_options(profile_dir) ${file}] [file join\
      $sn_path(etcdir) ${file}]] {
        if {[file exists ${file}]} {
            sn_log "Executing... ${file}"
            catch {uplevel #0 source [list ${file}]} err
            sn_log "Result Executing ${file}:\n${err}"
            break
        }
    }

    #call as first user command 'sn_rc'
    catch {sn_rc}
}

#the following defines how a variable can be set
#cat:     categorie (def, both, sys or <empty>)
#var:     variable name
#value:   initialization
#type:    to be tested for valid values (string, integer, logical).
#trigger: user defined command to be executed when the option changes.
proc sn_add_option {cat var {value ""} {type "string"} {trigger ""} {valid ""}\
  {compatible ""} {readonly "no"}} {
    global sn_options
    global sn_user_options
    global sn_user_variables
    global sn_compatible

    if {${type} == ""} {
        set type "string"
    }

    #add categorie to variable name
    if {${cat} != ""} {
        set intvar ${cat},${var}
    } else {
        set intvar ${var}
    }
    if {${trigger} == ""} {
        if {${type} == "string"} {
            set trigger "sn_notempty_trigger"
        }
    }
    if {${valid} == "" && ${type} == "logical"} {
        set valid {yes no y n 1 0}
    }

    #compatible parameter names
    if {${compatible} != ""} {
        foreach c ${compatible} {
            set sn_compatible(${c}) ${var}
        }
    }

    set sn_options(${intvar}) ${value}

    set sn_user_variables(${var}) yes
    set sn_user_options(${var},name) ${intvar}
    set sn_user_options(${var},type) ${type}
    set sn_user_options(${var},value) ${value}
    set sn_user_options(${var},trigger) ${trigger}
    set sn_user_options(${var},valid) ${valid}
    set sn_user_options(${var},readonly) ${readonly}
}

#lists all exported options with information
#about its possible values.
proc sn_list_options {} {
    global sn_user_options
    global sn_user_variables
    global tcl_platform

    set txt_opts "Settable Parameters:
    use command line option \"--define or -D\" or add the options in your
    profile (~/.sn/profile, format variable:value) to modify the default
    settings.
    Interactive (in your ~/.sn/rc.tcl file) you can use tcl command
    \"sn_modify_option\" to change this values.
    Example: sn_modify_option gdb-command \"xterm -e gdb\"
    If you want to read the current option values, use \"sn_read_option\",
    Example: set prj \[sn_read_option project-file\]
    For more information please refer to the documentation and the README\
      file.\n"
    foreach n [lsort -dictionary [array names sn_user_variables]] {
        set txt "${n},\t"
        append txt "type=" $sn_user_options(${n},type)
        if {$sn_user_options(${n},readonly)} {
            append txt ",\tREADONLY"
        }\
        elseif {$sn_user_options(${n},value) != ""} {
            append txt ",\t" "default=" "\"$sn_user_options(${n},value)\""
        }
        if {$sn_user_options(${n},valid) != ""} {
            append txt ",\tvalid values=" "\{$sn_user_options(${n},valid)\}"
        }
        append txt_opts ${txt} "\n"
    }
    return ${txt_opts}
}

#called when the user specify option changes in the profile or
#on the command line
proc sn_modify_option {var value} {
    global sn_options
    global sn_user_options
    global sn_user_specified
    global sn_compatible

    sn_log "modify option \"${var}\" into \"${value}\""

    #if a compatible parameter has been used here, trigger it
    #to the new variable name
    if {[info exists sn_compatible(${var})]} {
        return [sn_modify_option $sn_compatible(${var}) ${value}]
    }

    if {![info exists sn_user_options(${var},name)]} {
        sn_log -stderr "invalid option: \"${var}=${value}\""
        return 0
    }

    if {$sn_user_options(${var},readonly)} {
        sn_readonly_trigger ${var} ${value}
        return 0
    }

    #internal name of the variable, like "def,foo"
    set intvar $sn_user_options(${var},name)
    set valid $sn_user_options(${var},valid)

    #verify valid data
    if {${valid} != ""} {
        if {[lsearch -exact ${valid} ${value}] == -1} {
            sn_log -stderr "specified invalid value ${value} for ${var}, valid\
              values <${valid}>."
            return 0
        }
        #checkbuttons support strings, so we need to use
        #only (0 1) for logical values
        if {${valid} == {yes no y n 1 0}} {
            if {${value}} {
                set value 1
            } else {
                set value 0
            }
        }
    }
    #verify data types
    if {$sn_user_options(${var},trigger) == ""} {
        if {$sn_user_options(${var},type) == "integer"} {
            if {[catch {set foo [expr {${value} + 0}]}]} {
                sn_log -stderr "specified an invalid value for \"${var}\""
                return 0
            }
        }
    } else {
        #execute trigger
        set ok [eval $sn_user_options(${var},trigger) [list ${var}]\
          [list ${value}]]
        if {${ok}} {
            #don't overwrite user settings
            set sn_user_specified(${intvar}) yes
        }
        return ${ok}
    }

    #correct value specified.
    set sn_options(${intvar}) ${value}

    #don't overwrite user settings
    set sn_user_specified(${intvar}) yes

    return 1
}

#get the value of an exported variable
proc sn_read_option {var} {
    global sn_options
    global sn_user_options
    global sn_user_variables
    if {![info exists sn_user_variables(${var})]} {
        sn_log -stderr "read option: option \"${var}\" unknown"
        return ""
    }
    return $sn_options($sn_user_options(${var},name))
}

#default procedure to be called when an exported
#option is requested to change. Forces values to be not empty.
proc sn_notempty_trigger {var value} {
    global sn_options
    global sn_user_options
    if {${value} == ""} {
        sn_log -stderr "option variable \"${var}\" can't be empty, option not\
          modified."
        return 0
    }

    set sn_options($sn_user_options(${var},name)) ${value}
    sn_log "option variable \"${var}\" changed to \"${value}\""

    return 1
}

#default can-empty trigger
proc sn_empty_trigger {var value} {
    global sn_options
    global sn_user_options
    set sn_options($sn_user_options(${var},name)) ${value}
    return 1
}

proc sn_readonly_trigger {var value} {
    sn_log -stderr "option \"${var}\" is readonly and can't be changed.
use \[sn_read_option ${var}\] to read it's current value."

    return 0
}

proc sn_xref_option_trigger {var value} {
    global sn_options
    global sn_user_options
    global sn_user_specified

    if {${value}} {
        set sn_options(both,xref-create) "-x"
    } else {
        set sn_options(both,xref-create) ""
    }
    #don't overwrite the user settings
    set sn_user_specified(both,xref-create) yes
    return 1
}