home *** CD-ROM | disk | FTP | other *** search
/ PC World 1997 November / PCWorld_1997-11_cd.bin / software / programy / komix / DATA.Z / oldimport.tcl < prev    next >
Text File  |  1997-02-05  |  7KB  |  278 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        : @(#)oldimport.tcl    /main/hindenburg/9 (1.10)
  17. #    Original date    : 7-8-1992
  18. #    Description    : Import front end for old style targets
  19. #
  20. #---------------------------------------------------------------------------
  21. #
  22.  
  23. require wmt_util.tcl
  24. require cgen_msg.tcl
  25. require legacy.tcl
  26. require machdep.tcl
  27. require fstorage.tcl
  28. require subimport.tcl
  29.  
  30. global import_new; set import_new 0
  31. global import_sel; set import_sel 0
  32. global ooplClassFilter; set ooplClassFilter ""
  33. global ooplExclClassFilter; set ooplExclClassFilter ""
  34.  
  35. #
  36. # Boolean options understood by import.tcl.
  37. #
  38. # The first element of each sublist will cause the second element to be
  39. # made "global" and set to either 0 or 1, depending on whether the first
  40. # element was specified as an argument to 'otsh' after the "--".
  41. #
  42. # The third element in each sublist gives the default value for the option,
  43. # i.e. the value it will get if the option was not specified.
  44. #
  45.  
  46. global boolean_options
  47. set boolean_options { {-trace tracing 0} \
  48.               {-debug debug 0} \
  49.               {-time timing 0} }
  50.  
  51. #
  52. # See if any boolean options were specified, set the appropriate
  53. # variables, and remove any options from argv.
  54. #
  55.  
  56. proc parse_options {} {
  57.     global boolean_options argv
  58.     foreach opt $boolean_options {
  59.     set i [lsearch $argv [lindex $opt 0]]
  60.     set optvar [lindex $opt 1]
  61.     eval "global $optvar"
  62.     if {$i == -1} {
  63.         set optdef [lindex $opt 2]
  64.         eval "set $optvar $optdef"
  65.     } else {
  66.         set argv [lreplace $argv $i $i]
  67.         eval "set $optvar 1"
  68.     }
  69.     }
  70. }
  71.  
  72. # Import files: handles both import-new and import-selected by
  73. # loading the model and by "sourcing" gensql.tcl and/or gen${t_lang}.tcl
  74. #
  75. proc import {} {
  76.     global oomodel do_struct_file
  77.     set t_lang [m4_var get M4_target_lang]
  78.     set do_struct_file 0
  79.  
  80.     # remove sql as src_object for languages without persistent code
  81.     # generation
  82.     if ![supportPersistentCodeGen] {
  83.         regsub -all "sql" $src_objects "" new_src_objects
  84.         set src_objects $new_src_objects
  85.     }
  86.  
  87.     if {![loadomt $t_lang]} {
  88.         return
  89.     }
  90.     if [lempty $tgt_objects] {
  91.         global import_new
  92.         set import_new 1
  93.         if [lempty $src_objects] {
  94.             if [supportPersistentCodeGen] {
  95.                 require_with_reload gensql.tcl
  96.             }
  97.             require_with_reload gen${t_lang}.tcl
  98.             return
  99.         }
  100.  
  101.         # Always generate struct file if Import New + OOPL + SQL
  102.         # generation, because struct file may have changed if new
  103.         # persistent classes are imported.
  104.         #
  105.         set do_struct_file [expr {$t_lang == "cpp" &&
  106.             [lsearch $src_objects "oopl"] != -1 &&
  107.             [lsearch $src_objects "sql"] != -1}]
  108.  
  109.         set post_require_files {}
  110.         foreach imp_model $src_objects {
  111.             case $imp_model in {
  112.             {oopl} {lappend post_require_files gen${t_lang}.tcl}
  113.             {sql} {require_with_reload gensql.tcl}
  114.             }
  115.         }
  116.         foreach prf $post_require_files {
  117.             require_with_reload $prf
  118.         }
  119.         return
  120.     }
  121.     #
  122.     # Import selected: Generate the selected target files
  123.     #
  124.     global import_sel
  125.     set import_sel 1
  126.     set oopl_files ""
  127.     set sql_files ""
  128.  
  129.     foreach file $tgt_objects {
  130.         set type [nt_get_type $file]
  131.  
  132.         if {[lsearch [getOoplTypesToGenerateFor] $type] != -1} {
  133.             lappend oopl_files $file
  134.             continue
  135.         }
  136.  
  137.         if [supportPersistentCodeGen] {
  138.             if {"$type" == "$sql_type"} {
  139.                 lappend sql_files $file
  140.                 continue
  141.             }
  142.         }
  143.  
  144.         m4_warning $W_UNKNOWN_FILE $file
  145.     }
  146.  
  147.     global tool_tgt_objs
  148.     if {![lempty $sql_files]} {
  149.         set tool_tgt_objs $sql_files
  150.         require_with_reload gensql.tcl
  151.     }
  152.     if {![lempty $oopl_files]} {
  153.         set tool_tgt_objs $oopl_files
  154.         require_with_reload gen${t_lang}.tcl
  155.     }
  156.     $oomodel delete
  157. }
  158.  
  159. proc loadomt {t_lang} {
  160.     global oomodel
  161.  
  162.     if [lempty $tgt_objects] {
  163.         set types_list [getOoplTypesToGenerateFor]
  164.         set cl_files [fstorage::dir $types_list]
  165.         global ooplExclClassFilter
  166.         set ooplExclClassFilter [get_class_list $cl_files]
  167.     } else {
  168.         global ooplClassFilter
  169.         set ooplClassFilter [get_class_list $tgt_objects]
  170.     }
  171.  
  172.     set cc [ClientContext::global]
  173.     set systemNameType [$cc levelNameAt System]
  174.     set phaseNameType [$cc levelNameAt Phase]
  175.     set prevPhaseV [[$cc currentPhase] previous [$cc currentConfig]]
  176.  
  177.     if [$prevPhaseV isNil] {
  178.         m4_error $E_NO_PREV_PHASE $phaseNameType
  179.         return 0
  180.     }
  181.  
  182.     set prevPhase [$prevPhaseV phase]
  183.     set prevPhaseNameType [$prevPhase name].[$prevPhase name]
  184.  
  185.     if {[$prevPhase type] != "ObjectDesign"} {
  186.         m4_error $E_WRONG_PREV_PHASE $prevPhaseNameType
  187.         return 0
  188.     }
  189.  
  190.     if {[catch {fstorage::goto_system $systemNameType $prevPhaseNameType} reason]} {
  191.         puts stderr $reason
  192.         return 0
  193.     }
  194.  
  195.     set oomodel [OOModel::createModel]
  196.  
  197.     fstorage::goto_system $systemNameType $phaseNameType
  198.  
  199.     if {[$oomodel error] > 0} {
  200.         ##m4_error $E_LOAD_MODEL
  201.         puts stdout "Loading OOPL model failed due to previous errors"
  202.         $oomodel delete
  203.         return 0
  204.     }
  205.  
  206.     return 1
  207. }
  208.  
  209. #
  210. # Make a list of classes out of a list of files
  211. #
  212.  
  213. proc get_class_list {file_list} {
  214.     set result ""
  215.  
  216.     foreach file $file_list {
  217.     set type [nt_get_type $file]
  218.     if {[lsearch [getOoplTypesToGenerateFor] $type] != -1} {
  219.         if [catch {set names [fstorage::get_imp_from $file]} reason] {
  220.         puts stderr $reason
  221.         set names ""
  222.         }
  223.  
  224.         if {"$names" == ""} {
  225.         set nm [nt_get_name $file]
  226.  
  227.         if {[lsearch [getNamesNotToGenerateFor] $nm] != -1} {
  228.             continue
  229.         }
  230.  
  231.         m4_warning $W_IMPFROM_NOT_SET $file $nm
  232.         }
  233.  
  234.         foreach nm $names {
  235.         if {[lsearch $result $nm] == -1} {
  236.             lappend result $nm
  237.         }
  238.         }
  239.     }
  240.     }
  241.  
  242.     return $result
  243. }
  244.  
  245. #
  246. # Parse options and make sure argv does not contain them anymore.
  247. #
  248.  
  249. parse_options
  250.  
  251. #
  252. # Save src/tgt objects
  253. #
  254.  
  255. global src_objects; set src_objects [CommandLineInterface::getSourceObjects]
  256. global tgt_objects; set tgt_objects [CommandLineInterface::getTargetObjects]
  257.  
  258. #
  259. # Now reimplement them
  260. #
  261.  
  262. proc get_tgt_objs {} {
  263.     global tool_tgt_objs
  264.     return [get tool_tgt_objs]
  265. }
  266.  
  267. #
  268. # Just call import
  269. #
  270.  
  271. if [catch {import} msg] {
  272.     switch $errorCode {
  273.         ERR_CPP_CONFIG {puts stderr "ERROR: $msg"}
  274.         ERR_UNIQUE_FILENAME {puts stderr "ERROR: $msg"}
  275.         default {puts stderr $errorInfo}
  276.     }
  277. }
  278.