home *** CD-ROM | disk | FTP | other *** search
/ PC World 1997 November / PCWorld_1997-11_cd.bin / software / programy / komix / DATA.Z / check.tcl < prev    next >
Text File  |  1996-09-17  |  9KB  |  330 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        : @(#)check.tcl    /main/hindenburg/4
  17. #       Author          : edri
  18. #    Original date    : 03-10-94
  19. #    Description    : Check front end
  20. #
  21. #---------------------------------------------------------------------------
  22. #
  23.  
  24. source [m4_path_name tcl cginit.tcl]
  25.  
  26. require legacy.tcl
  27. require wmt_util.tcl
  28. require chktcl_msg.tcl
  29. require check_util.tcl
  30. require check_conf.tcl
  31. require checks.tcl
  32. require prep_disp.tcl
  33. require prep_funcs.tcl
  34. require prep_db_fn.tcl
  35. require chk_disp.tcl
  36. require chk_funcs.tcl
  37. require chk_db_fn.tcl
  38. require libsql.tcl
  39.  
  40. global ooplClassFilter; set ooplClassFilter ""
  41. global ooplExclClassFilter; set ooplExclClassFilter ""
  42.  
  43. #
  44. # See if any boolean options were specified, set the appropriate
  45. # variables, and remove any options from argv.
  46. #
  47. proc parse_options {} {
  48.     global boolean_options argv
  49.     foreach opt $boolean_options {
  50.         set i [lsearch $argv [lindex $opt 0]]
  51.     set optvar [lindex $opt 1]
  52.     eval "global $optvar"
  53.         if {$i == -1} {
  54.             set optdef [lindex $opt 2]
  55.             eval "set $optvar $optdef"
  56.         } else {
  57.         set argv [lreplace $argv $i $i]
  58.             eval "set $optvar 1"
  59.         }
  60.     }
  61. }
  62.  
  63. #
  64. # Set check status for specified diagram
  65. #
  66.  
  67. proc set_check_status {diagramName {newStatus ""}} {
  68.     # E_SET_CHECK_STATUS    Wrong number of arguments, should be: set_check_status diagram.type [reset|ok|failed]
  69.  
  70.     set fileName [nt_get_name $diagramName]
  71.     set fileType [nt_get_type $diagramName]
  72.  
  73.     if {$fileName == "" || $fileType == ""} {
  74.     puts stderr "ERROR: set_check_status: file name '$diagramName' not of format 'diagram.type'"
  75.     return 0
  76.     }
  77.  
  78.     set cc [ClientContext::global]
  79.     set sysV [$cc currentSystem]
  80.     set fileV [$sysV findFileVersion $fileName $fileType]
  81.  
  82.     if [$fileV isNil] {
  83.     #
  84.     # Exceptional case: A.B.cdm
  85.     #
  86.  
  87.     set fileV [$sysV findFileVersion $fileName.$fileType cdm]
  88.  
  89.     if [$fileV isNil] {
  90.         puts stderr "ERROR: set_check_status: '$diagramName': no such fileV"
  91.         return 0
  92.     }
  93.     }
  94.  
  95.     switch -exact -- "$newStatus" {
  96.     ""      -
  97.     reset   { set status "not checked" }
  98.     ok      { set status "checked OK" }
  99.     failed  { set status "checked with errors" }
  100.     default { puts stderr "ERROR: set_check_status: '$newStatus': bad status; should be one of \[reset|ok|failed\]" ; return 0}
  101.     }
  102.  
  103. if 0 {
  104.     #
  105.     # Cannot set property while diagram is locked ...
  106.     #
  107.     if {[catch {$fileV setProperty check_status "$status"} reason]} {
  108.     # for now, ignore failure message...
  109.     #m4_warning $W_CHECK_STATUS "$status"
  110.     #puts stderr "WARNING: Unable to set property 'check_status' to value '$status'"
  111.     #puts stderr $reason
  112.     return 0
  113.     }
  114. }  # 0
  115.  
  116.     return 1
  117. }
  118.  
  119.  
  120.  
  121.  
  122. #
  123. # Main entry point for extended checking
  124. #
  125. proc checkMain {} {
  126.     global oomodel ooplmodel
  127.  
  128.     m4_message $M_STARTING_EXTENDED_CHECKING
  129.     M4CheckManager::resetErrorCount
  130.     parse_options
  131.  
  132.     if {$usecase} {
  133.     uplevel #0 {require chkucmodel.tcl}
  134.     checkUseCaseModel
  135.     show_errors
  136.     return
  137.     }
  138.  
  139.     OTShRegister::check
  140.  
  141.     find_file_types
  142.     set sources ""
  143.     set eventtypes ""
  144.     set diagram_count 0
  145.     set diagram ""
  146.     foreach obj [CommandLineInterface::getSourceObjects] {
  147.     if {[string first "." $obj] == -1} {
  148.         #  obj is a class
  149.         lappend sources $obj
  150.     } else {
  151.             set diagname [nt_get_name $obj]
  152.             set diagtype [string tolower [nt_get_type $obj]]
  153.             if {$diagtype == "cdm"} {
  154.                 # obj is a class after all
  155.                 lappend sources $diagname
  156.                 continue
  157.             } elseif {$diagtype == "ccd" ||
  158.                       $diagtype == "etd" ||
  159.                       $diagtype == "std"} {
  160.                 #  Remember which kinds of events are needed
  161.                 lappend eventtypes $diagtype
  162.             } elseif {$diagtype != "cad"} {
  163.                 m4_message $M_CANNOT_CHECK_DIAG_TYPE $diagname $diagtype
  164.                 continue
  165.             }
  166.  
  167.             # remember if just one event diagram is specified; if so,
  168.             # we only check events in that diagram
  169.             if {$diagtype == "ccd" ||
  170.         $diagtype == "etd" ||
  171.                 $diagtype == "std"} {
  172.         incr diagram_count
  173.         if {$diagram_count == 1} {
  174.             set diagram $obj
  175.         } else {
  176.             set diagram ""
  177.         }
  178.             }
  179.  
  180.             # add diagram to sources
  181.             lappend sources $obj
  182.     }
  183.     }
  184.  
  185.     #
  186.     # If no event diagrams specified or doing global checking,
  187.     # get events sent in any diagram
  188.     #
  189.     if {[lempty $eventtypes] || $global} {
  190.         set eventtypes {ccd etd std}
  191.     }
  192.  
  193.     #
  194.     # Check(s) needing specific types of events to be loaded.
  195.     #
  196.     if {[M4CheckManager::errorControl  $E_NO_CORR_CCDMSG_FOUND] != "off"} {
  197.         lappend eventtypes "ccd"
  198.     }
  199.  
  200.     if { [[ClientContext::global] currentLevel] == "File" } {
  201.     [ClientContext::global] upLevel
  202.     }   
  203.     set oomodel [load_model $sources $eventtypes $global 0 1 $timing]
  204.     if {"$oomodel" == ""} {
  205.         m4_message $M_LOADING_OOPL_FAILED
  206.         show_errors
  207.         return
  208.     }
  209.     set ooplmodel [$oomodel ooplModel]
  210.  
  211.     #
  212.     # Prepare the model for checking
  213.     #
  214.     puts stdout "\nPreparing the model for checking.\n"
  215.     prepare $ooplmodel check
  216.     if {[$oomodel error] > 0} {
  217.         m4_message $M_PREPARE_CHECK_FAILED
  218.         $oomodel delete
  219.         return
  220.     }
  221.  
  222.     # Check the internal model
  223.     #
  224.     $ooplmodel check "$sources"
  225.  
  226.     #set sqlmodel [$oomodel sqlModel]
  227.     #$sqlmodel check
  228.     #
  229.     # Check the model
  230.     #
  231.     puts stdout "\nChecking the model.\n"
  232.     check $ooplmodel $diagram
  233.     show_errors
  234.  
  235.     #
  236.     # Update check statusses of all specified diagrams.
  237.     #
  238.     # Note that this may set the status of a diagram incorrectly, for
  239.     # example if a diagram was specified that did not contain any
  240.     # incorrect classes.
  241.     #
  242.     foreach diagram $sources {
  243.     if {[string first "." $diagram] > 0} {
  244.             set status [expr {([M4CheckManager::getErrorCount] == 0) ? "ok" : "failed"}]
  245.         if [catch {set_check_status $diagram $status} msg] {
  246.                 puts stdout "$diagram: $msg\n"
  247.             }
  248.     }
  249.     }
  250.  
  251.     $oomodel delete
  252. }
  253.  
  254. #
  255. # Load and return the OOModel for the specified list of sources, which is
  256. # a list of diagram names and/or class names.
  257. #
  258. proc load_model {sources eventtypes global {quiet "0"} {subjects 1} {time 0}} {
  259.  
  260.     if {$global} {
  261.     #
  262.     #  Global checking, load all classes, except the ones specified.
  263.         #  Also load all CCD Subjects in the system.
  264.     #
  265.         if {!$quiet} {
  266.         m4_message $M_LOADING_MODEL
  267.         }
  268.     } else {
  269.         if [lempty $sources] {
  270.         if {!$quiet} {
  271.                 m4_message $M_NO_CLASSES_SPECIFIED
  272.             }
  273.             return ""
  274.         }
  275.         #
  276.         #  Only load CCD Subjects in any CCDs specified.
  277.         #
  278.         if {!$quiet} {
  279.             m4_message $M_LOADING_SPECIFIED
  280.         }
  281.     }
  282.  
  283.     set time_info [time {eval "set model \[OOModel::createModel]"}]
  284.     global ooplClassFilter
  285.     set ooplClassFilter $sources
  286.  
  287.     if {$time} {
  288.     set classcount [llength [getSelectedClasses [$model ooplModel]]]
  289.     puts stdout "Loaded $classcount classes in\
  290.         [format %3.2f [expr {"[lindex $time_info 0].0" / 1000000.0}]] seconds.\n"
  291.     }
  292.  
  293.     if {[$model error] > 0} {
  294.         $model delete
  295.         return ""
  296.     }
  297.  
  298.     return $model
  299. }
  300.  
  301.  
  302. set cc [ClientContext::global]
  303.  
  304. #
  305. # Add or override certain check functions by target language dependent checks
  306. # using the file "langchecks.tcl" (which typically resides in the l_$target_lang
  307. # sub directory)
  308. # 
  309. if {[$cc customFileExists langchecks tcl tcl 1]} {
  310.     require langchecks.tcl
  311. }
  312.  
  313. #
  314. # Let user override certain check functions using the u_check.tcl file.
  315. #
  316. if {[$cc customFileExists u_check tcl "" 0]} {
  317.     require u_check.tcl
  318. }
  319.  
  320. #
  321. # Just call checkMain
  322. #
  323. if [catch {checkMain} msg] {
  324.     if {"[string range $msg 0 5]" == "ERROR:"} {
  325.     puts stderr $msg
  326.     } else {
  327.     puts stderr $errorInfo
  328.     }
  329. }
  330.