# ------------------------------------------------------------------
#  METHOD:  constructor - build the dialog
# ------------------------------------------------------------------
body MemWin::constructor {args} {
  global _mem
  debug $args
  eval itk_initialize $args
  
  set top [winfo toplevel $itk_interior]
  gdbtk_busy
  
  set _mem($this,enabled) 1
  set bg white 
  
  if {![info exists type(1)]} {
    set type(1) char
    set type(2) short
    set type(4) int
    set type(8) "long long"
  }
  
  if {[pref getd gdb/mem/menu] != ""} {
    set mbar 0
  }
  
  init_addr_exp
  build_win
  gdbtk_idle
  
  add_hook gdb_update_hook "$this update"
  add_hook gdb_busy_hook [list $this busy]
  add_hook gdb_idle_hook [list $this idle]
}

# ------------------------------------------------------------------
#  METHOD:  destructor - destroy the dialog
# ------------------------------------------------------------------
body MemWin::destructor {} {
  if {[winfo exists $prefs_win]} {
    $prefs_win cancel
  }
  remove_hook gdb_update_hook "$this update"
  remove_hook gdb_busy_hook [list $this busy]
  remove_hook gdb_idle_hook [list $this idle]
}


# ------------------------------------------------------------------
#  METHOD:  build_win - build the main memory window
# ------------------------------------------------------------------
body MemWin::build_win {} {
  global tcl_platform gdb_ImageDir _mem ${this}_memval

  set maxlen 0
  set maxalen 0
  set saved_value ""

  if { $mbar } {
    menu $itk_interior.m -tearoff 0
    $top configure -menu $itk_interior.m
    $itk_interior.m add cascade -menu $itk_interior.m.addr -label "Addresses" -underline 0
    set m [menu $itk_interior.m.addr]
    $m add check -label " Auto Update" -variable _mem($this,enabled) \
      -underline 1 -command "after idle $this toggle_enabled"
    $m add command -label " Update Now" -underline 1 \
      -command "$this update_address" -accelerator {Ctrl+U}
    $m add separator
    $m add command -label " Preferences..." -underline 1 \
      -command "$this create_prefs"
  }

  # Numcols = number of columns of data
  # numcols = number of columns in table (data plus headings plus ASCII)
  # if numbytes are 0, then use window size to determine how many to read
  if {$numbytes == 0} {
    set Numrows 8
  } else {
    set Numrows [expr {$numbytes / $bytes_per_row}]
  }
  set numrows [expr {$Numrows + 1}]
  
  set Numcols [expr {$bytes_per_row / $size}]
  if {$ascii} {
    set numcols [expr {$Numcols + 2}]
  } else {
    set numcols [expr {$Numcols + 1}]
  }

  table $itk_interior.t -titlerows 1 -titlecols 1 -variable ${this}_memval \
    -roworigin -1 -colorigin -1 -bg $bg \
    -browsecmd "$this changed_cell %s %S" -font src-font\
    -colstretch unset -rowstretch unset -selectmode single \
    -xscrollcommand "$itk_interior.sx set" -resizeborders none \
    -cols $numcols -rows $numrows -autoclear 1
  
  if {$numbytes} {
    $itk_interior.t configure -yscrollcommand "$itk_interior.sy set"
    scrollbar $itk_interior.sy -command [list $itk_interior.t yview]
  } else {
    $itk_interior.t configure -rowstretchmode none
  }
  scrollbar $itk_interior.sx -command [list $itk_interior.t xview] -orient horizontal
  $itk_interior.t tag config sel -bg [$itk_interior.t cget -bg] -relief sunken
  $itk_interior.t tag config active -bg lightgray -relief sunken -wrap 0

  # rebind all events that use tkTableMoveCell to our local version
  # because we don't want to move into the ASCII column if it exists
  bind $itk_interior.t <Up>		"$this memMoveCell %W -1  0; break"
  bind $itk_interior.t <Down>		"$this memMoveCell %W  1  0; break"
  bind $itk_interior.t <Left>		"$this memMoveCell %W  0 -1; break"
  bind $itk_interior.t <Right>	"$this memMoveCell %W  0  1; break"
  bind $itk_interior.t <Return>	"$this memMoveCell %W 0 1; break"
  bind $itk_interior.t <KP_Enter>	"$this memMoveCell %W 0 1; break"

  # bind button 3 to popup
  bind $itk_interior.t <3> "$this do_popup %X %Y"

  # bind Paste and button2 to the paste function
  # this is necessary because we want to not just paste the
  # data into the cell, but we also have to write it
  # out to real memory
  bind $itk_interior.t <ButtonRelease-2> [format {after idle %s paste %s %s} $this %x %y]
  bind $itk_interior.t <<Paste>> [format {after idle %s paste %s %s} $this %x %y]

  menu $itk_interior.t.menu -tearoff 0
  bind_plain_key $top Control-u "$this update_address"

  # bind resize events
  bind $itk_interior <Configure> "$this newsize %h"

  frame $itk_interior.f
  iwidgets::spinint $itk_interior.f.cntl -labeltext " Address " -width 20 \
    -command "after idle $this update_address_cb" \
    -increment "after idle $this incr_addr -1" \
    -decrement "after idle $this incr_addr 1" \
    -validate {} \
    -textbackground white

  $itk_interior.f.cntl delete 0 end
  $itk_interior.f.cntl insert end $addr_exp

  balloon register [$itk_interior.f.cntl childsite].uparrow \
    "Scroll Up (Decrement Address)"
  balloon register [$itk_interior.f.cntl childsite].downarrow \
    "Scroll Down (Increment Address)"

  if {!$mbar} {
    button $itk_interior.f.upd -command "$this update_address" \
      -image [image create photo -file [::file join $gdb_ImageDir check.gif]]
    balloon register $itk_interior.f.upd "Update Now"
    checkbutton $itk_interior.cb -variable _mem($this,enabled) -command "$this toggle_enabled"
    balloon register $itk_interior.cb "Toggles Automatic Display Updates"
    grid $itk_interior.f.upd $itk_interior.f.cntl -sticky ew -padx 5
  } else {
    grid $itk_interior.f.cntl x -sticky w
    grid columnconfigure $itk_interior.f 1 -weight 1
  }

  # draw top border
  set col 0
  for {set i 0} {$i < $bytes_per_row} { incr i $size} {
    set ${this}_memval(-1,$col) [format " %X" $i]
    incr col
  }

  if {$ascii} {
    set ${this}_memval(-1,$col) ASCII
  }

  # fill initial display
  if {$nb} {
    update_address
  }

  if {!$mbar} {
    grid $itk_interior.f x -row 0 -column 0 -sticky nws
    grid $itk_interior.cb -row 0 -column 1 -sticky news
  } else {
    grid $itk_interior.f -row 0 -column 0 -sticky news
  }
  grid $itk_interior.t -row 1 -column 0 -sticky news
  if {$numbytes} { grid $itk_interior.sy -row 1 -column 1 -sticky ns }
  grid $itk_interior.sx -sticky ew
  grid columnconfig  $itk_interior 0 -weight 1
  grid rowconfig  $itk_interior 1 -weight 1
  focus $itk_interior.f.cntl

  window_name "Memory"
}

