home *** CD-ROM | disk | FTP | other *** search
/ PC World 1998 October / PCWorld_1998-10_cd.bin / software / prehled / komix / DATA.Z / legacy.tcl < prev    next >
Text File  |  1997-11-13  |  15KB  |  700 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/titanic/5
  17. #    Author        : Discovery
  18. #    Original date    : May 1995
  19. #    Description    : Legacy stuff for 3.x compatibility
  20. #
  21. #---------------------------------------------------------------------------
  22. #
  23. # @(#)legacy.tcl    /main/titanic/5 13 Nov 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 getPropertyValue freeText]
  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_source {table} {
  389.     return [$table getSource]
  390. }
  391.  
  392. proc get_system {table} {
  393.     $table getSystem
  394. }
  395.  
  396. proc get_src_objs {} {
  397.     return [CommandLineInterface::getSourceObjects]
  398. }
  399.  
  400. proc get_sender_name {receivedEvent} {
  401.     return [$receivedEvent getSenderName]
  402. }
  403.  
  404. proc get_storage {table} {
  405.     return [$table getStorage]
  406. }
  407.  
  408. proc get_system_classes {{sysName ""}} {
  409.     set clientCont [ClientContext::global]
  410.     set currentPhase [$clientCont currentPhase]
  411.     if [$currentPhase isNil] {
  412.     return ""
  413.     }
  414.     set currentSystem [$clientCont currentSystem]
  415.     if {$sysName == "" } {
  416.     if [$currentSystem isNil] {
  417.         return ""
  418.     }
  419.     } else {
  420.     set currentSystem [$currentPhase findSystemVersion $sysName system]
  421.     }
  422.  
  423.     query -s file.name "file.type == cdm" [$currentSystem localFileVersions]
  424.  
  425. }
  426.  
  427. proc chr2hex {charString} {
  428.     return [BinUtil::chr2Hex $charString]
  429. }
  430.  
  431. proc constructNames { versionSet versionType} {
  432.     set fileNameSet ""
  433.     foreach version $versionSet {
  434.     set obj [$version $versionType]
  435.     lappend fileNameSet "[$obj name].[$obj type]"
  436.     }
  437.     return $fileNameSet
  438. }
  439.  
  440. proc dec2hex {number} {
  441.     return [BinUtil::dec2Hex $number]
  442. }
  443.  
  444. proc get_system_files {args} {
  445.     set currentSystem [[ClientContext::global] currentSystem]
  446.     if [$currentSystem isNil] {
  447.     return ""
  448.     }
  449.     if { $args != "" } {
  450.     set files [query "file.type == $args" \
  451.         [[[ClientContext::global] currentSystem] localFileVersions]]
  452.     } else {
  453.     set files [$currentSystem localFileVersions]
  454.     }
  455.     constructNames $files file
  456. }
  457.  
  458. proc get_systems {} {
  459.     set currentPhase [[ClientContext::global] currentPhase]
  460.     if [$currentPhase isNil] {
  461.     return ""
  462.     }
  463.     set systems [$currentPhase systemVersions]
  464.     constructNames $systems system
  465. }
  466.  
  467. proc get_sql_model {ooModel} {
  468.     return [$ooModel sqlModel]
  469. }
  470.  
  471. proc get_sql_postfix {column} {
  472.     return [$column getSqlPostfix]
  473. }
  474.  
  475. proc get_subjects {ooplModel} {
  476.     return [$ooplModel subjectSet]
  477. }
  478.  
  479. proc get_sub_classes {object} {
  480.     if {[$object get_obj_type] == "inher_group"} {
  481.     return [$object subClassSet]
  482.     }
  483.  
  484.     return [$object specNodeSet]
  485. }
  486.  
  487. proc get_super_class {inhgroup} {
  488.     return [$inhgroup superClass]
  489. }
  490.  
  491. proc get_super_classes {ooplClass} {
  492.     return [$ooplClass genNodeSet]
  493. }
  494.  
  495. proc get_super_name {inhgroup} {
  496.     return [$inhgroup getSuperClassName]
  497. }
  498.  
  499. proc get_super_type {inhgroup} {
  500.     return [$inhgroup getSuperClassType]
  501. }
  502.  
  503. proc get_table {class} {
  504.     return [$class table]
  505. }
  506.  
  507. proc get_tables {sqlModel} {
  508.     return [$sqlModel tableSet]
  509. }
  510.  
  511. proc get_tgt_objs {} {
  512.     return [CommandLineInterface::getTargetObjects]
  513. }
  514.  
  515. proc get_type {object} {
  516.     return [$object ooplType]
  517. }
  518.  
  519. proc get_type_3gl {object} {
  520.     return [$object getType3GL]
  521. }
  522.  
  523. proc get_type_4gl {object} {
  524.     return [$object getType4GL]
  525. }
  526.  
  527. proc get_type_std {object} {
  528.     return [$object getTypeStd]
  529. }
  530.  
  531. proc get_unique_name {object} {
  532.     return [$object getUniqueName]
  533. }
  534.  
  535. proc get_upd_type {link} {
  536.     return [$link getUpdType]
  537. }
  538.  
  539. proc get_user_name {} {
  540.     return [M4Login::getRealName]
  541. }
  542.  
  543. proc get_workbench {} {
  544.     if [[[ClientContext::global] currentPhase] isNil] {
  545.     return ""
  546.     }
  547.     [[[ClientContext::global] currentPhase] phase] type
  548. }
  549.  
  550. proc goto_system {sysName {phaseName ""}} {
  551.     return [fstorage::goto_system $sysName $phaseName]
  552. }
  553.  
  554. proc has_attributes {receivedEvent} {
  555.     return [$receivedEvent hasAttributes]
  556. }
  557.  
  558. proc has_tdb {} {
  559.     set cc [ClientContext::global]
  560.     set configV [$cc currentConfig]
  561.  
  562.     if [$configV isNil] {
  563.     return 0
  564.     }
  565.  
  566.     if {[$configV getPropertyValue tdbname] != ""} {
  567.     return 1
  568.     }
  569.  
  570.     return 0
  571. }
  572.  
  573. proc hexwrite {fileId hexString} {
  574.     return [BinUtil::hexWrite $fileId $hexString]
  575. }
  576.  
  577. proc is_abstract {operation} {
  578.     return [$operation isAbstract]
  579. }
  580.  
  581. proc is_aggregate {object} {
  582.     return [$object isAggregate]
  583. }
  584.  
  585. proc is_class_feature {object} {
  586.     return [$object isClassFeature]
  587. }
  588.  
  589. proc is_const_func {operation} {
  590.     return [$operation isConstFunc]
  591. }
  592.  
  593. proc is_derived {object} {
  594.     return [$object isDerived]
  595. }
  596.  
  597. proc is_dyn_bound {operation} {
  598.     return [$operation isDynBound]
  599. }
  600.  
  601. proc is_external {object} {
  602.     return [$object isExternal]
  603. }
  604.  
  605. proc is_mandatory {attrib} {
  606.     return [$attrib isMandatory]
  607. }
  608.  
  609. proc is_nullable {column} {
  610.     return [$column isNullable]
  611. }
  612.  
  613. proc is_ordered {attrib} {
  614.     return [$attrib isOrdered]
  615. }
  616.  
  617. proc is_overlapping {inhgroup} {
  618.     return [$inhgroup isOverlapping]
  619. }
  620.  
  621. proc is_synthetic {object} {
  622.     return [$object isSynthetic]
  623. }
  624.  
  625. proc load_oo_model {args} {
  626.     return [OOModel::createModel]
  627. }
  628.  
  629. proc m4_error_control {errorId} {
  630.     return [M4CheckManager::errorControl $errorId]
  631. }
  632.  
  633. proc m4_error_count {{reset ""}} {
  634.     if {"$reset" == "reset"} {
  635.     return [M4CheckManager::resetErrorCount]
  636.     }
  637.  
  638.     return [M4CheckManager::getErrorCount]
  639. }
  640.  
  641. proc m4_fmt_message {string} {
  642.     puts stdout $string
  643. }
  644.  
  645. proc m4_warning_count {{reset ""}} {
  646.     if {"$reset" == "reset"} {
  647.     return [M4CheckManager::resetWarningCount]
  648.     }
  649.  
  650.     return [M4CheckManager::getWarningCount]
  651. }
  652.  
  653. proc initSectionCmdMap {} {
  654.     global sectionCmdMap
  655.  
  656.     set sectionCmdMap(append)            {append}
  657.     set sectionCmdMap(append_section)        {appendSect}
  658.     set sectionCmdMap(dealloc)            {delete}
  659.     set sectionCmdMap(get_column_nr)        {columnNr}
  660.     set sectionCmdMap(get_contents)        {contents}
  661.     set sectionCmdMap(get_indent)        {indent}
  662.     set sectionCmdMap(get_indent_string)    {indentString}
  663.     set sectionCmdMap(get_line_nr)        {lineNr}
  664.     set sectionCmdMap(get_tab_width)        {tabWidth}
  665.     set sectionCmdMap(pop_indent)        {popIndent}
  666.     set sectionCmdMap(push_indent)        {pushIndent}
  667.     set sectionCmdMap(set_indent)        {indent}
  668.     set sectionCmdMap(set_tab_width)        {tabWidth}
  669.     set sectionCmdMap(write)            {write}
  670. }
  671.  
  672. proc section {subcmnd {sect ""} {args ""}} {
  673.     global sectionCmdMap
  674.     if ![info exists sectionCmdMap] {
  675.     initSectionCmdMap
  676.     }
  677.  
  678.     if {$subcmnd == "create"} {
  679.     return [TextSection new]
  680.     } elseif {$subcmnd == "dealloc"} {
  681.     return ""
  682.     } elseif {$subcmnd == "append"} {
  683.     foreach arg $args {
  684.         $sect append $arg
  685.     }
  686.  
  687.     return ""
  688.     }
  689.  
  690.     if ![info exists sectionCmdMap($subcmnd)] {
  691.     return -code error "Invalid command: section $subcmnd $sect $args"
  692.     }
  693.  
  694.     return [eval [concat $sect $sectionCmdMap($subcmnd) $args]]
  695. }
  696.  
  697. proc strxfrm {string8bit} {
  698.     return [Map8Bit::map $string8bit]
  699. }
  700.