home *** CD-ROM | disk | FTP | other *** search
/ PC World 1998 October / PCWorld_1998-10_cd.bin / software / prehled / komix / DATA.Z / guiclassin.tcl < prev    next >
Text File  |  1996-12-12  |  5KB  |  171 lines
  1. #---------------------------------------------------------------------------
  2. #
  3. # Copyright (c) 1996 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 Cayenne Software Inc.
  13. #
  14. #---------------------------------------------------------------------------
  15. #
  16. #    File        : @(#)guiclassin.tcl    /main/titanic/3
  17. #    Author        : 
  18. #    Original date    : 30-7-1996
  19. #    Description    :
  20. #
  21. #---------------------------------------------------------------------------
  22. #
  23.  
  24. # Note: this class needs libsql.tcl to be required first!
  25.  
  26. Class GuiClassInfo : {GCObject} {
  27.     constructor
  28.     method destructor
  29.     method init
  30.     method printInfo
  31.     attribute guiClass
  32.     attribute refClassName
  33.     attribute refClass
  34.     attribute refClassHierarchy
  35.     attribute refColumns
  36.     attribute initStatus
  37. }
  38.  
  39. constructor GuiClassInfo {class this guiClass} {
  40.         set this [GCObject::constructor $class $this]
  41.     $this initStatus [$this init $guiClass]
  42.         return $this
  43. }
  44.  
  45. method GuiClassInfo::destructor {this} {
  46. }
  47.  
  48. # Initialize:
  49. # - guiClass: the guiClass
  50. # - refClass: the class referred by the guiClass
  51. # - refClassHierarchy: all classes (in hierachical order) having data
  52. #   attributes referred by data attributes of the guiClass; the first class in
  53. #   this list always is the rootclass
  54. # - refColumns: the columns corresponding with the data attributes of the
  55. #   guiClass
  56. #
  57. method GuiClassInfo::init {this guiClass} {
  58.     $this guiClass $guiClass
  59.     $this refClassName ""
  60.     $this refClass ""
  61.     $this refClassHierarchy ""
  62.     $this refColumns ""
  63.  
  64.     # init refClass ...
  65.     #
  66.     set refClassName [$guiClass getPropertyValue "referred_class"]
  67.     if {$refClassName == ""} {
  68.         puts "ERROR: Property 'Referred Class' of gui-class\
  69.             [$guiClass getName] not set."
  70.         return -1
  71.     }
  72.     $this refClassName $refClassName
  73.     set refClass [[$guiClass ooplModel] classByName $refClassName]
  74.     if {$refClass == ""} {
  75.         puts "ERROR: Class '$refClassName' referred by gui-class\
  76.             '[$guiClass getName]' not found."
  77.         return -1
  78.     }
  79.     $this refClass $refClass
  80.     if {![$refClass isPersistent]} {
  81.         puts "ERROR: Class '$refClassName' referred by gui-class\
  82.             '[$guiClass getName]' is not persistent."
  83.         return -1
  84.     }
  85.  
  86.     # init refClassHierarchy and refColumns ...
  87.     #
  88.     set retVal 0
  89.     set hier [get_hierarchy $refClass]
  90.     foreach cl $hier {
  91.         if {[$cl isPersistent]} {
  92.             foreach attr [$cl dataAttrSet] {
  93.                 set attr2Class([$attr getName]) $cl
  94.                 set attr2Col([$attr getName]) [$attr column]
  95.                 if {![$attr isNullable]} {
  96.                     set notNullCols([$attr column]) $attr
  97.                 }
  98.             }
  99.         } else {
  100.             puts "ERROR: Superclass '[$cl getName]' of persistent\
  101.                 class '$refClassName' is not persistent"
  102.             set retVal -1
  103.         }
  104.     }
  105.     set rootClass [lindex $hier 0]
  106.     # default put all keys up front
  107.     if ![$rootClass isPersistent] {
  108.         set retVal -1
  109.         set refCols ""
  110.     } else {
  111.         set refCols [get_col_list [$rootClass table] KEYS]
  112.     }
  113.     set refClasses $rootClass
  114.     foreach attr [$guiClass dataAttrSet] {
  115.         set attrName [$attr getName]
  116.         if {![info exists attr2Class($attrName)]} {
  117.             puts "WARNING: Attribute '$attrName' of gui-class\
  118.                 '[$guiClass getName]' does not have a matching\
  119.                 attribute in referred class '$refClassName' or\
  120.                 one of its ancestors: it will be discarded."
  121.         } else {
  122.             set cl $attr2Class($attrName)
  123.             if {[lsearch -exact $refClasses $cl] == -1} {
  124.                 lappend refClasses $cl
  125.             }
  126.             # here it is sure attr2Col($attrName) exists too
  127.             set col $attr2Col($attrName)
  128.             if {[lsearch -exact $refCols $col] == -1} {
  129.                 lappend refCols $col
  130.             }
  131.         }
  132.     }
  133.     # look for not referred not-nullable attributes
  134.     if {[info exists notNullCols]} {
  135.         foreach col [array names notNullCols] {
  136.         if {[lsearch -exact $refCols $col] == -1} {
  137.             set attr $notNullCols($col)
  138.             puts "ERROR: Not nullable attribute '[$attr getName]'\
  139.             of class '[[$attr ooplClass] getName]' is not\
  140.             referred in gui-class '[$guiClass getName]'."
  141.             set retVal -1
  142.         }
  143.         }
  144.     }
  145.  
  146.     foreach cl $hier {
  147.         if {[lsearch -exact $refClasses $cl] != -1} {
  148.             lappend refClassHierarchy $cl
  149.         }
  150.     }
  151.     $this refClassHierarchy $refClassHierarchy
  152.     $this refColumns $refCols
  153.  
  154.     return $retVal
  155. }
  156.  
  157. method GuiClassInfo::printInfo {this} {
  158.     puts "*** Start GuiClassInfo ***"
  159.         puts "guiClass:        [$this guiClass] ('[[$this guiClass] getName])'"
  160.         puts "refClass:        [$this refClass] ('[$this refClassName]')"
  161.         puts "refClassHierarchy:"
  162.     foreach cl [$this refClassHierarchy] {
  163.         puts "            $cl ('[$cl getName]')"
  164.     }
  165.         puts "refColumns:        "
  166.     foreach col [$this refColumns] {
  167.         puts "            $col ('[$col getUniqueName]')"
  168.     }
  169.     puts "*** End GuiClassInfo ***"
  170. }
  171.