gdb/gdbtk/library/debugwin.itb

   1 # Debug window for GDBtk.
   2 # Copyright (C) 1998, 1999, 2000, 2001, 2002 Red Hat, Inc.
   3 #
   4 # This program is free software; you can redistribute it and/or modify it
   5 # under the terms of the GNU General Public License (GPL) as published by
   6 # the Free Software Foundation; either version 2 of the License, or (at
   7 # your option) any later version.
   8 #
   9 # This program is distributed in the hope that it will be useful,
  10 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 # GNU General Public License for more details.
  13
  14
  15 # -----------------------------------------------------------------------------
  16 # NAME:         DebugWin::constructor
  17 #
  18 # SYNOPSIS:     constructor::args
  19 #
  20 # DESC:         Creates the debug window
  21 #
  22 # ARGS:         None are used yet.
  23 # -----------------------------------------------------------------------------
  24 itcl::body DebugWin::constructor {args} {
  25   debug $args
  26   window_name "Insight Debug" "Debug"
  27
  28   build_win
  29 }
  30
  31 # -----------------------------------------------------------------------------
  32 # NAME:         DebugWin::destructor
  33 #
  34 # SYNOPSIS:     Not called by hand
  35 #
  36 # DESC:         Destroys the debug window
  37 #
  38 # ARGS:         None
  39 # -----------------------------------------------------------------------------
  40 itcl::body DebugWin::destructor {} {
  41   # notify debug code that window is going away
  42   ::debug::debugwin ""
  43 }
  44
  45 # -----------------------------------------------------------------------------
  46 # NAME:         DebugWin::reconfig
  47 #
  48 # SYNOPSIS:     Reconfigure callback
  49 #
  50 # DESC:         Fixes up window colors
  51 #
  52 # ARGS:         None
  53 # -----------------------------------------------------------------------------
  54 itcl::body DebugWin::reconfig {} {
  55   # This keeps the Debug window using its unique black background.
  56   # Otherwise, a reconfigure event will color it to match the other windows
  57   $itk_interior.s configure -textbackground black
  58 }
  59
  60 # -----------------------------------------------------------------------------
  61 # NAME:         DebugWin::build_win
  62 #
  63 # SYNOPSIS:     build_win
  64 #
  65 # DESC:         Creates the Debug Window. Reads the contents of the debug log
  66 #               file, if it exists. Notifies the debug functions in ::debug
  67 #               to send output here.
  68 # -----------------------------------------------------------------------------
  69 itcl::body DebugWin::build_win {} {
  70   global gdb_ImageDir GDBTK_LIBRARY
  71
  72   set top [winfo toplevel $itk_interior]
  73
  74   # initialize the gdbtk_de array
  75   if {![info exists ::gdbtk_de]} {
  76     set ::gdbtk_de(ALL) 1
  77     set ::gdbtk_de(ERRORS_ONLY) 0
  78     set ::gdbtk_de(others) 0
  79     set ::gdbtk_de(filter_var) ALL
  80   }
  81
  82   # create menubar
  83   set menu [menu $itk_interior.m  -tearoff 0]
  84   $menu add cascade -menu $menu.file -label "File" -underline 0
  85   set m [menu $menu.file]
  86   $m add command -label "Clear" -underline 1 \
  87     -command [code $this _clear]
  88   $m add command -label "Mark Old" -underline 1 \
  89     -command [code $this _mark_old]
  90   $m add separator
  91   $m add command -label "Save" -underline 0 \
  92     -command [code $this _save_contents]
  93   $m add separator
  94   $m add command -label "Close" -underline 0 \
  95     -command "::debug::debugwin {};delete object $this"
  96   $menu add cascade -menu $menu.trace -label "Trace"
  97   set m [menu $menu.trace]
  98   $m add radiobutton -label Start -variable ::debug::tracing -value 1
  99   $m add radiobutton -label Stop -variable ::debug::tracing -value 0
 100   $menu add cascade -menu $menu.rs -label "ReSource"
 101   set m [menu $menu.rs]
 102   foreach f [lsort [glob [file join $GDBTK_LIBRARY *.itb]]] {
 103     $m add command -label "Source [file tail $f]"\
 104       -command [list source $f]
 105   }
 106   $m add separator
 107   $m add command -label "Source ALL" -command [code $this _source_all]
 108
 109   $menu add cascade -menu $menu.opt -label "Options"
 110   set m [menu $menu.opt]
 111   $m add command -label "Display" -underline 0 \
 112     -command [list ManagedWin::open DebugWinDOpts -over $this]
 113   if {!$::debug::initialized} {
 114     $menu entryconfigure 1 -state disabled
 115     $menu add cascade -label "     Tracing Not Initialized" -foreground red \
 116       -activeforeground red
 117   }
 118   $menu add cascade -menu $menu.help -label "Help" -underline 0
 119   set m [menu $menu.help]
 120   $m add command -label "Debugging Functions" -underline 0 \
 121     -command {open_help debug.html}
 122
 123   $top configure -menu $menu
 124
 125   iwidgets::scrolledtext $itk_interior.s -hscrollmode static \
 126     -vscrollmode static -wrap none -textbackground black -foreground white
 127   set _t [$itk_interior.s component text]
 128   pack $itk_interior.s -expand 1 -fill both
 129
 130   # define tags
 131   foreach color $_colors {
 132     $_t tag configure [lindex $color 0] -foreground [lindex $color 1]
 133   }
 134   $_t tag configure trace -foreground gray
 135   $_t tag configure args -foreground blue
 136   $_t tag configure marked -background grey20
 137
 138   loadlog
 139
 140   # now notify the debug functions to use this window
 141   ::debug::debugwin $this
 142
 143   # override the window delete procedure so the messages are
 144   # turned off first.
 145   wm protocol $top WM_DELETE_WINDOW "::debug::debugwin {};destroy $top"
 146 }
 147
 148 # -----------------------------------------------------------------------------
 149 # NAME:         DebugWin::puts
 150 #
 151 # SYNOPSIS:     puts {level cls func msg}
 152 #
 153 # DESC:         Writes debugging information into the DebugWin. A filter
 154 #               will be applied to determine if the message should be
 155 #               displayed or not.
 156 #
 157 # ARGS:         level - priority level. See debug::dbug for details.
 158 #               cls   - class name of caller, for example "SrcWin"
 159 #               func  - function name of caller
 160 #               msg   - message to display
 161 # -----------------------------------------------------------------------------
 162 itcl::body DebugWin::puts {level cls func msg} {
 163   # filter. check if we should display this message
 164   # for now we always let high-level messages through
 165   if {$level == "I"} {
 166
 167     # errors and warnings only
 168     if {$::gdbtk_de(ERRORS_ONLY)} { return }
 169
 170     # ALL classes except those set
 171     if {$::gdbtk_de(ALL)} {
 172       if {[info exists ::gdbtk_de($cls)]} {
 173         if {$::gdbtk_de($cls)} {
 174           return
 175         }
 176       } elseif {$::gdbtk_de(others)} {
 177         return
 178       }
 179     }
 180
 181     # ONLY the classes set
 182     if {!$::gdbtk_de(ALL)} {
 183       if {[info exists ::gdbtk_de($cls)]} {
 184         if {!$::gdbtk_de($cls)} {
 185           return
 186         }
 187       } elseif {!$::gdbtk_de(others)} {
 188         return
 189       }
 190     }
 191   }
 192
 193   if {$func != ""} {
 194     append cls ::$func
 195   }
 196   $_t insert end "($cls) " {} "$msg\n" $level
 197   $_t see insert
 198 }
 199
 200 # -----------------------------------------------------------------------------
 201 # NAME:         DebugWin::put_trace
 202 #
 203 # SYNOPSIS:     put_trace {enter level func ar}
 204 #
 205 # DESC:         Writes trace information into the DebugWin. A filter
 206 #               will be applied to determine if the message should be
 207 #               displayed or not.
 208 #
 209 # ARGS:         enter - 1 if this is a function entry, 0 otherwise.
 210 #               level - stack level
 211 #               func  - function name
 212 #               ar    - function arguments
 213 # -----------------------------------------------------------------------------
 214 itcl::body DebugWin::put_trace {enter level func ar} {
 215   set x [expr {$level * 2 - 2}]
 216   if {$enter} {
 217     $_t insert end "[string range $_bigstr 0 $x]$func " trace "$ar\n" args
 218   } else {
 219     $_t insert end "[string range $_bigstr 0 $x]<- $func " trace "$ar\n" args
 220   }
 221   $_t see insert
 222 }
 223
 224 # -----------------------------------------------------------------------------
 225 # NAME:         DebugWin::loadlog
 226 #
 227 # SYNOPSIS:     loadlog
 228 #
 229 # DESC:         Reads the contents of the debug log file, if it exists, into
 230 #               the DebugWin.
 231 # -----------------------------------------------------------------------------
 232 itcl::body DebugWin::loadlog {} {
 233   $_t delete 0.0 end
 234   # Now load in log file, if possible.
 235   # this is rather rude, using the logfile variable in the debug namespace
 236   if {$::debug::logfile != "" && $::debug::logfile != "stdout"} {
 237     flush $::debug::logfile
 238     seek $::debug::logfile 0 start
 239     while {[gets $::debug::logfile line] >= 0} {
 240       while {[catch {set f [lindex $line 0]} f]} {
 241         # If the lindex failed its because the remainder of the
 242         # list is on the next line.  Get it.
 243         if {[gets $::debug::logfile line2] < 0} {
 244           break
 245         }
 246         append line \n $line2
 247       }
 248       if {$f == "T"} {
 249         put_trace [lindex $line 1] [lindex $line 2] [lindex $line 3] \
 250           [lindex $line 4]
 251       } else {
 252         puts $f [lindex $line 1] [lindex $line 2] [lindex $line 3]
 253       }
 254     }
 255   }
 256 }
 257
 258 # -----------------------------------------------------------------------------
 259 # NAME:         DebugWin::_source_all
 260 #
 261 # SYNOPSIS:     _source_all
 262 #
 263 # DESC:         Re-sources all the .itb files.
 264 # -----------------------------------------------------------------------------
 265 itcl::body DebugWin::_source_all {} {
 266   foreach f [glob [file join $::GDBTK_LIBRARY *.itb]] {
 267     source $f
 268   }
 269 }
 270
 271 # -----------------------------------------------------------------------------
 272 # NAME:         DebugWin::_clear
 273 #
 274 # SYNOPSIS:     _clear
 275 #
 276 # DESC:         Clears out the content of the debug window.
 277 # -----------------------------------------------------------------------------
 278 itcl::body DebugWin::_clear {} {
 279   $_t delete 1.0 end
 280 }
 281
 282 # -----------------------------------------------------------------------------
 283 # NAME:         DebugWin::_mark_old
 284 #
 285 # SYNOPSIS:     _mark_old
 286 #
 287 # DESC:         Changes the background of the current contents of the window.
 288 # -----------------------------------------------------------------------------
 289 itcl::body DebugWin::_mark_old {} {
 290   $_t tag add marked 1.0 "end - 1c"
 291 }
 292
 293 # -----------------------------------------------------------------------------
 294 # NAME:         DebugWin::_save_contents
 295 #
 296 # SYNOPSIS:     _save_contents
 297 #
 298 # DESC:         Changes the background of the current contents of the window.
 299 # -----------------------------------------------------------------------------
 300 itcl::body DebugWin::_save_contents {} {
 301   set file [tk_getSaveFile -title "Choose debug window dump file" \
 302               -parent [winfo toplevel $itk_interior]]
 303   if {$file == ""} {
 304     return
 305   }
 306
 307   if {[catch {::open $file w} fileH]} {
 308     tk_messageBox -type ok -icon error -message \
 309       "Can't open file: \"$file\". \n\nThe error was:\n\n\"$fileH\""
 310     return
 311   }
 312   ::puts $fileH [$_t get 1.0 end]
 313
 314 }
 315
 316 ###############################################################################
 317 # -----------------------------------------------------------------------------
 318 # NAME:         DebugWinDOpts::constructor
 319 #
 320 # SYNOPSIS:     constructor
 321 #
 322 # DESC:         Creates the Debug Window Options Dialog.
 323 # -----------------------------------------------------------------------------
 324 itcl::body DebugWinDOpts::constructor {args} {
 325     window_name "Debug Window Options"
 326     build_win
 327     eval itk_initialize $args
 328 }
 329
 330 ###############################################################################
 331 # -----------------------------------------------------------------------------
 332 # NAME:         DebugWinDOpts::destructor
 333 #
 334 # SYNOPSIS:     Not called by hand
 335 #
 336 # DESC:         Destroys the Debug Window Options Dialog.
 337 # -----------------------------------------------------------------------------
 338 itcl::body DebugWinDOpts::destructor {} {
 339 }
 340
 341
 342 # -----------------------------------------------------------------------------
 343 # NAME:         DebugWinDOpts::build_win
 344 #
 345 # SYNOPSIS:     build_win
 346 #
 347 # DESC:         Creates the Debug Window Options Dialog. This dialog allows the
 348 #               user to select which information is displayed in the debug
 349 #               window and (eventually) how it looks.
 350 # -----------------------------------------------------------------------------
 351 itcl::body DebugWinDOpts::build_win {} {
 352   wm title [winfo toplevel $itk_interior] "Debug Display Options"
 353   # initialize here so we can resource this file and update the list
 354   set _classes {DebugWin RegWin SrcBar SrcWin ToolBar WatchWin EmbeddedWin \
 355                   ManagedWin GDBWin StackWin SrcTextWin global \
 356                   BpWin TargetSelection ModalDialog ProcessWin \
 357                   GDBEventHandler MemWin VarTree}
 358   set _classes [concat [lsort $_classes] others]
 359
 360   set f [frame $itk_interior.f]
 361   set btns [frame $itk_interior.buttons]
 362
 363   iwidgets::Labeledframe $f.display -labelpos nw -labeltext {Classes}
 364   set fr [$f.display childsite]
 365   radiobutton $fr.0 -text "Messages from ALL classes EXCEPT those selected below" \
 366     -variable ::gdbtk_de(filter_var) -value ALL -command [code $this _all]
 367   radiobutton $fr.1 -text "Messages from ONLY those classes selected below" \
 368     -variable ::gdbtk_de(filter_var) -value ONLY -command [code $this _all]
 369   radiobutton $fr.2 -text "Only WARNINGS and ERRORS" \
 370     -variable ::gdbtk_de(filter_var) -value ERRORS -command [code $this _all]
 371
 372   grid $fr.0 -sticky w -padx 5 -pady 5
 373   grid $fr.1 -sticky w -padx 5 -pady 5
 374   grid $fr.2 -sticky w -padx 5 -pady 5
 375
 376   iwidgets::Labeledframe $f.classes
 377   set fr [$f.classes childsite]
 378
 379   set i 0
 380   foreach cls $_classes {
 381     if {![info exists ::gdbtk_de($cls)]} {
 382       set ::gdbtk_de($cls) 0
 383     }
 384     checkbutton $fr.$i -text $cls -variable ::gdbtk_de($cls)
 385     incr i
 386   }
 387
 388   set k [expr 3*(int($i/3))]
 389   set more [expr $i - $k]
 390   set j 0
 391   while {$j < $k} {
 392     grid $fr.$j $fr.[expr $j+1] $fr.[expr $j+2] -sticky w -padx 5 -pady 5
 393     incr j 3
 394   }
 395   switch $more {
 396     1 { grid $fr.$j x x -sticky w -padx 5 -pady 5}
 397     2 { grid $fr.$j $fr.[expr $j+1] x -sticky w -padx 5 -pady 5}
 398   }
 399
 400   pack $f.display -side top -expand 1 -fill both
 401   pack $f.classes -side top -expand 1 -fill both
 402
 403   button $btns.ok -text [gettext OK] -width 7 -command [code $this _apply 1] \
 404     -default active
 405   button $btns.apply -text "Apply to All"  -width 7 \
 406     -command [code $this _apply 0]
 407   if {$::debug::logfile == "" || $::debug::logfile == "stdout"} {
 408     $btns.apply configure -state disabled
 409   }
 410   button $btns.help -text [gettext Help] -width 10 -command [code $this help] \
 411     -state disabled
 412   standard_button_box $btns
 413   bind $btns.ok <Return> "$btns.ok flash; $btns.ok invoke"
 414   bind $btns.apply <Return> "$btns.apply flash; $btns.apply invoke"
 415   bind $btns.help <Return> "$btns.help flash; $btns.help invoke"
 416
 417   pack $btns $f -side bottom -expand 1 -fill both -anchor e
 418   focus $btns.ok
 419 }
 420
 421 # -----------------------------------------------------------------------------
 422 # NAME:         DebugWinDOpts::_all
 423 #
 424 # SYNOPSIS:     _all
 425 #
 426 # DESC:         Callback for selecting ALL classes. If the user selects ALL,
 427 #               deselect all the individual class checkbuttons.
 428 # -----------------------------------------------------------------------------
 429 itcl::body DebugWinDOpts::_all {} {
 430   switch $::gdbtk_de(filter_var) {
 431     ALL {
 432       set ::gdbtk_de(ALL) 1
 433       set ::gdbtk_de(ERRORS_ONLY) 0
 434       #enable class buttons
 435       set num 0
 436       foreach class $_classes {
 437         [$itk_interior.f.classes childsite].$num configure -state normal
 438         incr num
 439       }
 440     }
 441     ONLY {
 442       set ::gdbtk_de(ALL) 0
 443       set ::gdbtk_de(ERRORS_ONLY) 0
 444       #enable class buttons
 445       set num 0
 446       foreach class $_classes {
 447         [$itk_interior.f.classes childsite].$num configure -state normal
 448         incr num
 449       }
 450     }
 451     ERRORS {
 452       set ::gdbtk_de(ALL) 0
 453       set ::gdbtk_de(ERRORS_ONLY) 1
 454       # disable class buttons
 455       set num 0
 456       foreach class $_classes {
 457         [$itk_interior.f.classes childsite].$num configure -state disabled
 458         incr num
 459       }
 460     }
 461   }
 462 }
 463
 464
 465 # -----------------------------------------------------------------------------
 466 # NAME:         DebugWinDOpts::_apply
 467 #
 468 # SYNOPSIS:     _apply
 469 #
 470 # DESC:         Callback for the "Apply" button. Loads the contents of the
 471 #               log file through the new filter into the debug window. The
 472 #               button is disabled if there is no log file.
 473 # -----------------------------------------------------------------------------
 474 itcl::body DebugWinDOpts::_apply { done } {
 475   set dw [ManagedWin::find DebugWin]
 476   debug $dw
 477   if {$dw != ""} {
 478     $dw loadlog
 479   }
 480   if {$done} {
 481     delete object $this
 482   }
 483 }