home *** CD-ROM | disk | FTP | other *** search
/ PC World 1998 October / PCWorld_1998-10_cd.bin / software / prehled / komix / DATA.Z / wmt_util.tcl < prev    next >
Text File  |  1997-07-14  |  11KB  |  413 lines
  1. #---------------------------------------------------------------------------
  2. #
  3. # Copyright (c) 1992-1995 by Cadre Technologies 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        : @(#)wmt_util.tcl    /main/titanic/6 (1.8)
  17. #    Original date    : Wed Aug  5 12:04:46 MET DST 1992
  18. #    Description    : Cadre TCL utilities
  19. #
  20. #---------------------------------------------------------------------------
  21. #
  22. # @(#)wmt_util.tcl    /main/titanic/6 14 Jul 1997 Copyright 1992-1995 Cadre Technologies Inc.
  23. #
  24. #---------------------------------------------------------------------------
  25.  
  26. require caynutil.tcl
  27. require fstorage.tcl
  28. require libsql_msg.tcl
  29. require tdbop_msg.tcl
  30.  
  31. # This proc is still defined for compatibility reasons
  32. proc find_file_types {} {
  33. }
  34.  
  35. #
  36. # topological sort, input 'dep_list' output 'sorted_list', 'unsortables'
  37. #
  38. # (a topological sort algorithm of the famous Ellis Horowitz.)
  39. #
  40. # 'dep_list' is an array indexed by (sort-object) name
  41. # an array element is a list with the first element being a count
  42. # on how many other objects this object depends.
  43. # the rest of the list enumerates the objects which depend
  44. # on his one.
  45. # e.g.  obj1: { 0 obj2 obj3 obj4 } means
  46. #    object 1 does not depend on any other object
  47. #    object 2, 3 and 4 depend on object 1
  48. # e.g.  obj5: { 3 }
  49. #    object 5 depends on three other objects,
  50. #    no other object depends on object 5
  51. #
  52. # 'sorted_list' is a list of object names that can be sorted
  53. # 'unsortables' is a list of object names that cannot be sorted due to one or
  54. #  more cycles
  55. #
  56.  
  57. proc topo_sort {dep_list sl us} {
  58.     upvar $dep_list dep
  59.     upvar $sl sorted_list
  60.     upvar $us unsortables
  61.     set top 0
  62.     set sorted_list ""
  63.     set unsortables ""
  64.  
  65. #   create a linked stack of nodes with no predecessors
  66. #   i.e. nodes with no dependency
  67.  
  68.     foreach index [array names dep] {
  69.     if {[lindex $dep($index) 0]==0} {
  70.         lvarpop dep($index)
  71.         set dep($index) [linsert $dep($index) 0 $top]
  72.         set top $index
  73.     }
  74.     }
  75.  
  76. #   fill 'sorted' in topological order
  77.  
  78.     foreach index [array names dep] {
  79.     if {$top==0} {
  80.         set unsortables [array names dep]
  81.         return
  82.     }
  83.     set j $top
  84.     set top [lindex $dep($top) 0]
  85.  
  86.     lappend sorted_list $j
  87.  
  88.     set links [lrange $dep($j) 1 end]
  89.     while {![lempty $links]} {
  90.         set elem [lvarpop links]
  91.         set count [expr {[lvarpop dep($elem)] - 1}]
  92.         set dep($elem) [linsert $dep($elem) 0 $count]
  93.  
  94.         if {$count==0} {
  95.         lvarpop dep($elem)
  96.         set dep($elem) [linsert $dep($elem) 0 $top]
  97.         set top $elem
  98.         }
  99.     }
  100.     catch {unset dep($j)}
  101.  
  102.     }
  103.     return
  104. }
  105.  
  106. #
  107. # Search for file 'file' with type 'type' in system 'System' and
  108. # yank the contents of the file into the current section
  109. #
  110.  
  111. proc @include {file type {System ""} {Phase ""}} {
  112.  
  113.     # Global array containing the already included files
  114.     #
  115.     global included_files
  116.     upvar current_section current_section
  117.  
  118.     if { $current_section == ""} {
  119.         m4_error $E_TCL_NO_SECTION "@include"
  120.     }
  121.  
  122.     set clientCont [ClientContext::global]
  123.     set orgSys [$clientCont levelNameAt System]
  124.     set orgPhase [$clientCont levelNameAt Phase]
  125.  
  126.     #set orgSys [OTShContext::getSystemName]
  127.     #set orgPhase [OTShContext::getPhaseName]
  128.  
  129.     if { $Phase == ""} {
  130.         set Phase $orgPhase
  131.     }
  132.  
  133.     if { $System == "" } {
  134.         set System $orgSys
  135.     }
  136.  
  137.     if { $System != $orgSys} {
  138.         if {[catch {fstorage::goto_system $System $Phase} reason]} {
  139.             puts stderr $reason
  140.             return
  141.         }
  142.         }
  143.  
  144.     #
  145.     # Check if the file does exist
  146.     #
  147.  
  148.     set line_nr [$current_section lineNr]
  149.     if {[catch {set fp [fstorage::get_uenv_path $file.$type absolute]}]} {
  150.         m4_error $E_NO_INCL $line_nr $type $file $System
  151.         if { $System != $orgSys} {
  152.             fstorage::goto_system $orgSys $orgPhase
  153.         }
  154.         return
  155.     }
  156.  
  157.     if { [get included_files($fp)] == 1 } {
  158.         return
  159.     } else {
  160.         set included_files($fp) 1
  161.     }
  162.     #
  163.     # Return to the original system
  164.     #
  165.     if { $System != $orgSys} {
  166.         fstorage::goto_system $orgSys $orgPhase
  167.     }
  168.     #
  169.     # Yank the contents of the include file into the current section
  170.     #
  171.     set txt ""
  172.     read_file_into_text $fp txt
  173.     expand_text $current_section "$txt" current_section $current_section
  174.     return
  175. }
  176.  
  177. proc string_to_oopl_comment {section str {commentIndicator "--"}} {
  178.     set lines [split $str "\n"]
  179.  
  180.     foreach line $lines {
  181.         $section append "$commentIndicator $line\n"
  182.     }
  183. }
  184.  
  185. proc file_to_oopl_comment {section file {commentIndicator "--"}} {
  186.     if [catch {set fd [open $file r]}] {
  187.         return
  188.     }
  189.     if {$fd == ""} {
  190.         return
  191.     }
  192.     set string [read $fd nonewline]
  193.     close $fd
  194.  
  195.     string_to_oopl_comment $section $string $commentIndicator
  196. }
  197.  
  198. # rm -rf function with verbose option
  199. # requires extended Tcl commands 'unlink' and 'rmdir'
  200.  
  201. proc rm_rf {entries {verbose 0}} {
  202.     foreach e $entries {
  203.         if [file isdirectory $e] {
  204.             rm_rf [glob $e/*] $verbose
  205.             if $verbose {
  206.                 puts "rmdir $e"
  207.             }
  208.             rmdir -nocomplain $e
  209.         } else {
  210.             if {$verbose && [file exists $e]} {
  211.                 puts "rm $e"
  212.             }
  213.             unlink -nocomplain $e
  214.         }
  215.     }
  216. }
  217.  
  218. #
  219. # Test whether the contents of a section equals the contents of a file
  220. #
  221. proc section_equals_file {sect file} {
  222.     if [catch {set fd [fstorage::open $file r]}] {
  223.         return 0
  224.     }
  225.     if {$fd == ""} {
  226.         return 0
  227.     }
  228.     set result [string compare [$sect contents] [read $fd]]
  229.     fstorage::close $fd
  230.     return [expr {$result == 0}]
  231. }
  232.  
  233. #
  234. # Returns a new section with the contents of oldSect where double lines are
  235. # removed.
  236. # Note: empty lines are not removed.
  237. #
  238. proc removeDoubleLinesFromSection {oldSect} {
  239.     set lst [split [$oldSect contents] "\n"]
  240.  
  241.     # remove double elements
  242.     for {set i 0} {$i < [llength $lst]} {incr i} {
  243.         for {set j [expr [llength $lst] - 1]} {$j > $i} {incr j -1} {
  244.             if {[lindex $lst $i] == ""} {
  245.                 # keep empty lines
  246.                 continue
  247.             }
  248.             if {[lindex $lst $i] == [lindex $lst $j]} {
  249.                 set lst [lreplace $lst $j $j]
  250.                 incr j -1
  251.             }
  252.         }
  253.     }
  254.  
  255.     # put in new section
  256.     set newSect [TextSection new]
  257.     $newSect append [join $lst "\n"]
  258.     return $newSect
  259. }
  260.  
  261. #
  262. # Proc getPartString is used by proc padString.
  263. # It returns a part of $str starting at $startIdx.
  264. # The length of the returned string is $maxLen characters, or less in which
  265. # case it was truncated after the space character closest to index $maxLen.
  266. # startIdx is set to the index at which the partial string was truncated.
  267. #
  268. proc getPartString {str startIdx maxLen} {
  269.     upvar $startIdx start
  270.     set end [expr $start + $maxLen - 1]
  271.  
  272.     set restStr [string range $str $start end]
  273.     if {[string length $restStr] <= $maxLen} {
  274.         set start [string length $str]
  275.         return $restStr
  276.     }
  277.     set partStr [string range $restStr 0 [expr $maxLen - 1]]
  278.     set idx [string last " " $partStr]
  279.     if {$idx == -1 || [string index $str [expr $end + 1]] == " "} {
  280.         set start [expr $end + 1]
  281.         return $partStr
  282.     }
  283.     set partStr [string range $partStr 0 $idx]
  284.     set start [expr $start + $idx + 1]
  285.     return $partStr
  286. }
  287.  
  288. #
  289. # Proc padString first concatenates $beginStr, $str and $endStr.
  290. # This string is padded with $padStr at intervals with a maximum length $maxLen.
  291. # The resulting string is returned.
  292. #
  293. proc padString {beginStr str endStr padStr {maxLen 80}} {
  294.     set totalStr $beginStr$str$endStr
  295.     set length [string length $totalStr]
  296.  
  297.     set startIdx 0
  298.     set newStr [getPartString $totalStr startIdx $maxLen]
  299.     while {$startIdx < $length} {
  300.         set partStr [getPartString $totalStr startIdx $maxLen]
  301.         set newStr $newStr$padStr$partStr
  302.     }
  303.     return $newStr
  304. }
  305.  
  306. #
  307. # To make a proper selection of the oopl classes the get_selected_classes
  308. # procedure can be used.
  309. # This function takes a list of sources as argument.
  310. # Sources can be class names or diagrams
  311. #
  312.  
  313. proc getSelectedOoplClasses {ooplModel {sources ""}} {
  314.     global ooplClassFilter
  315.     global ooplExclClassFilter
  316.     set classes ""
  317.  
  318.     if {$sources == ""} {
  319.     set sources $ooplClassFilter
  320.     }
  321.  
  322.     if {$sources == ""} {
  323.     foreach className [$ooplModel getClassNames] {
  324.         if {[lsearch $classes $className] == -1 &&
  325.         [lsearch $ooplExclClassFilter $className] == -1} {
  326.             lappend classes $className
  327.         }
  328.     }
  329.     } else {
  330.     foreach source $sources {
  331.         if {[string first "." $source] == -1} {
  332.         #  obj is a class
  333.         if {[lsearch $classes $source] == -1 &&
  334.             [lsearch $ooplExclClassFilter $source] == -1} {
  335.             lappend classes $source
  336.         }
  337.         } else {
  338.         foreach class [get_diagram_classes $source] {
  339.             if {[lsearch $classes $class] == -1} {
  340.             lappend classes $class
  341.             }
  342.         }
  343.         if {[lindex [split $source '.'] 1] == "std" } {
  344.             set stdName [lindex [split $source '.'] 0]
  345.             if {[lsearch $classes $stdName] == -1 } {
  346.             lappend classes [lindex [split $stdName '/'] 0]
  347.             }
  348.         }
  349.         }
  350.     }
  351.     }
  352.  
  353.     set ooplClasses ""
  354.  
  355.     foreach sourceClass $classes {
  356.     if {$sourceClass == ""} {
  357.         puts stderr "Skipping class '$sourceClass'"
  358.         continue
  359.     }
  360.  
  361.     set class [$ooplModel classByName $sourceClass]
  362.  
  363.     if {$class == ""} {
  364.         puts stderr "Unable to load class '$sourceClass'"
  365.         continue
  366.     }
  367.  
  368.     if {[lsearch $ooplClasses $class] == -1 &&
  369.         [lsearch $ooplExclClassFilter $class] == -1} {
  370.         lappend ooplClasses $class
  371.     }
  372.     }
  373.  
  374.     return $ooplClasses
  375. }
  376.  
  377. proc getSelectedOoplSubjects {ooplModel {sources ""}} {
  378.     global ooplClassFilter
  379.  
  380.     set subjects ""
  381.  
  382.     if {$sources == ""} {
  383.     set sources $ooplClassFilter
  384.     }
  385.  
  386.     foreach source $sources {
  387.     if {[string first "." $source] != -1} {
  388.         #  obj is a class
  389.         lappend subjects [get_diagram_subjects $source]
  390.     }
  391.     }
  392.  
  393.     set ooplSubjects ""
  394.  
  395.     foreach subject [$ooplModel subjectSet] {
  396.     if {[lsearch $ooplSubjects [$subject getName]] != -1} {
  397.         lappend ooplSubjects $subject
  398.     }
  399.     }
  400.  
  401.     return $ooplSubjects
  402. }
  403.  
  404. proc getCurrentSystemName {} {
  405.     set clientCont [ClientContext::global]
  406.     set currentSystem [$clientCont currentSystem]
  407.     if ![$currentSystem isNil] {
  408.     return [[$currentSystem system] name]
  409.     } else {
  410.     return ""
  411.     }
  412. }
  413.