# ------------------------------------------------------------------
#  METHOD:  paste - paste callback. Update cell contents after paste
# ------------------------------------------------------------------
body MemWin::paste {x y} {
  edit [$itk_interior.t index @$x,$y]
}

# ------------------------------------------------------------------
#  METHOD:  validate - because the control widget wants this
# ------------------------------------------------------------------
body MemWin::validate {val} {
  return $val
}

# ------------------------------------------------------------------
#  METHOD:  create_prefs - create memory preferences dialog
# ------------------------------------------------------------------
body MemWin::create_prefs {} {
  if {$Running} { return }

  # make sure row height is set
  if {$rheight == ""} {
    set rheight [lindex [$itk_interior.t bbox 0,0] 3]
  }

  set prefs_win [ManagedWin::open MemPref -force -over $this\
		   -transient -win $this \
		   -size $size -format $format -numbytes $numbytes \
		   -bpr $bytes_per_row -ascii $ascii \
		   -ascii_char $ascii_char -color $color]
}

# ------------------------------------------------------------------
#  METHOD:  changed_cell - called when moving from one cell to another
# ------------------------------------------------------------------
body MemWin::changed_cell {from to} {
  #debug "moved from $from to $to"
  #debug "value = [$itk_interior.t get $from]"
  if {$saved_value != ""} {
    if {$saved_value != [$itk_interior.t get $from]} {
      edit $from
    }
  }
  set saved_value [$itk_interior.t get $to]
}

