--- /dev/null
+# Debug window for GDBtk.
+# Copyright (C) 1998, 1999, 2000, 2001, 2002 Red Hat, Inc.
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License (GPL) as published by
+# the Free Software Foundation; either version 2 of the License, or (at
+# your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+
+
+# -----------------------------------------------------------------------------
+# NAME: DebugWin::constructor
+#
+# SYNOPSIS: constructor::args
+#
+# DESC: Creates the debug window
+#
+# ARGS: None are used yet.
+# -----------------------------------------------------------------------------
+itcl::body DebugWin::constructor {args} {
+ debug $args
+ window_name "Insight Debug" "Debug"
+
+ build_win
+}
+
+# -----------------------------------------------------------------------------
+# NAME: DebugWin::destructor
+#
+# SYNOPSIS: Not called by hand
+#
+# DESC: Destroys the debug window
+#
+# ARGS: None
+# -----------------------------------------------------------------------------
+itcl::body DebugWin::destructor {} {
+ # notify debug code that window is going away
+ ::debug::debugwin ""
+}
+
+# -----------------------------------------------------------------------------
+# NAME: DebugWin::reconfig
+#
+# SYNOPSIS: Reconfigure callback
+#
+# DESC: Fixes up window colors
+#
+# ARGS: None
+# -----------------------------------------------------------------------------
+itcl::body DebugWin::reconfig {} {
+ # This keeps the Debug window using its unique black background.
+ # Otherwise, a reconfigure event will color it to match the other windows
+ $itk_interior.s configure -textbackground black
+}
+
+# -----------------------------------------------------------------------------
+# NAME: DebugWin::build_win
+#
+# SYNOPSIS: build_win
+#
+# DESC: Creates the Debug Window. Reads the contents of the debug log
+# file, if it exists. Notifies the debug functions in ::debug
+# to send output here.
+# -----------------------------------------------------------------------------
+itcl::body DebugWin::build_win {} {
+ global gdb_ImageDir GDBTK_LIBRARY
+
+ set top [winfo toplevel $itk_interior]
+
+ # initialize the gdbtk_de array
+ if {![info exists ::gdbtk_de]} {
+ set ::gdbtk_de(ALL) 1
+ set ::gdbtk_de(ERRORS_ONLY) 0
+ set ::gdbtk_de(others) 0
+ set ::gdbtk_de(filter_var) ALL
+ }
+
+ # create menubar
+ set menu [menu $itk_interior.m -tearoff 0]
+ $menu add cascade -menu $menu.file -label "File" -underline 0
+ set m [menu $menu.file]
+ $m add command -label "Clear" -underline 1 \
+ -command [code $this _clear]
+ $m add command -label "Mark Old" -underline 1 \
+ -command [code $this _mark_old]
+ $m add separator
+ $m add command -label "Save" -underline 0 \
+ -command [code $this _save_contents]
+ $m add separator
+ $m add command -label "Close" -underline 0 \
+ -command "::debug::debugwin {};delete object $this"
+ $menu add cascade -menu $menu.trace -label "Trace"
+ set m [menu $menu.trace]
+ $m add radiobutton -label Start -variable ::debug::tracing -value 1
+ $m add radiobutton -label Stop -variable ::debug::tracing -value 0
+ $menu add cascade -menu $menu.rs -label "ReSource"
+ set m [menu $menu.rs]
+ foreach f [lsort [glob [file join $GDBTK_LIBRARY *.itb]]] {
+ $m add command -label "Source [file tail $f]"\
+ -command [list source $f]
+ }
+ $m add separator
+ $m add command -label "Source ALL" -command [code $this _source_all]
+
+ $menu add cascade -menu $menu.opt -label "Options"
+ set m [menu $menu.opt]
+ $m add command -label "Display" -underline 0 \
+ -command [list ManagedWin::open DebugWinDOpts -over $this]
+ if {!$::debug::initialized} {
+ $menu entryconfigure 1 -state disabled
+ $menu add cascade -label " Tracing Not Initialized" -foreground red \
+ -activeforeground red
+ }
+ $menu add cascade -menu $menu.help -label "Help" -underline 0
+ set m [menu $menu.help]
+ $m add command -label "Debugging Functions" -underline 0 \
+ -command {open_help debug.html}
+
+ $top configure -menu $menu
+
+ iwidgets::scrolledtext $itk_interior.s -hscrollmode static \
+ -vscrollmode static -wrap none -textbackground black -foreground white
+ set _t [$itk_interior.s component text]
+ pack $itk_interior.s -expand 1 -fill both
+
+ # define tags
+ foreach color $_colors {
+ $_t tag configure [lindex $color 0] -foreground [lindex $color 1]
+ }
+ $_t tag configure trace -foreground gray
+ $_t tag configure args -foreground blue
+ $_t tag configure marked -background grey20
+
+ loadlog
+
+ # now notify the debug functions to use this window
+ ::debug::debugwin $this
+
+ # override the window delete procedure so the messages are
+ # turned off first.
+ wm protocol $top WM_DELETE_WINDOW "::debug::debugwin {};destroy $top"
+}
+
+# -----------------------------------------------------------------------------
+# NAME: DebugWin::puts
+#
+# SYNOPSIS: puts {level cls func msg}
+#
+# DESC: Writes debugging information into the DebugWin. A filter
+# will be applied to determine if the message should be
+# displayed or not.
+#
+# ARGS: level - priority level. See debug::dbug for details.
+# cls - class name of caller, for example "SrcWin"
+# func - function name of caller
+# msg - message to display
+# -----------------------------------------------------------------------------
+itcl::body DebugWin::puts {level cls func msg} {
+ # filter. check if we should display this message
+ # for now we always let high-level messages through
+ if {$level == "I"} {
+
+ # errors and warnings only
+ if {$::gdbtk_de(ERRORS_ONLY)} { return }
+
+ # ALL classes except those set
+ if {$::gdbtk_de(ALL)} {
+ if {[info exists ::gdbtk_de($cls)]} {
+ if {$::gdbtk_de($cls)} {
+ return
+ }
+ } elseif {$::gdbtk_de(others)} {
+ return
+ }
+ }
+
+ # ONLY the classes set
+ if {!$::gdbtk_de(ALL)} {
+ if {[info exists ::gdbtk_de($cls)]} {
+ if {!$::gdbtk_de($cls)} {
+ return
+ }
+ } elseif {!$::gdbtk_de(others)} {
+ return
+ }
+ }
+ }
+
+ if {$func != ""} {
+ append cls ::$func
+ }
+ $_t insert end "($cls) " {} "$msg\n" $level
+ $_t see insert
+}
+
+# -----------------------------------------------------------------------------
+# NAME: DebugWin::put_trace
+#
+# SYNOPSIS: put_trace {enter level func ar}
+#
+# DESC: Writes trace information into the DebugWin. A filter
+# will be applied to determine if the message should be
+# displayed or not.
+#
+# ARGS: enter - 1 if this is a function entry, 0 otherwise.
+# level - stack level
+# func - function name
+# ar - function arguments
+# -----------------------------------------------------------------------------
+itcl::body DebugWin::put_trace {enter level func ar} {
+ set x [expr {$level * 2 - 2}]
+ if {$enter} {
+ $_t insert end "[string range $_bigstr 0 $x]$func " trace "$ar\n" args
+ } else {
+ $_t insert end "[string range $_bigstr 0 $x]<- $func " trace "$ar\n" args
+ }
+ $_t see insert
+}
+
+# -----------------------------------------------------------------------------
+# NAME: DebugWin::loadlog
+#
+# SYNOPSIS: loadlog
+#
+# DESC: Reads the contents of the debug log file, if it exists, into
+# the DebugWin.
+# -----------------------------------------------------------------------------
+itcl::body DebugWin::loadlog {} {
+ $_t delete 0.0 end
+ # Now load in log file, if possible.
+ # this is rather rude, using the logfile variable in the debug namespace
+ if {$::debug::logfile != "" && $::debug::logfile != "stdout"} {
+ flush $::debug::logfile
+ seek $::debug::logfile 0 start
+ while {[gets $::debug::logfile line] >= 0} {
+ while {[catch {set f [lindex $line 0]} f]} {
+ # If the lindex failed its because the remainder of the
+ # list is on the next line. Get it.
+ if {[gets $::debug::logfile line2] < 0} {
+ break
+ }
+ append line \n $line2
+ }
+ if {$f == "T"} {
+ put_trace [lindex $line 1] [lindex $line 2] [lindex $line 3] \
+ [lindex $line 4]
+ } else {
+ puts $f [lindex $line 1] [lindex $line 2] [lindex $line 3]
+ }
+ }
+ }
+}
+
+# -----------------------------------------------------------------------------
+# NAME: DebugWin::_source_all
+#
+# SYNOPSIS: _source_all
+#
+# DESC: Re-sources all the .itb files.
+# -----------------------------------------------------------------------------
+itcl::body DebugWin::_source_all {} {
+ foreach f [glob [file join $::GDBTK_LIBRARY *.itb]] {
+ source $f
+ }
+}
+
+# -----------------------------------------------------------------------------
+# NAME: DebugWin::_clear
+#
+# SYNOPSIS: _clear
+#
+# DESC: Clears out the content of the debug window.
+# -----------------------------------------------------------------------------
+itcl::body DebugWin::_clear {} {
+ $_t delete 1.0 end
+}
+
+# -----------------------------------------------------------------------------
+# NAME: DebugWin::_mark_old
+#
+# SYNOPSIS: _mark_old
+#
+# DESC: Changes the background of the current contents of the window.
+# -----------------------------------------------------------------------------
+itcl::body DebugWin::_mark_old {} {
+ $_t tag add marked 1.0 "end - 1c"
+}
+
+# -----------------------------------------------------------------------------
+# NAME: DebugWin::_save_contents
+#
+# SYNOPSIS: _save_contents
+#
+# DESC: Changes the background of the current contents of the window.
+# -----------------------------------------------------------------------------
+itcl::body DebugWin::_save_contents {} {
+ set file [tk_getSaveFile -title "Choose debug window dump file" \
+ -parent [winfo toplevel $itk_interior]]
+ if {$file == ""} {
+ return
+ }
+
+ if {[catch {::open $file w} fileH]} {
+ tk_messageBox -type ok -icon error -message \
+ "Can't open file: \"$file\". \n\nThe error was:\n\n\"$fileH\""
+ return
+ }
+ ::puts $fileH [$_t get 1.0 end]
+
+}
+
+###############################################################################
+# -----------------------------------------------------------------------------
+# NAME: DebugWinDOpts::constructor
+#
+# SYNOPSIS: constructor
+#
+# DESC: Creates the Debug Window Options Dialog.
+# -----------------------------------------------------------------------------
+itcl::body DebugWinDOpts::constructor {args} {
+ window_name "Debug Window Options"
+ build_win
+ eval itk_initialize $args
+}
+
+###############################################################################
+# -----------------------------------------------------------------------------
+# NAME: DebugWinDOpts::destructor
+#
+# SYNOPSIS: Not called by hand
+#
+# DESC: Destroys the Debug Window Options Dialog.
+# -----------------------------------------------------------------------------
+itcl::body DebugWinDOpts::destructor {} {
+}
+
+
+# -----------------------------------------------------------------------------
+# NAME: DebugWinDOpts::build_win
+#
+# SYNOPSIS: build_win
+#
+# DESC: Creates the Debug Window Options Dialog. This dialog allows the
+# user to select which information is displayed in the debug
+# window and (eventually) how it looks.
+# -----------------------------------------------------------------------------
+itcl::body DebugWinDOpts::build_win {} {
+ wm title [winfo toplevel $itk_interior] "Debug Display Options"
+ # initialize here so we can resource this file and update the list
+ set _classes {DebugWin RegWin SrcBar SrcWin ToolBar WatchWin EmbeddedWin \
+ ManagedWin GDBWin StackWin SrcTextWin global \
+ BpWin TargetSelection ModalDialog ProcessWin \
+ GDBEventHandler MemWin VarTree}
+ set _classes [concat [lsort $_classes] others]
+
+ set f [frame $itk_interior.f]
+ set btns [frame $itk_interior.buttons]
+
+ iwidgets::Labeledframe $f.display -labelpos nw -labeltext {Classes}
+ set fr [$f.display childsite]
+ radiobutton $fr.0 -text "Messages from ALL classes EXCEPT those selected below" \
+ -variable ::gdbtk_de(filter_var) -value ALL -command [code $this _all]
+ radiobutton $fr.1 -text "Messages from ONLY those classes selected below" \
+ -variable ::gdbtk_de(filter_var) -value ONLY -command [code $this _all]
+ radiobutton $fr.2 -text "Only WARNINGS and ERRORS" \
+ -variable ::gdbtk_de(filter_var) -value ERRORS -command [code $this _all]
+
+ grid $fr.0 -sticky w -padx 5 -pady 5
+ grid $fr.1 -sticky w -padx 5 -pady 5
+ grid $fr.2 -sticky w -padx 5 -pady 5
+
+ iwidgets::Labeledframe $f.classes
+ set fr [$f.classes childsite]
+
+ set i 0
+ foreach cls $_classes {
+ if {![info exists ::gdbtk_de($cls)]} {
+ set ::gdbtk_de($cls) 0
+ }
+ checkbutton $fr.$i -text $cls -variable ::gdbtk_de($cls)
+ incr i
+ }
+
+ set k [expr 3*(int($i/3))]
+ set more [expr $i - $k]
+ set j 0
+ while {$j < $k} {
+ grid $fr.$j $fr.[expr $j+1] $fr.[expr $j+2] -sticky w -padx 5 -pady 5
+ incr j 3
+ }
+ switch $more {
+ 1 { grid $fr.$j x x -sticky w -padx 5 -pady 5}
+ 2 { grid $fr.$j $fr.[expr $j+1] x -sticky w -padx 5 -pady 5}
+ }
+
+ pack $f.display -side top -expand 1 -fill both
+ pack $f.classes -side top -expand 1 -fill both
+
+ button $btns.ok -text [gettext OK] -width 7 -command [code $this _apply 1] \
+ -default active
+ button $btns.apply -text "Apply to All" -width 7 \
+ -command [code $this _apply 0]
+ if {$::debug::logfile == "" || $::debug::logfile == "stdout"} {
+ $btns.apply configure -state disabled
+ }
+ button $btns.help -text [gettext Help] -width 10 -command [code $this help] \
+ -state disabled
+ standard_button_box $btns
+ bind $btns.ok <Return> "$btns.ok flash; $btns.ok invoke"
+ bind $btns.apply <Return> "$btns.apply flash; $btns.apply invoke"
+ bind $btns.help <Return> "$btns.help flash; $btns.help invoke"
+
+ pack $btns $f -side bottom -expand 1 -fill both -anchor e
+ focus $btns.ok
+}
+
+# -----------------------------------------------------------------------------
+# NAME: DebugWinDOpts::_all
+#
+# SYNOPSIS: _all
+#
+# DESC: Callback for selecting ALL classes. If the user selects ALL,
+# deselect all the individual class checkbuttons.
+# -----------------------------------------------------------------------------
+itcl::body DebugWinDOpts::_all {} {
+ switch $::gdbtk_de(filter_var) {
+ ALL {
+ set ::gdbtk_de(ALL) 1
+ set ::gdbtk_de(ERRORS_ONLY) 0
+ #enable class buttons
+ set num 0
+ foreach class $_classes {
+ [$itk_interior.f.classes childsite].$num configure -state normal
+ incr num
+ }
+ }
+ ONLY {
+ set ::gdbtk_de(ALL) 0
+ set ::gdbtk_de(ERRORS_ONLY) 0
+ #enable class buttons
+ set num 0
+ foreach class $_classes {
+ [$itk_interior.f.classes childsite].$num configure -state normal
+ incr num
+ }
+ }
+ ERRORS {
+ set ::gdbtk_de(ALL) 0
+ set ::gdbtk_de(ERRORS_ONLY) 1
+ # disable class buttons
+ set num 0
+ foreach class $_classes {
+ [$itk_interior.f.classes childsite].$num configure -state disabled
+ incr num
+ }
+ }
+ }
+}
+
+
+# -----------------------------------------------------------------------------
+# NAME: DebugWinDOpts::_apply
+#
+# SYNOPSIS: _apply
+#
+# DESC: Callback for the "Apply" button. Loads the contents of the
+# log file through the new filter into the debug window. The
+# button is disabled if there is no log file.
+# -----------------------------------------------------------------------------
+itcl::body DebugWinDOpts::_apply { done } {
+ set dw [ManagedWin::find DebugWin]
+ debug $dw
+ if {$dw != ""} {
+ $dw loadlog
+ }
+ if {$done} {
+ delete object $this
+ }
+}
OSDN Git Service
