path: root/gdb/gdbtk/library/kod.itb

# 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
}