home *** CD-ROM | disk | FTP | other *** search
/ PC World 1998 October / PCWorld_1998-10_cd.bin / software / prehled / komix / DATA.Z / caynutil.tcl < prev    next >
Text File  |  1997-11-27  |  10KB  |  449 lines
  1. #---------------------------------------------------------------------------
  2. #
  3. # Copyright (c) 1992-1997 by Cayenne Software, Inc.
  4. #
  5. # This software is furnished under a license and may be used only in
  6. # accordance with the terms of such license and with the inclusion of
  7. # the above copyright notice. This software or any other copies thereof
  8. # may not be provided or otherwise made available to any other person.
  9. # No title to and ownership of the software is hereby transferred.
  10. #
  11. # The information in this software is subject to change without notice
  12. # and should not be construed as a commitment by Cadre Technologies Inc.
  13. #
  14. #---------------------------------------------------------------------------
  15. #
  16. #    File        : @(#)caynutil.tcl    /main/titanic/13
  17. #    Original date    : Wed Aug  5 12:04:46 MET DST 1992
  18. #    Description    : Cayenne TCL utilities
  19. #              Basic utilities, should not use TCL procs defined
  20. #              in other files !!!
  21. #
  22. #---------------------------------------------------------------------------
  23. #
  24. # @(#)caynutil.tcl    /main/titanic/13    27 Nov 1997 Copyright 1992-1997 Cayenne Software, Inc.
  25. #
  26. #---------------------------------------------------------------------------
  27.  
  28. require cayn_msg.tcl
  29.  
  30. #
  31. # Procedure to reset the result to ""
  32. #
  33.  
  34. proc null {} {}
  35.  
  36. #
  37. # The Unix date command implemented in Tcl
  38. #
  39.  
  40. proc date {} {
  41.     return [clock format [clock seconds]]
  42. }
  43.  
  44. #
  45. # Return the name part of name.type
  46. #
  47.  
  48. proc nt_get_name {name} {
  49.     regsub {\.[^.]*$} $name "" name
  50.     return $name
  51. }
  52.  
  53. #
  54. # Return the type part of name.type
  55. #
  56.  
  57. proc nt_get_type {fullname} {
  58.     if {[regsub {.*\.} $fullname "" type]} {
  59.         return [get type]
  60.     }
  61.     return ""
  62. }
  63.  
  64. #
  65. # Print the contents of variable s on the standard output stream
  66. #
  67.  
  68. proc echo {s} {
  69.     puts stdout $s
  70. }
  71.  
  72. #
  73. # Print the contents of errorInfo on the standard output stream
  74. #
  75.  
  76. proc perror {} {
  77.     echo $errorInfo
  78. }
  79.  
  80. #
  81. # Read the contents from a file into a Tcl string
  82. #
  83.  
  84. proc read_file_into_text {path text} {
  85.     upvar $text txt
  86.  
  87.     if {![file exists $path]} {
  88.         m4_error $E_EXIST_FILE $path
  89.         return 0
  90.     }
  91.  
  92.     set fd [open $path "r"]
  93.     set txt [read $fd]
  94.     close $fd
  95.     return 1
  96. }
  97.  
  98. #
  99. # capitalize the first letter of a string
  100. #
  101.  
  102. proc cap {str} {
  103.     set ch [string toupper [string index $str 0]]
  104.     return "$ch[string range $str 1 end]"
  105. }
  106.  
  107. #
  108. # uncapitalize the first letter of a string
  109. #
  110.  
  111. proc uncap {str} {
  112.     set ch [string tolower [string index $str 0]]
  113.     return "$ch[string range $str 1 end]"
  114. }
  115.  
  116. #
  117. # For all words separated by underscores in s, create a string
  118. # where all these words are capitalized and separated by spaces.
  119. #
  120. proc cap_underscores {s} {
  121.     set new ""
  122.     foreach word [split $s _] {
  123.         if ![lempty $new] {
  124.             append new " "
  125.         }
  126.         append new [cap $word]
  127.     }
  128.     return $new
  129. }
  130.  
  131. #
  132. # Copy a file
  133. #
  134.  
  135. proc copy_text_file {from to} {
  136.     set max 8092
  137.     set in [open $from r]
  138.     set out [open $to w]
  139.  
  140.     while {[set result [read $in $max]] != ""} {
  141.         puts $out $result nonewline
  142.     }
  143.  
  144.     close $in
  145.     close $out
  146. }
  147.  
  148. #
  149. # Function to show proc invocations, activated using option "-trace"
  150. #
  151.  
  152. proc trace_call {call obj args} {
  153.     global tracing
  154.  
  155.     if {$tracing == 1} {
  156.         puts -nonewline "    >>> [$obj get_obj_type]::$call '"
  157.  
  158.         if [catch {puts -nonewline "[$obj getName]"}] {
  159.         puts -nonewline "<unnamed>"
  160.         }
  161.  
  162.         puts "' $args"
  163.     }
  164. }
  165.  
  166. #
  167. # Append one or more strings to the given list only if it was not
  168. # already present.  Has exactly the same calling interface as the builtin
  169. # 'lappend'.
  170. #
  171. # Returns the new list
  172. #
  173.  
  174. proc lappend_unique {l args} {
  175.     upvar $l list
  176.  
  177.     foreach s $args {
  178.         if {[lsearch -exact $list $s] == -1} {
  179.         lappend list $s
  180.         }
  181.     }
  182.  
  183.     return $list
  184. }
  185.  
  186. #
  187. # Reverse the given list and return it.
  188. #
  189. proc listReverse {list} {
  190.     set rev {}
  191.     foreach e $list {
  192.         set rev [linsert $rev 0 $e]
  193.     }
  194.     return $rev
  195. }
  196.  
  197. #
  198. # Subtract two lists: all elements that are in the
  199. # first list but not in the second list are returned.
  200. #
  201. proc listSubtract {first second} {
  202.     set diff {}
  203.     foreach e $first {
  204.         if {[lsearch $second $e] == -1} {
  205.             lappend diff $e
  206.         }
  207.     }
  208.     return $diff
  209. }
  210.  
  211. #
  212. # Expand customization file 'typeName'.hdr into TextSection 'sect';
  213. # 'fileName' is used to expand the variable $filename in the header.
  214. #
  215. proc expandHeaderIntoSection {fileName typeName sect} {
  216.     set clientContext [ClientContext::global]
  217.  
  218.     set proj [$clientContext currentProject]
  219.     set configV [$clientContext currentConfig]
  220.     set phaseV [$clientContext currentPhase]
  221.     set systemV [$clientContext currentSystem]
  222.  
  223.     if {![$proj isNil] } {
  224.         set projName [$proj name]
  225.     } else {
  226.         set projName unknown
  227.     }
  228.  
  229.     if {![$configV isNil] } {
  230.         set configName [[$configV config] name]
  231.         set configVersion [$configV versionNumber]
  232.     } else {
  233.         set configName unknown
  234.         set configVersion "?"
  235.     }
  236.  
  237.     if {![$phaseV isNil] } {
  238.         set phaseName [[$phaseV phase] name]
  239.         set phaseVersion [$phaseV versionNumber]
  240.     } else {
  241.         set phaseName unknown
  242.         set phaseVersion "?"
  243.     }
  244.  
  245.     if {![$systemV isNil] } {
  246.         set systemName [[$systemV system] name]
  247.         set systemVersion [$systemV versionNumber]
  248.     } else {
  249.         set systemName unknown
  250.         set systemVersion "?"
  251.     }
  252.  
  253.     set headerFile [BasicFS::tmpFile]
  254.  
  255.     $clientContext downLoadCustomFile $typeName hdr etc $headerFile
  256.     expand_file $sect $headerFile \
  257.             filename $fileName \
  258.             proj $proj \
  259.             configV $configVersion \
  260.             phaseV $phaseVersion \
  261.             systemV $systemVersion \
  262.             projName $projName \
  263.             configName $configName \
  264.             phaseName $phaseName \
  265.             systemName $systemName
  266.  
  267.     unlink $headerFile
  268. }
  269.  
  270. #
  271. # Find the name of the first (selected) module with a certain type
  272. #
  273. proc getModuleNameByType {typeName} {
  274.     set modh [ModuleHandler new]
  275.     $modh setCurrentContext
  276.     foreach mod [$modh moduleSpecSet] {
  277.         if [$mod selectState] {
  278.             if {[$mod type] == $typeName} {
  279.                 return [$mod name]
  280.             }
  281.         }
  282.     }
  283.     return ""
  284. }
  285.  
  286. #
  287. # Check whether the type is a legal diagram type
  288. #
  289. proc isLegalDiagType {type} {
  290.     switch -exact -- $type {
  291.         cad    -
  292.         ccd    -
  293.         cdm    -
  294.         cod    -
  295.         dfd    -
  296.         etd    -
  297.         mgd    -
  298.         std    -
  299.         ucd    {return 1}
  300.     }
  301.     return 0
  302. }
  303.  
  304.  
  305. proc otglob { args } {
  306.  
  307.     set argErr "wrong # args: should be \"otglob ?-esc <char>? ?switches? name ?name ...?\""
  308.  
  309.     if { [lempty $args] } {
  310.         error $argErr
  311.         return
  312.     }
  313.  
  314.     set command ""
  315.     set parsing 1
  316.     for { set i 0 } { $i < [llength $args] } { incr i } {
  317.  
  318.         set parm [lindex $args $i]
  319.  
  320.         if { $parm == "--" } { set parsing 0 }
  321.  
  322.         if { $parsing && [string first "-esc" $parm] != -1 } {
  323.             incr i
  324.             set escape [string index [lindex $args $i] 0]
  325.  
  326.             if { ![info exists escape] || [lempty $escape] } { 
  327.                 error "bad switch \"$parm\": must be -nocomplain, -esc <char> or --"
  328.                 return
  329.             }
  330.             continue
  331.         }
  332.  
  333.         if { [string first " " $parm] != -1 } {
  334.             # Excessive quoting needed to allow 'otglob "i:\\my dir\\*"'
  335.             set parm "{{$parm}}"
  336.         }
  337.  
  338.         if { [lempty $command] } {
  339.             set command $parm
  340.         } else {
  341.             set command "$command $parm"
  342.         }
  343.     }
  344.     if { ![info exists escape] || [lempty $escape] } { set escape # }
  345.  
  346.     if { [lempty $command] } {
  347.         error $argErr
  348.         return
  349.     }
  350.  
  351.     if { $tcl_platform(platform) == "windows" } {
  352.         regsub -all {\\} $command {/} command
  353.     } 
  354.  
  355.     regsub -all "$escape" $command {\\\\} command
  356.  
  357.     set catchResult [catch "eval glob $command" result]
  358.  
  359.     if { $tcl_platform(platform) == "windows" } {
  360.     set tmpResult ""
  361.     foreach file $result {
  362.         regsub -all {/} $file {\\} file
  363.         lappend tmpResult $file
  364.     }
  365.     set result $tmpResult
  366.     } 
  367.  
  368.     if { $catchResult == 1 } {
  369.         error "$result"
  370.     }
  371.     return $result
  372. }
  373.  
  374. #
  375. # Evaluate a script at the current procedure level.
  376. #
  377. # During evaluation, any backslashes in the variables named by
  378. # the stringRefs list are replaced by strings of the form @@@
  379. # to be able to do Tcl string manipulations safely.
  380. #
  381. # Both existing variables that contain backslashes and new variables
  382. # set by the script must be specified in the variable list.
  383. #
  384. # Example:
  385. #
  386. #   set cmd "d:\\bin\\command.exe d:\\dir\\file z:\\dir.z"
  387. #   protect_backslashes {cmd arg1} {set arg1 [lindex $cmd 1]}
  388. #   puts "$arg1"
  389. #
  390. # This will correctly print "d:\dir\file", which would not be
  391. # the case if this is done:
  392. #
  393. #   set cmd "d:\\bin\\command.exe d:\\dir\\file z:\\dir.z"
  394. #   set arg1 [lindex $cmd 1]
  395. #   puts "$arg1"
  396. #
  397. proc protect_backslashes {stringRefs script} {
  398.     foreach stringRefN $stringRefs {
  399.         upvar $stringRefN stringN
  400.     catch {regsub -all {\\} $stringN {@@@} stringN}
  401.     }
  402.  
  403.     set result [uplevel $script]
  404.  
  405.     foreach stringRefN $stringRefs {
  406.         upvar $stringRefN stringN
  407.     catch {regsub -all {@@@} $stringN {\\} stringN}
  408.     }
  409.  
  410.     return $result
  411. }
  412.  
  413. # try to find out if we have an object id
  414. # call example: isObjectId Corporate:Uj0DiRzQBN50W8wAAAGUAAQAAAAAA Corporate:
  415. #
  416. proc isObjectId {str {prefix ""}} {
  417.     set colon [string first : $str]
  418.     if {$colon == -1} {
  419.         # must contain a colon
  420.         return 0
  421.     }
  422.     if {$prefix != ""} {
  423.         set strL [string length $str]
  424.         set prefixL [string length $prefix]
  425.         incr strL -$prefixL
  426.         incr prefixL -1
  427.         if [string compare $prefix [string range $str 0 $prefixL]] {
  428.             return 0
  429.         }
  430.     } else {
  431.         incr colon
  432.         set strL [string length [string range $str $colon end]]
  433.     }
  434.     # id part must be 29 long
  435.     if {$strL != 29} {
  436.         return 0
  437.     }
  438.     if [catch {set decodeId [ORB::decodeObjectId $str]}] {
  439.         return 0
  440.     }
  441.     # second number must be between 100 and 1000
  442.     set secNum [lindex $decodeId 1]
  443.     if [expr (100<$secNum) && ($secNum<1000)] {
  444.         return 1
  445.     }
  446.     return 0
  447. }
  448.  
  449.