home *** CD-ROM | disk | FTP | other *** search
/ PC World 1998 October / PCWorld_1998-10_cd.bin / software / prehled / komix / DATA.Z / libmss.tcl < prev    next >
Text File  |  1997-03-20  |  6KB  |  211 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        : @(#)libmss.tcl    /main/titanic/1
  17. #    Original date    : November 1994
  18. #    Description    : Special procedures for the SQLServer target
  19. #
  20. #---------------------------------------------------------------------------
  21. #
  22. # @(#)libmss.tcl    /main/titanic/1 20 Mar 1997 Copyright 1992-1995 Cadre Technologies Inc.
  23. #
  24. #---------------------------------------------------------------------------
  25. require {mssql_msg.tcl}
  26.  
  27. #
  28. # Add extra column_selectors for target mss
  29. #
  30. global column_selector
  31. set column_selector(SERIAL)        {([$col getTypeStd] == "serial" &&
  32.                       [$col get_obj_type] != "imp_column")}
  33. set column_selector(ALL_NONSERIAL)    {[$col getTypeStd] != "serial" ||
  34.                      [$col get_obj_type] == "imp_column"}
  35. set column_selector(NONKEYS_NONSERIAL)    {[$col getColumnType] != "key" &&
  36.                      ([$col getTypeStd] != "serial" ||
  37.                      [$col get_obj_type] == "imp_column")}
  38. set column_selector(NONKEYFIELDS_NONSERIAL) {[$col get_obj_type] == "column" &&
  39.                          [$col getColumnType] != "key" &&
  40.                          [$col getTypeStd] != "serial"}
  41.  
  42. #
  43. # Global extra binding table
  44. #
  45. global bindingTable
  46. set bindingTable [DbBindTab::createTable]
  47.  
  48. proc get_bind_typestd { typeStd } {
  49.     set handle [$bindingTable getBinding $typeStd]
  50.     if { $handle == "" } {
  51.         m4_error $E_NOBINDENT $typeStd
  52.         set handle [$bindingTable getBinding "integer"]
  53.         if { $handle == "" } {
  54.             set handle [$bindingTable getBinding "int"]
  55.             if { $handle == "" } {
  56.                 m4_fatal $F_NODEFBIND
  57.             }
  58.         }
  59.     }
  60.     return $handle
  61. }
  62.  
  63. proc get_bind_entry { column } {
  64.     set type [$column getTypeStd]
  65.     if { [regsub {([^[]+)\[[0-9]*\]} $type {\1} typeStd] } {
  66.         set typeStd "${typeStd}\[\]"
  67.     }
  68.     return [get_bind_typestd $typeStd]
  69. }
  70.  
  71. proc get_format_char { column } {
  72.     return [[get_bind_entry $column] format]
  73. }
  74.  
  75. proc get_bind_type { column } {
  76.     return [[get_bind_entry $column] binding]
  77. }
  78.  
  79. proc mss_gen_compare {sect table { selector "" } \
  80.         {pre1 ""} {post1 ""} {pre2 ""} {post2 ""} {seperator ", "} \
  81.         {newline ""} { master_table "" } { dbproc "dbproc"} } {
  82.  
  83.     set columns [ get_col_list $table $selector $master_table]
  84.  
  85.     while {! [lempty $columns] } {
  86.         set col [lvarpop columns]
  87.         set col_nm [$col getUniqueName]
  88.  
  89.         $sect append "dbfcmd($dbproc,\"$pre1$col_nm$post1="
  90.         $sect append "[get_format_char $col]"
  91.         if {! [lempty $columns] } {
  92.             $sect append $seperator
  93.         }
  94.         $sect append "$newline\",$pre2$col_nm$post2);\n"
  95.     }
  96. }
  97.  
  98. proc mss_gen_compare_cl {sect link {pre1 ""} {post1 ""} \
  99.             {pre2 ""} {post2 ""} {seperator ", "}
  100.             {newline ""} { dbproc "dbproc" }} {
  101.  
  102.     if { [ $link getLinkType] == "export" }  {
  103.         set link [ $link friendLink]
  104.     }
  105.  
  106.     set columns [ $link columnSet ]
  107.  
  108.     while {! [lempty $columns] } {
  109.         set col [lvarpop columns]
  110.         set tcol_nm [$col getUniqueName]
  111.         set mcol_nm [$col getForeignName]
  112.  
  113.         $sect append "dbfcmd($dbproc,\"$pre1$tcol_nm$post1="
  114.         $sect append "[get_format_char $col]"
  115.         if {! [lempty $columns] } {
  116.             $sect append $seperator
  117.         }
  118.         $sect append "$newline\",$pre2$mcol_nm$post2);\n"
  119.     }
  120. }
  121.  
  122. proc mss_gen_binding { sect link { pre ""} { post "" } { selector "ALL" } \
  123.              { master_table "" } { dbproc "dbproc"}} {
  124.  
  125.     set columns [ get_col_list $link $selector $master_table]
  126.     set colnum 0
  127.  
  128.     while {! [lempty $columns] } {
  129.         set col [lvarpop columns]
  130.         set colnum [expr $colnum + 1]
  131.         set tcol_nm [$col getUniqueName]
  132.         set type [$col getType3GL]
  133.  
  134.         $sect append "dbbind($dbproc, $colnum, "
  135.         $sect append "[get_bind_type $col], (DBINT) 0, "
  136.         $sect append "(BYTE *) "
  137.  
  138.         # Check if this is a pointer type
  139.         if { ! [regexp {^.+(\[[0-9]+\])|(\*)$} $type] } {
  140.             $sect append "&"
  141.         }
  142.         
  143.         $sect append "${pre}${tcol_nm}${post});\n"
  144.     }
  145. }
  146.  
  147. proc mss_gen_nbinding { sect link { pre ""} { post "" } { selector "ALL" } \
  148.              { master_table "" } { dbproc "dbproc"} } {
  149.  
  150.     set columns [ get_col_list $link $selector $master_table]
  151.     set colnum 0
  152.  
  153.     while {! [lempty $columns] } {
  154.         set col [lvarpop columns]
  155.         set colnum [expr $colnum + 1]
  156.         set tcol_nm [$col getUniqueName]
  157.  
  158.         $sect append "dbnullbind($dbproc, $colnum, "
  159.         $sect append "(LPCDBINT) &${pre}${tcol_nm}${post});\n"
  160.     }
  161. }
  162.  
  163. proc mss_gen_var_ind_list { sect table { selector "ALL" } \
  164.         { pre1 "" } { pre2 "" } { pre3 "" } { sep ", " } \
  165.         { master_table "" } { dbproc "dbproc" } } {
  166.     
  167.     set columns [ get_col_list $table $selector $master_table]
  168.  
  169.     while {! [lempty $columns] } {
  170.         set col [lvarpop columns]
  171.         set col_nm [$col getUniqueName]
  172.         set type [$col getType3GL]
  173.  
  174.         if {! [lempty $columns] } {
  175.             set csep $sep
  176.         } else {
  177.             set csep ""
  178.         }
  179.  
  180.         $sect append "if (${pre2}$col_nm == -1) \{\n"
  181.         $sect indent +
  182.         $sect append "dbcmd($dbproc,\"${pre3}${col_nm}=NULL${csep}\");\n"
  183.         $sect indent -
  184.         $sect append "\} else \{\n"
  185.         $sect indent +
  186.         $sect append "dbfcmd($dbproc,\"${pre3}${col_nm}="
  187.         $sect append "[get_format_char $col]$csep"
  188.         $sect append "\",${pre1}$col_nm);\n"
  189.         $sect indent -
  190.         $sect append "\}\n"
  191.     }
  192. }
  193.  
  194. #
  195. # Work around for problem with cardinality in the SQL model
  196. #
  197. proc mss_sqlpostfix_needed { col } {
  198.     if {[$col getTypeStd] == "serial"} {
  199.     if {[$col get_obj_type] != "imp_column"} {
  200.         return "IDENTITY"
  201.     }
  202.     }
  203.     if {[$col getColumnType] == "key"} {
  204.     return "NOT NULL"
  205.     }
  206.     if [$col isNullable] {
  207.     return "NULL"
  208.     }
  209.     return "NOT NULL"
  210. }
  211.