You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
475 lines
15 KiB
Plaintext
475 lines
15 KiB
Plaintext
15 years ago
|
# Kernel Object Display Window for Insight.
|
||
|
|
# Copyright (C) 1998, 1999, 2001 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.
|
||
|
|
#
|
||
|
|
# AUTHOR: Fernando Nasser <fnasser@cygnus.com>
|
||
|
|
#
|
||
|
|
|
||
|
|
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
# CONSTRUCTOR - create new process window
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
itcl::body KodWin::constructor {args} {
|
||
|
|
#
|
||
|
|
# Create a window with the same name as this object
|
||
|
|
#
|
||
|
|
global gdb_kod_cmd
|
||
|
|
|
||
|
|
# initialize local variables
|
||
|
|
set LevelCmd(0) "info $gdb_kod_cmd "
|
||
|
|
debug "Level 0 kod command is $LevelCmd(0)"
|
||
|
|
|
||
|
|
gdbtk_busy
|
||
|
|
build_win
|
||
|
|
gdbtk_idle
|
||
|
|
}
|
||
|
|
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
# METHOD: build_win - build the main KOD window
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
itcl::body KodWin::build_win {} {
|
||
|
|
# FIXME: rename this variable.
|
||
|
|
global kodActivePane
|
||
|
|
|
||
|
|
debug "Will build KOD window"
|
||
|
|
|
||
|
|
cyg::PanedWindow $itk_interior.pw -orient horizontal
|
||
|
|
$itk_interior.pw add titlepane
|
||
|
|
# We would like to use a fixed pane for the buttons. However,
|
||
|
|
# this feature of PanedWindow doesn't work.
|
||
|
|
# $itk_interior.pw add buttonpane -resizable 0
|
||
|
|
$itk_interior.pw add pane1
|
||
|
|
$itk_interior.pw add pane2
|
||
|
|
|
||
|
|
# Now a frame for what is being listed, headers and list
|
||
|
|
set tp [$itk_interior.pw childsite titlepane]
|
||
|
|
Labelledframe $tp.tf -text "No Kernel Objects Known" \
|
||
|
|
-anchor nw
|
||
|
|
set titl $tp.tf
|
||
|
|
set lf [$tp.tf get_frame]
|
||
|
|
|
||
|
|
set p1 [$itk_interior.pw childsite pane1]
|
||
|
|
set p2 [$itk_interior.pw childsite pane2]
|
||
|
|
$p1 configure -height 120 -bd 2
|
||
|
|
$p2 configure -height 120 -bd 2
|
||
|
|
Labelledframe $p1.d1 -text "Details" -anchor nw
|
||
|
|
Labelledframe $p2.d2 -text "Details" -anchor nw
|
||
|
|
set d1 [$p1.d1 get_frame]
|
||
|
|
set d2 [$p2.d2 get_frame]
|
||
|
|
pack $p1.d1 $p2.d2 -side top -expand yes -fill both -padx 5 -pady 5
|
||
|
|
set pl1 $p1.d1
|
||
|
|
set pl2 $p2.d2
|
||
|
|
|
||
|
|
# Setup the button box
|
||
|
|
set bf [frame $tp.bf]
|
||
|
|
set BTop [button $bf.top -height 1 -text Top -command [code $this top]]
|
||
|
|
set BUp [button $bf.up -height 1 -text Up -command [code $this up]]
|
||
|
|
set BClear [button $bf.clear -height 1 -text Clear \
|
||
|
|
-command [code $this clear]]
|
||
|
|
set BDisplay [button $bf.display -height 1 -text Display \
|
||
|
|
-command [code $this display]]
|
||
|
|
set kodActivePane pane1
|
||
|
|
set BPane1 [radiobutton $bf.pane1 -variable kodActivePane \
|
||
|
|
-height 1 -text "Pane 1" -value pane1]
|
||
|
|
set BPane2 [radiobutton $bf.pane2 -variable kodActivePane \
|
||
|
|
-height 1 -text "Pane 2" -value pane2]
|
||
|
|
balloon register $bf.top "Return to List of Kernel Objects"
|
||
|
|
balloon register $bf.up "Return to previous List of Objects"
|
||
|
|
balloon register $bf.clear "Clear Object Detail Panes\nand Active setting"
|
||
|
|
balloon register $bf.display \
|
||
|
|
"Display Object or\nList of Objects of this type"
|
||
|
|
balloon register $bf.pane1 "Make Pane 1 Active"
|
||
|
|
balloon register $bf.pane2 "Make Pane 2 Active"
|
||
|
|
pack $bf.top $bf.up -side left -padx 5
|
||
|
|
pack $bf.display $bf.clear -side right -padx 5
|
||
|
|
pack $bf.pane2 $bf.pane1 -side bottom -padx 5 -fill both
|
||
|
|
|
||
|
|
# The list of objects
|
||
|
|
table $lf.s -titlerows 1 \
|
||
|
|
-colstretch last -rowstretch last -selectmode single \
|
||
|
|
-selecttype row -variable $this \
|
||
|
|
-yscrollcommand "$lf.sb set" -resizeborders none \
|
||
|
|
-state disabled
|
||
|
|
scrollbar $lf.sb -orient vertical -command "$lf.s yview"
|
||
|
|
bind $lf.s <Double-1> [code $this display]
|
||
|
|
$lf.s tag configure coltag -anchor nw
|
||
|
|
|
||
|
|
grid $lf.s -row 0 -column 0 -sticky nsew
|
||
|
|
grid $lf.sb -row 0 -column 1 -sticky nsw
|
||
|
|
grid columnconfigure $lf 0 -weight 1
|
||
|
|
grid rowconfigure $lf 0 -weight 1
|
||
|
|
|
||
|
|
# Areas to display object details
|
||
|
|
set t1 [table $d1.t1 -titlerows 1 -colstretch last -rowstretch last \
|
||
|
|
-selectmode single -selecttype row -variable $this-pane1 \
|
||
|
|
-yscrollcommand "$d1.s1 set" -resizeborders none \
|
||
|
|
-rows 1 -cols 1 -state disabled]
|
||
|
|
scrollbar $d1.s1 -orient vertical -command "$d1.t1 yview"
|
||
|
|
set t2 [table $d2.t2 -titlerows 1 -colstretch last -rowstretch last \
|
||
|
|
-selectmode single -selecttype row -variable $this-pane2 \
|
||
|
|
-yscrollcommand "$d2.s2 set" -resizeborders none \
|
||
|
|
-rows 1 -cols 1 -state disabled]
|
||
|
|
scrollbar $d2.s2 -orient vertical -command "$d2.t2 yview"
|
||
|
|
|
||
|
|
grid $d1.t1 -row 0 -column 0 -sticky nsew
|
||
|
|
grid $d1.s1 -row 0 -column 1 -sticky nsw
|
||
|
|
grid columnconfigure $d1 0 -weight 1
|
||
|
|
grid rowconfigure $d1 0 -weight 1
|
||
|
|
grid $d2.t2 -row 0 -column 0 -sticky nsew
|
||
|
|
grid $d2.s2 -row 0 -column 1 -sticky nsw
|
||
|
|
grid columnconfigure $d2 0 -weight 1
|
||
|
|
grid rowconfigure $d2 0 -weight 1
|
||
|
|
|
||
|
|
debug "Will pack KOD window"
|
||
|
|
pack $tp.tf -side top -expand yes -fill both -padx 5 -pady 5
|
||
|
|
pack $tp.bf -side top -expand no -fill x -padx 5 -pady 5
|
||
|
|
pack $itk_interior.pw -side bottom -expand yes -fill both
|
||
|
|
wm minsize $_top 450 500
|
||
|
|
|
||
|
|
# Initialize button state variables for idle (called before update)
|
||
|
|
set BState(BDisplay) disabled
|
||
|
|
set BState(BClear) disabled
|
||
|
|
set BState(BTop) disabled
|
||
|
|
set BState(BUp) disabled
|
||
|
|
|
||
|
|
# window_name "Kernel Objects"
|
||
|
|
|
||
|
|
update dummy
|
||
|
|
}
|
||
|
|
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
# METHOD: update - update widget when something changes
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
itcl::body KodWin::update {event} {
|
||
|
|
|
||
|
|
debug "updating kod window"
|
||
|
|
|
||
|
|
_disable_buttons
|
||
|
|
|
||
|
|
display_list
|
||
|
|
display_object
|
||
|
|
|
||
|
|
_restore_buttons
|
||
|
|
|
||
|
|
}
|
||
|
|
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
# METHOD: display - update the display based on the selection
|
||
|
|
# it can be a list or an actual object
|
||
|
|
# We get here from a press on the Display button or
|
||
|
|
# from a <Double-1> on a line of the list of objects
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
itcl::body KodWin::display {} {
|
||
|
|
upvar \#0 $this table_vals
|
||
|
|
if {!$Running && [$lf.s cget -rows] > 1} {
|
||
|
|
gdbtk_busy
|
||
|
|
set linenum [$lf.s index active row]
|
||
|
|
set object $table_vals($linenum,0)
|
||
|
|
debug "display selection on line $linenum $object"
|
||
|
|
incr level
|
||
|
|
set LevelCmd($level) $LevelCmd([expr $level-1])
|
||
|
|
append LevelCmd($level) $object
|
||
|
|
debug "kod command for level $level is now: $LevelCmd($level)"
|
||
|
|
update dummy
|
||
|
|
# Run idle hooks and cause all other widgets to update
|
||
|
|
gdbtk_idle
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
# METHOD: display_list - display list of objects
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
itcl::body KodWin::display_list {} {
|
||
|
|
upvar \#0 $this table_vals
|
||
|
|
|
||
|
|
debug "displaying list of objects"
|
||
|
|
|
||
|
|
$lf.s configure -state normal
|
||
|
|
set cmd $LevelCmd($level)
|
||
|
|
debug "new kod command is $cmd"
|
||
|
|
if {[catch "gdb_cmd \"$cmd\"" objects]} {
|
||
|
|
# failed. leave window blank
|
||
|
|
$titl configure -text "Kernel Object Display Failed"
|
||
|
|
$lf.s delete rows 0 [$lf.s index end row]
|
||
|
|
$lf.s configure -state disabled
|
||
|
|
set BState(BDisplay) disabled
|
||
|
|
return
|
||
|
|
}
|
||
|
|
|
||
|
|
debug "KodWin update: \n$objects"
|
||
|
|
if {[llength $objects] == 0} {
|
||
|
|
$titl configure -text "No Kernel Objects Known"
|
||
|
|
# no objects listed.
|
||
|
|
$lf.s delete rows 0 [$lf.s index end row]
|
||
|
|
$lf.s configure -state disabled
|
||
|
|
set BState(BDisplay) disabled
|
||
|
|
return
|
||
|
|
}
|
||
|
|
|
||
|
|
# insert each line one at a time
|
||
|
|
set num_lines -1
|
||
|
|
foreach line [split $objects \n] {
|
||
|
|
if {$num_lines == -1} {
|
||
|
|
if {![string match List* $line]} {
|
||
|
|
if {($level > 0)} {
|
||
|
|
display_object $cmd objects
|
||
|
|
incr level -1
|
||
|
|
$lf.s configure -state disabled
|
||
|
|
return
|
||
|
|
} else {
|
||
|
|
# if level 0 first line does not start with List ignore it
|
||
|
|
$titl configure -text "List of Kernel Objects"
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
$titl configure -text $line
|
||
|
|
}
|
||
|
|
# Clear listbox and headers to get new stuff.
|
||
|
|
$lf.s delete rows 0 [$lf.s index end row]
|
||
|
|
} elseif {$line == ""} {
|
||
|
|
break
|
||
|
|
} else {
|
||
|
|
set col 0
|
||
|
|
set list [split [string trim $line] \t]
|
||
|
|
if {$num_lines == 0} {
|
||
|
|
$lf.s configure -cols [llength $list] -titlerows 1
|
||
|
|
}
|
||
|
|
foreach item $list {
|
||
|
|
debug "inserting $item at $num_lines,$col"
|
||
|
|
set table_vals($num_lines,$col) $item
|
||
|
|
incr col
|
||
|
|
}
|
||
|
|
}
|
||
|
|
incr num_lines
|
||
|
|
}
|
||
|
|
$lf.s configure -rows [expr {$num_lines + 1}]
|
||
|
|
|
||
|
|
if {$num_lines > 0} {
|
||
|
|
set BState(BDisplay) active
|
||
|
|
}
|
||
|
|
|
||
|
|
if {$level == 0} {
|
||
|
|
set BState(BTop) disabled
|
||
|
|
set BState(BUp) disabled
|
||
|
|
} else {
|
||
|
|
set BState(BTop) active
|
||
|
|
set BState(BUp) active
|
||
|
|
}
|
||
|
|
|
||
|
|
$lf.s configure -state disabled
|
||
|
|
$lf.s see 0,0
|
||
|
|
$lf.s activate 1,0
|
||
|
|
|
||
|
|
_restore_buttons
|
||
|
|
}
|
||
|
|
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
# METHOD: display_object - display information about an object
|
||
|
|
# When called from update we have to reissue the gdb
|
||
|
|
# command to get fresh data
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
itcl::body KodWin::display_object {{cmd ""} {obj ""}} {
|
||
|
|
debug "Displaying object details..."
|
||
|
|
upvar $obj objects
|
||
|
|
global kodActivePane
|
||
|
|
debug "Active Pane is $kodActivePane"
|
||
|
|
|
||
|
|
# Determine which frame to use
|
||
|
|
if {$kodActivePane == "pane2"} {
|
||
|
|
set curpan $t2
|
||
|
|
upvar \#0 $this-pane2 pane_values
|
||
|
|
if {$cmd != ""} {
|
||
|
|
# save command for update
|
||
|
|
set pane2command $cmd
|
||
|
|
} else {
|
||
|
|
# reuse saved command
|
||
|
|
set cmd $pane2command
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
set curpan $t1
|
||
|
|
upvar \#0 $this-pane1 pane_values
|
||
|
|
if {$cmd != ""} {
|
||
|
|
# save command for update
|
||
|
|
set pane1command $cmd
|
||
|
|
} else {
|
||
|
|
# reuse saved command
|
||
|
|
set cmd $pane1command
|
||
|
|
}
|
||
|
|
}
|
||
|
|
debug "curpan $curpan"
|
||
|
|
|
||
|
|
# here we must take care of the case where the user has activated a window
|
||
|
|
# but it does not have been filled yet. We just return.
|
||
|
|
if {$cmd == ""} {
|
||
|
|
return
|
||
|
|
}
|
||
|
|
|
||
|
|
$curpan configure -state normal
|
||
|
|
$curpan delete rows 0 [$curpan index end row]
|
||
|
|
if {$obj == ""} {
|
||
|
|
debug "pane kod command is $cmd"
|
||
|
|
if {[catch "gdb_cmd \"$cmd\"" objects]
|
||
|
|
|| $objects == ""} {
|
||
|
|
# Failed. Tell user object no longer there.
|
||
|
|
$curpan configure -state disabled
|
||
|
|
return
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
set num_lin 0
|
||
|
|
foreach line [split $objects \n] {
|
||
|
|
set col 0
|
||
|
|
set list [split [string trim $line] \t]
|
||
|
|
if {$num_lin == 0} {
|
||
|
|
$curpan configure -cols [llength $list]
|
||
|
|
}
|
||
|
|
foreach item $list {
|
||
|
|
set pane_values($num_lin,$col) $item
|
||
|
|
incr col
|
||
|
|
}
|
||
|
|
incr num_lin
|
||
|
|
}
|
||
|
|
$curpan configure -rows $num_lin -state disabled
|
||
|
|
}
|
||
|
|
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
# METHOD: clear - clear detail panes and reset pane selection
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
itcl::body KodWin::clear {} {
|
||
|
|
debug "going to clear detail panes and pane selection"
|
||
|
|
$t1 configure -state normal
|
||
|
|
$t2 configure -state normal
|
||
|
|
$t1 delete rows 0 [$t1 index end row]
|
||
|
|
$t2 delete rows 0 [$t2 index end row]
|
||
|
|
$t1 configure -state disabled
|
||
|
|
$t2 configure -state disabled
|
||
|
|
# Default to pane 1 again.
|
||
|
|
global kodActivePane
|
||
|
|
set kodActivePane pane1
|
||
|
|
set pane1command ""
|
||
|
|
set pane2command ""
|
||
|
|
}
|
||
|
|
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
# METHOD: top - go to the list of types of objects (top level)
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
itcl::body KodWin::top {} {
|
||
|
|
debug "going to top from level $level"
|
||
|
|
if {$level > 0} {
|
||
|
|
set level 0
|
||
|
|
update dummy
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
# METHOD: up - go to the list of objects which led to the current one
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
itcl::body KodWin::up {} {
|
||
|
|
debug "going up from level $level..."
|
||
|
|
if {$level > 0} {
|
||
|
|
incr level -1
|
||
|
|
debug "...to level $level"
|
||
|
|
update dummy
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
# DESTRUCTOR - destroy window containing widget
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
itcl::body KodWin::destructor {} {
|
||
|
|
upvar \#0 $this table_vals $this-pane1 pane1_vals $this-pane2 pane2_vals
|
||
|
|
global kodActivePane
|
||
|
|
|
||
|
|
catch {unset table_vals}
|
||
|
|
catch {unset pane1_vals}
|
||
|
|
catch {unset pane2_vals}
|
||
|
|
catch {unset kodActivePane}
|
||
|
|
}
|
||
|
|
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
# PUBLIC METHOD: set_variable - called when user runs `set os'
|
||
|
|
# command
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
itcl::body KodWin::set_variable {event} {
|
||
|
|
|
||
|
|
set value [$event get value]
|
||
|
|
if {[$event get variable] == "os" && $value != ""} {
|
||
|
|
set LevelCmd(0) "info $value "
|
||
|
|
set level 0
|
||
|
|
update dummy
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
# METHOD: reconfig - used when preferences change
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
itcl::body KodWin::reconfig {} {
|
||
|
|
destroy $itk_interior.bf
|
||
|
|
destroy $titl
|
||
|
|
build_win
|
||
|
|
}
|
||
|
|
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
# METHOD: busy - BusyEvent handler
|
||
|
|
#
|
||
|
|
# This method should accomplish blocking
|
||
|
|
# - clicks in the window
|
||
|
|
# - change mouse pointer
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
itcl::body KodWin::busy {event} {
|
||
|
|
set Running 1
|
||
|
|
_disable_buttons
|
||
|
|
cursor watch
|
||
|
|
}
|
||
|
|
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
# METHOD: idle - idle event handler. Run when the target is not
|
||
|
|
# running
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
itcl::body KodWin::idle {event} {
|
||
|
|
set Running 0
|
||
|
|
_restore_buttons
|
||
|
|
cursor {}
|
||
|
|
}
|
||
|
|
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
# METHOD: cursor - set the window cursor
|
||
|
|
# This is a convenience method which simply sets the mouse
|
||
|
|
# pointer to the given glyph.
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
itcl::body KodWin::cursor {glyph} {
|
||
|
|
$_top configure -cursor $glyph
|
||
|
|
}
|
||
|
|
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
# PRIVATE METHOD: _disable_buttons - disable all buttons
|
||
|
|
# Used when we are busy and can't take another event
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
itcl::body KodWin::_disable_buttons {} {
|
||
|
|
$BTop configure -state disabled
|
||
|
|
$BUp configure -state disabled
|
||
|
|
$BDisplay configure -state disabled
|
||
|
|
$BClear configure -state disabled
|
||
|
|
}
|
||
|
|
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
# PRIVATE METHOD: _restore_buttons - restore all buttons to their
|
||
|
|
# previous states.
|
||
|
|
# Used when we are busy and can't take another event
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
itcl::body KodWin::_restore_buttons {} {
|
||
|
|
$BTop configure -state $BState(BTop)
|
||
|
|
$BUp configure -state $BState(BUp)
|
||
|
|
$BDisplay configure -state $BState(BDisplay)
|
||
|
|
# CLEAR is always active, except when busy
|
||
|
|
$BClear configure -state active
|
||
|
|
}
|