Open Mash Cross Reference
mash/tcl/common/dbg-err.tcl

   # dbg-err.tcl --
   #
   #       Error procedures, this file should be preloaded
   #       These procedures allow some simple diagnostics to be performed when
   #       there is an error.
   #
   # Copyright (c) 1993-2002 The Regents of the University of California.
   # All rights reserved.
   #
  # Redistribution and use in source and binary forms, with or without
  # modification, are permitted provided that the following conditions are met:
  #
  # A. Redistributions of source code must retain the above copyright notice,
  #    this list of conditions and the following disclaimer.
  # B. Redistributions in binary form must reproduce the above copyright notice,
  #    this list of conditions and the following disclaimer in the documentation
  #    and/or other materials provided with the distribution.
  # C. Neither the names of the copyright holders nor the names of its
  #    contributors may be used to endorse or promote products derived from this
  #    software without specific prior written permission.
  #
  # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS''
  # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  # ARE DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR
  # ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
  # SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
  # CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
  # OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
  # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  
  
  proc tkerror msg {
          global errorInfo mb
  
          if {[string match "no more colors*" $msg]} {
                  set app [tk appname]
                  puts "$app: $msg"
                  return
          }
          append errmsg "Error message: "
          append errmsg $msg\n
          set errInf $errorInfo
  
          if {[winfo exists .masherrdiag] || [winfo exists .mashstacktrace]} {
                  puts stderr "$errmsg stack trace: $errorInfo"
                  return
          }
          puts stderr "error: $errorInfo"
          set retCode [tk_dialog .masherrdiag Error $errmsg error \
                          0 Exit "Stack Trace" Continue Dump]
  
          case $retCode {
                  0 {abort}
                  1 {     set p [new StackTrace]
                          $p open $errInf
                  }
                  2 {puts stderr $errmsg}
          }
          return 1
  }
  
  proc bgerror msg {
          tkerror $msg
  }
  
  # individual apps should overwrite this to do more stuff if needed
  proc abort {} {
          exit -1
  }
  
  Class StackTrace
  
  StackTrace instproc open {errmsg} {
          global traceok traceCmd
          $self instvar t_
  
          set p [toplevel .mashstacktrace]
          set f [frame $p.top]
          set t_ [text $f.t -yscrollcommand "$f.sy set" \
                          -xscrollcommand "$p.sx set"]
          bind $t_ <Button-3> "$t_ get sel.first sel.last"
  
          set sx [scrollbar $p.sx -orient horiz -command "$t_ xview"]
          set sy [scrollbar $f.sy -orient vert -command "$t_ yview"]
  
          pack $f -side top -expand true -fill both
          pack $sy -side right -fill y
          pack $sx -side top -fill x
          pack $t_ -side left -expand true -fill both
  
          set panel [frame $p.b]
          pack $panel -side bottom -fill x
          set abort [button $panel.abort -command "abort" -text "abort"]
          set exitB  [button $panel.exitB -text "exit" \
                      -command "delete [Application instance] ; exit"]
          set cont  [button $panel.continue -command {set traceok ok} \
                          -text continue]
         set sep [label $panel.gap -width 10 -text "" -relief flat]
         set ent [entry $panel.entry -textvar traceCmd -width 40]
         set evl [button $panel.evl -text eval \
                         -command "$self eval_str \$traceCmd"]
         set cls [button $panel.info -text class \
                         -command "$self get_info \$traceCmd"]
         bind $ent <Return> "$evl invoke"
 
         $t_ insert insert $errmsg
         pack $exitB $abort $cont $sep $ent $evl $cls -side left -fill both
         wm title $p "DebugInfo@[info hostname]"
 
         tkwait variable traceok
         destroy $p
         return
 }
 
 if 0 {
         StackTrace instproc get_next {} {
                 $self instvar t_
                 set i [$t_ search -forwards -regexp --  "_o[0-9]*"  sel.first]
                 puts stderr $i
                 set str [$t_ get $i wordend]
                 puts stderr $str
         }
 }
 
 StackTrace instproc destroy {} {
         $self next
 }
 
 StackTrace instproc get_info {str} {
         $self instvar t_
         if {$str==""} {
              set str [$t_ get sel.first sel.last]
         }
         $self eval_str [concat $str info class]
 }
 
 StackTrace instproc eval_str {str} {
         $self instvar t_
         $t_ insert 1.0 "eval: $str\n"
         if [catch {eval $str} result] {
                 $t_ insert 1.0 "error: $result\n"
         } else {
 #                DbgOut "$result"
                 $t_ insert 1.0 "result: $result\n"
         }
 }