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