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