home *** CD-ROM | disk | FTP | other *** search
/ PC World 1997 November / PCWorld_1997-11_cd.bin / software / programy / komix / DATA.Z / libsybsql.tcl < prev    next >
Encoding:
Text File  |  1996-06-05  |  14.4 KB  |  524 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        : @(#)libsybsql.tcl    2.1
  17. #    Original date    : Tue Dec  5 10:39:19 MET 1995
  18. #    Description    : Sybase specific procedures for gensql
  19. #
  20. #---------------------------------------------------------------------------
  21. #
  22.  
  23. #
  24. # FROM tcl/l_cpp/cpp_disp.tcl
  25. #
  26.  
  27.  
  28. #
  29. # FROM tcl/l_cpp/cpp_funcs.tcl
  30. #
  31.  
  32.  
  33. proc attrib_init::generate {init init_sect body_sect} {
  34.     ### hack !?
  35.     set data_struct 0
  36.     set attrib [$init attrib]
  37.     if {[$attrib get_obj_type] == "db_data_attrib"} {
  38.         set tgt "data.[[$attrib column] getUniqueName]"
  39.         set data_struct 1
  40.     } else {
  41.         set tgt [$attrib getName]
  42.     }
  43.     if {[type_is_char_scalar [$attrib ooplType]]} {
  44.         $body_sect append \
  45.         "$tgt\[0\] = [$init getName]; $tgt\[1\] = '\\0';\n"
  46.     } else { if [type_is_char_array [$attrib ooplType]] {
  47.                 add_[determine_sect_type $body_sect]_inc_name "string" "h"
  48.         $body_sect append "strcpy($tgt, [$init getName]);\n"
  49.     } else {
  50.         if $data_struct {
  51.             $body_sect append "$tgt = [$init getName];\n"
  52.             return
  53.         }
  54.         append_ctor_init $tgt [$init getName]
  55.     } }
  56. }
  57.  
  58. proc inher_key_init::generate {init init_sect body_sect} {
  59.     set col [$init key]
  60.     set name [$col getUniqueName]
  61.     if {$name == $TYPE_ID_NM} {
  62.         return
  63.     }
  64.     set class_nm [[$init ooplClass] getName]
  65.  
  66.     if {[type_is_char_scalar $col]} {
  67.         set base_name "[$col getForeignName]\[0\]"
  68.     } else {
  69.         set base_name [$col getForeignName]
  70.     }
  71.  
  72.     $body_sect append \
  73.         "[assign_var data.$name $class_nm::data.$base_name $col $body_sect]\n"
  74. }
  75.  
  76. proc assign_var {to from type_obj {sect "src"}} {
  77.     if {[type_is_char_scalar $type_obj]} {
  78.     return "$to\[0\] = $from; $to\[1\] = '\\0';"
  79.     }
  80.     if {[type_is_char_array $type_obj]} {
  81.     add_[determine_sect_type $sect]_inc_name "string" "h"
  82.     return "strcpy($to, $from);"
  83.     }
  84.     return "$to = $from;"
  85. }
  86.  
  87. proc base_type::gen_var_decl {type name {col ""}} {
  88.     set type [$type getType3GL]
  89.  
  90.     if {$type == "char"} {
  91.     return "$type $name\[2\]"
  92.     #return "CS_BINARY $name\[2\]"
  93.     }
  94.  
  95.     if [regsub {(var)?char\[} $type "char $name\[" type] {
  96.     regexp {\[(.*)\]$} $type dummy index
  97.     set index [expr {$index + 1}]
  98.     regsub {\[(.*)\]$} $type "\[$index]" type
  99.     return $type
  100.     #set _type {} ; regsub {^char } $type {CS_BINARY } _type ; return $_type
  101.     }
  102.     return "$type $name"
  103. }
  104.  
  105.  
  106.  
  107. #
  108. # FROM tcl/libsql.tcl
  109. #
  110.  
  111. #
  112. # Extra column_selectors
  113. #
  114. global column_selector
  115. set column_selector(ALL_NONSERIAL)    {!([$col getTypeStd] == "identity" && [$col get_obj_type] == "column")}
  116. set column_selector(NONKEYS_NONSERIAL)    {[$col getColumnType] != "key" && !([$col getTypeStd] == "identity" && [$col get_obj_type] == "column")}
  117.  
  118.  
  119. if 1 {
  120.  
  121. proc sqlpostfix_needed { col } {
  122.     if {[$col getColumnType] == "key"} {
  123.     return "NOT NULL"
  124.     }
  125.  
  126.     if { [$col get_obj_type] == "column" }  {
  127.     if {[$col getColumnType] == "key"} {
  128.         return "NOT NULL"
  129.     }
  130.     if {[$col getTypeStd] == "identity"} {
  131.         return "IDENTITY"
  132.     }
  133.     if {[$col isNullable]} {
  134.         return "NULL"
  135.     }
  136.     return "NOT NULL"
  137.     }
  138.  
  139.     # it's an imported column
  140.     #
  141.     set link [$col getImport]
  142.     if {[$link getDelType] == "optional" && [$col getColumnType] == "field"}  {
  143.     return "NULL"
  144.     }
  145.  
  146.     #if {[$col getPropertyValue "nullable"] == 1} { return "NULL" }
  147.     return "NULL"
  148. }
  149.  
  150. } else {  # 0
  151.  
  152. proc sqlpostfix_needed {col} {
  153.  
  154.     if {[$col get_obj_type] == "column"}  {
  155.     if {[$col getTypeStd] == "identity"} {
  156.         return "IDENTITY"
  157.     }
  158.        return [$col getSqlPostfix]
  159.     }
  160.     set link [$col getImport]
  161.     if {[$link getDetailType] == "optional" &&
  162.     [$col getColumnType] == "field"}  {
  163.         return "";
  164.     }
  165.     return [$col getSqlPostfix]
  166. }
  167.  
  168. }  # 0
  169.  
  170.  
  171. # Return the Sybase dependent string for one assignment
  172. #
  173. proc assign_elem {col {prefix1 ""} {postfix1 ""} {prefix2 ""} \
  174.                  {postfix2 ""} {sect "src"}} {
  175.     set name [$col getUniqueName]
  176.     if [type_is_char_scalar $col] {
  177.     return "$prefix1$name$postfix1\[0\] = $prefix2$name$postfix2; $prefix1$name$postfix1\[1\] = '\\0';\n"
  178.     }
  179.     if [type_is_char_array $col] {
  180.     add_[determine_sect_type $sect]_inc_name "string" "h"
  181.     return "strcpy($prefix1$name$postfix1, $prefix2$name$postfix2);\n"
  182.     }
  183.     return "$prefix1$name$postfix1 = $prefix2$name$postfix2;\n"
  184. }
  185.  
  186.  
  187. proc get_type_3gl {object} {
  188.     set type [$object getType3GL]
  189.     if {$type == "char"} {
  190.     set type "char\[1\]"
  191.     }
  192.     return $type
  193. }
  194.  
  195.  
  196. # Generate a 3gl data declaration
  197. #
  198. proc gen_data_decl_3gl {section table selector {prefix ""} \
  199.                        {newline ""} {postfix ""}} {
  200.  
  201.     set columns [get_col_list $table $selector]
  202.     if { [lempty $columns] } {
  203.         return
  204.     }
  205.     $section pushIndent
  206.     set col [lvarpop columns]
  207.  
  208.     # first col
  209.  
  210.     build_type_3gl [get_type_3gl $col] result_type result_range
  211.     set result_type $prefix$result_type
  212.     set result_range $result_range$postfix
  213.     expand_text $section {\~[create_3gl_var {~$name} {~$type} {~$range}
  214. ]} \
  215.     name [$col getUniqueName] type $result_type range $result_range
  216.     set newprefix $newline$prefix
  217.  
  218.     foreach col $columns {
  219.  
  220.     # next cols
  221.  
  222.     build_type_3gl [get_type_3gl $col] result_type result_range
  223.     set result_type $newprefix$result_type
  224.     set result_range $result_range$postfix
  225.     expand_text $section {\~[create_3gl_var {~$name} {~$type} {~$range}
  226. ]} \
  227.         name [$col getUniqueName] type $result_type range $result_range
  228.     }
  229.     $section append $newline
  230.     $section popIndent
  231. }
  232.  
  233. # Generate a 3gl data declaration directly (without calling create_3gl_var)
  234. #
  235. proc gen_dir_data_decl_3gl {section object selector {separator ", "} \
  236.                {newline ""} {prefix ""} {postfix ""} \
  237.                {prefix2 ""} {flag ""}} {
  238.  
  239.     gen_dir_data_decl_3glc $section [get_col_list $object $selector] \
  240.             $separator $newline $prefix $postfix $prefix2 $flag
  241. }
  242.  
  243. # Generate a 3gl data declaration for a link directly (without calling
  244. # create_3gl_var)
  245. #
  246. proc gen_dir_data_decl_3gl_link {section link {separator ", "} \
  247.                 {newline ""} {prefix ""} {postfix ""} \
  248.                 {prefix2 ""} {flag ""}} {
  249.  
  250.     gen_dir_data_decl_3glc $section [$link columnSet] \
  251.             $separator $newline $prefix $postfix $prefix2 $flag
  252. }
  253.             
  254. proc gen_dir_data_decl_3glc {section columns {separator ", "} \
  255.                 {newline ""} {prefix ""} {postfix ""} \
  256.                 {prefix2 ""} {flag ""}} {
  257.  
  258.     if { [lempty $columns] } {
  259.         return
  260.     }
  261.     set col [lvarpop columns]
  262.     $section pushIndent
  263.     $section append $prefix[mk_3gl_decl $col $postfix $prefix2 $flag]
  264.     set newpf $separator$newline$prefix
  265.     foreach col $columns {
  266.     $section append $newpf[mk_3gl_decl $col $postfix $prefix2 $flag]
  267.     }
  268.     $section popIndent
  269.     $section append $newline
  270. }
  271.  
  272. # Make a 3gl variable declaration for Sybase
  273. # {name, simpel_type} becomes   "simpel_type    name"
  274. # {name, char       } becomes   "char           name[2]"
  275. # {name, char[index]} becomes   "char           name[index + 1]"
  276. #
  277. proc mk_3gl_decl {col {postfix ""} {prefix ""} {flag ""}} {
  278.     set name [$col getUniqueName]
  279.     set type [$col getType3GL]
  280.  
  281.     # if {$flag == "syb"}
  282.     if {$type == "char"} {
  283.     return "$type $prefix$name$postfix\[2\]"
  284.     #return "CS_BINARY $prefix$name$postfix\[2\]"
  285.     }
  286.  
  287.     if [regsub {(var)?char\[} $type "char $prefix$name\[" type] {
  288.     regexp {\[(.*)\]$} $type dummy index
  289.     set index [expr {$index + 1}]
  290.     regsub {\[(.*)\]$} $type "$postfix\[$index]" type
  291.     return $type
  292.     #set _type {} ; regsub {^char } $type {CS_BINARY } _type ; return $_type
  293.     }
  294.     return "$type $prefix$name$postfix"
  295. }
  296.  
  297. # Determine if the 3gl type is a character array
  298. #
  299. proc type_is_char_array {obj} {
  300.     return [string match {*char\[*} [get_type_3gl $obj]]
  301. }
  302.  
  303. # Determine if the 3gl type is a character scalar
  304. #
  305. proc type_is_char_scalar {obj} {
  306.     #return [regexp {^[     ]*char[     ]*$} [$obj getType3GL]]
  307.     return [expr {([$obj getType3GL] == "char") ? 1 : 0}]
  308. }
  309.  
  310.  
  311. #
  312. # NEWly added
  313. #
  314.  
  315.  
  316. if 0 {
  317.  
  318. proc getTypeInfo {obj} {
  319.     set type [get_table_type $obj]
  320.     set match {}
  321.     set dbtype {}
  322.     set arg1 {}
  323.     set arg2 {}
  324.     regexp -- {^([^(]*)\(*([^,)]*),*([^)]*).*$} $type match dbtype arg1 arg2
  325.     switch -- "$dbtype" {
  326.     "VARCHAR"    {set dbtype CHAR}
  327.     "INTEGER"    {set dbtype SMALLINT}
  328.     "DEC"        {set dbtype NUMERIC}
  329.     }
  330.     return [list $dbtype $arg1 $arg2 ""]
  331. }
  332.  
  333. }  # 0
  334.  
  335.  
  336. proc getTypeInfo {obj} {
  337.     set cpp_type [get_type_3gl $obj]
  338.     set dummy {}
  339.     set index {}
  340.     regexp -- {\[(.*)\]$} $cpp_type dummy index
  341.     switch -glob -- "$cpp_type" {
  342.     "*unsigned*char*"    {set dbtype CHAR} # TINYINT?
  343.     "*signed*char*"        -
  344.     "*char*"        {set dbtype CHAR}
  345.     "*short*"        {set dbtype SMALLINT}
  346.     "*long*"        -
  347.     "*int*"            {set dbtype INT}
  348.     "*float*"        {set dbtype REAL}
  349.     "*double*"        {set dbtype FLOAT}
  350.     default            {set dbtype ILLEGAL}
  351.     }
  352.     set type [get_table_type $obj]
  353.     set match {}
  354.     set arg1 {}
  355.     set arg2 {}
  356.     regexp -- {^([^(]*)\(*([^,)]*),*([^)]*).*$} $type match syb_type arg1 arg2
  357.     switch -glob -- "$syb_type" {
  358.     "*CHAR"        {set is_str_type 1}
  359.     default        {set is_str_type 0}
  360.     }
  361.     return [list $dbtype $index "" $is_str_type]
  362. }
  363.  
  364.  
  365. proc gen_syb_arg_listc {section columns {prefix ""} {postfix ""} \
  366.                {separator ", "} {newline ""}} {
  367.     if { [lempty $columns] } {
  368.     return;
  369.     }
  370.     set newpf $separator$newline$prefix
  371.     set col [lvarpop columns]
  372.     set arg "${prefix}[$col getUniqueName]"
  373.     set i_arg "${postfix}[$col getUniqueName]"
  374.     set typeInfo [getTypeInfo $col]
  375.     set dbtype [lindex $typeInfo 0]
  376.     if {$dbtype == "CHAR"} {
  377.     set len "strlen($arg)"
  378.     } else {
  379.     set len 1
  380.     }
  381.     set type CS_${dbtype}_TYPE
  382.     set isStrType [lindex $typeInfo 3]
  383.     expand_text $section {__str += sybConvert(&~$arg, ~$type, ~$isStrType,
  384.             ~$len, ~$i_arg);
  385.     }
  386.     foreach col $columns {
  387.     set arg "${prefix}[$col getUniqueName]"
  388.     set i_arg "${postfix}[$col getUniqueName]"
  389.     set typeInfo [getTypeInfo $col]
  390.     set dbtype [lindex $typeInfo 0]
  391.     if {$dbtype == "CHAR"} {
  392.         set len "strlen($arg)"
  393.     } else {
  394.         set len 1
  395.     }
  396.     set type CS_${dbtype}_TYPE
  397.     set isStrType [lindex $typeInfo 3]
  398.     expand_text $section {__str += " , ";
  399.     }
  400.     expand_text $section {__str += sybConvert(&~$arg, ~$type, ~$isStrType,
  401.             ~$len, ~$i_arg);
  402.     }
  403.     }
  404. }
  405.  
  406. proc gen_syb_arg_list {section table selector {prefix ""} {postfix ""} \
  407.               {separator ", "} {newline ""} {master_table ""}} {
  408.     gen_syb_arg_listc $section [get_col_list $table $selector $master_table] \
  409.         $prefix $postfix $separator $newline
  410. }
  411.  
  412.  
  413. # Generate a Sybase local assignment for the given list of columns
  414. #
  415. proc gen_syb_lcl_assignc {section columns {prefix ""} {postfix ""} \
  416.              {separator ","} {newline ""}} {
  417.  
  418.     if { [lempty $columns] } {
  419.        return;
  420.     }
  421.     $section pushIndent
  422.     set newpf $separator$newline$prefix
  423.     set col [lvarpop columns]
  424.     expand_text $section {~$prefix~[$col getUniqueName] = ~[$col getUniqueName]~$postfix}
  425.     foreach col $columns {
  426.     expand_text $section {~$newpf~[$col getUniqueName] = ~[$col getUniqueName]~$postfix}
  427.     }
  428.     $section append $newline
  429.     $section popIndent
  430. }
  431.  
  432. # Generate a Sybase local assignment
  433. # The list of columns is determined by the value of the selector
  434. #
  435. proc gen_syb_lcl_assign {section table selector {prefix ""} {postfix ""} \
  436.             {separator ","} {newline ""} {master_table ""}} {
  437.  
  438.     gen_syb_lcl_assignc $section [get_col_list $table $selector $master_table] $prefix $postfix $separator $newline
  439. }
  440.  
  441.  
  442. # Generate a list of column names for the given link
  443. # If type is "char" then "...[0]" is created
  444. #
  445. proc gen_char_col_listl {section link {prefix ""} {postfix ""} \
  446.             {separator ", "} {newline ""}} {
  447.  
  448.     gen_char_col_listc $section [$link columnSet] $prefix $postfix \
  449.                $separator $newline
  450. }
  451.  
  452. # Generate a list of column names for the given list of columns
  453. # If type is "char" then "...[0]" is created
  454. #
  455. proc gen_char_col_listc {section columns {prefix ""} {postfix ""} \
  456.                 {separator ", "} {newline ""}} {
  457.  
  458.     if { [lempty $columns] } {
  459.        return;
  460.     }
  461.     $section pushIndent
  462.     set newpf $separator$newline$prefix
  463.     set col [lvarpop columns]
  464.     if [type_is_char_scalar $col] {
  465.     expand_text $section {~$prefix~[$col getUniqueName][0]~$postfix}
  466.     } else {
  467.     expand_text $section {~$prefix~[$col getUniqueName]~$postfix}
  468.     }
  469.     foreach col $columns {
  470.     if [type_is_char_scalar $col] {
  471.         expand_text $section {~$newpf~[$col getUniqueName][0]~$postfix}
  472.     } else {
  473.         expand_text $section {~$newpf~[$col getUniqueName]~$postfix}
  474.     }
  475.     }
  476.     $section append $newline
  477.     $section popIndent
  478. }
  479.  
  480. # Generate a list of column names for the given table
  481. # The list of columns is determined by the value of the selector
  482. # If type is "char" then "...[0]" is created
  483. #
  484. proc gen_char_col_list {section table selector {prefix ""} {postfix ""} \
  485.                {separator ", "} {newline ""} {master_table ""}} {
  486.     
  487.     gen_char_col_listc $section [get_col_list $table $selector $master_table] \
  488.           $prefix $postfix $separator $newline
  489. }
  490.  
  491.  
  492. proc gen_trunc_calls {section table selector {prefix ""}} {
  493.  
  494.     set columns [get_col_list $table $selector]
  495.     if {[lempty $columns]}  {
  496.        return;
  497.     }
  498.     $section pushIndent
  499.     set newline "\n"
  500.     set newpf $newline
  501.     set col [lvarpop columns]
  502.     set name [$col getUniqueName]
  503.     if {[regexp {char} [$col getType3GL]]} {
  504.     expand_text $section {sybTruncate(~$prefix~$name);}
  505.     }
  506.     while {![lempty $columns]} {
  507.     set col [lvarpop columns]
  508.     set name [$col getUniqueName]
  509.     if {[regexp {char} [$col getType3GL]]} {
  510.         expand_text $section {
  511.         ~${newpf}sybTruncate(~$prefix~$name);}
  512.     }
  513.     }
  514.     #$section append $newline
  515.     $section popIndent
  516. }
  517.  
  518. proc strToCharPtr {name} {
  519.     if {$name == "String"} {
  520.     return "as_ptr()"
  521.     }
  522.     return "data()"
  523. }
  524.