# ------------------------------------------------------------------
#  METHOD:  edit - edit a cell
# ------------------------------------------------------------------
body MemWin::edit { cell } {
  global _mem ${this}_memval

  #debug "edit $cell"

  if {$Running || $cell == ""} { return }
  set rc [split $cell ,]
  set row [lindex $rc 0]
  set col [lindex $rc 1]
  set val [$itk_interior.t get $cell]

  if {$col == $Numcols} { 
    # editing the ASCII field
    set addr [expr {$current_addr + $bytes_per_row * $row}]
    set start_addr $addr

    # calculate number of rows to modify
    set len [string length $val]
    set rows 0
    while {$len > 0} { 
      incr rows
      set len [expr {$len - $bytes_per_row}]
    }
    set nb [expr {$rows * $bytes_per_row}]

    # now process each char, one at a time
    foreach c [split $val ""] {
      if {$c != $ascii_char} {
	if {$c == "'"} {set c "\\'"}
	catch {gdb_cmd "set *(char *)($addr) = '$c'"}
      }
      incr addr
    }
    set addr $start_addr
    set nextval 0
    # now read back the data and update the widget
    catch {gdb_get_mem $addr $format $size $nb $bytes_per_row $ascii_char} vals
    for {set n 0} {$n < $nb} {incr n $bytes_per_row} {
      set ${this}_memval($row,-1) [format "0x%x" $addr]
      for { set col 0 } { $col < [expr {$bytes_per_row / $size}] } { incr col } {
	set ${this}_memval($row,$col) [lindex $vals $nextval]
	incr nextval
      }
      set ${this}_memval($row,$col) [lindex $vals $nextval]
      incr nextval
      incr addr $bytes_per_row
      incr row
    }
    return
  }

  # calculate address based on row and column
  set addr [expr {$current_addr + $bytes_per_row * $row + $size * $col}]
  #debug "  edit $row,$col         [format "%x" $addr] = $val"
  #set memory
  catch {gdb_cmd "set *($type($size) *)($addr) = $val"} res
  # read it back
  # FIXME - HACK ALERT - This call causes trouble with remotes on Windows. 
  # This routine is in fact called from within an idle handler triggered by
  # memMoveCell.  Something evil happens in that handler that causes gdb to
  # start writing this changed value into all the visible cells...
  # I have not figured out the cause of this, so for now I commented this
  # line out.  It will only matter if the write did not succeed, and this was
  # not a very good way to tell the user about that anyway...
  #
  # catch {gdb_get_mem $addr $format $size $size $size ""} val
  # delete whitespace in response
  set val [string trimright $val]
  set val [string trimleft $val]
  set ${this}_memval($row,$col) $val
}


# ------------------------------------------------------------------
#  METHOD:  toggle_enabled - called when enable is toggled
# ------------------------------------------------------------------
body MemWin::toggle_enabled {} {
  global _mem

  if {$Running} { return }
  if {$_mem($this,enabled)} {
    update_address
    set bg white
    set state normal
  } else {
    set bg gray
    set state disabled
  }
  $itk_interior.t config -background $bg -state $state
}

# ------------------------------------------------------------------
#  METHOD:  update - update widget after every PC change
# ------------------------------------------------------------------
body MemWin::update {} {
  global _mem
  if {$_mem($this,enabled)} {
    update_address
  }
}

