home *** CD-ROM | disk | FTP | other *** search
/ PC World 1998 October / PCWorld_1998-10_cd.bin / software / prehled / komix / DATA.Z / procs.tcl < prev    next >
Text File  |  1997-09-26  |  17KB  |  657 lines
  1. #---------------------------------------------------------------------------
  2. #
  3. #      (c)     Cayenne Software Inc.    1997
  4. #
  5. #      File:           @(#)procs.tcl    /main/titanic/39
  6. #      Author:         voyager
  7. #      Description:
  8. #---------------------------------------------------------------------------
  9. # SccsId = @(#)procs.tcl    /main/titanic/39   26 Sep 1997 Copyright 1995 Westmount Technology
  10.  
  11. proc isReadOnly {obj} {
  12.     return [expr {[$obj readOnly] != 0}]
  13. }
  14.  
  15. proc isOneLevel {obj} {
  16.     return [expr {[$obj oneLevel] != 0}]
  17. }
  18.  
  19. # Execute $script while showing a busy cursor. Catch errors in $script, 
  20. # execute $epilog and either return or reraise the error if one occurred.
  21. # $script (not $epilog) may contain 'break' or 'return' to jump out of the
  22. # busy script. In those cases $epilog is still evaluated.
  23. #
  24. # We assume the following values for Tcl constants:
  25. # TCL_OK          0
  26. # TCL_ERROR       1
  27. # TCL_RETURN      2
  28. # TCL_BREAK       3
  29. # TCL_CONTINUE    4
  30. #
  31. proc busy {script {epilog {}}} {
  32.     .main busy 1
  33.     set error 0
  34.     set retCode [catch {uplevel 1 $script} errMsg]
  35.     case $retCode in {
  36.     {1 4} {
  37.         set savedInfo $errorInfo
  38.         set savedCode $errorCode
  39.         set error 1
  40.     }
  41.     {3} {
  42.         set retCode 0
  43.     }}
  44.     if [catch {uplevel 1 $epilog} epilogMsg] {
  45.         if $error {
  46.             set errMsg "$epilogMsg\n$errMsg"
  47.             set savedInfo \
  48.                 "$epilogMsg\nwhile recovering from\n$savedInfo"
  49.         } else {
  50.             set errMsg $epilogMsg
  51.             set savedInfo $errorInfo
  52.             set savedCode $errorCode
  53.             set error 1
  54.         }
  55.     }
  56.     .main busy 0
  57.     if $error {
  58.         error $errMsg $savedInfo $savedCode
  59.     }
  60.     return -code $retCode
  61. }
  62.  
  63. proc blockOutput {script {epilog {}}} {
  64.     [.main editorArea] blockOutput
  65.     set error 0
  66.     set retCode [catch {uplevel 1 $script} errMsg]
  67.     case $retCode in {
  68.     {1 4} {
  69.         set savedInfo $errorInfo
  70.         set savedCode $errorCode
  71.         set error 1
  72.     }
  73.     {3} {
  74.         set retCode 0
  75.     }}
  76.     if [catch {uplevel 1 $epilog} epilogMsg] {
  77.         if $error {
  78.             set errMsg "$epilogMsg\n$errMsg"
  79.             set savedInfo \
  80.                 "$epilogMsg\nwhile recovering from\n$savedInfo"
  81.         } else {
  82.             set errMsg $epilogMsg
  83.             set savedInfo $errorInfo
  84.             set savedCode $errorCode
  85.             set error 1
  86.         }
  87.     }
  88.     [.main editorArea] enableOutput
  89.     [.main editorArea] redraw
  90.     if $error {
  91.         error $errMsg $savedInfo $savedCode
  92.     }
  93.     return -code $retCode
  94. }
  95.  
  96. proc interface {class name spec} {
  97.     set parent [getParent $name]
  98.     if { $parent != ""} {
  99.         if ![isCommand $parent] {
  100.             puts "parent $parent does not exist"
  101.             return ""
  102.         }
  103.     } else {
  104.         return ""
  105.     }
  106.  
  107.     $class new $name
  108.  
  109.     while {![lempty $spec]} {
  110.         set key [lvarpop spec]
  111.         if [isCommand $key] {
  112.             interface $key $name.[lvarpop spec] [lvarpop spec]
  113.         } else {
  114.             $name $key [lvarpop spec]
  115.         }
  116.     }
  117.     return $name
  118. }
  119.  
  120. proc getParent { child } {
  121.     set parent ""
  122.     set index [string last "." $child]
  123.     if {$index != -1} {
  124.         incr index -1
  125.         set parent [string range $child 0 $index]
  126.     }
  127.     return $parent
  128. }
  129.  
  130.  
  131. # Return 1 when 'child' is within the tree with root 'parent'
  132. #
  133. proc inTree {child parent} {
  134.     if {(! [strncmp $child $parent]) &&
  135.         ([string length $child] >= [string length $parent])} {
  136.         return 1
  137.     }
  138.     return 0
  139. }
  140.  
  141.  
  142. # Copy a file
  143. #
  144. proc copy_text_file {from to} {
  145.     set max 8092
  146.     set in [open $from r]
  147.     set out [open $to w]
  148.     while {[set result [read $in $max]] != ""} {
  149.         puts $out $result nonewline
  150.     }
  151.     close $in
  152.     close $out
  153. }
  154.  
  155. # Return the maximum lengths of a set of lists in a list
  156. #
  157. proc maxLengthList {args} {
  158.     set arrayList [lindex $args 0]
  159.     set maxLengthList [lindex $args 1]
  160.     set lengthList {}
  161.     set count [llength [lindex $arrayList 0]]
  162.     for {set i [llength $maxLengthList]} {$i < $count} {incr i 1} {
  163.     lappend maxLengthList 0
  164.     }
  165.     for {set i 0} {$i < $count} {incr i 1} {
  166.     lappend lengthList 0
  167.     }
  168.     foreach array  $arrayList {
  169.     for {set i 0} {$i < $count} {incr i 1} {
  170.         set len [string length [lindex $array $i]]
  171.         set maxLen [lindex $maxLengthList $i]
  172.         if {$maxLen && ($len > $maxLen)} {
  173.         set len $maxLen
  174.         }
  175.         if {$len > [lindex $lengthList $i]} {
  176.         set lengthList [lreplace $lengthList $i $i $len]
  177.         }
  178.     }
  179.     }
  180.     return $lengthList
  181. }
  182.  
  183. # Return the context of a M4 variable
  184. #
  185. proc context {m4var} {
  186.     set index [string last "__" $m4var]
  187.     if {$index <= 0} {
  188.     return ""
  189.     }
  190.     return [string range $m4var [expr $index + 2] end]
  191. }
  192.  
  193. # Cleanup the given directory
  194. proc cleanDir {dir} {
  195.     # No tilde substitution!
  196.     set pattern [path_name concat $dir "*"]
  197.     if {! [catch {set files [otglob $pattern]}]} {
  198.     foreach file $files {
  199.         unlink $file
  200.     }
  201.     }
  202.     rmdir $dir
  203. }
  204.  
  205. # return the type of the item referred by a file with the specified type
  206. proc file2itemtype {type} {
  207.     case $type in {
  208.     {cad ccd ucd}    {return cl}
  209.     {dfd mgd std}    {return pe}
  210.     {etd}        {return et}
  211.     {cod}        {return ce}
  212.     }
  213. }
  214.  
  215. global file2HasScopePhase
  216. set file2HasScopePhase(cad)    1
  217. set file2HasScopePhase(ccd)    1
  218. set file2HasScopePhase(cod)    1
  219. set file2HasScopePhase(dfd)    0
  220. set file2HasScopePhase(etd)    1
  221. set file2HasScopePhase(mgd)    0
  222. set file2HasScopePhase(std)    1
  223. set file2HasScopePhase(ucd)    1
  224.  
  225. proc fileHasScopePhase {type} {
  226.     global file2HasScopePhase
  227.     return $file2HasScopePhase($type)
  228. }
  229.  
  230. # split file <name>.<type> into <name> and <type>
  231. proc splitFileName {file {splitter .}} {
  232.     set dot [string last "$splitter" "$file"]
  233.     set len [string length "$file"]
  234.     if {$dot < 0} {
  235.     set name $file
  236.     } elseif {$dot == 0} {
  237.     set name ""
  238.     } else {
  239.     set name [string range $file 0 [expr $dot - 1]]
  240.     }
  241.     if {($dot < 0) || ($dot == [expr $len - 1])} {
  242.     set type ""
  243.     } else {
  244.     set type [string range $file [expr $dot + 1] end]
  245.     }
  246.     return [list "$name" "$type"]
  247. }
  248.  
  249. # Initialize table for conversion from repository object to browser object
  250. proc initRepObj2UiObjTable {} {
  251.     return {
  252.     ConfigVersion ConfVDbObj
  253.     Corporate CorpDbObj
  254.     CustomFiles HCustFUiObj
  255.     CustomFileVersion CustFVDbObj
  256.     CustomFileVersions CustFVUiObj
  257.     ExternalFile ExtFUiObj
  258.     ExternalFileVersion ExtFVDbObj
  259.     ExternalLink ExtLDbObj
  260.     Graph GraphVDbObj
  261.     Matrix MtrxVDbObj
  262.     None NoneUiObj
  263.     PhaseVersion PhaseVDbObj
  264.     SystemVersion SSysVDbObj
  265.     UserCustomFiles UCustFUiObj
  266.     WorkItem WItemDbObj
  267.     WorkItems WItemUiObj
  268.     }
  269. }
  270.  
  271. # perform garbage-collection and display results
  272. proc garbageCollection {} {
  273.     puts "========================================================"
  274.     puts "GC: GARBAGE COLLECTION"
  275.     GCControl collect
  276.     puts "GC: nrOfCollections =    '[GCControl nrOfCollections]'"
  277.     puts "GC: totalCollectTime =   '[GCControl totalCollectTime]'"
  278.     puts "GC: totalDestructTime =  '[GCControl totalDestructTime]'"
  279.     puts "GC: totalNrOfCollected = '[GCControl totalNrOfCollected]'"
  280.     puts "GC: lastCollectTime =    '[GCControl lastCollectTime]'"
  281.     puts "GC: lastDestructTime =   '[GCControl lastDestructTime]'"
  282.     puts "GC: lastNrOfCollected =  '[GCControl lastNrOfCollected]'"
  283.     puts "========================================================"
  284. }
  285.  
  286. # Remove white space from 's'
  287. #
  288. proc rmWhiteSpace {s} {
  289.     regsub -all "\[ \t\n\]" $s {} s
  290.     return $s
  291. }
  292.  
  293. # Source an optional tcl customization file. Name is the name of a tcl file,
  294. # e.g. "u_desk". If the file exists in the user customization directory
  295. # that one is sourced too, AFTER the customization file.
  296. #
  297. proc sourceOptional {name} {
  298.     set context [ClientContext::global]
  299.     if [$context customFileExists $name tcl tcl] {
  300.         eval [$context getCustomFileContents $name tcl tcl]
  301.     }
  302.     set userFile [path_name concat [location ~ icase] $name tcl]
  303.     if [file exists $userFile] {
  304.         source $userFile
  305.     }
  306. }
  307.  
  308. # Find an object-type specification
  309. proc getObjectSpec {objectHdlr repositoryType subType {showError 1}} {
  310.     set typeSpec [$objectHdlr getObjectSpec "$repositoryType" "$subType"]
  311.     if {$showError && "$typeSpec" == ""} {
  312.     set message "Could not find object-type specification '$repositoryType"
  313.     if {"$repositoryType" != "$subType"} {
  314.         append message " ($subType)"
  315.     }
  316.     append message "'"
  317.     wmtkerror "$message"
  318.     }
  319.     return "$typeSpec"
  320. }
  321.  
  322. # Check if interperter is running
  323. proc isRunning {interp {showError 0}} {
  324.     if [catch {send $interp get_comm_name} error] {
  325.     if $showError {
  326.         wmtkerror "Error: $error"
  327.     }
  328.     return 0
  329.     }
  330.     return 1
  331. }
  332.  
  333. # Return ORB_class for a repository id
  334. proc ORB_class {id} {
  335.     set ORB_class [[RepositoryObject new $id] ORB_class]
  336.     $ORB_class new $id
  337.     return $ORB_class
  338. }
  339.  
  340. # Read phases file
  341. proc getPhases {} {
  342.     global BrowserProcs::phases
  343.  
  344.     # Download the phases file
  345.     set tmpFile [args_file {}]
  346.     set context [ClientContext::global]
  347.     $context downLoadCustomFile phases phases etc $tmpFile
  348.  
  349.     # Check syntax:
  350.     # phases file must consist of a list of phase-name, phase-type tuples
  351.     # where the phase names are unique
  352.     set phases ""
  353.     set errorMsg ""
  354.     set fid [open $tmpFile]
  355.     foreach phase [read -nonewline $fid] {
  356.     if {[llength $phase] != 2} {
  357.         append errorMsg \
  358.         "line '{$phase}' ignored: invalid syntax\n"
  359.         continue
  360.     }
  361.     set phaseName [lindex $phase 0]
  362.     if [info exists definedPhase($phaseName)] {
  363.         append errorMsg \
  364.         "line '{$phase}' ignored: phase name '$phaseName' not unique\n"
  365.         continue
  366.     }
  367.     set definedPhase($phaseName) 1
  368.     lappend phases $phase
  369.     }
  370.     if {"$errorMsg" == "" && [lempty $phases]} {
  371.     append errorMsg "file is empty"
  372.     }
  373.     set BrowserProcs::phases $phases
  374.     close $fid
  375.     unlink $tmpFile
  376.  
  377.     # Show warning if phases file exists at current level
  378.     set level [$context currentLevel]
  379.     if {"$errorMsg" != "" &&
  380.     [$context customFileExistsAt $level phases phases etc]} {
  381.     regsub -all "\t" $errorMsg "  " errorMsg
  382.     wmtkwarning \
  383.         "Warning while loading phases file at $level level\n$errorMsg"
  384.     }
  385. }
  386.  
  387. # Retrieve the possible file types from objectHdlr
  388. proc getFileTypes {objectHdlr} {
  389.     global BrowserProcs::externalFileTypes
  390.     global BrowserProcs::diagramFileTypes
  391.     global BrowserProcs::programmerFileTypes
  392.  
  393.     set BrowserProcs::externalFileTypes ""
  394.     set BrowserProcs::diagramFileTypes ""
  395.     set BrowserProcs::programmerFileTypes ""
  396.     foreach objectSpec [$objectHdlr currentObjectSpecSet] {
  397.     set browserType [$objectSpec browserType]
  398.     if {"$browserType" == ""} continue
  399.     case [$objectSpec repositoryType]  in {
  400.         {ExternalFileVersion} {
  401.         lappend BrowserProcs::programmerFileTypes $browserType
  402.         }
  403.         {Graph Matrix} {
  404.         lappend BrowserProcs::diagramFileTypes $browserType
  405.         }
  406.         {ExternalLink} {
  407.         lappend BrowserProcs::externalFileTypes $browserType
  408.         }
  409.     }
  410.     }
  411. }
  412.  
  413. # Break a line into parts of max 'limit' size
  414. # try to look a the break char to perform a break
  415. # if no break is found just break at 'limit'
  416. # return a list of the parts
  417. #
  418. proc lineBreak {line limit breakChar} {
  419.     set l $line
  420.     set result {}
  421.     set limit_minus1 $limit
  422.     incr limit_minus1 -1
  423.     while {[string length $l] >= $limit} {
  424.         set part [string range $l 0 $limit_minus1]
  425.         set idx [string last $breakChar $part]
  426.         if { $idx == -1 } {
  427.             set l [string range $l $limit end]
  428.         } else {
  429.                set part [string range $l 0 $idx]
  430.             incr idx
  431.             set l [string range $l $idx end]
  432.         }
  433.         lappend result $part
  434.     }
  435.     lappend result $l
  436.     return $result
  437. }
  438.  
  439.  
  440. # returns quoted string if 'str' consists of more than on part
  441. # intended use: pathnames with spaces
  442. #
  443. proc quoteIf {str} {
  444.     if {[llength $str] > 1} {
  445.         return \"$str\"
  446.     }
  447.     return $str
  448. }
  449.  
  450. # common code for report invocation
  451. #
  452. proc startReportInMtool {file comment} {
  453.     set script "[quoteIf [m4_path_name bin otsh$EXE_EXT]] \
  454.         -f [quoteIf [m4_path_name reports startreport.tcl]] \
  455.         -- $file"
  456.     .main startCommand mtool "$script" "" \
  457.         "Starting 'Report $comment'" {0 0} 0
  458. }
  459.  
  460. # common code for configure invocation
  461. #
  462. proc startConfigureInXtool {file comment} {
  463.     set otsh [quoteIf [m4_path_name bin otsh$EXE_EXT]]
  464.     set file [quoteIf [m4_path_name config $file]]
  465.     .main startCommand xtool "$otsh -f $file" "" \
  466.         "Starting '$comment'" {0 0} 0
  467. }
  468.  
  469. # read module file:
  470. #    take the first module when no module is specified
  471. #
  472. proc read_module_file { file {moduleName ""} {sourceProc source}} {
  473.  
  474.     if {"$moduleName" == ""} {
  475.     set files [$globalModuleHandler getSelectedFiles tcl $file]
  476.     if [lempty $files] return
  477.     $sourceProc [lindex $files 0]
  478.     return
  479.     }
  480.  
  481.     set module [$globalModuleHandler getModuleSpec $moduleName]
  482.     if {"$module" == ""} {
  483.     wmtkerror "Module '$moduleName' not found."
  484.     return
  485.     }
  486.  
  487.     set moduleFiles [$globalModuleHandler getFiles tcl $file $module]
  488.     if {"$moduleFiles" != ""} {
  489.     $sourceProc [lindex $moduleFiles 0]
  490.     } else {
  491.     wmtkerror "Module file '$file' not found in module '$moduleName'."
  492.     }
  493. }
  494.  
  495. proc require_module_file {file {moduleName ""} } {
  496.     read_module_file $file $moduleName module_require
  497. }
  498.  
  499. # source file only once (internal use only)
  500. #
  501. proc module_require {file} {
  502.     global required_module_files
  503.     if [info exists required_module_files($file)] {
  504.     return
  505.     }
  506.     set required_module_files($file) 1
  507.     source $file
  508. }
  509.  
  510. # Read all promoter module files of the given object type (p_<class>.tcl)
  511. #
  512. global modulePromoterSet
  513. set modulePromoterSet [Dictionary new]
  514.  
  515. proc module_promoter {class object} {
  516.  
  517.     global modulePromoterSet
  518.  
  519.     if {![$modulePromoterSet exists $class]} {
  520.     set moduleSet {}
  521.     # fill dictionary
  522.     set file [string range "p_[string tolower $class]" 0 9].tcl
  523.     foreach module [$globalModuleHandler moduleSpecSet] {
  524.         set moduleFiles [$globalModuleHandler getFiles tcl $file $module]
  525.         if {"$moduleFiles" == ""} continue
  526.         lappend moduleSet [$module name]
  527.         module_require [lindex $moduleFiles 0]
  528.     }
  529.     $modulePromoterSet set $class $moduleSet 
  530.     } else {
  531.     set moduleSet [$modulePromoterSet set $class]
  532.     }
  533.  
  534.     #set moduleSet [$modulePromoterSet set $class]
  535.     foreach module $moduleSet {
  536.     $class::${module}_promoter $object
  537.     }
  538. }
  539.  
  540. # Check for module_proc
  541. #
  542. proc module_proc {args} {
  543.  
  544.     set proc [lvarpop args]
  545.  
  546.     foreach module [$globalModuleHandler moduleSpecSet] {
  547.     if [isCommand ${proc}_[$module name]] {
  548.         eval ${proc}_[$module name] $args
  549.     }
  550.     }
  551. }
  552.  
  553. # make levelpath from config/phase/system version
  554. #
  555. proc mkLevelPath {cV pV sV} {
  556.     set cc [ClientContext::global]
  557.     set result "/"
  558.     append result [[$cc currentCorporate] name]/
  559.     append result [[$cc currentProject] name]/
  560.     append result [[$cV ConfigVersion::config] name]:[$cV versionNumber]/
  561.     append result [[$pV phase] name].[[$pV phase] type]/
  562.     append result [[$sV system] name].[[$sV system] type]
  563.     return $result
  564.             "Starting '$comment'" {1 0} 0
  565. }
  566.  
  567. proc showActiveModules {} {
  568.  
  569.     set mods ""
  570.     foreach mdl [$globalModuleHandler moduleSpecSet] {
  571.         lappend mods [$mdl name]
  572.         lappend mods [$mdl longName]
  573.     }
  574.  
  575.     global classCount
  576.     set box .main.showObjectInfo$classCount
  577.     incr classCount
  578.     interface TemplateDialog $box {
  579.         title "Active Modules"
  580.         DlgColumn col {}
  581.         okPressed {%this delete}
  582.     }
  583.     $box modal $win95
  584.     $box delCancelButton
  585.     $box delHelpButton
  586.  
  587.     set len [llength $mods]
  588.     for {set i 0} {$i < $len} {incr i 2} {
  589.         DlgRow new $box.col.row$i \
  590.             -spaceType NONE \
  591.             -justification RIGHT
  592.         Label new $box.col.row$i.header \
  593.             -text "[lindex $mods $i]:" \
  594.             -alignment RIGHT \
  595.             -horStretchFactor 10 \
  596.             -justification TOP \
  597.             -font "courier-bold-12"
  598.         DlgColumn new $box.col.row$i.col
  599.         set breakUpCnt 0
  600.         foreach part [lineBreak [lindex $mods [expr $i+1]] 50 " "] {
  601.             set text [format "%-50s" $part]
  602.             Label new $box.col.row$i.col.label$breakUpCnt \
  603.                 -text $text \
  604.                 -font "courier-normal-12"
  605.             incr breakUpCnt
  606.         }
  607.     }
  608.         
  609.     $box popUp
  610. }
  611.  
  612. proc checkModuleWarnings {{moduleHandler ""}} {
  613.  
  614.     if {$moduleHandler == ""} {
  615.         set moduleHandler $globalModuleHandler
  616.     }
  617.  
  618.     set warnings [$moduleHandler warningSet]
  619.     global globalWarning
  620.     set globalWarning ""
  621.     foreach warning $warnings {
  622.         if {$globalWarning != ""} {
  623.             append globalWarning "\n"
  624.         }
  625.         append globalWarning "$warning"
  626.      }
  627.      if {$globalWarning != ""} {
  628.         wmtkwarning $globalWarning
  629.      }
  630. }
  631.  
  632. # compare the first 'n' characters of two strings (default: min length).
  633. #
  634. proc strncmp {str1 str2 {n -1}} {
  635.     if {$n == 0} {
  636.     return 0
  637.     }
  638.  
  639.     set last $n
  640.     set len1 [string length $str1]
  641.     if {($last < 0) || ($len1 < $last)} {
  642.     set last $len1
  643.     }
  644.     set len2 [string length $str2]
  645.     if {$len2 < $last} {
  646.     set last $len2
  647.     }
  648.     incr last -1
  649.     if {$last < 0} {
  650.     return [string compare $str1 $str2]
  651.     }
  652.     return [string compare \
  653.     [string range $str1 0 $last] \
  654.     [string range $str2 0 $last] \
  655.     ]
  656. }
  657.