home *** CD-ROM | disk | FTP | other *** search
/ PC World 1997 November / PCWorld_1997-11_cd.bin / software / programy / komix / DATA.Z / classes.tcl < prev    next >
Encoding:
Text File  |  1997-06-03  |  7.7 KB  |  304 lines
  1. #---------------------------------------------------------------------------
  2. #
  3. #    (c) Cadre Technologies Inc. 1995
  4. #
  5. #    File:        @(#)classes.tcl    /main/hindenburg/8
  6. #    Author:        Harm Leijendeckers
  7. #    Description:    Report on classes
  8. #    Usage in:    SystemVersion and CAD editor
  9. #
  10. #---------------------------------------------------------------------------
  11. # SccsId = @(#)classes.tcl    /main/hindenburg/8    3 Jun 1997    Copyright 1995 Cadre Technologies Inc.
  12.  
  13.  
  14. eval [$cc getCustomFileContents semanticbase tcl reports]
  15.  
  16.  
  17. Class ReportClasses : {SemanticBase} {
  18.     constructor
  19.     method doReport
  20.  
  21.     method getItemName
  22.     method showProps
  23.  
  24.     method classProps
  25.     method attrProps
  26.     method methodProps
  27.  
  28.     attribute maxPropNameLength
  29. }
  30.  
  31.  
  32. constructor ReportClasses {class this} {
  33.     set this [SemanticBase::constructor $class $this]
  34.     $this reportName Classes
  35.  
  36.     # calculate max length op property name for a good format in showProps
  37.     set max 0
  38.     foreach propName [concat [$this classProps] \
  39.                  [$this attrProps]  \
  40.                  [$this methodProps]] {
  41.     set len [string length $propName]
  42.     if { $len > $max } {
  43.         set max $len
  44.     }
  45.     }
  46.     $this maxPropNameLength $max
  47.  
  48.     return $this
  49. }
  50.  
  51.  
  52. method ReportClasses::doReport {this model} {
  53.     # get all CAD Classes
  54.     set classes [$model getSMObjects $OMT_CAD_CB_Class]
  55.     set classItems [flatten [query -s getItem "getItem != [ORB::nil]" $classes]]
  56.     if [lempty $classItems] { return 0 }
  57.  
  58.     set class_props [lvarpop Options]
  59.     set attribute_props [lvarpop Options]
  60.     set method_props [lvarpop Options]
  61.     set report [$this report]
  62.     set cv [$this configV]
  63.     set pv [$this phaseV]
  64.     set sv [$this systemV]
  65.     if ![$sv isNil] {
  66.     set allCdms [query "file.type == cdm" $sv.localFileVersions]
  67.     } else {
  68.     set allCdms [query "file.type == cdm" \
  69.         $pv.systemVersions.localFileVersions]
  70.     }
  71.     set qoAllCdms [QueryObject new allCdms file.name]
  72.  
  73.     foreach classItem [osort name -nocase $classItems] {
  74.     set name [$classItem name]
  75.     set cdm [query "file.name == \"$name\"" $qoAllCdms]
  76.     if [lempty $cdm] {
  77.         $pv getDecompositions $classItem $cv decompFiles {cdm} dummy cdm
  78.     }
  79.  
  80.     set classDescription ""
  81.     append classDescription "Class $name"
  82.     if ![lempty $cdm] {
  83.         if { [$cdm status] == "reused" } {
  84.         append classDescription "(reused) "
  85.         }
  86.         if [$cdm inCorporate] {
  87.         append classDescription " (in corporate)"
  88.         }
  89.     }
  90.  
  91.     $report print $classDescription\: line
  92.     $report print = [string length $classDescription] fill line
  93.  
  94.     set classWi [$pv findDefinition $classItem $cv]
  95.     $report space 2
  96.     $report print "scope" [$this maxPropNameLength]
  97.     $report print ": "
  98.     if ![$classWi isNil] {
  99.         set scope [$classWi scope]
  100.         regsub -all scope [$classWi scope] "" scope
  101.         $report print $scope
  102.  
  103.         set owner [$classWi owner]
  104.         if { $owner != $sv } {
  105.         $report print " (defined in [$owner text])"
  106.         }
  107.     } else {
  108.         $report print "PhaseRef (no definition)"
  109.     }
  110.     $report line
  111.  
  112.     # print class properties if given
  113.     #
  114.     if ![lempty [$this classProps]] {
  115.         if { ![$classWi isNil] && ![[$classWi properties] isNil] } {
  116.         $this showProps [[$classWi properties] properties] \
  117.             [$this classProps] 2
  118.         }
  119.     }
  120.  
  121.     # print empty line between class name and attributes
  122.     $report line
  123.  
  124.     # stop with class if no cdm found
  125.     if [lempty $cdm] {
  126.         $report print "    No cdm found." line
  127.         $report line
  128.         $report line
  129.         continue
  130.     }
  131.  
  132.     # print cdm
  133.     $cdm loadRowData {{name_type}} rowDataList
  134.     set label_attr 0
  135.     set label_meth 0
  136.     foreach rowData $rowDataList {
  137.         set row          [lvarpop rowData]
  138.         set rowItems     [lvarpop rowData]
  139.         set rowProps     [lvarpop rowData]
  140.         set cellDataList [lvarpop rowData]
  141.         set type [$row type]
  142.         
  143.         # print Attributes: or Operations:
  144.         if { !$label_attr && $type == "attribute" } {
  145.         $report print "    Attributes:" line
  146.         $report print "    ----------" line
  147.         set label_attr 1
  148.         } else {
  149.         if { !$label_meth && $type == "method" } {
  150.             $report print "    Operations:" line
  151.             $report print "    ----------" line
  152.             set label_meth 1
  153.         }
  154.         }
  155.  
  156.         set name_item [query "type != cl" $rowItems]
  157.         set type_item [query "type == cl" $rowItems]
  158.         set row_name [$this getItemName $name_item]
  159.         set row_type [$this getItemName $type_item]
  160.  
  161.         $report space 8
  162.         # $
  163.         set icf [query "name == is_class_feature && value == 1" $rowProps]
  164.         if ![lempty $icf] {
  165.         $report print "$"
  166.         }
  167.  
  168.         set ikey [query "name == key && value == 1" $rowProps]
  169.         if ![lempty $ikey] {
  170.         $report print "*"
  171.         }
  172.  
  173.         set ider [query "name == is_derived && value == 1" $rowProps]
  174.         if ![lempty $ider] {
  175.         $report print "/"
  176.         }
  177.  
  178.         # name
  179.         $report print $row_name
  180.  
  181.         # args if it's a method
  182.         if { $type == "method" } {
  183.         set hpl [query "name == has_parmlist && value == 1" $rowProps]
  184.         if { $row_name == "create" && ![lempty $icf] && [lempty $hpl]} {
  185.             $report line
  186.             continue
  187.         }
  188.  
  189.         $report print (
  190.         set first 1
  191.         foreach cellData $cellDataList {
  192.             set cell      [lvarpop cellData]
  193.             set cellItems [lvarpop cellData]
  194.             set cellProps [lvarpop cellData]
  195.  
  196.             set cell_name_item [query "type != cl" $cellItems]
  197.             set cell_type_item [query "type == cl" $cellItems]
  198.  
  199.             if !$first {
  200.             $report print ", "
  201.             } else {
  202.             set first 0
  203.             }
  204.  
  205.             $report print [$this getItemName $cell_name_item]
  206.             $report print " : "
  207.             $report print [$this getItemName $cell_type_item]
  208.         }
  209.         $report print )
  210.         }
  211.  
  212.         if ![lempty $row_type] {
  213.         $report print " : "
  214.  
  215.         # type
  216.         $report print [$this getItemName $type_item]
  217.         }
  218.  
  219.         # initial value
  220.         set ival [query -s value "name == initial_value" $rowProps]
  221.         if ![lempty $ival] {
  222.         $report print " = $ival"
  223.         }
  224.  
  225.         $report line
  226.  
  227.         # print attribute properties if given
  228.         #
  229.         if { ![lempty [$this attrProps]] && $type == "attribute" } {
  230.         set wi [$pv findDefinition $name_item $cv]
  231.         if ![$wi isNil] {
  232.             $this showProps "[[$wi properties] properties] $rowProps" \
  233.                     [$this attrProps] 16
  234.         }
  235.         }
  236.         # print method properties if given
  237.         #
  238.         if { ![lempty [$this methodProps]] && $type == "method" } {
  239.         set wi [$pv findDefinition $name_item $cv]
  240.         if ![$wi isNil] {
  241.             $this showProps "[[$wi properties] properties] $rowProps" \
  242.                     [$this methodProps] 16
  243.         }
  244.         }
  245.  
  246.         # print empty line between every attribute and method
  247.         $report line
  248.     }
  249.  
  250.     $report line
  251.     }
  252.  
  253.     if { [[$executeMe report] pageno] || [[$executeMe report] lineno] } {
  254.     $report page
  255.     }
  256.  
  257.     return 0
  258. }
  259.  
  260.  
  261. method ReportClasses::getItemName {this item} {
  262.     if ![lempty $item] {
  263.     return [$item name]
  264.     }
  265. }
  266.  
  267.  
  268. method ReportClasses::showProps {this properties propNames spaces} {
  269.     if [lempty $properties] {
  270.     return
  271.     }
  272.     set report [$this report]
  273.     foreach prop [query "name in {$propNames}" $properties] {
  274.     $report space $spaces
  275.     $report print [$prop name] [$this maxPropNameLength] break
  276.     $report print ": "
  277.     $report print [$prop value] 99 line
  278.     }
  279. }
  280.  
  281.  
  282. # Note: Next three methods define which properties are printed for each
  283. #       class, attribute and method and the order in which they are shown.
  284. #       Add or remove a short property name to change the report.
  285.  
  286.  
  287. method ReportClasses::classProps {this} {
  288.     return "freeText persistent abbrev class_source include_list"
  289. }
  290.  
  291.  
  292. method ReportClasses::attrProps {this} {
  293.     return "freeText abbrev attrib_access nullable"
  294. }
  295.  
  296.  
  297. method ReportClasses::methodProps {this} {
  298.     return "freeText method_access method_impl is_dyn_bound is_const_func \
  299.         modifier"
  300. }
  301.  
  302.  
  303. set executeMe [ReportClasses new]
  304.