# ------------------------------------------------------------------
#  METHOD:  idle - memory window is idle, so enable menus
# ------------------------------------------------------------------
body MemWin::idle {} {
  # Fencepost
  set Running 0

  # Cursor
  cursor {}

  # Enable menus
  if {$mbar} {
    for {set i 0} {$i <= [$itk_interior.m.addr index last]} {incr i} {
      if {[$itk_interior.m.addr type $i] != "separator"} {
	$itk_interior.m.addr entryconfigure $i -state normal
      }
    }
  }

  # Enable control
  $itk_interior.f.cntl configure -state normal
}


# ------------------------------------------------------------------
#  METHOD: busy - disable menus 'cause we're busy updating things
# ------------------------------------------------------------------
body MemWin::busy {} {
  # Fencepost
  set Running 1

  # cursor
  cursor watch

  # Disable menus
  if {$mbar} {
    for {set i 0} {$i <= [$itk_interior.m.addr index last]} {incr i} {
      if {[$itk_interior.m.addr type $i] != "separator"} {
	$itk_interior.m.addr entryconfigure $i -state disabled
      }
    }
  }

  # Disable control
  $itk_interior.f.cntl configure -state disabled
}

# ------------------------------------------------------------------
#  METHOD: newsize - calculate how many rows to display when the
#  window is resized.
# ------------------------------------------------------------------
body MemWin::newsize {height} {
  if {$dont_size || $Running} {
    return 
  }
  
  # only add rows if numbytes is zero
  if {$numbytes == 0} {
    ::update idletasks

    # make sure row height is set
    if {$rheight == ""} {
      set rheight [lindex [$itk_interior.t bbox 0,0] 3]
    }

    set theight [winfo height $itk_interior.t]
    set Numrows [expr {$theight / $rheight}]
    $itk_interior.t configure -rows $Numrows
    update_addr
  }
}

# ------------------------------------------------------------------
#  METHOD: update_address_cb - address entry widget callback
# ------------------------------------------------------------------
body MemWin::update_address_cb {} {
  set new_entry 1
  update_address [$itk_interior.f.cntl get]
}

