PC World 1997 November/PCWorld_1997-11_cd.bin/software/programy/komix/DATA.Z/procs.tcl

Text File | 1997-04-11 | 12.6 KB | 482 lines

#---------------------------------------------------------------------------
#
#      (c)     Westmount Technology    1995
#
#      File:           @(#)procs.tcl    /main/hindenburg/10
#      Author:         voyager
#      Description:    usefull procs for building GUI interfaces
#---------------------------------------------------------------------------
# SccsId = @(#)procs.tcl    /main/hindenburg/10   11 Apr 1997 Copyright 1995 Westmount Technology

proc isReadOnly {obj} {
    return [expr {[$obj readOnly] != 0}]
}

proc isOneLevel {obj} {
    return [expr {[$obj oneLevel] != 0}]
}

# Execute $script while showing a busy cursor. Catch errors in $script,
# execute $epilog and either return or reraise the error if one occurred.
# $script (not $epilog) may contain 'break' or 'return' to jump out of the
# busy script. In those cases $epilog is still evaluated.
#
# We assume the following values for Tcl constants:
# TCL_OK          0
# TCL_ERROR       1
# TCL_RETURN      2
# TCL_BREAK       3
# TCL_CONTINUE    4
#
proc busy {script {epilog {}}} {
    .main busy 1
    set error 0
    set retCode [catch {uplevel 1 $script} errMsg]
    case $retCode in {
    {1 4} {
        set savedInfo $errorInfo
        set savedCode $errorCode
        set error 1
    }
    {3} {
        set retCode 0
    }}
    if [catch {uplevel 1 $epilog} epilogMsg] {
        if $error {
            set errMsg "$epilogMsg\n$errMsg"
            set savedInfo \
                "$epilogMsg\nwhile recovering from\n$savedInfo"
        } else {
            set errMsg $epilogMsg
            set savedInfo $errorInfo
            set savedCode $errorCode
            set error 1
        }
    }
    .main busy 0
    if $error {
        error $errMsg $savedInfo $savedCode
    }
    return -code $retCode
}


proc interface {class name spec} {
    set parent [getParent $name]
    if { $parent != ""} {
        if ![isCommand $parent] {
            puts "parent $parent does not exist"
            return ""
        }
    } else {
        return ""
    }

    $class new $name

    while {![lempty $spec]} {
        set key [lvarpop spec]
        if [isCommand $key] {
            interface $key $name.[lvarpop spec] [lvarpop spec]
        } else {
            $name $key [lvarpop spec]
        }
    }
    return $name
}

proc getParent { child } {
    set parent ""
    set index [string last "." $child]
    if {$index != -1} {
        incr index -1
        set parent [string range $child 0 $index]
    }
    return $parent
}


# Copy a file
#
proc copy_text_file {from to} {
    set max 8092
    set in [open $from r]
    set out [open $to w]
    while {[set result [read $in $max]] != ""} {
        puts $out $result nonewline
    }
    close $in
    close $out
}

# Return the maximum lengths of a set of lists in a list
#
proc maxLengthList {args} {
    set arrayList [lindex $args 0]
    set maxLengthList [lindex $args 1]
    set lengthList {}
    set count [llength [lindex $arrayList 0]]
    for {set i [llength $maxLengthList]} {$i < $count} {incr i 1} {
    lappend maxLengthList 0
    }
    for {set i 0} {$i < $count} {incr i 1} {
    lappend lengthList 0
    }
    foreach array  $arrayList {
    for {set i 0} {$i < $count} {incr i 1} {
        set len [string length [lindex $array $i]]
        set maxLen [lindex $maxLengthList $i]
        if {$maxLen && ($len > $maxLen)} {
        set len $maxLen
        }
        if {$len > [lindex $lengthList $i]} {
        set lengthList [lreplace $lengthList $i $i $len]
        }
    }
    }
    return $lengthList
}

# Return the context of a M4 variable
#
proc context {m4var} {
    set index [string last "__" $m4var]
    if {$index <= 0} {
    return ""
    }
    return [string range $m4var [expr $index + 2] end]
}

# Cleanup the given directory
proc cleanDir {dir} {
    set curPath [pwd]
    if {! [catch {cd $dir}]} {
    if {! [catch {set files [glob *]}]} {
        foreach file $files {
        unlink $file
        }
    }
    cd $curPath
    rmdir $dir
    }
}

# return the type of the item referred by a file with the specified type
proc file2itemtype {type} {
    case $type in {
        {cad ccd ucd}    {return cl}
        {dfd mgd std}    {return pe}
        {etd}        {return et}
    }
}

global file2HasScopePhase
set file2HasScopePhase(cad)    1
set file2HasScopePhase(ccd)    1
set file2HasScopePhase(dfd)    0
set file2HasScopePhase(etd)    1
set file2HasScopePhase(mgd)    0
set file2HasScopePhase(std)    1
set file2HasScopePhase(ucd)    1

