home *** CD-ROM | disk | FTP | other *** search
/ PC World 1997 November / PCWorld_1997-11_cd.bin / software / programy / komix / DATA.Z / libora.tcl < prev    next >
Encoding:
Text File  |  1996-12-09  |  7.7 KB  |  300 lines
  1. #---------------------------------------------------------------------------
  2. #
  3. # Copyright (c) 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        : @(#)libora.tcl    /main/hindenburg/1
  17. #    Original date    : November 1995
  18. #    Description    : Oracle specific routines
  19. #
  20. #---------------------------------------------------------------------------
  21. #
  22. # @(#)libora.tcl    /main/hindenburg/1    9 Dec 1996 Copyright 1995 Cadre Technologies Inc.
  23. #
  24. #---------------------------------------------------------------------------
  25.  
  26. #
  27. #    Procedures to support mapping of standard type "sequence"
  28. #
  29.  
  30. proc is_sequence {type} {
  31.     return [regexp {sequence*} $type]
  32. }
  33.  
  34. #
  35. #    The "normal" way to get the 4gl type. Always does the mapping
  36. #
  37.  
  38. proc get_ora_type_4gl {column} {
  39.  
  40.     if [is_sequence [$column getTypeStd]] {
  41.     return NUMBER
  42.     }
  43.  
  44.     return [$column getType4GL]
  45. }
  46.  
  47.  
  48. #
  49. #    Generate declaration of variables for selected columns in table
  50. #    For character arrays the hosttype VARCHAR is used.
  51. #
  52.  
  53. proc gen_ora_decl {section table selector {prefix ""} {postfix ""} \
  54.                 {separator ";\n"}} {
  55.     gen_ora_decl_columns $section [get_col_list $table $selector] \
  56.                         $prefix $postfix $separator
  57. }
  58.  
  59. #
  60. #    Generate declaration of variables for columns in link
  61. #    For character arrays the hosttype VARCHAR is used.
  62. #
  63.  
  64. proc gen_ora_decl_link {section link {prefix ""} {postfix ""}
  65.             {separator ";\n"}} {
  66.     gen_ora_decl_columns $section [$link columnSet] $prefix $postfix $separator
  67. }
  68.  
  69. #
  70. #    Generate declaration of variables for each column in column list
  71. #    For character arrays the hosttype VARCHAR is used.
  72. #
  73.  
  74. proc gen_ora_decl_columns {section columns {prefix ""} {postfix ""}
  75.             {separator ";\n"}} {
  76.     $section pushIndent
  77.  
  78.     foreach col $columns {
  79.     $section append [mk_ora_decl $col $prefix $postfix]$separator
  80.     }
  81.  
  82.     $section popIndent
  83. }
  84.  
  85. #
  86. #   Generate declaration of variable: use VARCHAR type for character arrays
  87. #
  88.  
  89. proc mk_ora_decl {col {prefix ""} {postfix ""}} {
  90.     set name [$col getUniqueName]
  91.     set type [$col getType3GL]
  92.  
  93.     if [regsub {(var)?char\[} $type "VARCHAR $prefix$name\[" type] {
  94.     regexp {\[(.*)\]$} $type dummy index
  95.     set index [expr {$index + 1}]
  96.     regsub {\[(.*)\]$} $type "$postfix\[$index]" type
  97.     return $type
  98.     }
  99.  
  100.     return "$type $prefix$name$postfix"
  101. }
  102.  
  103. #
  104. # Generate pointers to struct
  105. #
  106.  
  107. proc gen_ptr_decl_assign {section table selector {pref1 ""} {post1 ""} \
  108.                  {pref2 ""} {post2 ""} {separator ";\n"}} {
  109.     $section pushIndent
  110.  
  111.     foreach col [get_col_list $table $selector] {
  112.     set colName [$col getUniqueName]
  113.     set lside $pref1$colName$post1
  114.     set type3GL [$col getType3GL]
  115.  
  116.     if {[string first "\[" $type3GL] == -1} {
  117.         set rside &($pref2$colName$post2)
  118.     } else {
  119.         set rside $pref2$colName$post2
  120.     }
  121.  
  122.     set typeName [lindex [split [$col getType3GL] "\["] 0]
  123.     $section append "const $typeName *$lside = $rside$separator"
  124.     }
  125.  
  126.     $section popIndent
  127. }
  128.  
  129. #
  130. # Generate pointers to indicator struct
  131. #
  132.  
  133. proc gen_ind_decl_assign {section table selector {pref1 ""} {post1 ""} \
  134.                  {pref2 ""} {post2 ""} {separator ";\n"}} {
  135.     $section pushIndent
  136.  
  137.     foreach col [get_col_list $table $selector] {
  138.     set colName [$col getUniqueName]
  139.     set lside $pref1$colName$post1
  140.     set rside &($pref2$colName$post2)
  141.  
  142.     $section append "short *$lside = $rside$separator"
  143.     }
  144.  
  145.     $section popIndent
  146. }
  147.  
  148. #
  149. #    Generate assignment statement for Oracle columns (may need VARCHAR type)
  150. #
  151.  
  152. proc gen_ora_assign {section table selector {pref1 ""} {post1 ""}
  153.             {pref2 ""} {post2 ""} {flag1 ""} {flag2 ""}} {
  154.     $section pushIndent
  155.  
  156.     foreach col [get_col_list $table $selector] {
  157.     $section append [assign_ora_elem $section $col $pref1 $post1 \
  158.                     $pref2 $post2 $flag1 $flag2]
  159.     }
  160.  
  161.     $section popIndent
  162. }
  163.  
  164. #
  165. #    Generate assignment statement for Oracle columns (may need VARCHAR type)
  166. #
  167.  
  168. proc gen_ora_assign_cl {section link {pref1 ""} {post1 ""}
  169.             {pref2 ""} {post2 ""} {flag1 ""} {flag2 ""}} {
  170.     $section pushIndent
  171.     foreach col [$link columnSet] {
  172.      $section append [assign_ora_elem_md $section $col \
  173.             $pref1 $post1 $pref2 $post2 $flag1 $flag2]
  174.     }
  175.     $section popIndent
  176. }
  177.  
  178. #
  179. #    Generate assignment statement for Oracle columns (may need VARCHAR type)
  180. #
  181.  
  182. proc gen_ora_assign_link {section link {pref1 ""} {post1 ""}
  183.             {pref2 ""} {post2 ""} {flag1 ""} {flag2 ""}} {
  184.     $section pushIndent
  185.     foreach col [$link columnSet] {
  186.      $section append [assign_ora_elem $section $col \
  187.             $pref1 $post1 $pref2 $post2 $flag1 $flag2]
  188.     }
  189.     $section popIndent
  190. }
  191.  
  192. #
  193. #    Generate assignment for Oracle columns (may need VARCHAR type)
  194. #
  195.  
  196. proc assign_ora_elem {section column {pref1 ""} {post1 ""}
  197.                 {pref2 ""} {post2 ""} {flag1 ""} {flag2 ""}} {
  198.     set name [$column getUniqueName]
  199.  
  200.     set part1 $pref1$name$post1
  201.     set part2 $pref2$name$post2
  202.  
  203.     if [type_is_char_array $column] {
  204.     add_[determine_sect_type $section]_inc_name "string" "h"
  205.  
  206.     if {($flag1 == "") && ($flag2 == "")} {
  207.         return "strcpy($part1, $part2);\n"
  208.     }
  209.  
  210.     return [assign_ora_char_type $part1 $part2 $flag1 $flag2]
  211.     }
  212.  
  213.     return "$part1 = $part2;\n"
  214. }
  215.  
  216. #
  217. #    Generate assignment for Oracle columns (may need VARCHAR type)
  218. #
  219.  
  220. proc assign_ora_elem_md {sect col {pref1 ""} {post1 ""} {pref2 ""} {post2 ""}
  221.             {flag1 ""} {flag2 ""}} {
  222.     set name [$col getUniqueName]
  223.     set fname [$col getForeignName]
  224.  
  225.     set part1 $pref1$name$post1
  226.     set part2 $pref2$fname$post2
  227.  
  228.     if [type_is_char_array $col] {
  229.     add_[determine_sect_type $sect]_inc_name "string" "h"
  230.  
  231.     if {($flag1 == "") && ($flag2 == "")} {
  232.         return "strcpy($part1, $part2);\n"
  233.     }
  234.  
  235.     return [assign_ora_char_type $part1 $part2 $flag1 $flag2]
  236.     }
  237.  
  238.     return "$part1 = $part2;\n"
  239. }
  240.  
  241. #
  242. #    Generate assignment for Oracle VARCHAR type
  243. #
  244.  
  245. proc assign_ora_char_type {part1 part2 {flag1 ""} {flag2 ""}} {
  246.     if {($flag1 == "ora") && ($flag2 == "ora")} {
  247.     set line1 "strncpy((char *)${part1}.arr, (char *)${part2}.arr, ${part2}.len);\n"
  248.     set line2 "${part1}.len = ${part2}.len;\n"
  249.     return $line1$line2
  250.     }
  251.  
  252.     if {$flag1 == "ora"} {
  253.     set line1 "strcpy((char *)${part1}.arr, $part2);\n"
  254.     set line2 "${part1}.len = strlen($part2);\n"
  255.     return $line1$line2
  256.     }
  257.  
  258.     if {$flag2 == "ora"} {
  259.     set line1 "strncpy(${part1}, (char *)${part2}.arr, ${part2}.len);\n"
  260.     set line2 "${part1}\[${part2}.len\] = '\\0';\n"
  261.     return $line1$line2
  262.     }
  263.  
  264.     return "strcpy($part1, $part2);\n"
  265. }
  266.  
  267. #
  268. #
  269. #
  270.  
  271. proc init_base_sequences {section class} {
  272.     $section pushIndent
  273.  
  274.     foreach col [get_col_list [$class table] IMPKEYS] {
  275.     if [is_sequence [$col getTypeStd]] {
  276.         set colName [$col getUniqueName]
  277.         set baseCol [$col column]
  278.         set baseColName [$baseCol getUniqueName]
  279.  
  280.         foreach inhGroup [$class genNodeSet] {
  281.         set baseClass [$inhGroup superClass]
  282.         if {![$baseClass isPersistent]} {
  283.             continue
  284.         }
  285.         set baseTable [$baseClass table]
  286.  
  287.         if {[$baseCol table] == $baseTable} {
  288.             set baseClassName [$baseClass getName]
  289.  
  290.             expand_text $section {
  291.             data.~$colName = ~$baseClassName::data.~$baseColName;
  292.             }
  293.         }
  294.         }
  295.     }
  296.     }
  297.  
  298.     $section popIndent
  299. }
  300.