home *** CD-ROM | disk | FTP | other *** search
/ PC World 1997 November / PCWorld_1997-11_cd.bin / software / programy / komix / DATA.Z / procs.tcl < prev    next >
Text File  |  1997-04-11  |  13KB  |  482 lines
  1. #---------------------------------------------------------------------------
  2. #
  3. #      (c)     Westmount Technology    1995
  4. #
  5. #      File:           @(#)procs.tcl    /main/hindenburg/10
  6. #      Author:         voyager
  7. #      Description:    usefull procs for building GUI interfaces
  8. #---------------------------------------------------------------------------
  9. # SccsId = @(#)procs.tcl    /main/hindenburg/10   11 Apr 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.  
  64. proc interface {class name spec} {
  65.     set parent [getParent $name]
  66.     if { $parent != ""} {
  67.         if ![isCommand $parent] {
  68.             puts "parent $parent does not exist"
  69.             return ""
  70.         }
  71.     } else {
  72.         return ""
  73.     }
  74.  
  75.     $class new $name
  76.  
  77.     while {![lempty $spec]} {
  78.         set key [lvarpop spec]
  79.         if [isCommand $key] {
  80.             interface $key $name.[lvarpop spec] [lvarpop spec]
  81.         } else {
  82.             $name $key [lvarpop spec]
  83.         }
  84.     }
  85.     return $name
  86. }
  87.  
  88. proc getParent { child } {
  89.     set parent ""
  90.     set index [string last "." $child]
  91.     if {$index != -1} {
  92.         incr index -1
  93.         set parent [string range $child 0 $index]
  94.     }
  95.     return $parent
  96. }
  97.  
  98.  
  99. # Copy a file
  100. #
  101. proc copy_text_file {from to} {
  102.     set max 8092
  103.     set in [open $from r]
  104.     set out [open $to w]
  105.     while {[set result [read $in $max]] != ""} {
  106.         puts $out $result nonewline
  107.     }
  108.     close $in
  109.     close $out
  110. }
  111.  
  112. # Return the maximum lengths of a set of lists in a list
  113. #
  114. proc maxLengthList {args} {
  115.     set arrayList [lindex $args 0]
  116.     set maxLengthList [lindex $args 1]
  117.     set lengthList {}
  118.     set count [llength [lindex $arrayList 0]]
  119.     for {set i [llength $maxLengthList]} {$i < $count} {incr i 1} {
  120.     lappend maxLengthList 0
  121.     }
  122.     for {set i 0} {$i < $count} {incr i 1} {
  123.     lappend lengthList 0
  124.     }
  125.     foreach array  $arrayList {
  126.     for {set i 0} {$i < $count} {incr i 1} {
  127.         set len [string length [lindex $array $i]]
  128.         set maxLen [lindex $maxLengthList $i]
  129.         if {$maxLen && ($len > $maxLen)} {
  130.         set len $maxLen
  131.         }
  132.         if {$len > [lindex $lengthList $i]} {
  133.         set lengthList [lreplace $lengthList $i $i $len]
  134.         }
  135.     }
  136.     }
  137.     return $lengthList
  138. }
  139.  
  140. # Return the context of a M4 variable
  141. #
  142. proc context {m4var} {
  143.     set index [string last "__" $m4var]
  144.     if {$index <= 0} {
  145.     return ""
  146.     }
  147.     return [string range $m4var [expr $index + 2] end]
  148. }
  149.  
  150. # Cleanup the given directory
  151. proc cleanDir {dir} {
  152.     set curPath [pwd]
  153.     if {! [catch {cd $dir}]} {
  154.     if {! [catch {set files [glob *]}]} {
  155.         foreach file $files {
  156.         unlink $file
  157.         }
  158.     }
  159.     cd $curPath
  160.     rmdir $dir
  161.     }
  162. }
  163.  
  164. # return the type of the item referred by a file with the specified type
  165. proc file2itemtype {type} {
  166.     case $type in {
  167.         {cad ccd ucd}    {return cl}
  168.         {dfd mgd std}    {return pe}
  169.         {etd}        {return et}
  170.     }
  171. }
  172.  
  173. global file2HasScopePhase
  174. set file2HasScopePhase(cad)    1
  175. set file2HasScopePhase(ccd)    1
  176. set file2HasScopePhase(dfd)    0
  177. set file2HasScopePhase(etd)    1
  178. set file2HasScopePhase(mgd)    0
  179. set file2HasScopePhase(std)    1
  180. set file2HasScopePhase(ucd)    1
  181.  
  182. proc fileHasScopePhase {type} {
  183.     global file2HasScopePhase
  184.     return $file2HasScopePhase($type)
  185. }
  186.  
  187. # split file <name>.<type> into <name> and <type>
  188. proc splitFileName {file {splitter .}} {
  189.     set dot [string last "$splitter" "$file"]
  190.     set len [string length "$file"]
  191.     if {$dot < 0} {
  192.     set name $file
  193.     } elseif {$dot == 0} {
  194.     set name ""
  195.     } else {
  196.     set name [string range $file 0 [expr $dot - 1]]
  197.     }
  198.     if {($dot < 0) || ($dot == [expr $len - 1])} {
  199.     set type ""
  200.     } else {
  201.     set type [string range $file [expr $dot + 1] end]
  202.     }
  203.     return [list "$name" "$type"]
  204. }
  205.  
  206. # Initialize table for conversion from repository object to browser object
  207. proc initRepObj2UiObjTable {dictionary} {
  208.     [.main $dictionary] contents {
  209.     AccessRule RuleUiObj
  210.     AccessRules RulesUiObj
  211.     ConfigList ConfCLDbObj
  212.     ConfigPhaseLinkList ConfPLCLDbObj
  213.     ConfigVersion ConfVDbObj
  214.     ConfigVersionList ConfVCLDbObj
  215.     ControlledClass CClassDbObj
  216.     ControlledClasses CClassUiObj
  217.     ControlledList CListObj
  218.     ControlledLists CListUiObj
  219.     Corporate CorpDbObj
  220.     CorporateGroupVersion CorpGVDbObj
  221.     CorporateGroupVersions CorpGVUiObj
  222.     CustomFiles HCustFUiObj
  223.     CustomFileList CustFCLDbObj
  224.     CustomFileVersion CustFVDbObj
  225.     CustomFileVersionList CustFVCLDbObj
  226.     CustomFileVersions CustFVUiObj
  227.     ExternalFile ExtFUiObj
  228.     ExternalFileVersion ExtFVDbObj
  229.     ExternalLink ExtLDbObj
  230.     ExternalLinkList ExtLCLDbObj
  231.     FileList FileCLDbObj
  232.     FilePropertyReference FilePRDbObj
  233.     FileVersionList FileVCLDbObj
  234.     Graph GraphVDbObj
  235.     GroupList GroupCLDbObj
  236.     GroupVersion GroupVDbObj
  237.     GroupVersionList GroupVCLDbObj
  238.     ItemPropertyReference ItemPRDbObj
  239.     LevelCustomFileLinkList LvlCFLCLDbObj
  240.     Matrix MtrxVDbObj
  241.     None NoneUiObj
  242.     PhaseList PhaseCLDbObj
  243.     PhaseSystemLinkList PhaseSLCLDbObj
  244.     PhaseVersion PhaseVDbObj
  245.     PhaseVersionList PhaseVCLDbObj
  246.     Project ProjDbObj
  247.     ProjectList ProjCLDbObj
  248.     PropertyReferenceList PropRCLDbObj
  249.     Role RoleDbObj
  250.     Roles RoleUiObj
  251.     SavedGroupVersion SvdGVDbObj
  252.     SavedGroupVersions SvdGVUiObj
  253.     SystemCorporateLinkList SCorpLCLDbObj
  254.     SystemFileLinkList SFileLCLDbObj
  255.     SystemFileReference SFileLDbObj
  256.     SystemFileReferenceList SFileRCLDbObj
  257.     SystemGroupLinkList SGroupLCLDbObj
  258.     SystemList SysCLDbObj
  259.     SystemVersion SSysVDbObj
  260.     SystemVersionList SysVCLDbObj
  261.     User UsrDbObj
  262.     UserCustomFiles UCustFUiObj
  263.     UserRoleLink UsrLDbObj
  264.     Users UsrUiObj
  265.     WorkItem WItemDbObj
  266.     WorkItems WItemUiObj
  267.     }
  268. }
  269.  
  270. # perform garbage-collection and display results
  271. proc garbageCollection {} {
  272.     puts "========================================================"
  273.     puts "GC: GARBAGE COLLECTION"
  274.     GCControl collect
  275.     puts "GC: nrOfCollections =    '[GCControl nrOfCollections]'"
  276.     puts "GC: totalCollectTime =   '[GCControl totalCollectTime]'"
  277.     puts "GC: totalDestructTime =  '[GCControl totalDestructTime]'"
  278.     puts "GC: totalNrOfCollected = '[GCControl totalNrOfCollected]'"
  279.     puts "GC: lastCollectTime =    '[GCControl lastCollectTime]'"
  280.     puts "GC: lastDestructTime =   '[GCControl lastDestructTime]'"
  281.     puts "GC: lastNrOfCollected =  '[GCControl lastNrOfCollected]'"
  282.     puts "========================================================"
  283. }
  284.  
  285. # Remove white space from 's'
  286. #
  287. proc rmWhiteSpace {s} {
  288.     regsub -all "\[ \t\n\]" $s {} s
  289.     return $s
  290. }
  291.  
  292. # Source an optional tcl customization file. Name is the name of a tcl file,
  293. # e.g. "u_desk". If the file exists in the user customization directory
  294. # that one is sourced too, AFTER the customization file.
  295. #
  296. proc sourceOptional {name} {
  297.     set context [ClientContext::global]
  298.     if [$context customFileExists $name tcl tcl] {
  299.         eval [$context getCustomFileContents $name tcl tcl]
  300.     }
  301.     set userFile [path_name concat [location ~ icase] $name tcl]
  302.     if [file exists $userFile] {
  303.         source $userFile
  304.     }
  305. }
  306.  
  307. # Find an object-type specification
  308. proc getObjectSpec {objectHdlr repositoryType subType} {
  309.     set typeSpec [$objectHdlr getObjectSpec "$repositoryType" "$subType"]
  310.     if {"$typeSpec" == ""} {
  311.     set message "Could not find object-type specification '$repositoryType"
  312.     if {"$repositoryType" != "$subType"} {
  313.         append message " ($subType)"
  314.     }
  315.     append message "'"
  316.     wmtkerror "$message"
  317.     }
  318.     return "$typeSpec"
  319. }
  320.  
  321. # Check if interperter is running
  322. proc isRunning {interp {showError 0}} {
  323.     if [catch {send $interp get_comm_name} error] {
  324.     if $showError {
  325.         wmtkerror "Error: $error"
  326.     }
  327.     return 0
  328.     }
  329.     return 1
  330. }
  331.  
  332. # Return ORB_class for a repository id
  333. proc ORB_class {id} {
  334.     set ORB_class [[RepositoryObject new $id] ORB_class]
  335.     $ORB_class new $id
  336.     return $ORB_class
  337. }
  338.  
  339. # Read phases file
  340. proc getPhases {} {
  341.     global BrowserProcs::phases
  342.  
  343.     # Download the phases file
  344.     set tmpFile [args_file {}]
  345.     set context [ClientContext::global]
  346.     $context downLoadCustomFile phases "" etc $tmpFile
  347.  
  348.     # Check syntax:
  349.     # phases file must consist of a list of phase-name, phase-type tuples
  350.     # where the phase names are unique
  351.     set phases ""
  352.     set errorMsg ""
  353.     set fid [open $tmpFile]
  354.     foreach phase [read -nonewline $fid] {
  355.     if {[llength $phase] != 2} {
  356.         append errorMsg \
  357.         "line '{$phase}' ignored: invalid syntax\n"
  358.         continue
  359.     }
  360.     set phaseName [lindex $phase 0]
  361.     if [info exists definedPhase($phaseName)] {
  362.         append errorMsg \
  363.         "line '{$phase}' ignored: phase name '$phaseName' not unique\n"
  364.         continue
  365.     }
  366.     set definedPhase($phaseName) 1
  367.     lappend phases $phase
  368.     }
  369.     if {"$errorMsg" == "" && [lempty $phases]} {
  370.     append errorMsg "file is empty"
  371.     }
  372.     set BrowserProcs::phases $phases
  373.     close $fid
  374.     unlink $tmpFile
  375.  
  376.     # Show warning if phases file exists at current level
  377.     set level [$context currentLevel]
  378.     if {"$errorMsg" != "" &&
  379.     [$context customFileExistsAt $level phases "" etc]} {
  380.     regsub -all "\t" $errorMsg "  " errorMsg
  381.     wmtkwarning \
  382.         "Warning while loading phases file at $level level\n$errorMsg"
  383.     }
  384. }
  385.  
  386. # Retrieve the possible file types from objectHdlr
  387. proc getFileTypes {objectHdlr} {
  388.     global BrowserProcs::externalFileTypes
  389.     global BrowserProcs::diagramFileTypes
  390.     global BrowserProcs::programmerFileTypes
  391.  
  392.     set BrowserProcs::externalFileTypes ""
  393.     set BrowserProcs::diagramFileTypes ""
  394.     set BrowserProcs::programmerFileTypes ""
  395.     foreach objectSpec [$objectHdlr getCurrentObjectSpecSet] {
  396.     set browserType [$objectSpec browserType]
  397.     if {"$browserType" == ""} continue
  398.     case [$objectSpec repositoryType]  in {
  399.         {ExternalFileVersion} {
  400.         lappend BrowserProcs::programmerFileTypes $browserType
  401.         }
  402.         {Graph Matrix} {
  403.         lappend BrowserProcs::diagramFileTypes $browserType
  404.         }
  405.         {ExternalLink} {
  406.         lappend BrowserProcs::externalFileTypes $browserType
  407.         }
  408.     }
  409.     }
  410. }
  411.  
  412. # Break a line into parts of max 'limit' size
  413. # try to look a the break char to perform a break
  414. # if no break is found just break at 'limit'
  415. # return a list of the parts
  416. #
  417. proc lineBreak {line limit breakChar} {
  418.     set l $line
  419.     set result {}
  420.     set limit_minus1 $limit
  421.     incr limit_minus1 -1
  422.     while {[string length $l] >= $limit} {
  423.         set part [string range $l 0 $limit_minus1]
  424.         set idx [string last $breakChar $part]
  425.         if { $idx == -1 } {
  426.             set l [string range $l $limit end]
  427.         } else {
  428.                set part [string range $l 0 $idx]
  429.             incr idx
  430.             set l [string range $l $idx end]
  431.         }
  432.         lappend result $part
  433.         }
  434.     lappend result $l
  435.     return $result
  436. }
  437.  
  438.  
  439. # returns quoted string if 'str' consists of more than on part
  440. # intended use: pathnames with spaces
  441. #
  442. proc quoteIf {str} {
  443.     if {[llength $str] > 1} {
  444.         return \"$str\"
  445.     }
  446.     return $str
  447. }
  448.  
  449. # common code for report invocation
  450. #
  451. proc startReportInMtool {file comment} {
  452.     set script "[quoteIf [m4_path_name bin otsh$EXE_EXT]] \
  453.             -f [quoteIf [m4_path_name reports startreport.tcl]] \
  454.             -- $file"
  455.         .main startCommand mtool "$script" "" \
  456.             "Starting 'Report $comment'" {0 0} 0
  457. }
  458.  
  459. # common code for configure invocation
  460. #
  461. proc startConfigureInXtool {file comment} {
  462.     set otsh [quoteIf [m4_path_name bin otsh$EXE_EXT]]
  463.     set file [quoteIf [m4_path_name config $file]]
  464.         .main startCommand xtool "$otsh -f $file" "" \
  465.             "Starting '$comment'" {1 0} 0
  466. }
  467.  
  468. proc endForkOnlineDoc {cmd} {
  469.     foreach exitStatus [.main exitStatusList] {
  470.     if $exitStatus {
  471.         wmtkerror "Starting Online Documentation Program '$cmd' failed."
  472.         break
  473.     }
  474.    }
  475. }
  476.  
  477. proc forkOnlineDoc {cmd} {
  478.     require systemutil.tcl
  479.     SystemUtilities::fork otk watchdog "[get_comm_name]" $cmd \
  480.         "endForkOnlineDoc [list $cmd]"
  481. }
  482.