global.tcl

Tornado 2.0.2 source code!vxworks的源代码

# tempDirGet - returns the temporary directory.
#
# This routine returns the temporary directory set by the environment
# variable TMP.  
#
# SYNOPSIS:
# tempDirGet
# 
# PARAMETERS: N/A
#
# RETURNS: the temporary directory.
#
# ERRORS: 
# "Temp dir not set"
#

proc tempDirGet {} {
    global env

    if {[info exists env(TMP)]} {
        return $env(TMP)
    } else {
        error "Temp dir not set" 
    }
}

##############################################################################
#
# exitMsgSet - sets the exit message.
#
# Sets the global variable exitMessage to the specified exit message.
# 
# SYNOPSIS:
# currentIndexSet msg
#
# PARAMETERS:
# <msg>
# The exit message.
#
# RETURNS: N/A
#
# ERRORS: N/A
#

proc exitMsgSet {msg} {
    global exitMessage

    set exitMessage $msg
}

##############################################################################
#
# exitMsgGet - returns the exit message.  
#
# This routine returns the exit message.  If it does not exist, it returns
# the message "Installation complete."
#
# SYNOPSIS:
# exitMsgGet
# 
# PARAMETERS: N/A
#
# RETURNS: the exit message if it exists, else "Installation complete."
#
# ERRORS: N/A
#

proc exitMsgGet {} {
    global exitMessage

    if {![info exists exitMessage]} {
        set exitMessage "Installation complete."
    }

    return $exitMessage
}

##############################################################################
#
# defGroupSet - sets the default group.
#
# Sets the global variable defGroup to the specified default group. 
#
# SYNOPSIS:
# defGroupSet group
#
# PARAMETERS:
# <group>
# The default group.
#
# RETURNS: N/A
#
# ERRORS: N/A
#

proc defGroupSet {group} {
    global defGroup

    if {[portMapperIconExist $group] == 1} {
        set defGroup "Tornado2"
    } else {
        set defGroup $group
    }
}

##############################################################################
#
# defGroupGet - returns the default group.
#
# This routine returns the default group.  If it does not exist an empty
# string is returned.
#
# SYNOPSIS:
# defGroupGet
#
# PARAMETERS: N/A
#
# RETURNS: the default group if it exists, else an empty string.
#
# ERRORS: N/A
#

proc defGroupGet {} {
    global defGroup

    if ![info exists defGroup] {
        set defGroup ""
    }

    return $defGroup
}

##############################################################################
#
# setupSizeGet - returns the size of setup directory
#
# This routine returns the size of setup directory
#
# SYNOPSIS:
# setupSizeGet
#
# PARAMETERS: N/A
#
# RETURNS:  the size of setup directory
#
# ERRORS: N/A
#

proc setupSizeGet {} {

    switch [windHostTypeGet] {
        x86-win32 {
            return 6.3
        }
        sun4-solaris2 {
            return 7.2
        }
        parisc-hpux10 {
            return 11.3
        }
        default {
            return 6.3
        }
    }
}

##############################################################################
#
# instTypeSet - sets the installation type.
#
# Sets the global variable instType to the installation type (for example,
# "icon" for an icon-only installation).
#
# SYNOPSIS:
# instTypeSet type
#
# PARAMETERS:
# <type>
# The installation type.
#
# RETURNS: N/A
#
# ERRORS: N/A
#

proc instTypeSet {type} {
    global instType

    set instType $type
}

##############################################################################
#
# instTypeGet - returns the installation type.
#
# This routine returns the installation type (for example, "icon" for 
# an icon-only installation).  If the installation type has not been
# set, an empty string is returned.
#
# SYNOPSIS:
# userNameGet
#
# PARAMETERS: N/A
#
# RETURNS: the installation type if it exists, else an empty string.
#
# ERRORS: N/A
#

proc instTypeGet {} {
    global instType

    if ![info exists instType] {
        set instType ""
    }

    return $instType
}

##############################################################################
#
# checkPathLen - checks the path length and trims the path if necessary.
#                
# This routine checks the length of a given path.  If the length is
# over 50 characters, part of the path is replaced with "..."  This
# allows a long path to fit in a dialog window.
#
# SYNOPSIS:
# checkPathLen path
#
# PARAMETERS: 
# <path>
# A directory path.
#
# RETURNS: The original path partially replaced with "..." if over
#          50 characters.  
#
# ERRORS: N/A
#

proc checkPathLen {path} {

    if {[string length $path] >= 50} {
        set totLen [string length $path]
        set lastIndex [string last "/" $path]
        if {$lastIndex > [string last "\\" $path]} {
            # Unix type path

            set path2 [string range $path 0 [expr $lastIndex - 1]]
            set fname [string range $path [expr $lastIndex + 1] $totLen]
            set lastIndex2 [string last "/" $path2]
            while {[expr [string length $path2] + [string length $fname] + 5] \
                >= 50} {
                set path2 [string range $path2 0 [expr $lastIndex2 -1]]
                set lastIndex2 [string last "/" $path2]
                if {$lastIndex2 == -1} {
                    break;
                }
            }
           set path [format "%s/.../%s" $path2 $fname]

        } else { 
            # DOS type path

            set lastIndex [string last "\\" $path]
            set path2 [string range $path 0 [expr $lastIndex - 1]]
            set fname [string range $path [expr $lastIndex + 1] $totLen]
            set lastIndex2 [string last "\\" $path2]
            while {[expr [string length path2] + [string length $fname] + 5] \
                >= 50} {
                set path2 [string range $path2 0 [expr $lastIndex2 -1]]
                set lastIndex2 [string last "\\" $path2]
                if {$lastIndex2 == -1} {
                    break;
                }
            }
            set $path [format "%s\\...\\%s" $path2 $fname]

        }
    }
    return $path
}

