home *** CD-ROM | disk | FTP | other *** search
/ PC World 1997 November / PCWorld_1997-11_cd.bin / software / programy / komix / DATA.Z / legacy.tcl < prev    next >
Text File  |  1997-05-27  |  15KB  |  696 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        : @(#)legacy.tcl    /main/hindenburg/3
  17. #    Author        : Discovery
  18. #    Original date    : May 1995
  19. #    Description    : Legacy stuff for 3.x compatibility
  20. #
  21. #---------------------------------------------------------------------------
  22. #
  23. # @(#)legacy.tcl    /main/hindenburg/3 27 May 1997 Copyright 1995 Cadre Technologies Inc.
  24. #
  25. #---------------------------------------------------------------------------
  26.  
  27. require wmt_util.tcl
  28.  
  29. #
  30. #   Create TCL Callback routines for User Defined Properties
  31. #
  32.  
  33. OTShRegister::propertyCallbacks
  34.  
  35. #
  36. #   Procedures to convert 3.x style routines to 4.0
  37. #
  38.  
  39. proc add_attr {object propName propValue} {
  40.     return [$object addRunTimeProperty $propName $propValue]
  41. }
  42.  
  43. proc add_class {ooplModel className {classType class}} {
  44.     return [$ooplModel addClass $className $classType]
  45. }
  46.  
  47. proc add_operation {ooplModel class operName {returnType ""} {parList ""}} {
  48.  
  49.     set operation [$class addOperation $operName $returnType]
  50.  
  51.     foreach param $parList {
  52.     $operation addParameter [lindex $param 0] [lindex $param 1]
  53.     }
  54.  
  55.     return $operation
  56. }
  57.  
  58. proc add_super_class {ooplModel subClass superClass} {
  59.     return [$ooplModel addSuperClass $subClass $superClass]
  60. }
  61.  
  62. proc dealloc_model {model} {
  63.     $model delete
  64. }
  65.  
  66. proc get_action {receivedEvent} {
  67.     return [$receivedEvent getAction]
  68. }
  69.  
  70. proc get_assoc {initializer} {
  71.     return [$initializer assoc]
  72. }
  73.  
  74. proc get_attrib {object} {
  75.     return [$object attrib]
  76. }
  77.  
  78. proc get_attributes {receivedEvent} {
  79.     return [$receivedEvent getAttributes]
  80. }
  81.  
  82. proc get_card {link} {
  83.     return [$link getCard]
  84. }
  85.  
  86. proc get_child_events {event} {
  87.     return [$event childEventSet]
  88. }
  89.  
  90. proc get_class {initializer} {
  91.     return [$initializer ooplClass]
  92. }
  93.  
  94. proc get_classes {ooplModel} {
  95.     return [$ooplModel ooplClassSet]
  96. }
  97.  
  98. proc get_column {object} {
  99.     return [$object column]
  100. }
  101.  
  102. proc get_column_type {column} {
  103.     return [$column getColumnType]
  104. }
  105.  
  106. proc get_columns {table} {
  107.     return [$table columnSet]
  108. }
  109.  
  110. proc get_conditions {receivedEvent} {
  111.     return [$receivedEvent getConditions]
  112. }
  113.  
  114. proc get_constraint {object} {
  115.     return [$object getConstraint]
  116. }
  117.  
  118. proc get_creation_params {ooplClass} {
  119.     return [$ooplClass creationParamSet]
  120. }
  121.  
  122. proc get_del_type {link} {
  123.     return [$link getDelType]
  124. }
  125.  
  126. proc get_detail {link} {
  127.     return [$link detail]
  128. }
  129.  
  130. proc get_detail_type {link} {
  131.     return [$link getDetailType]
  132. }
  133.  
  134. proc get_details {table} {
  135.     return [$table detailSet]
  136. }
  137.  
  138. OTShRegister::reportWriter
  139.  
  140. proc get_diagram_classes {name {type ""}} {
  141.     if {$type == "" } {
  142.     set type [nt_get_type $name]
  143.     set name [nt_get_name $name]
  144.     }
  145.  
  146.     set clientCont [ClientContext::global]
  147.     set systemV [$clientCont currentSystem]
  148.     if [$systemV isNil] {
  149.     return ""
  150.     }
  151.  
  152.     set diag [$systemV findFileVersion $name $type]
  153.  
  154.     if [$diag isNil] {
  155.     #
  156.     # Exceptional case: A.B.cdm ...
  157.     #
  158.  
  159.     set diag [$systemV findFileVersion $name.$type cdm]
  160.  
  161.     if [$diag isNil] {
  162.         puts "ERROR: diagram $name.$type not found"
  163.         return ""
  164.     }
  165.  
  166.     return $name.$type
  167.     }
  168.  
  169.     set items [query -u -s labels.itemRefs.item \
  170.         "type in {cad_class cad_container ccd_class ccd_class_ref ccd_container etd_object std_class}" \
  171.         $diag.components]
  172.  
  173.     return [query -s name -n "type == cl" $items]
  174. }
  175.  
  176.  
  177. proc get_diagram_subjects {name {type ""}} {
  178.     if {$type == "" } {
  179.     set type [nt_get_type $name]
  180.     set name [nt_get_name $name]
  181.     }
  182.  
  183.     set clientCont [ClientContext::global]
  184.     set systemV [$clientCont currentSystem]
  185.     if [$systemV isNil] {
  186.     return ""
  187.     }
  188.  
  189.     set diag [$systemV findFileVersion $name $type]
  190.  
  191.     if [$diag isNil] {
  192.     #
  193.     # Exceptional case: A.B.cdm ...
  194.     #
  195.  
  196.     set diag [$systemV findFileVersion $name.$type cdm]
  197.  
  198.     if [$diag isNil] {
  199.         puts "ERROR: diagram $name.$type not found"
  200.         return ""
  201.     }
  202.  
  203.     return ""
  204.     }
  205.  
  206.     set items [query -u -s labels.itemRefs.item \
  207.         "type in {subject}" \
  208.         $diag.components]
  209.  
  210.     return [query -s name -n $items]
  211. }
  212.  
  213. proc get_diagram_name {object} {
  214.     return [$object getDiagramName]
  215. }
  216.  
  217. proc get_diagram_type {object} {
  218.     return [$object getDiagramType]
  219. }
  220.  
  221. proc get_error {ooModel} {
  222.     return [$ooModel error]
  223. }
  224.  
  225. proc get_event {receivedEvent} {
  226.     return [$receivedEvent event]
  227. }
  228.  
  229. proc get_event_type {receivedEvent} {
  230.     return [$receivedEvent getEventType]
  231. }
  232.  
  233. proc get_external {object} {
  234.     return [$object getExternal]
  235. }
  236.  
  237. proc get_parent_event {event} {
  238.     return [$event parentEvent]
  239. }
  240.  
  241. proc get_exports {table} {
  242.     return [$table exportSet]
  243. }
  244.  
  245. proc get_features {ooplClass} {
  246.     return [$ooplClass featureSet]
  247. }
  248.  
  249. proc get_foreign_name {column} {
  250.     return [$column getForeignName]
  251. }
  252.  
  253. proc get_friend {link} {
  254.     return [$link friendLink]
  255. }
  256.  
  257. proc get_ftext {object} {
  258.     return [$object getFreeText]
  259. }
  260.  
  261. proc get_import {impColumn} {
  262.     return [$impColumn getImport]
  263. }
  264.  
  265. proc get_import_type {link} {
  266.     return [$link getImportType]
  267. }
  268.  
  269. proc get_imports {table} {
  270.     return [$table importSet]
  271. }
  272.  
  273. proc get_initial_value {object} {
  274.     return [$object getPropertyValue initial_value]
  275. }
  276.  
  277. proc get_initializers {constructor} {
  278.     return [$constructor initializerSet]
  279. }
  280.  
  281. proc get_ins_type {link} {
  282.     return [$link getInsType]
  283. }
  284.  
  285. proc get_item_id {object} {
  286.     return [$object getItemId]
  287. }
  288.  
  289. proc get_key {object} {
  290.     return [$object key]
  291. }
  292.  
  293. proc get_link {object} {
  294.     set objType [$object get_obj_type]
  295.  
  296.     if {! [string match "db_*_attrib" $objType]} {
  297.     return ""
  298.     }
  299.  
  300.     if {"$objType" == "db_data_attrib"} {
  301.     return ""
  302.     }
  303.  
  304.     return [$object link]
  305. }
  306.  
  307. proc get_link_type {link} {
  308.     return [$link getLinkType]
  309. }
  310.  
  311. proc get_login_name {} {
  312.     return [M4Login::getUserName]
  313. }
  314.  
  315. proc get_master {link} {
  316.     return [$link master]
  317. }
  318.  
  319. proc get_master_type {link} {
  320.     return [$link getMasterType]
  321. }
  322.  
  323. proc get_masters {table} {
  324.     return [$table masterSet]
  325. }
  326.  
  327. proc get_multiplicity {attr} {
  328.     return [$attr getMultiplicity]
  329. }
  330.  
  331. proc get_name {object} {
  332.     return [$object getName]
  333. }
  334.  
  335. proc get_obj_type {object} {
  336.     return [$object get_obj_type]
  337. }
  338.  
  339. proc get_oopl_model {ooModel} {
  340.     return [$ooModel ooplModel]
  341. }
  342.  
  343. proc get_opposite {attr} {
  344.     return [$attr opposite]
  345. }
  346.  
  347. proc get_opposite_link {object} {
  348.     return [$object oppositeLink]
  349. }
  350.  
  351. proc get_parameters {object} {
  352.     if {[$object get_obj_type] == "constructor"} {
  353.     return ""
  354.     }
  355.  
  356.     return [$object parameterSet]
  357. }
  358.  
  359. proc get_phase_classes {} {
  360.     set clientCont [ClientContext::global]
  361.     set currentPhase [$clientCont currentPhase]
  362.     if [$currentPhase isNil] {
  363.     return ""
  364.     }
  365.     set classes ""
  366.     foreach systemV [$currentPhase systemVersions] {
  367.     set classes [concat $classes [get_system_classes [[$systemV system] name]]]
  368.     }
  369.     return $classes
  370. }
  371.  
  372. proc get_qualifier {object} {
  373.     return [$object qualifier]
  374. }
  375.  
  376. proc get_received_events {object} {
  377.     return [$object receivedEventSet]
  378. }
  379.  
  380. proc get_relation {link} {
  381.     return [$link relation]
  382. }
  383.  
  384. proc get_relation_type {relation} {
  385.     return [$relation getRelationType]
  386. }
  387.  
  388. proc get_system {table} {
  389.     $table getSystem
  390. }
  391.  
  392. proc get_src_objs {} {
  393.     return [CommandLineInterface::getSourceObjects]
  394. }
  395.  
  396. proc get_sender_name {receivedEvent} {
  397.     return [$receivedEvent getSenderName]
  398. }
  399.  
  400. proc get_storage {table} {
  401.     return [$table getStorage]
  402. }
  403.  
  404. proc get_system_classes {{sysName ""}} {
  405.     set clientCont [ClientContext::global]
  406.     set currentPhase [$clientCont currentPhase]
  407.     if [$currentPhase isNil] {
  408.     return ""
  409.     }
  410.     set currentSystem [$clientCont currentSystem]
  411.     if {$sysName == "" } {
  412.     if [$currentSystem isNil] {
  413.         return ""
  414.     }
  415.     } else {
  416.     set currentSystem [$currentPhase findSystemVersion $sysName system]
  417.     }
  418.  
  419.     query -s file.name "file.type == cdm" [$currentSystem localFileVersions]
  420.  
  421. }
  422.  
  423. proc chr2hex {charString} {
  424.     return [BinUtil::chr2Hex $charString]
  425. }
  426.  
  427. proc constructNames { versionSet versionType} {
  428.     set fileNameSet ""
  429.     foreach version $versionSet {
  430.     set obj [$version $versionType]
  431.     lappend fileNameSet "[$obj name].[$obj type]"
  432.     }
  433.     return $fileNameSet
  434. }
  435.  
  436. proc dec2hex {number} {
  437.     return [BinUtil::dec2Hex $number]
  438. }
  439.  
  440. proc get_system_files {args} {
  441.     set currentSystem [[ClientContext::global] currentSystem]
  442.     if [$currentSystem isNil] {
  443.     return ""
  444.     }
  445.     if { $args != "" } {
  446.     set files [query "file.type == $args" \
  447.         [[[ClientContext::global] currentSystem] localFileVersions]]
  448.     } else {
  449.     set files [$currentSystem localFileVersions]
  450.     }
  451.     constructNames $files file
  452. }
  453.  
  454. proc get_systems {} {
  455.     set currentPhase [[ClientContext::global] currentPhase]
  456.     if [$currentPhase isNil] {
  457.     return ""
  458.     }
  459.     set systems [$currentPhase systemVersions]
  460.     constructNames $systems system
  461. }
  462.  
  463. proc get_sql_model {ooModel} {
  464.     return [$ooModel sqlModel]
  465. }
  466.  
  467. proc get_sql_postfix {column} {
  468.     return [$column getSqlPostfix]
  469. }
  470.  
  471. proc get_subjects {ooplModel} {
  472.     return [$ooplModel subjectSet]
  473. }
  474.  
  475. proc get_sub_classes {object} {
  476.     if {[$object get_obj_type] == "inher_group"} {
  477.     return [$object subClassSet]
  478.     }
  479.  
  480.     return [$object specNodeSet]
  481. }
  482.  
  483. proc get_super_class {inhgroup} {
  484.     return [$inhgroup superClass]
  485. }
  486.  
  487. proc get_super_classes {ooplClass} {
  488.     return [$ooplClass genNodeSet]
  489. }
  490.  
  491. proc get_super_name {inhgroup} {
  492.     return [$inhgroup getSuperClassName]
  493. }
  494.  
  495. proc get_super_type {inhgroup} {
  496.     return [$inhgroup getSuperClassType]
  497. }
  498.  
  499. proc get_table {class} {
  500.     return [$class table]
  501. }
  502.  
  503. proc get_tables {sqlModel} {
  504.     return [$sqlModel tableSet]
  505. }
  506.  
  507. proc get_tgt_objs {} {
  508.     return [CommandLineInterface::getTargetObjects]
  509. }
  510.  
  511. proc get_type {object} {
  512.     return [$object ooplType]
  513. }
  514.  
  515. proc get_type_3gl {object} {
  516.     return [$object getType3GL]
  517. }
  518.  
  519. proc get_type_4gl {object} {
  520.     return [$object getType4GL]
  521. }
  522.  
  523. proc get_type_std {object} {
  524.     return [$object getTypeStd]
  525. }
  526.  
  527. proc get_unique_name {object} {
  528.     return [$object getUniqueName]
  529. }
  530.  
  531. proc get_upd_type {link} {
  532.     return [$link getUpdType]
  533. }
  534.  
  535. proc get_user_name {} {
  536.     return [M4Login::getRealName]
  537. }
  538.  
  539. proc get_workbench {} {
  540.     if [[[ClientContext::global] currentPhase] isNil] {
  541.     return ""
  542.     }
  543.     [[[ClientContext::global] currentPhase] phase] type
  544. }
  545.  
  546. proc goto_system {sysName {phaseName ""}} {
  547.     return [fstorage::goto_system $sysName $phaseName]
  548. }
  549.  
  550. proc has_attributes {receivedEvent} {
  551.     return [$receivedEvent hasAttributes]
  552. }
  553.  
  554. proc has_tdb {} {
  555.     set cc [ClientContext::global]
  556.     set configV [$cc currentConfig]
  557.  
  558.     if [$configV isNil] {
  559.     return 0
  560.     }
  561.  
  562.     if {[$configV getPropertyValue tdbname] != ""} {
  563.     return 1
  564.     }
  565.  
  566.     return 0
  567. }
  568.  
  569. proc hexwrite {fileId hexString} {
  570.     return [BinUtil::hexWrite $fileId $hexString]
  571. }
  572.  
  573. proc is_abstract {operation} {
  574.     return [$operation isAbstract]
  575. }
  576.  
  577. proc is_aggregate {object} {
  578.     return [$object isAggregate]
  579. }
  580.  
  581. proc is_class_feature {object} {
  582.     return [$object isClassFeature]
  583. }
  584.  
  585. proc is_const_func {operation} {
  586.     return [$operation isConstFunc]
  587. }
  588.  
  589. proc is_derived {object} {
  590.     return [$object isDerived]
  591. }
  592.  
  593. proc is_dyn_bound {operation} {
  594.     return [$operation isDynBound]
  595. }
  596.  
  597. proc is_external {object} {
  598.     return [$object isExternal]
  599. }
  600.  
  601. proc is_mandatory {attrib} {
  602.     return [$attrib isMandatory]
  603. }
  604.  
  605. proc is_nullable {column} {
  606.     return [$column isNullable]
  607. }
  608.  
  609. proc is_ordered {attrib} {
  610.     return [$attrib isOrdered]
  611. }
  612.  
  613. proc is_overlapping {inhgroup} {
  614.     return [$inhgroup isOverlapping]
  615. }
  616.  
  617. proc is_synthetic {object} {
  618.     return [$object isSynthetic]
  619. }
  620.  
  621. proc load_oo_model {args} {
  622.     return [OOModel::createModel]
  623. }
  624.  
  625. proc m4_error_control {errorId} {
  626.     return [M4CheckManager::errorControl $errorId]
  627. }
  628.  
  629. proc m4_error_count {{reset ""}} {
  630.     if {"$reset" == "reset"} {
  631.     return [M4CheckManager::resetErrorCount]
  632.     }
  633.  
  634.     return [M4CheckManager::getErrorCount]
  635. }
  636.  
  637. proc m4_fmt_message {string} {
  638.     puts stdout $string
  639. }
  640.  
  641. proc m4_warning_count {{reset ""}} {
  642.     if {"$reset" == "reset"} {
  643.     return [M4CheckManager::resetWarningCount]
  644.     }
  645.  
  646.     return [M4CheckManager::getWarningCount]
  647. }
  648.  
  649. proc initSectionCmdMap {} {
  650.     global sectionCmdMap
  651.  
  652.     set sectionCmdMap(append)            {append}
  653.     set sectionCmdMap(append_section)        {appendSect}
  654.     set sectionCmdMap(dealloc)            {delete}
  655.     set sectionCmdMap(get_column_nr)        {columnNr}
  656.     set sectionCmdMap(get_contents)        {contents}
  657.     set sectionCmdMap(get_indent)        {indent}
  658.     set sectionCmdMap(get_indent_string)    {indentString}
  659.     set sectionCmdMap(get_line_nr)        {lineNr}
  660.     set sectionCmdMap(get_tab_width)        {tabWidth}
  661.     set sectionCmdMap(pop_indent)        {popIndent}
  662.     set sectionCmdMap(push_indent)        {pushIndent}
  663.     set sectionCmdMap(set_indent)        {indent}
  664.     set sectionCmdMap(set_tab_width)        {tabWidth}
  665.     set sectionCmdMap(write)            {write}
  666. }
  667.  
  668. proc section {subcmnd {sect ""} {args ""}} {
  669.     global sectionCmdMap
  670.     if ![info exists sectionCmdMap] {
  671.     initSectionCmdMap
  672.     }
  673.  
  674.     if {$subcmnd == "create"} {
  675.     return [TextSection new]
  676.     } elseif {$subcmnd == "dealloc"} {
  677.     return ""
  678.     } elseif {$subcmnd == "append"} {
  679.     foreach arg $args {
  680.         $sect append $arg
  681.     }
  682.  
  683.     return ""
  684.     }
  685.  
  686.     if ![info exists sectionCmdMap($subcmnd)] {
  687.     return -code error "Invalid command: section $subcmnd $sect $args"
  688.     }
  689.  
  690.     return [eval [concat $sect $sectionCmdMap($subcmnd) $args]]
  691. }
  692.  
  693. proc strxfrm {string8bit} {
  694.     return [Map8Bit::map $string8bit]
  695. }
  696.