# ------------------------------------------------------------------
#  METHOD: update_address - update address and data displayed
# ------------------------------------------------------------------
body MemWin::update_address { {ae ""} } {
  if {$ae == ""} {
    set addr_exp [string trimleft [$itk_interior.f.cntl get]]
  } else {
    set addr_exp $ae
  }

  set saved_addr $current_addr
  if {[string match {[a-zA-Z_&0-9\*]*} $addr_exp]} {
    # Looks like an expression
    set retVal [catch {gdb_eval "$addr_exp"} current_addr]
    if {$retVal || [string match "No symbol*" $current_addr] || \
	  [string match "Invalid *" $current_addr]} {
      BadExpr $current_addr
      return
    }
    if {[string match {\{*} $current_addr]} {
      set current_addr [lindex $current_addr 1]
      if {$current_addr == ""} {
	return
      }
    }
  } elseif {[string match {\$*} $addr_exp]} {
    # Looks like a local variable
    catch {gdb_eval "$addr_exp"} current_addr
    if {$current_addr == "No registers.\n"} { 
      # we asked for a register value and debugging hasn't started yet
      return 
    }
    if {$current_addr == "void"} {
      BadExpr "No Local Variable Named \"$addr_ex\""
      return
    }
  } else {
    # something really strange, like "0.1" or ""
    BadExpr "Can't Evaluate \"$addr_expr\""
    return
  }

  # Check for spaces
  set index [string first \  $current_addr]
  if {$index != -1} {
    incr index -1
    set current_addr [string range $current_addr 0 $index]
  }
  
  # set table background
  $itk_interior.t config -bg white -state normal
  catch {update_addr}
}

# ------------------------------------------------------------------
#  METHOD:  BadExpr - handle a bad expression
# ------------------------------------------------------------------
body MemWin::BadExpr {errTxt} {
  if {$new_entry} {
    tk_messageBox -type ok -icon error -message $errTxt
    set new_entry 0
  }
  # set table background to gray
  $itk_interior.t config -bg gray -state disabled
  set current_addr $saved_addr
  set saved_addr ""
}

# ------------------------------------------------------------------
#  METHOD:  incr_addr - callback from control widget to increment
#  the current address.
# ------------------------------------------------------------------
body MemWin::incr_addr {num} {

  if {$current_addr == ""} {
    return
  }
  set old_addr $current_addr

  # You have to be careful with address calculations here, since the memory
  # space of the target may be bigger than a long, which will cause Tcl to
  # overflow.  Let gdb do the calculations instead.

  set current_addr [gdb_cmd "printf \"%u\", $current_addr + $num * $bytes_per_row"]

  # A memory address less than zero is probably not a good thing...
  #

  if {($num < 0 && [gdb_eval "$current_addr > $old_addr"]) \
      ||($num > 0 && [gdb_eval "$current_addr < $old_addr"]) } {
    bell
    set current_addr $old_addr
    return
  }
  $itk_interior.t config -background white -state normal
  update_addr
  $itk_interior.f.cntl clear
  $itk_interior.f.cntl insert 0 [format "0x%x" $current_addr]
}


# ------------------------------------------------------------------
#  METHOD:  update_addr - read in data starting at $current_addr
#  This is just a helper function for update_address.
# ------------------------------------------------------------------
body MemWin::update_addr {} {
  global _mem ${this}_memval

  gdbtk_busy
  set addr $current_addr

  set row 0

  if {$numbytes == 0} {
    set nb [expr {$Numrows * $bytes_per_row}]
  } else {
    set nb $numbytes
  }
  set nextval 0
  set num [expr {$bytes_per_row / $size}]
  if {$ascii} {
    set asc $ascii_char
  } else {
    set asc ""
  }

  set retVal [catch {gdb_get_mem $addr $format \
		       $size $nb $bytes_per_row $asc} vals]
 
  if {$retVal || [llength $vals] == 0}  {
    # FIXME gdb_get_mem does not always return an error when addr is invalid.
    BadExpr "Couldn't get memory at address: \"$addr\""
    gdbtk_idle 
    debug "gdb_get_mem returned return code: $retVal and value: \"$vals\""
    return    
  }

  set mlen 0
  for {set n 0} {$n < $nb} {incr n $bytes_per_row} {
    set x [format "0x%x" $addr]
    if {[string length $x] > $mlen} {
      set mlen [string length $x]
    }
    set ${this}_memval($row,-1) $x
    for { set col 0 } { $col < $num } { incr col } {
      set x [lindex $vals $nextval]
      if {[string length $x] > $maxlen} {set maxlen [string length $x]}
      set ${this}_memval($row,$col) $x
      incr nextval
    }
    if {$ascii} {
      set x [lindex $vals $nextval]
      if {[string length $x] > $maxalen} {set maxalen [string length $x]}
      set ${this}_memval($row,$col) $x
      incr nextval
    }
    incr addr $bytes_per_row
    incr row
  }
  # set default column width to the max in the data columns
  $itk_interior.t configure -colwidth [expr {$maxlen + 1}]
  # set border column width
  $itk_interior.t width -1 [expr {$mlen + 1}]
  if {$ascii} {
    # set ascii column width
    $itk_interior.t width $Numcols [expr {$maxalen + 1}]
  }

  gdbtk_idle
}

# ------------------------------------------------------------------
#  METHOD:  hidemb - hide the menubar.  NOT CURRENTLY USED
# ------------------------------------------------------------------
body MemWin::hidemb {} {
  set mbar 0
  reconfig
}

# ------------------------------------------------------------------
#  METHOD:  reconfig - used when preferences change
# ------------------------------------------------------------------
body MemWin::reconfig {} {
  debug
  set addr_exp [string trimright [string trimleft $addr_exp]]
  set wh [winfo height $top]
  
  if [winfo exists $itk_interior.m] { destroy $itk_interior.m }
  if [winfo exists $itk_interior.cb] { destroy $itk_interior.cb }
  if [winfo exists $itk_interior.f.upd] { destroy $itk_interior.f.upd }
  if [winfo exists $itk_interior.sy] { destroy $itk_interior.sy }  
  destroy $itk_interior.f.cntl $itk_interior.f $itk_interior.t $itk_interior.sx 
  
  set dont_size 1

  # If the fonts change, then you will need to recompute the 
  # row height.  Ditto for switch from fixed number of rows to
  # depends on size.

  set rheight ""

  build_win
  set dont_size 0
  ::update
  
  if {$numbytes == 0} {
    newsize $wh
  }
}

# ------------------------------------------------------------------
#  METHOD:  do_popup - Display popup menu
# ------------------------------------------------------------------
body MemWin::do_popup {X Y} {
  if {$Running} { return }
  $itk_interior.t.menu delete 0 end
  $itk_interior.t.menu add check -label "Auto Update" -variable _mem($this,enabled) \
    -underline 0 -command "$this toggle_enabled"
  $itk_interior.t.menu add command -label "Update Now" -underline 0 \
    -command "$this update_address"
  $itk_interior.t.menu add command -label "Go To [$itk_interior.t curvalue]" -underline 0 \
    -command "$this goto [$itk_interior.t curvalue]"
  $itk_interior.t.menu add command -label "Open New Window at [$itk_interior.t curvalue]" -underline 0 \
    -command [list ManagedWin::open -force MemWin -addr_exp [$itk_interior.t curvalue]]
  $itk_interior.t.menu add separator
  $itk_interior.t.menu add command -label "Preferences..." -underline 0 \
    -command "$this create_prefs"
  tk_popup $itk_interior.t.menu $X $Y 
}

# ------------------------------------------------------------------
#  METHOD:  goto - change the address of the current memory window
# ------------------------------------------------------------------
body MemWin::goto { addr } {
  set current_addr $addr
  $itk_interior.f.cntl delete 0 end
  $itk_interior.f.cntl insert end $addr
}

# ------------------------------------------------------------------
#  METHOD:  init_addr_exp - initialize address expression
#  On startup, if the public variable "addr_exp" was not set,
#  then set it to the start of ".data" if found, otherwise "$pc"
# ------------------------------------------------------------------
body MemWin::init_addr_exp {} {
  if {$addr_exp == ""} {
    set err [catch {gdb_cmd "info file"} result]
    if {!$err} {
      foreach line [split [string trim $result] \n] { 
	if {[scan $line {%x - %x is %s} start stop section] == 3} {
	  if {$section == ".data"} {
	    set addr_exp [format "%#08x" $start]
	    break
	  }
	}
      }
    }
    if {$addr_exp == ""} {
      set addr_exp \$pc
    }
  }
}

# ------------------------------------------------------------------
#  METHOD:  cursor - set the cursor
# ------------------------------------------------------------------
body MemWin::cursor {glyph} {
  # Set cursor for all labels
  # for {set i 0} {$i < $bytes_per_row} {incr i $size} {
  #   $itk_interior.t.h.$i configure -cursor $glyph
  # }
  $top configure -cursor $glyph
}

# memMoveCell --
#
# Moves the location cursor (active element) by the specified number
# of cells and changes the selection if we're in browse or extended
# selection mode.
#
# Don't allow movement into the ASCII column.
#
# Arguments:
# w - The table widget.
# x - +1 to move down one cell, -1 to move up one cell.
# y - +1 to move right one cell, -1 to move left one cell.

body MemWin::memMoveCell {w x y} {
  if {[catch {$w index active row} r]} return
  set c [$w index active col]
  if {$ascii && ($c == $Numcols)} {
    # we're in the ASCII column so behave differently
    if {$y == 1} {set x 1}
    if {$y == -1} {set x -1}
    incr r $x
  } else {
    incr r $x
    incr c $y
    if { $c < 0 } {
      if {$r == 0} {
	set c 0
      } else {
	set c [expr {$Numcols - 1}]
	incr r -1
      }
    } elseif { $c >= $Numcols } {
      if {$r >= [expr {$Numrows - 1}]} {
	set c [expr {$Numcols - 1}]
      } else {
	set c 0
	incr r
      }
    }
  }
  if { $r < 0 } { set r 0 }
  $w activate $r,$c
  $w see active
}