#############################################################################
#
# fspace - returns free space available on Unix hosts
#
# This procedure returns the amount of free space avaiable on the given drive.
#
# SYNOPSIS:
# fspace dir
#
# PARAMETERS: 
# <dir>
# a directory path.
#
# RETURNS: the number of free space in kilobytes avaiable
#
# ERRORS: N/A
#

proc fspace {dir} {

    if {![file isdirectory $dir]} {
        return "$dir: bad directory name"
    }

    # get the directory name in extension

    set here [pwd]
    cd $dir
    set dir [pwd]

    set free "unknown"

    switch [windHostTypeGet] {
        sun4-solaris2 {
            if {![catch {exec /bin/df -k $dir} result]} {
                set free [lindex $result 10]
            } else {
                set free [lindex $result 10]
            }
        }

        parisc-hpux10 {
            set found 0
            set ix 0
            while {$found == 0} {
                incr ix
                if {$ix > 30} {
                    break
                }
                if {[catch "exec /bin/df $dir" res]} {
                    # go backward one step looking for actual mounting
                    # point or device name alias
                    set dir [file dirname $dir]
                } else {
                    set freeSize [lindex [exec /bin/df -k $dir | /bin/sed -e "/total/d" -e "/used/d" ] 0]
                    if {[regexp {[^0-9]+} $freeSize] == 0} {
                        set free $freeSize
                    }
                    set found 1
                }
            }
        }

        default         {}
    }
    cd $here
    return $free
}

##############################################################################
#
# debug - turns on debug mode
#
# SYNOPSIS
# debug
#
# PARAMETERS: N/A
#
# RETURNS: true if the environment var SETUP_DEBUG exists, otherwise false
#
# ERRORS: N/A
#

proc debug {} {
    global env
    global setupVals

    if {[info exists env(SETUP_DEBUG)]} {
        return 1
    } else {
        return 0
    }
}

##############################################################################
#
# openSetupDebugLog - open the setup log file
#
# SYNOPSIS
# openSetupDeubgLog
#
# PARAMETERS: N/A
#
# RETURNS: N/A
#
# ERRORS: N/A
#

proc openSetupDebugLog {} {
    global env setupVals

    if {[info exists env(SETUP_DEBUG)] && $env(SETUP_DEBUG) != 0} { 
        if {[info exists env(SETUP_DBGLOGFILE)]} {
            if {![info exists setupVals(DBGLOG_FD)]} {
                if {[catch {open $env(SETUP_DBGLOGFILE) "w"} setupVals(DBGLOG_FD)]} {
                    puts "Can't open $env(SETUP_DBGLOGFILE)"
                }
            }
        }
    }
    if {[info exists env(INF_DEBUG)] &&  $env(INF_DEBUG) != 0} {
        if {[info exists env(SETUP_DBGLOGFILE)]} {
            if {![info exists setupVals(DBGLOG_FD)]} {
                if {[catch {open $env(SETUP_DBGLOGFILE) "w"} setupVals(DBGLOG_FD)]} {
                    puts "Can't open $env(SETUP_DBGLOGFILE)"
                }
            }
        }
    }
}

##############################################################################
#
# closeSetupDebugLog - close the setup log file
#
# SYNOPSIS
# closeSetupLog
#
# PARAMETERS: N/A
#
# RETURNS: N/A
#
# ERRORS: N/A
#

proc closeSetupDebugLog {} {
    global env
    global setupVals

    if {[info exists setupVals(DBGLOG_FD)]} {
        catch {close $setupVals(DBGLOG_FD)}
    }
}

#############################################################################
#
# dbgputs - wrapper for debug puts function.
#
# Wrapper for the puts function.  Only prints out the specified string
# either to the setup debug log file in env(SETUP_DBGLOGFILE) or the console,
# if the environment variable SETUP_DEBUG exists and is set to a nonzero value. 
#
# SYNOPSIS
# dbgputs <line>
#
# PARAMETERS: 
#   line : string to output.   
#
# RETURNS: N/A
#   
# ERRORS: N/A
#

proc dbgputs {line} {
    global env
    global setupVals

    if {[info exists env(SETUP_DEBUG)]} {
    	if {$env(SETUP_DEBUG) != 0 && [info exists setupVals(DBGLOG_FD)]} {
            puts $setupVals(DBGLOG_FD) $line
            flush $setupVals(DBGLOG_FD)
        } else {
            puts $line
        }
    }
}