home *** CD-ROM | disk | FTP | other *** search
/ PC World 1998 October / PCWorld_1998-10_cd.bin / software / prehled / komix / DATA.Z / libnesql.tcl < prev    next >
Encoding:
Text File  |  1997-10-02  |  10.4 KB  |  360 lines
  1. #---------------------------------------------------------------------------
  2. #
  3. # Copyright (c) 1994-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        : @(#)libnesql.tcl    /main/titanic/4
  17. #    Original date    : 17-12-1994
  18. #    Description    : Redefine some procedures (used by NewEra code
  19. #            generation) previously defined in libsql.tcl.
  20. #            So source this tcl file after libsql.tcl.
  21. #            Also define some new procedures.
  22. #
  23. #---------------------------------------------------------------------------
  24. #
  25.  
  26.  
  27. # Return the string for one assignment
  28. #
  29. proc assign_elem {col {prefix1 ""} {postfix1 ""} {prefix2 ""} {postfix2 ""} \
  30.         {sect "src"}} {
  31.     set name [$col getUniqueName]
  32.     return "LET $prefix1$name$postfix1 = $prefix2$name$postfix2\n"
  33. }
  34.  
  35. # Return the string for one assignment in a master-detail relationship
  36. #
  37. proc assign_elem_md {col {prefix1 ""} {postfix1 ""} {prefix2 ""} \
  38.          {postfix2 ""} {sect "src"}} {
  39.     set name [$col getUniqueName]
  40.     set fname [$col getForeignName]
  41.     return "LET $prefix1$name$postfix1 = $prefix2$fname$postfix2\n"
  42. }
  43.  
  44. # Return a string containing a series of question marks separated by commas
  45. #
  46. proc gen_dyn_place_holders {section table selector} {
  47.     set columns [get_col_list $table $selector]
  48.     if { [lempty $columns] }  {
  49.     return ""
  50.     }
  51.     lvarpop columns
  52.     set str "?"
  53.     while { ![lempty $columns] } {
  54.     append str ", ?"
  55.     lvarpop columns
  56.     }
  57.     return $str
  58. }
  59.  
  60. # Generate a compare of column names with dynamic placeholders
  61. #
  62. proc gen_dyn_comparec {section columns {prefix1 ""} {postfix1 ""} \
  63.         {separator ", "} {newline ""}} {
  64.     if { [lempty $columns] }  {
  65.     return;
  66.     }
  67.     $section pushIndent
  68.     set newpf $separator$newline$prefix1
  69.     set col [lvarpop columns]
  70.     set name [$col getUniqueName]
  71.     expand_text $section {~$prefix1~$name~$postfix1 = ?}
  72.     while { ![lempty $columns] } {
  73.     set col [lvarpop columns]
  74.     set name [$col getUniqueName]
  75.     expand_text $section {
  76.         ~$newpf~$name~$postfix1 = ?}
  77.     }
  78.     $section append $newline
  79.     $section popIndent
  80. }
  81.  
  82. proc gen_dyn_compare {section table selector {prefix1 ""} {postfix1 ""} \
  83.         {separator ", "} {newline ""}} {
  84.  
  85.     gen_dyn_comparec $section [get_col_list $table $selector] $prefix1 \
  86.         $postfix1 $separator $newline
  87. }
  88.  
  89. # Generate setParam statements to replace placeholders
  90. #
  91. proc gen_setparamc {section table pnr selectors rowname} {
  92.     upvar $pnr param_nr
  93.     $section pushIndent
  94.     set columns [$table columnSet]
  95.     foreach selector $selectors {
  96.     foreach col $columns {
  97.         if [expr $column_selector($selector)] {
  98.         expand_text $section {
  99.             CALL stmt.setParam(~$param_nr, ~${rowname}.getVal(~[get_column_nr $col]))
  100.         }
  101.         incr param_nr
  102.         }
  103.     }
  104.     }
  105.     $section popIndent
  106. }
  107.  
  108. proc gen_setparamc_name {section table selectors} {
  109.     set param_nr 1
  110.     $section pushIndent
  111.     set columns [$table columnSet]
  112.     foreach selector $selectors {
  113.     foreach col $columns {
  114.         if [expr $column_selector($selector)] {
  115.         set ixval [map_fgl2ixval [$col getType3GL]]
  116.         set name [$col getUniqueName]
  117.         expand_text $section {
  118.             CALL stmt.setParam(~$param_nr, ~$name)
  119.         }
  120.         incr param_nr
  121.         }
  122.     }
  123.     }
  124.     $section popIndent
  125. }
  126.  
  127. # Generate setParam statements to replace placeholders
  128. #
  129. proc gen_setparam_cl {section link pnr rowname} {
  130.     upvar $pnr param_nr
  131.     $section pushIndent
  132.     if { [$link getLinkType] == "export" }  {
  133.     set link [$link friendLink]
  134.     }
  135.     set columns [$link columnSet]
  136.     foreach col $columns {
  137.     expand_text $section {
  138.         CALL stmt.setParam(~$param_nr, ~${rowname}.getVal(~[get_foreign_column_nr $col]))
  139.     }
  140.     incr param_nr
  141.    }
  142.     $section popIndent
  143. }
  144.  
  145. # Generate a compare list with dynamic placeholders for imported/exported
  146. # columns i.e. the list of columns must have obj_type "imp_column".
  147. # If the link is a export_link get the friend of the link
  148. #
  149. proc gen_dyn_compare_cl {section link {prefix1 ""} {postfix1 ""} \
  150.     {separator ", "} {newline ""}} {
  151.     if { [$link getLinkType] == "export" }  {
  152.     set link [$link friendLink]
  153.     }
  154.     set columns [$link columnSet]
  155.     if { [lempty $columns] }  {
  156.     return ;
  157.     }
  158.     set col [lvarpop columns]
  159.     set tcol_nm [$col getUniqueName]
  160.     $section pushIndent
  161.     expand_text $section {~$prefix1~$tcol_nm~$postfix1 = ?}
  162.     set newpf $separator$newline$prefix1
  163.     while {![lempty $columns]} {
  164.     set col [lvarpop columns]
  165.     set tcol_nm [$col getUniqueName]
  166.     expand_text $section {~$newpf~$tcol_nm~$postfix1 = ?}
  167.     }
  168.     $section popIndent
  169.     $section append $newline
  170. }
  171.  
  172. # Generate a list of getVal calls for values in a row. The values correspond
  173. # to the columns.
  174. #
  175. proc gen_rowgetval_c {section columns {prefix ""} {postfix ""} \
  176.     {separator ", "}  {newline ""}} {
  177.  
  178.     if { [lempty $columns] }  {
  179.     return ;
  180.     }
  181.     set col [lvarpop columns]
  182.     $section pushIndent
  183.     set ixval [map_fgl2ixval [$col getType3GL]]
  184.     expand_text $section {~${prefix}.getVal(~[get_column_nr $col])~$postfix\
  185.     CAST ~$ixval}
  186.     set newpf $separator$newline$prefix
  187.     while {![lempty $columns]} {
  188.     set col [lvarpop columns]
  189.     set ixval [map_fgl2ixval [$col getType3GL]]
  190.     expand_text $section {~${newpf}.getVal(~[get_column_nr $col])~$postfix\
  191.         CAST ~$ixval}
  192.     }
  193.     $section popIndent
  194.     $section append $newline
  195. }
  196.  
  197. proc gen_rowgetval {section table selector {prefix ""} {postfix ""} \
  198.     {separator ", "} {newline ""}} {
  199.  
  200.     gen_rowgetval_c $section [get_col_list $table $selector] $prefix \
  201.         $postfix $separator $newline
  202. }
  203.  
  204. proc gen_rowgetval_l {section link {prefix ""} {postfix ""} {separator ", "} \
  205.     {newline ""}} {
  206.  
  207.     gen_rowgetval_c $section [$link columnSet] $prefix $postfix \
  208.         $separator $newline
  209. }
  210.  
  211. # Generate a list of getVal calls for values in a row. The values correspond
  212. # to the columns. These procs are the same as the gen_rowgetval* procs, except
  213. # that the index used to get values from a row, is not the column_nr, but an 
  214. # incremental index ("inc" in gen_rowgetvalinc* stands for "incremental").
  215. #
  216. proc gen_rowgetvalinc_c {section columns {prefix ""} {postfix ""} \
  217.         {separator ", "} {newline ""}} {
  218.  
  219.     if { [lempty $columns] }  {
  220.         return ;
  221.     }
  222.     set col [lvarpop columns]
  223.     $section pushIndent
  224.     set ixval [map_fgl2ixval [$col getType3GL]]
  225.     set i 1
  226.     expand_text $section {~${prefix}.getVal(~$i)~$postfix CAST ~$ixval}
  227.     set newpf $separator$newline$prefix
  228.     while {![lempty $columns]} {
  229.         set col [lvarpop columns]
  230.         set ixval [map_fgl2ixval [$col getType3GL]]
  231.     incr i
  232.         expand_text $section {~${newpf}.getVal(~$i)~$postfix CAST ~$ixval}
  233.     }
  234.     $section popIndent
  235.     $section append $newline
  236. }
  237.  
  238. proc gen_rowgetvalinc {section table selector {prefix ""} {postfix ""} \
  239.         {separator ", "}} {
  240.  
  241.         gen_rowgetvalinc_c $section [get_col_list $table $selector] $prefix \
  242.                 $postfix $separator
  243. }
  244.  
  245. proc gen_rowgetvalinc_l {section link {prefix ""} {postfix ""} \
  246.     {separator ", "}} {
  247.  
  248.         gen_rowgetvalinc_c $section [$link columnSet] $prefix $postfix \
  249.                 $separator 
  250. }
  251.  
  252. # nullify columns
  253. #
  254. proc gen_assign_nullc {section columns {prefix1 ""} {postfix1 ""}} {
  255.     $section pushIndent
  256.     foreach col $columns {
  257.         $section append \
  258.             [assign_elem_null $col $prefix1 $postfix1]
  259.     }
  260.     $section popIndent
  261. }
  262.  
  263. # see gen_assign_nullc
  264. #
  265. proc gen_assign_null {section table selector {prefix1 ""} {postfix1 ""}} {
  266.     gen_assign_nullc $section [get_col_list $table $selector] $prefix1 \
  267.         $postfix1
  268. }
  269.  
  270. #  Return the string for one null assignment
  271. #
  272. proc assign_elem_null {col {prefix1 ""} {postfix1 ""}} {
  273.     set colnr [get_column_nr $col]
  274.     return "CALL $prefix1.getVal($colnr).setNull()\n"
  275. }
  276.  
  277. # Redefine for NewEra
  278. # Return the string for one assignment
  279. #
  280. proc assign_elem {col {prefix1 ""} {postfix1 ""} {prefix2 ""}
  281.         {postfix2 ""} {sect "src"} {retvarname retVal}} {
  282.     set name [$col getUniqueName]
  283.     set colnr [get_column_nr $col]
  284.     return "LET $retvarname = $prefix1.setVal(COPY $name, $colnr)\n"
  285. }
  286.  
  287. # Redefine for NewEra
  288. # Return the string for one assignment in a master-detail relationship
  289. #
  290. proc assign_elem_md {col {prefix1 ""} {postfix1 ""} {prefix2 ""}
  291.                      {postfix2 ""} {sect "src"} {retvarname retVal}} {
  292.     set colnr [get_column_nr $col]
  293.     set fcolnr [get_foreign_column_nr $col]
  294.     return "LET $retvarname = $prefix1.setVal(COPY $prefix2.getVal($fcolnr), $colnr)\n"
  295. }
  296.  
  297. # Special for initByRow
  298. #
  299. proc gen_assign_initrow {section table selector rowname initrowname} {
  300.     set columns [get_col_list $table $selector]
  301.     $section pushIndent
  302.     set i 1
  303.     foreach col $columns {
  304.         set colnr [get_column_nr $col]
  305.         expand_text $section {
  306.             LET retVal =\
  307.                 ~${rowname}.setVal(~${initrowname}.getVal(~${i}),\
  308.                 ~${colnr})
  309.         }
  310.         if {[$col getColumnType] == "key"} {
  311.             incr i
  312.         } else {
  313.             expand_text $section {
  314.                 LET retVal = ~${initrowname}.delete(~${i})
  315.             }
  316.         }
  317.     }
  318.     $section popIndent
  319. }
  320.  
  321.  
  322. # add a "column_nr" attribute to (imported) column objects in the model
  323. # add a "foreign_column_nr" attribute to imported column objects in the model
  324. #
  325. proc add_column_nr_attrs {} {
  326.     global oomodel
  327.     set tables [[$oomodel sqlModel] tableSet]
  328.     foreach table $tables {
  329.     set column_nr 1
  330.     set columns [$table columnSet]
  331.     foreach col $columns {
  332.         add_attr $col column_nr $column_nr
  333.         incr column_nr
  334.         if { [$col get_obj_type] == "imp_column" } {
  335.         set foreign_column_nr 1
  336.         set fcolumns [[$col master] columnSet]
  337.         foreach fcol $fcolumns {
  338.             if { [$col column] == $fcol } {
  339.             add_attr $col foreign_column_nr $foreign_column_nr
  340.             break
  341.             }
  342.             incr foreign_column_nr
  343.         }
  344.         }
  345.     }
  346.     }
  347. }
  348.  
  349. proc get_column_nr {col} {
  350.     if {$col != ""} {
  351.         return [$col getPropertyValue column_nr]
  352.     } else {
  353.         return -1
  354.     }
  355. }
  356.  
  357. proc get_foreign_column_nr {col} {
  358.     return [$col getPropertyValue foreign_column_nr]
  359. }
  360.