home *** CD-ROM | disk | FTP | other *** search
/ PC World 1997 November / PCWorld_1997-11_cd.bin / software / programy / komix / DATA.Z / libsql.tcl < prev    next >
Encoding:
Text File  |  1997-04-02  |  34.7 KB  |  1,187 lines
  1. #---------------------------------------------------------------------------
  2. #
  3. # Copyright (c) 1992-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        : @(#)libsql.tcl    /main/hindenburg/3 (2.1)
  17. #    Original date    : 7-1992
  18. #    Description    : Common procedures for gensql including
  19. #              the main gensql procedure
  20. #
  21. #---------------------------------------------------------------------------
  22. #
  23. # @(#)libsql.tcl    /main/hindenburg/3 2 Apr 1997 Copyright 1992-1995 Cayenne Software Inc.
  24. #
  25. #---------------------------------------------------------------------------
  26.  
  27. #---------------------------------------------------------------------------
  28. #
  29. # INCLUDE THE ERROR MESSAGE FILE
  30. #
  31. #---------------------------------------------------------------------------
  32.  
  33. require libsql_msg.tcl
  34.  
  35. #---------------------------------------------------------------------------
  36. #
  37. # CONDITIONS TO SELECT A SET OF COLUMNS. USED IN "get_col_list"
  38. #
  39. #---------------------------------------------------------------------------
  40. global column_selector
  41. set column_selector(ALL)    {1}
  42. set column_selector(NONE)    {0}
  43. set column_selector(KEYS)    {[$col getColumnType] == "key"}
  44. set column_selector(KEYS_NO_TYPE) {[$col getColumnType] == "key" &&
  45.                    [$col getName] != $TYPE_ID_NM}
  46. set column_selector(KEYS_TYPE) {[$col getColumnType] == "key" &&
  47.                    [$col getName] == $TYPE_ID_NM}
  48. set column_selector(TYPE)    {[$col getUniqueName] == $TYPE_ID_NM}
  49. set column_selector(NONKEYS)    {[$col getColumnType] != "key"}
  50. set column_selector(NONKEYFIELDS) {[$col get_obj_type] == "column" &&
  51.                    [$col getColumnType] != "key"}
  52. set column_selector(FKEYS)    {[$col get_obj_type] == "imp_column"}
  53. set column_selector(ALLNONIMP)    {[$col get_obj_type] == "column"}
  54. set column_selector(NONIMPKEYS)    {[$col get_obj_type] == "column" &&
  55.                  [$col getColumnType] == "key"}
  56. set column_selector(IMPKEYS)    {[$col get_obj_type] == "imp_column" &&
  57.                  [$col getColumnType] == "key"}
  58. set column_selector(IMPKEYS_NO_TYPE)    {[$col get_obj_type] == "imp_column" &&
  59.                      [$col getColumnType] == "key" &&
  60.                      [$col getName] != $TYPE_ID_NM}
  61. set column_selector(IMPFIELDS)    {[$col get_obj_type] == "imp_column" &&
  62.                  [$col getColumnType] != "key"}
  63. set column_selector(KEYS_FIELDS) {[$col getColumnType] == "key" ||
  64.                   [$col get_obj_type] == "column"}
  65. set column_selector(KEYS_IMPFIELDS) {[$col getColumnType] == "key" ||
  66.                   [$col get_obj_type] == "imp_column"}
  67. set column_selector(NULLABLES)    {[$col isNullable]}
  68. set column_selector(NOT_NULLABLES)    {![$col isNullable]}
  69. set column_selector(NOT_NULL_OR_INIT)    {![$col isNullable] ||
  70.                  [$col getPropertyValue initial_value] != ""}
  71. set column_selector(NULL_AND_NO_INIT)    {[$col isNullable] &&
  72.                  [$col getPropertyValue initial_value] == ""}
  73. set column_selector(NOT_NULL_FIELDS) {![$col isNullable] &&
  74.                     [$col getColumnType] == "field" &&
  75.                     [$col get_obj_type] == "column"}
  76.  
  77.  
  78.  
  79. #---------------------------------------------------------------------------
  80. #
  81. # The variable "get_type_4gl" contains the name of the procedure to
  82. # get the 4gl type from a column. This indirection is needed because
  83. # for some targets the 4gl type needs postprocessing (e.g. for Informix)
  84. # If the variable is not set, set it to the original get_type_4gl
  85. #
  86. #---------------------------------------------------------------------------
  87. global get_type_4gl
  88. if {![info exists get_type_4gl]} {
  89.     set get_type_4gl get_type_4gl
  90. }
  91.  
  92.  
  93. #---------------------------------------------------------------------------
  94. #
  95. #                 TARGET INDEPENDENT GENERAL PURPOSE PROCEDURES
  96. #
  97. #---------------------------------------------------------------------------
  98.  
  99. # Select those columns from 'table' that satisfy the 'selector' condition
  100. # If the selector is IMPKEYS or IMPKEYS_NO_TYPE, 'master_table' can be
  101. # specified to return only those columns that are imported from that table.
  102. #
  103. proc get_col_list {table selector {master_table ""}} {
  104.  
  105.     set list {}
  106.     if {$selector == "EXPKEYS"} {
  107.     foreach link [$table exportSet] {
  108.         foreach col [[$link friendLink] columnSet] {
  109.             lappend list $col
  110.         }
  111.     }
  112.     } else {
  113.     foreach col [$table columnSet] {
  114.         if [expr $column_selector($selector)] {
  115.         if {$master_table == "" || [$col master] == $master_table} {
  116.             lappend list $col
  117.         }
  118.         }
  119.     }
  120.  
  121.     global debug
  122.     if {$debug == "1"} {
  123.         set imports {}
  124.         foreach col $list {
  125.         lappend imports [$col getUniqueName]
  126.         }
  127.         if {$selector == "IMPKEYS" || $selector == "IMPKEYS_NO_TYPE"} {
  128.         puts "    >>> table '[$table getName]' imports '$imports' from\
  129.                 '[$master_table getName]'"
  130.         }
  131.     }
  132.     }
  133.     return $list
  134. }
  135.  
  136.  
  137. # Generate a list of names from a object list. The object must have
  138. # an attribute "unique_name"
  139. #
  140. proc gen_name_list {section objlist {prefix ""} {postfix ""} {separator ", "} \
  141.            {newline ""}} {
  142.  
  143.     if {[lempty $objlist]}  {
  144.     return
  145.     }
  146.     $section pushIndent
  147.     set newpf $separator$newline$prefix
  148.     set obj [lvarpop objlist]
  149.     expand_text $section {~$prefix~[$obj getUniqueName]~$postfix}
  150.     foreach obj $objlist {
  151.     expand_text $section {~$newpf~[$obj getUniqueName]~$postfix}
  152.     }
  153.     $section append $newline
  154.     $section popIndent
  155. }
  156.  
  157.  
  158. # Generate a list of column names for the given link
  159. #
  160. proc gen_col_listl {section link {prefix ""} {postfix ""} {separator ", "} \
  161.            {newline ""}} {
  162.  
  163.     gen_col_listc $section [$link columnSet] $prefix $postfix \
  164.           $separator $newline
  165. }
  166.  
  167. # Generate a compare of master and detail column names:
  168. #
  169. # if a detail colomn is prefixed it will be compared with it's foreign
  170. # name. I.e. the name in the master table.
  171. #
  172. proc gen_md_comparec {section columns {prefix1 ""} {postfix1 ""} \
  173.           {prefix2 ""} {postfix2 ""} {separator ", "} {newline ""}} {
  174.  
  175.     if {[lempty $columns]}  {
  176.        return;
  177.     }
  178.     $section pushIndent
  179.     set newpf $separator$newline$prefix1
  180.     set col [lvarpop columns]
  181.     set dname [$col getUniqueName]
  182.  
  183.     if {[$col get_obj_type] == "imp_column"} {
  184.     set mname [$col getForeignName]
  185.     } else {
  186.     set mname [$col getUniqueName]
  187.     }
  188.     set dname [$col getUniqueName]
  189.     expand_text $section {~$prefix1~$mname~$postfix1 = ~$prefix2~$dname~$postfix2}
  190.     while {![lempty $columns]} {
  191.     set col [lvarpop columns]
  192.     set dname [$col getUniqueName]
  193.     if {[$col get_obj_type] == "imp_column"} {
  194.         set mname [$col getForeignName]
  195.     } else {
  196.         set mname [$col getUniqueName]
  197.     }
  198.     expand_text $section {
  199.         ~$newpf~$mname~$postfix1 = ~$prefix2~$dname~$postfix2}
  200.     }
  201.     $section append $newline
  202.     $section popIndent
  203. }
  204.  
  205. # Generate a list of column names for the given list of columns
  206. #
  207. proc gen_col_listc {section columns {prefix ""} {postfix ""} {separator ", "} \
  208.            {newline ""}} {
  209.  
  210.     if {[lempty $columns]}  {
  211.     return;
  212.     }
  213.     $section pushIndent
  214.     set newpf $separator$newline$prefix
  215.     set col [lvarpop columns]
  216.     expand_text $section {~$prefix~[$col getUniqueName]~$postfix}
  217.     foreach col $columns {
  218.     expand_text $section {~$newpf~[$col getUniqueName]~$postfix}
  219.     }
  220.     $section append $newline
  221.     $section popIndent
  222. }
  223.  
  224.  
  225. # Generate a list of column names for the given table
  226. # The list of columns is determined by the value of the selector
  227. #
  228. proc gen_col_list {section table selector {prefix ""} {postfix ""} \
  229.           {separator ", "} {newline ""} {master_table ""}}  {
  230.  
  231.     gen_col_listc $section [get_col_list $table $selector $master_table] \
  232.             $prefix $postfix $separator $newline
  233. }
  234.  
  235. # The same as proc gen_col_list, however don't put the result in a section,
  236. # but return it as a string
  237. #
  238. proc gen_col_list_str {table selector {prefix ""} {postfix ""} \
  239.         {separator ", "} {newline ""} {master_table ""}}  {
  240.     set tmpSect [TextSection new]
  241.     gen_col_list $tmpSect $table $selector $prefix $postfix $separator \
  242.         $newline $master_table
  243.     return [$tmpSect contents]
  244. }
  245.  
  246. # Generate a list of variables with indicator variables
  247. #
  248. proc gen_var_ind_list {section table selector {prefix1 ""} {prefix2 ""}
  249.               {separator ", "} {newline ""}} {
  250.  
  251.     set columns [get_col_list $table $selector]
  252.     if {[lempty $columns]}  {
  253.        return;
  254.     }
  255.     $section pushIndent
  256.     set newpf $separator$newline$prefix1
  257.     set col [lvarpop columns]
  258.     set name [$col getUniqueName]
  259.     expand_text $section {~$prefix1~$name~$prefix2~$name}
  260.     while {![lempty $columns]} {
  261.     set col [lvarpop columns]
  262.     set name [$col getUniqueName]
  263.     expand_text $section {
  264.         ~$newpf~$name~$prefix2~$name}
  265.     }
  266.     $section append $newline
  267.     $section popIndent
  268. }
  269.  
  270. # Generate a compare of column names:
  271. #
  272. # Example: <col_name_1> = <col_name_1> AND
  273. #          <col_name_2> = <col_name_2>
  274. #
  275. proc gen_comparec {section columns {prefix1 ""} {postfix1 ""} \
  276.           {prefix2 ""} {postfix2 ""} {separator ", "} {newline ""}} {
  277.  
  278.     if {[lempty $columns]}  {
  279.        return;
  280.     }
  281.     $section pushIndent
  282.     set newpf $separator$newline$prefix1
  283.     set col [lvarpop columns]
  284.     set name [$col getUniqueName]
  285.     expand_text $section {~$prefix1~$name~$postfix1 = ~$prefix2~$name~$postfix2}
  286.     while {![lempty $columns]} {
  287.     set col [lvarpop columns]
  288.     set name [$col getUniqueName]
  289.     expand_text $section {
  290.         ~$newpf~$name~$postfix1 = ~$prefix2~$name~$postfix2}
  291.     }
  292.     $section append $newline
  293.     $section popIndent
  294. }
  295.  
  296. # Generate a compare of column names with indicator vars:
  297. #
  298. # Example: <col_name_1> = <col_name_1> AND
  299. #          <col_name_2> = <col_name_2>
  300. #
  301. proc gen_comparec_ind {section columns {prefix1 ""} {postfix1 ""} \
  302.           {prefix2a ""} {postfix2a ""} {prefix2b ""} {postfix2b ""} \
  303.           {separator ", "} {newline ""}} {
  304.  
  305.     if {[lempty $columns]}  {
  306.        return;
  307.     }
  308.     $section pushIndent
  309.     set newpf $separator$newline$prefix1
  310.     set col [lvarpop columns]
  311.     set name [$col getUniqueName]
  312.     expand_text $section {~$prefix1~$name~$postfix1 = ~$prefix2a~$name~$postfix2a~$prefix2b~$name~$postfix2b}
  313.     while {![lempty $columns]} {
  314.     set col [lvarpop columns]
  315.     set name [$col getUniqueName]
  316.     expand_text $section {
  317.         ~$newpf~$name~$postfix1 = ~$prefix2a~$name~$postfix2a~$prefix2b~$name~$postfix2b}
  318.     }
  319.     $section append $newline
  320.     $section popIndent
  321. }
  322.  
  323. # See: gen_comparec_ind
  324. #
  325. proc gen_compare_ind {section table selector {prefix1 ""} {postfix1 ""} \
  326.          {prefix2a ""} {postfix2a ""} {prefix2b ""} {postfix2b ""} \
  327.          {separator ", "} {newline ""}} {
  328.  
  329.     gen_comparec_ind $section [get_col_list $table $selector] $prefix1 \
  330.           $postfix1 $prefix2a $postfix2a $prefix2b $postfix2b \
  331.           $separator $newline
  332. }
  333.  
  334. # See: gen_comparec
  335. #
  336. proc gen_compare {section table selector {prefix1 ""} {postfix1 ""} \
  337.          {prefix2 ""} {postfix2 ""} {separator ", "} {newline ""}} {
  338.  
  339.     gen_comparec $section [get_col_list $table $selector] $prefix1 \
  340.           $postfix1 $prefix2 $postfix2 $separator $newline
  341. }
  342.  
  343.  
  344. # Generate a compare for a single column
  345. #
  346. proc gen_compare_elem {section column {prefix1 ""} {postfix1 ""} {prefix2 ""} \
  347.            {postfix2 ""}} {
  348.  
  349.     $section pushIndent
  350.     set name [$column getUniqueName]
  351.     expand_text $section {
  352.     ~$prefix1~$name~$postfix1 = ~$prefix2~$name~$postfix2}
  353.     $section popIndent
  354. }
  355.  
  356.  
  357. # Generate a compare list for imported/exported columns i.e.
  358. # the list of columns must have obj_type "imp_column".
  359. # If the link is a export_link get the friend of the link
  360. # and this procedure will work.
  361. #
  362. proc gen_compare_cl {section link {prefix1 ""} {postfix1 ""} \
  363.             {prefix2 ""} {postfix2 ""} {separator ", "} {newline ""}} {
  364.  
  365.     if {[$link getLinkType] == "export"}  {
  366.     set link [$link friendLink]
  367.     }
  368.     set columns [$link columnSet]
  369.     if {[lempty $columns]}  {
  370.        return ;
  371.     }
  372.     set col [lvarpop columns]
  373.     set tcol_nm [$col getUniqueName]
  374.     set mcol_nm [$col getForeignName]
  375.     $section pushIndent
  376.     expand_text $section {
  377.     ~$prefix1~$tcol_nm~$postfix1 = ~$prefix2~$mcol_nm~$postfix2}
  378.     set newpf $separator$newline$prefix1
  379.     while {![lempty $columns]} {
  380.     set col [lvarpop columns]
  381.     set tcol_nm [$col getUniqueName]
  382.     set mcol_nm [$col getForeignName]
  383.     expand_text $section {
  384.         ~$newpf~$tcol_nm~$postfix1 = ~$prefix2~$mcol_nm~$postfix2}
  385.     }
  386.     $section popIndent
  387.     $section append $newline
  388. }
  389.  
  390.  
  391.  
  392. # Generate for a link between the current table and the detail
  393. # a compare list of the exported columns.
  394. #
  395. proc gen_compare_dno {section table detail {prefix1 ""} {postfix1 ""} \
  396.              {prefix2 ""} {postfix2 ""} {separator ", "} {newline ""}} {
  397.  
  398.     set t_columns ""
  399.     set d_columns ""
  400.     foreach dlink [$table exportSet] {
  401.     if {[$dlink detail] == $detail} {
  402.         set t_columns [$dlink columnSet]
  403.         set d_columns [[$dlink friendLink] columnSet]
  404.         break
  405.     }
  406.     }
  407.     if {[lempty $t_columns]} {
  408.     return
  409.     }
  410.     set tcol_nm [[lvarpop t_columns] getUniqueName]
  411.     set dcol_nm [[lvarpop d_columns] getUniqueName]
  412.     $section pushIndent
  413.     expand_text $section {
  414.     ~$prefix1~$tcol_nm~$postfix1 = ~$prefix2~$dcol_nm~$postfix2}
  415.  
  416.     set newpf $separator$newline$prefix1
  417.     while {![lempty $t_columns]} {
  418.     set tcol_nm [[lvarpop t_columns] getUniqueName]
  419.     set dcol_nm [[lvarpop d_columns] getUniqueName]
  420.     expand_text $section {
  421.         ~$newpf~$tcol_nm~$postfix1 = ~$prefix2~$dcol_nm~$postfix2}
  422.     }
  423.     $section popIndent
  424.     $section append $newline
  425. }
  426.  
  427.  
  428. # As gen_compare_m but without prefixing the column names
  429. # with "table_name.".
  430. #
  431. proc gen_compare_mno {section table master {prefix1 ""} {postfix1 ""} \
  432.              {prefix2 ""} {postfix2 ""} {separator ", "} {newline ""}} {
  433.  
  434.     set t_columns ""
  435.     set m_columns ""
  436.     foreach mlink [$table importSet] {
  437.     if {[$mlink master] == $master} {
  438.         set t_columns [$mlink columnSet]
  439.         set m_columns [[$mlink friendLink] columnSet]
  440.         break
  441.     }
  442.     }
  443.     if {[lempty $t_columns]} {
  444.     return
  445.     }
  446.     set tcol_nm [[lvarpop t_columns] getUniqueName]
  447.     set mcol_nm [[lvarpop m_columns] getUniqueName]
  448.     $section pushIndent
  449.     expand_text $section {
  450.     ~$prefix2~$mcol_nm~$postfix2 = ~$prefix1~$tcol_nm~$postfix1}
  451.  
  452.     set newpf $separator$newline$prefix1
  453.     while {![lempty $t_columns]} {
  454.     set tcol_nm [[lvarpop t_columns] getUniqueName]
  455.     set mcol_nm [[lvarpop m_columns] getUniqueName]
  456.     expand_text $section {
  457.       ~$newpf~$tcol_nm~$postfix1 = ~$prefix2~$mcol_nm~$postfix2}
  458.     }
  459.     $section popIndent
  460.     $section append $newline
  461. }
  462.  
  463.  
  464. # Generate for a link between the current table and the master
  465. # a compare list of the imported columns.
  466. # The names of the columns are prefixed by the name of the table.
  467. #
  468. proc gen_compare_m {section table master {prefix1 ""} {postfix1 ""} \
  469.            {prefix2 ""} {postfix2 ""} {separator ", "} {newline ""}} {
  470.  
  471.     set t_columns ""
  472.     set m_columns ""
  473.     foreach mlink [$table importSet] {
  474.     if {[$mlink master] == $master} {
  475.         set t_columns [$mlink columnSet]
  476.         set m_columns [[$mlink friendLink] columnSet]
  477.         break
  478.     }
  479.     }
  480.     if {[lempty $t_columns]} {
  481.     return
  482.     }
  483.     set ttab_nm [$table getUniqueName]
  484.     set mtab_nm [$master getUniqueName]
  485.  
  486.     set tcol_nm [[lvarpop t_columns] getUniqueName]
  487.     set mcol_nm [[lvarpop m_columns] getUniqueName]
  488.     $section pushIndent
  489.     expand_text $section {
  490.     ~$prefix1~$ttab_nm.~$tcol_nm~$postfix1 = ~$prefix2~$mtab_nm.~$mcol_nm~$postfix2}
  491.  
  492.     set newpf $separator$newline$prefix1
  493.     while {![lempty $t_columns]} {
  494.     set tcol_nm [[lvarpop t_columns] getUniqueName]
  495.     set mcol_nm [[lvarpop m_columns] getUniqueName]
  496.     expand_text $section {
  497.       ~$newpf~$ttab_nm.~$tcol_nm~$postfix1 = ~$prefix2~$mtab_nm.~$mcol_nm~$postfix2}
  498.     }
  499.     $section popIndent
  500.     $section append $newline
  501. }
  502.  
  503.  
  504. # Generate a full data declaration for a given table
  505. #
  506. proc gen_data_decl_4gl {section table selector {separator ", "} {newline ""}} {
  507.  
  508.     set columns [get_col_list $table $selector]
  509.     if {[lempty $columns]} {
  510.     return
  511.     }
  512.     set col [lvarpop columns]
  513.     $section pushIndent
  514.     expand_text $section {
  515.     ~[$col getUniqueName] ~[$get_type_4gl $col] ~[sqlpostfix_needed $col]}
  516.     set newpf $separator$newline
  517.     foreach col $columns {
  518.     expand_text $section {
  519.         ~$newpf~[$col getUniqueName] ~[$get_type_4gl $col] ~[sqlpostfix_needed $col]}
  520.     }
  521.     $section popIndent
  522.     $section append $newline
  523. }
  524.  
  525.  
  526. # Generate a full SQLdata declaration for a given table
  527. #
  528. proc gen_data_decl_sql {section table selector {separator ", "} {newline ""}} {
  529.  
  530.     set columns [get_col_list $table $selector]
  531.     if {[lempty $columns]} {
  532.     return
  533.     }
  534.     set col [lvarpop columns]
  535.     $section pushIndent
  536.     expand_text $section {
  537.     ~[$col getUniqueName] ~[get_type_4gl $col] ~[sqlpostfix_needed $col]}
  538.     set newpf $separator$newline
  539.     foreach col $columns {
  540.     expand_text $section {
  541.         ~$newpf~[$col getUniqueName] ~[get_type_4gl $col] ~[sqlpostfix_needed $col]}
  542.     }
  543.     $section popIndent
  544.     $section append $newline
  545. }
  546.  
  547. # Generate a 3gl data declaration
  548. #
  549. proc gen_data_decl_3gl {section table selector {prefix ""} \
  550.             {newline ""} {postfix ""}} {
  551.  
  552.     set columns [get_col_list $table $selector]
  553.     if {[lempty $columns]} {
  554.     return
  555.     }
  556.     $section pushIndent
  557.     set col [lvarpop columns]
  558.  
  559.     # first col
  560.  
  561.     build_type_3gl [$col getType3GL] result_type result_range
  562.     set result_type $prefix$result_type
  563.     set result_range $result_range$postfix
  564.     expand_text $section {\~[create_3gl_var {~$name} {~$type} {~$range}
  565. ]} \
  566.     name [$col getUniqueName] type $result_type range $result_range
  567.     set newprefix $newline$prefix
  568.  
  569.     foreach col $columns {
  570.  
  571.     # next cols
  572.  
  573.     build_type_3gl [$col getType3GL] result_type result_range
  574.     set result_type $newprefix$result_type
  575.     set result_range $result_range$postfix
  576.     expand_text $section {\~[create_3gl_var {~$name} {~$type} {~$range}
  577. ]} \
  578.         name [$col getUniqueName] type $result_type range $result_range
  579.     }
  580.     $section append $newline
  581.     $section popIndent
  582. }
  583.  
  584. # Generate a 3gl data declaration directly (without calling create_3gl_var)
  585. #
  586. proc gen_dir_data_decl_3gl {section object selector {separator ", "}
  587.                {newline ""} {prefix ""} {postfix ""} {prefix2 ""}} {
  588.  
  589.     gen_dir_data_decl_3glc $section [get_col_list $object $selector] \
  590.                 $separator $newline $prefix $postfix $prefix2
  591. }
  592.  
  593. # Generate a 3gl data declaration for a link directly (without calling
  594. # create_3gl_var)
  595. #
  596. proc gen_dir_data_decl_3gl_link {section link {separator ", "}
  597.                 {newline ""} {prefix ""} {postfix ""}
  598.                 {prefix2 ""}} {
  599.  
  600.     gen_dir_data_decl_3glc $section [$link columnSet] \
  601.             $separator $newline $prefix $postfix $prefix2
  602. }
  603.  
  604. proc gen_dir_data_decl_3glc {section columns {separator ", "}
  605.             {newline ""} {prefix ""} {postfix ""} {prefix2 ""}} {
  606.  
  607.     if {[lempty $columns]} {
  608.     return
  609.     }
  610.     set col [lvarpop columns]
  611.     $section pushIndent
  612.     $section append $prefix[mk_3gl_decl $col $postfix $prefix2]
  613.     set newpf $separator$newline$prefix
  614.     foreach col $columns {
  615.     $section append $newpf[mk_3gl_decl $col $postfix $prefix2]
  616.     }
  617.     $section popIndent
  618.     $section append $newline
  619. }
  620.  
  621. # Make a 3gl variable declaration
  622. # {name, simpel_type} becomes    "simpel_type    name"
  623. # {name, char[index]} becomes    "char        name[index + 1]"
  624. #
  625. proc mk_3gl_decl {col {postfix ""} {prefix ""}} {
  626.     set name [$col getUniqueName]
  627.     set type [$col getType3GL]
  628.     if [regsub {(var)?char\[} $type "char $prefix$name\[" type] {
  629.     regexp {\[(.*)\]$} $type dummy index
  630.     set index [expr {$index + 1}]
  631.     regsub {\[(.*)\]$} $type "$postfix\[$index]" type
  632.     return $type
  633.     }
  634.     return "$type $prefix$name$postfix"
  635. }
  636.  
  637. # Generate a 4gl data declaration, without sqlpostfix
  638. #
  639. proc gen_simple_data_decl_4glc {section columns  {prefix ""} \
  640.                 {separator ", "} {newline ""}} {
  641.  
  642.     if {[lempty $columns]} {
  643.     return
  644.     }
  645.     $section pushIndent
  646.     set col [lvarpop columns]
  647.     expand_text $section {
  648.     ~$prefix~[$col getUniqueName] ~[$get_type_4gl $col]}
  649.     set newpf $separator$newline$prefix
  650.     while {![lempty $columns]} {
  651.     set col [lvarpop columns]
  652.     expand_text $section {
  653.         ~$newpf~[$col getUniqueName] ~[$get_type_4gl $col]}
  654.     }
  655.     $section append $newline
  656.     $section popIndent
  657. }
  658.  
  659.  
  660. # See: gen_simple_data_decl_4glc
  661. #
  662. proc gen_simple_data_decl_4gl {section table selector {prefix ""} \
  663.                   {separator ", "} {newline ""}} {
  664.  
  665.     set columns [get_col_list $table $selector]
  666.     gen_simple_data_decl_4glc $section $columns $prefix $separator $newline
  667. }
  668.  
  669. # Generate an assignment of columns in a master detail link
  670. #
  671. proc gen_assign_cl {section link {prefix1 ""} {postfix1 ""} \
  672.             {prefix2 ""} {postfix2 ""}} {
  673.  
  674.     $section pushIndent
  675.     foreach col [$link columnSet] {
  676.         $section append \
  677.         [assign_elem_md $col $prefix1 $postfix1 $prefix2 $postfix2 $section]
  678.     }
  679.     $section popIndent
  680. }
  681.  
  682. # Generate an assign of column names. string variables are assigned via strcpy
  683. #
  684. #
  685. proc gen_assignc {section columns {prefix1 ""} {postfix1 ""} \
  686.           {prefix2 ""} {postfix2 ""}} {
  687.  
  688.     $section pushIndent
  689.     foreach col $columns {
  690.         $section append \
  691.         [assign_elem $col $prefix1 $postfix1 $prefix2 $postfix2 $section]
  692.     }
  693.     $section popIndent
  694. }
  695.  
  696. # See: gen_assignc
  697. #
  698. proc gen_assign {section table selector {prefix1 ""} {postfix1 ""} \
  699.          {prefix2 ""} {postfix2 ""}} {
  700.  
  701.     gen_assignc $section [get_col_list $table $selector] $prefix1 $postfix1 \
  702.                 $prefix2 $postfix2
  703. }
  704.  
  705. #
  706. # Generate an assign of column names. No support for string variables
  707. #
  708.  
  709. proc gen_simple_assign {section table selector {prefix1 ""} {postfix1 ""} \
  710.         {prefix2 ""} {postfix2 ""}} {
  711.     $section pushIndent
  712.     foreach col [get_col_list $table $selector] {
  713.     set name [$col getUniqueName]
  714.     $section append "$prefix1$name$postfix1 = $prefix2$name$postfix2;\n"
  715.     }
  716.     $section popIndent
  717. }
  718.  
  719. # Return the string for one assignment
  720. #
  721. proc assign_elem {col {prefix1 ""} {postfix1 ""} {prefix2 ""}
  722.             {postfix2 ""} {sect "src"}} {
  723.     set name [$col getUniqueName]
  724.  
  725.     if [type_is_char_array $col] {
  726.     add_[determine_sect_type $sect]_inc_name "string" "h"
  727.  
  728.     return "strcpy($prefix1$name$postfix1, $prefix2$name$postfix2);\n"
  729.     }
  730.  
  731.     return "$prefix1$name$postfix1 = $prefix2$name$postfix2;\n"
  732. }
  733.  
  734. # Return the string for one assignment in a master-detail relationship
  735. #
  736. proc assign_elem_md {col {prefix1 ""} {postfix1 ""} {prefix2 ""}
  737.              {postfix2 ""} {sect "src"}} {
  738.     set name [$col getUniqueName]
  739.     set fname [$col getForeignName]
  740.  
  741.     if [type_is_char_array $col] {
  742.     add_[determine_sect_type $sect]_inc_name "string" "h"
  743.  
  744.     return "strcpy($prefix1$name$postfix1, $prefix2$fname$postfix2);\n"
  745.     }
  746.  
  747.     return "$prefix1$name$postfix1 = $prefix2$fname$postfix2;\n"
  748. }
  749.  
  750.  
  751. # Determine if the 3gl type is a character array
  752. #
  753. proc type_is_char_array {obj} {
  754.     return [string match {*char\[*} [$obj getType3GL]]
  755. }
  756.  
  757. proc strip_trailing_spaces {section columns {prefix ""} {postfix ""}} {
  758.     $section pushIndent
  759.  
  760.     foreach col $columns {
  761.     if {[type_is_char_array $col]} {
  762.         expand_text $section {
  763.         stripTrailingSpaces(~$prefix~[$col getUniqueName]~$postfix);
  764.         }
  765.     }
  766.     }
  767.  
  768.     $section popIndent
  769. }
  770.  
  771. # Declare a variable which is expanded by gen4gl
  772. #
  773. proc declare_4gl_var {section varname vartype} {
  774.  
  775.     expand_text $section {\~[create_var ~$varname {~$vartype}
  776. ]} \
  777.     varname $varname vartype $vartype
  778. }
  779.  
  780.  
  781. # Determine if the column needs a sqlpostfix, if not this
  782. # procedure returns an empty string else the sqlpostfix.
  783. #
  784. proc sqlpostfix_needed {col} {
  785.  
  786.     if {[$col get_obj_type] == "column"}  {
  787.        return [$col getSqlPostfix];
  788.     }
  789.     set link [$col getImport]
  790.     if {[$link getDetailType] == "optional" &&
  791.     [$col getColumnType] == "field"}  {
  792.         return "";
  793.     }
  794.     return [$col getSqlPostfix];
  795. }
  796.  
  797.  
  798. # Parse i.e. expand the constraint string. The following
  799. # variables are in the context of the constraint known:
  800. #
  801. #     o    ~$col_name    - the name of the current column
  802. #     o    ~$column      - handle to the current column
  803. #
  804. #     o    ~$tab_name    - the name of the current table
  805. #     o    ~$table       - handle to the current table
  806. #
  807. # You can only use one of these depending if you defined
  808. # the constraint for a column or table object.
  809. #
  810. proc parse_constr {current_section object {prefix ""}} {
  811.  
  812.     set constr [$object getConstraint]
  813.     if {$constr == ""} {
  814.     return
  815.     }
  816.     if {[$object get_obj_type] == "table"} {
  817.     set t_obj  $object
  818.     set t_name [$object getUniqueName]
  819.     set c_obj  ""
  820.     set c_name ""
  821.     } else {
  822.     set c_obj  $object
  823.     set c_name $prefix[$object getUniqueName]
  824.     set t_obj  [$object table]
  825.     set t_name [$t_obj getUniqueName]
  826.     }
  827.     # Replace ~~currfield by ~$col_name and
  828.     # replace ~~currtab by ~$tab_name.
  829.     #
  830.     regsub -all {~~currfield} $constr "~\$col_name" constr
  831.     regsub -all {~~currtab} $constr "~\$tab_name" constr
  832.     $current_section pushIndent
  833.     expand_text $current_section "$constr"\
  834.         col_name $c_name column $c_obj\
  835.         tab_name $t_name table $t_obj
  836.     $current_section popIndent
  837. }
  838.  
  839.  
  840. #---------------------------------------------------------------------------
  841. #
  842. #                        EMPTY PROCEDURE DETECTION
  843. #
  844. #---------------------------------------------------------------------------
  845.  
  846.  
  847. # Determine for each table if for a specific rule_type and
  848. # for all links (import or export) the rule is "none".
  849. # This used to prevent empty PROCEDRURES generation.
  850. #
  851. proc detect_empty_procs {model} {
  852.  
  853.     global empty_imports_procs
  854.     global empty_exports_procs
  855.     set link_types {imports exports}
  856.     set oper_types {ins del upd}
  857.  
  858.     m4_message $M_EMPTY_PROC_CHECK
  859.     foreach table [$model tableSet] {
  860.     foreach link_type $link_types {
  861.         foreach oper $oper_types  {
  862.         set empty [all_rules_none $table $link_type $oper]
  863.         set empty_${link_type}_procs($oper,$table) $empty
  864.         }
  865.     }
  866.     }
  867. }
  868.  
  869.  
  870. # Test if all rules have the value "none"
  871. #
  872. proc all_rules_none  {table link_type oper} {
  873.  
  874.     set links [get_$link_type $table]
  875.     set empty 1
  876.     foreach link $links {
  877.     if {[get_${oper}_type $link] != "none"} {
  878.         set empty 0
  879.         break
  880.     }
  881.     }
  882.     return $empty
  883. }
  884.  
  885.  
  886. #---------------------------------------------------------------------------
  887. #
  888. #                      CYCLE DETECTION IN THE SQLMODEL
  889. #
  890. #---------------------------------------------------------------------------
  891.  
  892.  
  893. # Build an array of impossible operations on a table.
  894. # A valid "operation" is one of: ins, upd, del.
  895. #
  896. proc detect_cycli {model} {
  897.  
  898.     # Look for cascade DELETE cycli
  899.     #
  900.     m4_message $M_DEL_CYCLE_CHECK
  901.     set cycle [check_cascade_cycle $model "del" "del_in_detail"]
  902.     if {![lempty $cycle]} {
  903.     m4_error $E_CYCLE "Delete" [format_cycle $cycle]
  904.     }
  905.     global impossible_procs
  906.     foreach table $cycle {
  907.     set impossible_procs(del,$table) 1
  908.     }
  909.  
  910.     # Look for cascade UPDATE cycli
  911.     #
  912.     m4_message $M_UPD_CYCLE_CHECK
  913.     set cycle [check_cascade_cycle $model "upd" "upd_in_detail"]
  914.     if {![lempty $cycle]} {
  915.     m4_error $E_CYCLE "Update" [format_cycle $cycle]
  916.     }
  917.     foreach table $cycle {
  918.     set impossible_procs(upd,$table) 1
  919.     }
  920. }
  921.  
  922.  
  923. # Check cascade cycle for detail tables.
  924. #
  925. proc check_cascade_cycle {model oper rule_type} {
  926.     set dep_list ""
  927.     build_dep_list $model dep_list $oper $rule_type
  928.     topo_sort dep_list sort unsort
  929.     return $unsort
  930. }
  931.  
  932.  
  933. # Format a string of table names separated by a ","
  934. #
  935. proc format_cycle {cycle} {
  936.  
  937.     lappend result '[[lvarpop cycle] getUniqueName]'
  938.     set separator ", "
  939.     foreach table $cycle {
  940.     lappend result $separator'[$table getUniqueName]'
  941.     }
  942.     # Make one string of a list of strings
  943.     #
  944.     return [join $result]
  945. }
  946.  
  947.  
  948. # Build cascade dependency list for all tables in 'model'
  949. #
  950. proc build_dep_list {model dl oper rule_type} {
  951.     upvar $dl dep_list
  952.     catch {unset dep_list}
  953.     foreach table [$model tableSet] {
  954.     set count($table) 0
  955.     set dep_list($table) ""
  956.     }
  957.     foreach table [$model tableSet] {
  958.     foreach link [$table exportSet] {
  959.         if {[get_${oper}_type $link] == $rule_type} {
  960.         lappend dep_list([$link detail]) $table
  961.         incr count($table)
  962.         }
  963.     }
  964.     }
  965.     foreach table [$model tableSet] {
  966.     set dep_list($table) [linsert $dep_list($table) 0 $count($table)]
  967.     }
  968. }
  969.  
  970.  
  971. #
  972. #
  973. proc print_dep_list {dl} {
  974.     upvar $dl dep
  975.     foreach table [array names dep] {
  976.     puts stdout "[$table getUniqueName]\t" nonewline
  977.     puts stdout "[lindex $dep($table) 0]\t" nonewline
  978.     foreach tdep [lrange $dep($table) 1 end] {
  979.         puts stdout "[$tdep getUniqueName] " nonewline
  980.     }
  981.     puts stdout ""
  982.     }
  983. }
  984.  
  985.  
  986. #---------------------------------------------------------------------------
  987. #
  988. #                         DETECTION OF POLICIES CONFLICTS
  989. #
  990. #---------------------------------------------------------------------------
  991.  
  992.  
  993. # Detect policy conflicts for the INSERT operation. A conflict would occur if
  994. # an insert into a detail table demands the existence of the
  995. # foreign key in the master table and visa versa i.e. you never will
  996. # be able to insert a tuple in both tables.
  997. # The solution is to make a transaction in which you do the inserts
  998. # into both tables and do not create the procedures which checks the RI
  999. # after an insert.
  1000. #
  1001. proc detect_pol_conflicts {model} {
  1002.  
  1003.     global impossible_procs
  1004.     m4_message $M_POL_CONFLICT_CHECK
  1005.     foreach table [$model tableSet] {
  1006.     foreach link [$table importSet] {
  1007.         detect_pol_conflict $link "insert" "rej_not_exist"
  1008.         detect_pol_conflict $link "delete" "rej_exist"
  1009.     }
  1010.     }
  1011. }
  1012.  
  1013. # Check for one link if the policies conflict between master and
  1014. # detail table
  1015. #
  1016. proc detect_pol_conflict {link oper rule_type} {
  1017.  
  1018.     set op [string range $oper 0 2]
  1019.     set detail_strat [get_${op}_type $link]
  1020.     set master_strat [get_${op}_type [$link friendLink]]
  1021.     if {$detail_strat == $rule_type && $master_strat == $rule_type} {
  1022.     set impossible_procs($op,[$link detail]) 1
  1023.     set master_name [[$link master] getUniqueName]
  1024.     set detail_name [[$link detail] getUniqueName]
  1025.     m4_message $M_NEWL
  1026.     m4_error $E_POL_CONFLICT $oper $detail_name $master_name
  1027.     }
  1028. }
  1029.  
  1030. #---------------------------------------------------------------------------
  1031. #
  1032. #                            GENSQL PROCEDURES
  1033. #
  1034. #---------------------------------------------------------------------------
  1035.  
  1036. #---------------------------------------------------------------------------
  1037. #
  1038. # MAPPING FROM SOURCE FILETYPES TO TARGET FILETYPES
  1039. # (See also the progtypes file in your etc/.. directory)
  1040. #
  1041. #---------------------------------------------------------------------------
  1042. global prog_types
  1043. set prog_types(g_ptmpl_3)                   predef_3gl
  1044. set prog_types(g_ptmpl_4)                   predef_4gl
  1045. set prog_types(g_ptmpl)                     predef_4gl
  1046. set prog_types(g_stmpl)                     sql_script
  1047.  
  1048. set prog_types(s_ptmpl_3)                   predef_3gl
  1049. set prog_types(s_ptmpl_4)                   predef_4gl
  1050. set prog_types(s_ptmpl)                     predef_4gl
  1051. set prog_types(s_stmpl)                     sql_script
  1052. set prog_types(stmpl)                       sql_script
  1053.  
  1054. #---------------------------------------------------------------------------
  1055. #
  1056. # MAPPING FROM FILE EXTENSION TO TARGET FILETYPES AND VISA VERSA
  1057. #
  1058. #---------------------------------------------------------------------------
  1059. global prog_files
  1060. set prog_files(pt4)                         predef_4gl
  1061. set prog_files(predef_4gl)                  pt4
  1062. set prog_files(pt3)                         predef_3gl
  1063. set prog_files(predef_3gl)                  pt3
  1064. set prog_files(sql)                         sql_script
  1065. set prog_files(sql_script)                  sql
  1066.  
  1067. # Global variabale used to check if the model already is loaded.
  1068. #
  1069. global model_loaded; set model_loaded 0;
  1070.  
  1071.  
  1072. # Global variabale used to store the loaded SQL and OOPL model.
  1073. #
  1074. # SqlModel
  1075. global model
  1076. # OoplModel
  1077. global oomodel
  1078.  
  1079. # Global array contains the database procedures which can
  1080. # not be generated because the table they are operating on
  1081. # is a part of a cycle.
  1082. #
  1083. # SYNTAX:   impossible_proc(oper,table)   value
  1084. #
  1085. #           oper : "ins", "upd", "del"
  1086. #           table: table_handle
  1087. #           value: 0 or 1
  1088. #
  1089. global impossible_procs
  1090.  
  1091. # Global array contains the database procedures which can
  1092. # cause generation of empty procedures. An empty procedure
  1093. # can be generated if all the policies i.e. the rules contain
  1094. # the value "none".
  1095. #
  1096. # SYNTAX:   empty_imports_procs(oper,table)   value
  1097. #
  1098. #           oper : "ins", "upd", "del"
  1099. #           table: table_handle
  1100. #           value: 0 or 1 (0 means empty, 1 not)
  1101. #
  1102. global empty_imports_procs
  1103. global empty_exports_procs
  1104.  
  1105. #---------------------------------------------------------------------------
  1106. #
  1107. #                        MAIN GENSQL PROCEDURE & FRIENDS
  1108. #
  1109. #---------------------------------------------------------------------------
  1110.  
  1111.  
  1112. # If the before_gensql procedure does not exist declare it.
  1113. #
  1114. if {[info procs before_gensql] != "before_gensql"} {
  1115.     proc before_gensql {model} {
  1116.  
  1117.     # Dummy procedure, do nothing!
  1118.     #
  1119.     }
  1120. }
  1121.  
  1122.  
  1123. #
  1124. #
  1125. proc gensql {} {
  1126.     global model oomodel
  1127.  
  1128.     set model [$oomodel sqlModel]
  1129.     if {[$model tableSet] == ""}  {
  1130.     m4_message $M_NO_TABLES
  1131.     return
  1132.     }
  1133.  
  1134.     # Call a procedure which can be declared in the target
  1135.     # depended Tcl script gensql.tcl. It is not nessecary for
  1136.     # before_gensql to have an implementation
  1137.     #
  1138.     before_gensql $model
  1139.  
  1140.     # Some additional checks
  1141.     #
  1142.     detect_cycli $model
  1143.     detect_pol_conflicts $model
  1144.     detect_empty_procs $model
  1145.  
  1146.     gensql_omt
  1147. }
  1148.  
  1149. # Generate Tcl include commands for the external tables
  1150. #
  1151. proc gen_includes {sect model name type} {
  1152.     foreach currtab [$model tableSet] {
  1153.         if [$currtab isExternal] {
  1154.             set refd_systems([get_system $currtab]) 1
  1155.         }
  1156.     }
  1157.     if {![info exists refd_systems]} {
  1158.         return
  1159.     }
  1160.     foreach sysname [array names refd_systems] {
  1161.         $sect append "~\[@include $name $type $sysname]\n"
  1162.     }
  1163. }
  1164.  
  1165. #
  1166. #    Sort the imported columns in the same order as they appear in
  1167. #    the master table.
  1168. #
  1169.  
  1170. proc gen_sorted_columns {import} {
  1171.     set masterTable [$import master]
  1172.     set masterColumns [get_col_list $masterTable "KEYS"]
  1173.     set linkColumns [$import columnSet]
  1174.     set list {}
  1175.  
  1176.     foreach masterCol $masterColumns {
  1177.     foreach linkCol $linkColumns {
  1178.         if {$masterCol == [$linkCol column]} {
  1179.         lappend list $linkCol
  1180.         }
  1181.     }
  1182.     }
  1183.  
  1184.     return $list
  1185. }
  1186.  
  1187.