proc fileHasScopePhase {type} {
    global file2HasScopePhase
    return $file2HasScopePhase($type)
}

# split file <name>.<type> into <name> and <type>
proc splitFileName {file {splitter .}} {
    set dot [string last "$splitter" "$file"]
    set len [string length "$file"]
    if {$dot < 0} {
    set name $file
    } elseif {$dot == 0} {
    set name ""
    } else {
    set name [string range $file 0 [expr $dot - 1]]
    }
    if {($dot < 0) || ($dot == [expr $len - 1])} {
    set type ""
    } else {
    set type [string range $file [expr $dot + 1] end]
    }
    return [list "$name" "$type"]
}

# Initialize table for conversion from repository object to browser object
proc initRepObj2UiObjTable {dictionary} {
    [.main $dictionary] contents {
    AccessRule RuleUiObj
    AccessRules RulesUiObj
    ConfigList ConfCLDbObj
    ConfigPhaseLinkList ConfPLCLDbObj
    ConfigVersion ConfVDbObj
    ConfigVersionList ConfVCLDbObj
    ControlledClass CClassDbObj
    ControlledClasses CClassUiObj
    ControlledList CListObj
    ControlledLists CListUiObj
    Corporate CorpDbObj
    CorporateGroupVersion CorpGVDbObj
    CorporateGroupVersions CorpGVUiObj
    CustomFiles HCustFUiObj
    CustomFileList CustFCLDbObj
    CustomFileVersion CustFVDbObj
    CustomFileVersionList CustFVCLDbObj
    CustomFileVersions CustFVUiObj
    ExternalFile ExtFUiObj
    ExternalFileVersion ExtFVDbObj
    ExternalLink ExtLDbObj
    ExternalLinkList ExtLCLDbObj
    FileList FileCLDbObj
    FilePropertyReference FilePRDbObj
    FileVersionList FileVCLDbObj
    Graph GraphVDbObj
    GroupList GroupCLDbObj
    GroupVersion GroupVDbObj
    GroupVersionList GroupVCLDbObj
    ItemPropertyReference ItemPRDbObj
    LevelCustomFileLinkList LvlCFLCLDbObj
    Matrix MtrxVDbObj
    None NoneUiObj
    PhaseList PhaseCLDbObj
    PhaseSystemLinkList PhaseSLCLDbObj
    PhaseVersion PhaseVDbObj
    PhaseVersionList PhaseVCLDbObj
    Project ProjDbObj
    ProjectList ProjCLDbObj
    PropertyReferenceList PropRCLDbObj
    Role RoleDbObj
    Roles RoleUiObj
    SavedGroupVersion SvdGVDbObj
    SavedGroupVersions SvdGVUiObj
    SystemCorporateLinkList SCorpLCLDbObj
    SystemFileLinkList SFileLCLDbObj
    SystemFileReference SFileLDbObj
    SystemFileReferenceList SFileRCLDbObj
    SystemGroupLinkList SGroupLCLDbObj
    SystemList SysCLDbObj
    SystemVersion SSysVDbObj
    SystemVersionList SysVCLDbObj
    User UsrDbObj
    UserCustomFiles UCustFUiObj
    UserRoleLink UsrLDbObj
    Users UsrUiObj
    WorkItem WItemDbObj
    WorkItems WItemUiObj
    }
}

# perform garbage-collection and display results
proc garbageCollection {} {
    puts "========================================================"
    puts "GC: GARBAGE COLLECTION"
    GCControl collect
    puts "GC: nrOfCollections =    '[GCControl nrOfCollections]'"
    puts "GC: totalCollectTime =   '[GCControl totalCollectTime]'"
    puts "GC: totalDestructTime =  '[GCControl totalDestructTime]'"
    puts "GC: totalNrOfCollected = '[GCControl totalNrOfCollected]'"
    puts "GC: lastCollectTime =    '[GCControl lastCollectTime]'"
    puts "GC: lastDestructTime =   '[GCControl lastDestructTime]'"
    puts "GC: lastNrOfCollected =  '[GCControl lastNrOfCollected]'"
    puts "========================================================"
}

# Remove white space from 's'
#
proc rmWhiteSpace {s} {
    regsub -all "\[ \t\n\]" $s {} s
    return $s
}

# Source an optional tcl customization file. Name is the name of a tcl file,
# e.g. "u_desk". If the file exists in the user customization directory
# that one is sourced too, AFTER the customization file.
#
proc sourceOptional {name} {
    set context [ClientContext::global]
    if [$context customFileExists $name tcl tcl] {
        eval [$context getCustomFileContents $name tcl tcl]
    }
    set userFile [path_name concat [location ~ icase] $name tcl]
    if [file exists $userFile] {
        source $userFile
    }
}

# Find an object-type specification
proc getObjectSpec {objectHdlr repositoryType subType} {
    set typeSpec [$objectHdlr getObjectSpec "$repositoryType" "$subType"]
    if {"$typeSpec" == ""} {
    set message "Could not find object-type specification '$repositoryType"
    if {"$repositoryType" != "$subType"} {
        append message " ($subType)"
    }
    append message "'"
    wmtkerror "$message"
    }
    return "$typeSpec"
}

