home *** CD-ROM | disk | FTP | other *** search
/ PC World 1998 October / PCWorld_1998-10_cd.bin / software / prehled / komix / DATA.Z / messagehdl.tcl < prev    next >
Encoding:
Text File  |  1997-11-20  |  6.3 KB  |  283 lines
  1. #---------------------------------------------------------------------------
  2. #
  3. #      (c)     Westmount Technology    1994
  4. #
  5. #      File:           @(#)messagehdl.tcl    /main/titanic/14
  6. #      Author:         frmo
  7. #      Description:    Generic Message Handling.
  8. #---------------------------------------------------------------------------
  9. # SccsId = @(#)messagehdl.tcl    /main/titanic/14   20 Nov 1997 Copyright 1994 Westmount Technology
  10.  
  11. # Start user added include file section
  12.  
  13. require procs.tcl
  14.  
  15. # End user added include file section
  16.  
  17.  
  18. # Format a message stack.
  19. #
  20. proc formatMessage {msgVarName} {
  21.     global errorCode
  22.     upvar $msgVarName msg
  23.  
  24.     set nl ""
  25.     set prevErrorStr ""
  26.     if {[lindex [get errorCode] 0] != "ErrorStack"} {
  27.         set errorStack $msg
  28.         set msg ""
  29.         foreach errorStr [split $errorStack "\n"] {
  30.             if {"$errorStr" == ""} continue
  31.             if [strncmp $errorStr $prevErrorStr] {
  32.                 append msg "$nl$errorStr"
  33.                 set nl "\n"
  34.                 set prevErrorStr $errorStr
  35.             }
  36.         }
  37.         return
  38.     }
  39.     set errorStack [lindex $errorCode 1]
  40.     set msg ""
  41.     foreach error $errorStack {
  42.         set errorStr "[lindex $error 1] [lindex $error 2]"
  43.         if [strncmp $errorStr $prevErrorStr] {
  44.             append msg "$nl$errorStr"
  45.             set nl "\n"
  46.             set prevErrorStr $errorStr
  47.         }
  48.     }
  49. }
  50.  
  51. # Reset error variables. This prevents "old" errors from showing up in
  52. # "new" errors when wmtkerror is called directly.
  53. #
  54. proc resetErrorVars {} {
  55.     global errorInfo errorCode
  56.  
  57.     if [info exists errorInfo] {
  58.         unset errorInfo
  59.     }
  60.     if [info exists errorCode] {
  61.         unset errorCode
  62.     }
  63. }
  64.  
  65. # Display a fatal error. Exits on "ok".
  66. #
  67. proc wmtkfatal {msg} {
  68.     formatMessage msg
  69.     if [isCommand .main.fatal] {
  70.         .main.fatal message "$msg\n[.main.fatal message]"
  71.         return
  72.     }
  73.     if {(! [isCommand MainWindow]) || (! [isCommand ErrorDialog])} {
  74.         puts "$msg"
  75.         exit
  76.     }
  77.     if {![isCommand .main]} {
  78.         MainWindow new .main -closed exit
  79.     }
  80.     ErrorDialog new .main.fatal \
  81.         -message $msg \
  82.         -title "Fatal" \
  83.         -okPressed {exit}
  84.     .main.fatal delHelpButton
  85.     .main.fatal popUp
  86. }
  87.  
  88. # Give details of the error.
  89. #
  90. proc errorHelp {} {
  91.     if [isCommand .main.errorInfo] {
  92.         return
  93.     }
  94.     interface TemplateDialog .main.errorInfo {
  95.         modal 1
  96.         okPressed {
  97.             %this delete
  98.         }
  99.         title "Error Info"
  100.         DlgColumn c {
  101.             Label l {
  102.                 text "Tcl Traceback:"
  103.             }
  104.             MultiLineText text {
  105.                 editable 0
  106.                 rowCount 24
  107.                 columnCount 80
  108.             }
  109.         }
  110.         PushButton print {
  111.             label "Print"
  112.             default 0
  113.             activated printErrorInfo
  114.         }
  115.         PushButton save {
  116.             label "Save..."
  117.             default 0
  118.             activated saveErrorInfo
  119.         }
  120.     }
  121.     # Check if errorInfo exists: could be unset by resetErrorVars
  122.     if [info exists errorInfo] {
  123.         set text $errorInfo
  124.     } else {
  125.         set text [.main.error message]
  126.     }
  127.     .main.errorInfo.c.text text $text
  128.     .main.errorInfo delCancelButton
  129.     .main.errorInfo delHelpButton
  130.     .main.errorInfo popUp
  131. }
  132.  
  133. proc printErrorInfo {} {
  134.     set printer [m4_var get M4_a_printer]
  135.     set printfile [args_file [list [.main.errorInfo.c.text text]]]
  136.     .main startCommand extern \
  137.         "$printer $printfile" [list BasicFS::removeFile $printfile] \
  138.         "Sending output to $printer..." \
  139.         {0 0} 0
  140. }
  141.  
  142. proc saveErrorInfo {} {
  143.     set box .main.saveErrorInfo
  144.     if {! [isCommand $box]} {
  145.         set cwd [pwd]
  146.         if $win95 {
  147.             # until TCL fixes pwd
  148.             # to support native pathnames
  149.             regsub -all {/} $cwd {\\} cwd
  150.         }
  151.         EntryDialog new $box \
  152.             -title "Save Error Info" \
  153.             -message "File:" \
  154.             -modal yes \
  155.             -entry "[path_name concat $cwd errorInfo[pid].txt]" \
  156.             -okPressed {
  157.                 set logFile [%this entry]
  158.                 if [catch {set fid [open $logFile w]} msg] {
  159.                     set box .main.saveErrorInfoError
  160.                     ErrorDialog new $box \
  161.                         -message $msg \
  162.                         -title "Save Error Info Error" \
  163.                         -okPressed "$box delete"
  164.                     $box delHelpButton
  165.                     $box popUp
  166.                     return
  167.                 }
  168.                 puts $fid "[.main.errorInfo.c.text text]"
  169.                 close $fid
  170.             }
  171.         $box delHelpButton
  172.     }
  173.     $box popUp
  174. }
  175.  
  176. # Display an error message. Exits if the interface was not yet set-up properly.
  177. #
  178. proc wmtkerror {msg} {
  179.     global errorInfo oldErrorInfo
  180.  
  181.     if {[lindex [get errorCode] 0] == "ErrorStack"} {
  182.         set msgStack [lindex $errorCode 1]
  183.         if {[llength $msgStack] == 1 &&
  184.             [lindex [lindex $msgStack 0] 0] == "MESSAGE"} {
  185.             wmtkmessage [lindex [lindex $msgStack 0] 2]
  186.             resetErrorVars
  187.             return
  188.         }
  189.     }
  190.     formatMessage msg
  191.     if {(! [info exists errorInfo]) || "$errorInfo" == "" ||
  192.         ([info exists oldErrorInfo] &&
  193.          [string first $oldErrorInfo $errorInfo] != -1)} {
  194.         set errorInfo $msg
  195.     }
  196.     if [isCommand .main.error] {
  197.         set lab1 "First Error:\n"
  198.         set lab2 "\n\nSecond Error:\n"
  199.         set newErrorInfo "$lab1$errorInfo$lab2$oldErrorInfo"
  200.         set oldErrorInfo $errorInfo
  201.         set errorInfo $newErrorInfo
  202.         .main.error message "$msg\n[.main.error message]"
  203.         return
  204.     }
  205.     set oldErrorInfo $errorInfo
  206.     if {(! [isCommand MainWindow]) || (! [isCommand ErrorDialog])} {
  207.         puts "$msg"
  208.         return
  209.     }
  210.     if {![isCommand .main]} {
  211.         MainWindow new .main -closed exit
  212.     }
  213.     ErrorDialog new .main.error \
  214.         -message $msg \
  215.         -title "Error" \
  216.         -okPressed {
  217.             if [.main guiReady] {
  218.                 %this delete
  219.                 resetErrorVars
  220.             } else {
  221.                 %this delete
  222.                 .main delete
  223.                 exit
  224.             }
  225.         } \
  226.         -helpPressed errorHelp
  227.     .main.error popUp
  228. }
  229.  
  230. # Display a warning.
  231. #
  232. proc wmtkwarning {msg} {
  233.     formatMessage msg
  234.     if [isCommand .main.warning] {
  235.         set prevMsg [.main.warning message]
  236.         if [strncmp $msg $prevMsg] {
  237.             .main.warning message "$msg\n$prevMsg"
  238.         }
  239.         return
  240.     }
  241.     if {(! [isCommand MainWindow]) || (! [isCommand WarningDialog])} {
  242.         puts "$msg"
  243.         return
  244.     }
  245.     if {![isCommand .main]} {
  246.         MainWindow new .main -closed exit
  247.     }
  248.     WarningDialog new .main.warning \
  249.         -message $msg \
  250.         -title "Warning" \
  251.         -okPressed {%this delete; resetErrorVars}
  252.     .main.warning delCancelButton
  253.     .main.warning delHelpButton
  254.     .main.warning popUp
  255. }
  256.  
  257. # Display a message, if there is a message area. Else the message is ignored.
  258. #
  259. proc wmtkmessage {msg} {
  260.     if {![isCommand .main]} {
  261.         return
  262.     }
  263.     set messageArea [.main messageArea]
  264.     if {$messageArea != ""} {
  265.         $messageArea message $msg
  266.     }
  267. }
  268.  
  269. # Display info in an InfoDialog
  270. #
  271. proc wmtkinfo {msg} {
  272.     if {![isCommand .main]} {
  273.         return
  274.     }
  275.     set box .main.wmtkinfo
  276.     InfoDialog new $box \
  277.         -title "Info" \
  278.         -message $msg \
  279.         -okPressed {%this delete}
  280.     $box delHelpButton
  281.     $box popUp
  282. }
  283.