# Check if interperter is running
proc isRunning {interp {showError 0}} {
    if [catch {send $interp get_comm_name} error] {
    if $showError {
        wmtkerror "Error: $error"
    }
    return 0
    }
    return 1
}

# Return ORB_class for a repository id
proc ORB_class {id} {
    set ORB_class [[RepositoryObject new $id] ORB_class]
    $ORB_class new $id
    return $ORB_class
}

# Read phases file
proc getPhases {} {
    global BrowserProcs::phases

    # Download the phases file
    set tmpFile [args_file {}]
    set context [ClientContext::global]
    $context downLoadCustomFile phases "" etc $tmpFile

    # Check syntax:
    # phases file must consist of a list of phase-name, phase-type tuples
    # where the phase names are unique
    set phases ""
    set errorMsg ""
    set fid [open $tmpFile]
    foreach phase [read -nonewline $fid] {
    if {[llength $phase] != 2} {
        append errorMsg \
        "line '{$phase}' ignored: invalid syntax\n"
        continue
    }
    set phaseName [lindex $phase 0]
    if [info exists definedPhase($phaseName)] {
        append errorMsg \
        "line '{$phase}' ignored: phase name '$phaseName' not unique\n"
        continue
    }
    set definedPhase($phaseName) 1
    lappend phases $phase
    }
    if {"$errorMsg" == "" && [lempty $phases]} {
    append errorMsg "file is empty"
    }
    set BrowserProcs::phases $phases
    close $fid
    unlink $tmpFile

    # Show warning if phases file exists at current level
    set level [$context currentLevel]
    if {"$errorMsg" != "" &&
    [$context customFileExistsAt $level phases "" etc]} {
    regsub -all "\t" $errorMsg "  " errorMsg
    wmtkwarning \
        "Warning while loading phases file at $level level\n$errorMsg"
    }
}

# Retrieve the possible file types from objectHdlr
proc getFileTypes {objectHdlr} {
    global BrowserProcs::externalFileTypes
    global BrowserProcs::diagramFileTypes
    global BrowserProcs::programmerFileTypes

    set BrowserProcs::externalFileTypes ""
    set BrowserProcs::diagramFileTypes ""
    set BrowserProcs::programmerFileTypes ""
    foreach objectSpec [$objectHdlr getCurrentObjectSpecSet] {
    set browserType [$objectSpec browserType]
    if {"$browserType" == ""} continue
    case [$objectSpec repositoryType]  in {
        {ExternalFileVersion} {
        lappend BrowserProcs::programmerFileTypes $browserType
        }
        {Graph Matrix} {
        lappend BrowserProcs::diagramFileTypes $browserType
        }
        {ExternalLink} {
        lappend BrowserProcs::externalFileTypes $browserType
        }
    }
    }
}

# Break a line into parts of max 'limit' size
# try to look a the break char to perform a break
# if no break is found just break at 'limit'
# return a list of the parts
#
proc lineBreak {line limit breakChar} {
    set l $line
    set result {}
    set limit_minus1 $limit
    incr limit_minus1 -1
    while {[string length $l] >= $limit} {
        set part [string range $l 0 $limit_minus1]
        set idx [string last $breakChar $part]
        if { $idx == -1 } {
            set l [string range $l $limit end]
        } else {
               set part [string range $l 0 $idx]
            incr idx
            set l [string range $l $idx end]
        }
        lappend result $part
        }
    lappend result $l
    return $result
}


# returns quoted string if 'str' consists of more than on part
# intended use: pathnames with spaces
#
proc quoteIf {str} {
    if {[llength $str] > 1} {
        return \"$str\"
    }
    return $str
}

# common code for report invocation
#
proc startReportInMtool {file comment} {
    set script "[quoteIf [m4_path_name bin otsh$EXE_EXT]] \
            -f [quoteIf [m4_path_name reports startreport.tcl]] \
            -- $file"
        .main startCommand mtool "$script" "" \
            "Starting 'Report $comment'" {0 0} 0
}

# common code for configure invocation
#
proc startConfigureInXtool {file comment} {
    set otsh [quoteIf [m4_path_name bin otsh$EXE_EXT]]
    set file [quoteIf [m4_path_name config $file]]
        .main startCommand xtool "$otsh -f $file" "" \
            "Starting '$comment'" {1 0} 0
}

proc endForkOnlineDoc {cmd} {
    foreach exitStatus [.main exitStatusList] {
    if $exitStatus {
        wmtkerror "Starting Online Documentation Program '$cmd' failed."
        break
    }
   }
}

proc forkOnlineDoc {cmd} {
    require systemutil.tcl
    SystemUtilities::fork otk watchdog "[get_comm_name]" $cmd \
        "endForkOnlineDoc [list $cmd]"
}