| # Tracepoint actions dialog for Insight. |
| # Copyright (C) 1997, 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. |
| |
| |
| itcl::class ActionDlg { |
| inherit ManagedWin |
| |
| # ------------------------------------------------------------------ |
| # CONSTRUCTOR |
| # ------------------------------------------------------------------ |
| constructor {args} { |
| global _TStepCount _TOtherVariable |
| |
| eval itk_initialize $args |
| |
| set Registers [gdb_reginfo name] |
| if {$Line != ""} { |
| set Locals [gdb_get_locals "$File:$Line"] |
| set Args [gdb_get_args "$File:$Line"] |
| } else { |
| set Locals [gdb_get_locals "*$Address"] |
| set Args [gdb_get_args "*$Address"] |
| } |
| set Variables [concat $Locals $Args] |
| foreach a $Registers { |
| lappend Variables "\$$a" |
| } |
| |
| if {[llength $Args] > 0} { |
| lappend Variables "All Arguments" |
| } |
| if {[llength $Locals] > 0} { |
| lappend Variables "All Locals" |
| } |
| lappend Variables "All Registers" |
| lappend Variables "Collect Stack" |
| |
| build_win |
| |
| # Set a default return status, in case we are destroyed |
| set _TOtherVariable {} |
| |
| # Fill the listboxes with any default data |
| if {"$Data" != {}} { |
| change 1 $Data |
| } |
| } |
| |
| # ------------------------------------------------------------------ |
| # DESTRUCTOR - destroy window containing widget |
| # ------------------------------------------------------------------ |
| destructor { |
| |
| # Remove this window and all hooks |
| # grab release $this |
| |
| # Note that this is okay: the callback (TraceDlg::done, usually) will |
| # ignore stray "cancel" callbacks |
| eval $Callback cancel |
| } |
| |
| # ------------------------------------------------------------------ |
| # METHOD: build_win - build the Trace dialog box (cache this?) |
| # ------------------------------------------------------------------ |
| method build_win {} { |
| global _TStepCount _TOtherVariable |
| |
| set f $itk_interior |
| |
| # The two frames of this dialog |
| set bbox [frame $f.bbox]; # for holding OK,CANCEL buttons |
| set data [frame $f.data]; # for everything else |
| |
| # Setup the button box |
| button $bbox.ok -text OK -command "$this ok" |
| button $bbox.cancel -text CANCEL -command "$this cancel" |
| pack $bbox.ok $bbox.cancel -side left -padx 10 -expand yes |
| |
| # The "Data Collection" Frame |
| set top [frame $data.top] |
| set bot [frame $data.bot] |
| |
| set boxes [frame $top.boxes] |
| set cFrame [frame $boxes.cFrame] |
| set vFrame [frame $boxes.vFrame] |
| set bFrame [frame $boxes.bframe] |
| set oFrame [frame $top.uFrame] |
| pack $cFrame $bFrame $vFrame -side left -expand yes -padx 5 |
| |
| # While stepping |
| if {$WhileStepping} { |
| set step_frame [frame $top.stepf] |
| label $step_frame.whilelbl -text {While Stepping, Steps:} |
| set WhileSteppingEntry [entry $step_frame.steps \ |
| -textvariable _TStepCount \ |
| -width 5] |
| pack $step_frame.whilelbl $WhileSteppingEntry -side left |
| } |
| |
| # The Collect listbox |
| label $cFrame.lbl -text {Collect:} |
| set CollectLB [iwidgets::scrolledlistbox $cFrame.lb -hscrollmode dynamic \ |
| -vscrollmode dynamic \ |
| -selectioncommand [code $this toggle_button_state 0] \ |
| -dblclickcommand [code $this change 0] \ |
| -selectmode extended \ |
| -exportselection false] |
| [$CollectLB component listbox] configure -background gray92 |
| pack $cFrame.lbl $cFrame.lb -side top -expand yes -pady 2 |
| |
| # The Variables listbox |
| label $vFrame.lbl -text {Variables:} |
| set VariablesLB [iwidgets::scrolledlistbox $vFrame.lb -hscrollmode dynamic \ |
| -vscrollmode dynamic \ |
| -selectioncommand [code $this toggle_button_state 1] \ |
| -dblclickcommand [code $this change 1] \ |
| -selectmode extended \ |
| -exportselection false] |
| [$VariablesLB component listbox] configure -background gray92 |
| pack $vFrame.lbl $vFrame.lb -side top -expand yes -pady 2 |
| |
| # The button frame |
| set AddButton [button $bFrame.add -text {<<< Collect} \ |
| -command "$this change 1" -state disabled] |
| set RemoveButton [button $bFrame.del -text {Ignore >>>} \ |
| -command "$this change 0" -state disabled] |
| pack $bFrame.add $bFrame.del -side top -expand yes -pady 5 |
| |
| # The other frame (type-in) |
| label $oFrame.lbl -text {Other:} |
| set OtherEntry [entry $oFrame.ent -textvariable _TOtherVariable] |
| pack $oFrame.lbl $OtherEntry -side left |
| bind $OtherEntry <Return> "$this change_other" |
| |
| # Pack these frames |
| if {$WhileStepping} { |
| pack $step_frame -side top |
| } |
| |
| pack $boxes $oFrame -side top -padx 5 -pady 5 |
| pack $top $bot -side top |
| |
| # Fill the list boxes |
| fill_listboxes |
| |
| # Pack the main frames |
| # after idle |
| pack $f.data $bbox -side top -padx 4 -pady 2 \ |
| -expand yes -fill x |
| |
| # !!??? |
| if {$WhileStepping} { |
| $WhileSteppingEntry delete 0 end |
| $WhileSteppingEntry insert 0 $Steps |
| } |
| } |
| |
| method toggle_button_state {add} { |
| |
| # This is invoked whenever a <1> event is generated in |
| # the listbox... |
| if {$add} { |
| set a [$VariablesLB getcurselection] |
| if {"$a" != ""} { |
| $AddButton configure -state normal |
| $RemoveButton configure -state disabled |
| } |
| } else { |
| set a [$CollectLB getcurselection] |
| if {"$a" != ""} { |
| $AddButton configure -state disabled |
| $RemoveButton configure -state normal |
| } |
| } |
| } |
| |
| |
| # ------------------------------------------------------------------ |
| # METHOD: fill_listboxes - fills the two listboxes |
| # ------------------------------------------------------------------ |
| method fill_listboxes {{last {}}} { |
| |
| # Fill the Collect listbox with the variables being collected |
| if {[info exists Collect]} { |
| fill_collect $last |
| } |
| |
| fill_variables $last |
| } |
| |
| # ------------------------------------------------------------------ |
| # METHOD: change - change a selected variable |
| # ------------------------------------------------------------------ |
| method change {add {select {}}} { |
| if {"$select" == {}} { |
| set selections [get_selections $add] |
| set lb [lindex $selections 0] |
| set last [lindex $selections 1] |
| set selection [lindex $selections 2] |
| set noname 1 |
| } else { |
| # This usually (only) occurs when we open this dialog for editing |
| # some existing action. |
| set lb {} |
| set last {} |
| set noname 0 |
| set selection $select |
| } |
| |
| $RemoveButton configure -state disabled |
| $AddButton configure -state disabled |
| |
| # Remove all the selections from one list |
| # and add them to the other list |
| if {$add} { |
| set list1 $Variables |
| set list2 $Collect |
| } else { |
| set list1 $Collect |
| set list2 $Variables |
| } |
| |
| foreach a $selection { |
| if {$noname} { |
| set name [$lb get $a] |
| } else { |
| set name $a |
| } |
| |
| if {"$name" == "All Locals" || "$name" == {$loc}} { |
| set name "All Locals" |
| set lists [all_locals $add] |
| set list1 [lindex $lists 0] |
| set list2 [lindex $lists 1] |
| } elseif {"$name" == "All Registers" || "$name" == {$reg}} { |
| set name "All Registers" |
| set lists [all_regs $add] |
| set list1 [lindex $lists 0] |
| set list2 [lindex $lists 1] |
| } elseif {"$name" == "All Arguments" || "$name" == {$arg}} { |
| set name "All Arguments" |
| set lists [all_args $add] |
| set list1 [lindex $lists 0] |
| set list2 [lindex $lists 1] |
| } else { |
| set i [lsearch -exact $list1 $name] |
| set list1 [lreplace $list1 $i $i] |
| |
| # Check if this is something we want to keep on a list |
| if {[lsearch $Args $name] != -1 || [lsearch $Registers [string trim $name \$]] != -1 || [lsearch $Locals $name] != -1 || $add} { |
| lappend list2 $name |
| } |
| } |
| |
| if {$add} { |
| set Collect $list2 |
| set Variables $list1 |
| } else { |
| set Collect $list1 |
| set Variables $list2 |
| } |
| } |
| |
| # Update boxes (!! SLOW !!) |
| fill_collect $last |
| fill_variables $last |
| } |
| |
| # ------------------------------------------------------------------ |
| # METHOD: fill_collect - fill the collect box |
| # ------------------------------------------------------------------ |
| method fill_collect {{last {}}} { |
| |
| $CollectLB delete 0 end |
| set Collect [sort $Collect] |
| foreach a $Collect { |
| $CollectLB insert end $a |
| } |
| if {"$last" != ""} { |
| $CollectLB see $last |
| } |
| } |
| |
| # ------------------------------------------------------------------ |
| # METHOD: fill_variables - fill the variables box |
| # ------------------------------------------------------------------ |
| method fill_variables {{last {}}} { |
| |
| $VariablesLB delete 0 end |
| set Variables [sort $Variables] |
| foreach a $Variables { |
| $VariablesLB insert end $a |
| } |
| |
| if {"$last" != ""} { |
| $VariablesLB see $last |
| } |
| } |
| |
| # ------------------------------------------------------------------ |
| # METHOD: sort - sort a list of variables, placing regs and |
| # special identifiers (like "All Locals") at end |
| # ------------------------------------------------------------------ |
| method sort {list} { |
| |
| set special_names { |
| "All Arguments" args \ |
| "All Locals" locs \ |
| "All Registers" regs \ |
| "Collect Stack" stack |
| } |
| |
| foreach {name var} $special_names { |
| set i [lsearch $list $name] |
| if {$i != -1} { |
| set $var 1 |
| set list [lreplace $list $i $i] |
| } else { |
| set $var 0 |
| } |
| } |
| |
| # Extract all the locals, regs, args, globals |
| set types_list {Args Locals Registers } |
| foreach type $types_list { |
| set used_$type {} |
| |
| foreach a [set $type] { |
| set i [lsearch $list $a] |
| if {$i != -1} { |
| lappend used_$type $a |
| set list [lreplace $list $i $i] |
| } |
| } |
| set used_$type [lsort [set used_$type]] |
| } |
| |
| set globals [lsort $list] |
| |
| # Sort the remaining list in order: args, locals, globals, regs |
| set list [concat $used_Args $used_Locals $globals $used_Registers] |
| |
| set list2 {} |
| |
| foreach {name var} $special_names { |
| if {[set $var]} { |
| lappend list2 $name |
| } |
| } |
| |
| set list [concat $list2 $list] |
| return $list |
| } |
| |
| # ------------------------------------------------------------------ |
| # METHOD: all_args - add/remove all args |
| # ------------------------------------------------------------------ |
| method all_args {add} { |
| |
| if {$add} { |
| set list1 $Variables |
| set list2 $Collect |
| } else { |
| set list1 $Collect |
| set list2 $Variables |
| } |
| |
| # foreach var $Args { |
| # set i [lsearch $list1 $var] |
| # if {$i != -1} { |
| # set list1 [lreplace $list1 $i $i] |
| # lappend list2 $var |
| # } |
| # } |
| |
| lappend list2 "All Arguments" |
| set i [lsearch $list1 "All Arguments"] |
| if {$i != -1} { |
| set list1 [lreplace $list1 $i $i] |
| } |
| |
| return [list $list1 $list2] |
| } |
| |
| # ------------------------------------------------------------------ |
| # METHOD: all_locals - add/remove all locals |
| # ------------------------------------------------------------------ |
| method all_locals {add} { |
| |
| if {$add} { |
| set list1 $Variables |
| set list2 $Collect |
| } else { |
| set list1 $Collect |
| set list2 $Variables |
| } |
| |
| # foreach var $Locals { |
| # set i [lsearch $list1 $var] |
| # if {$i != -1} { |
| # set list1 [lreplace $list1 $i $i] |
| # lappend list2 $var |
| # } |
| # } |
| |
| lappend list2 "All Locals" |
| set i [lsearch $list1 "All Locals"] |
| if {$i != -1} { |
| set list1 [lreplace $list1 $i $i] |
| } |
| |
| return [list $list1 $list2] |
| } |
| |
| # ------------------------------------------------------------------ |
| # METHOD: all_regs - add/remove all registers |
| # ------------------------------------------------------------------ |
| method all_regs {add} { |
| |
| if {$add} { |
| set list1 $Variables |
| set list2 $Collect |
| } else { |
| set list1 $Collect |
| set list2 $Variables |
| } |
| |
| # foreach var $Registers { |
| # set i [lsearch $list1 "\$$var"] |
| # if {$i != -1} { |
| # set list1 [lreplace $list1 $i $i] |
| # lappend list2 "\$$var" |
| # } |
| # } |
| |
| lappend list2 "All Registers" |
| set i [lsearch $list1 "All Registers"] |
| if {$i != -1} { |
| set list1 [lreplace $list1 $i $i] |
| } |
| |
| return [list $list1 $list2] |
| } |
| |
| # ------------------------------------------------------------------ |
| # METHOD: change_other - add/remove a user defined type |
| # ------------------------------------------------------------------ |
| method change_other {} { |
| set other [$OtherEntry get] |
| |
| if {"$other" != ""} { |
| set added 0 |
| |
| # Check if this is a local/register/arg |
| set i [lsearch $Locals "$other"] |
| if {$i != -1} { |
| set i [lsearch $Collect "$other"] |
| set added 1 |
| if {$i != -1} { |
| # It's a local on the collection list |
| debug "local on collection list" |
| set add 0 |
| set list1 [lreplace $Collect $i $i] |
| set list2 [concat $Variables "$other"] |
| } else { |
| # It's a local on the variables list |
| debug "local on variable list" |
| set add 1 |
| set i [lsearch $Variables "$other"] |
| set list1 [lreplace $Variables $i $i] |
| set list2 [concat $Collect "$other"] |
| } |
| } |
| |
| set i [lsearch $Registers [string trim "$other" \$]] |
| if {$i != -1} { |
| set i [lsearch $Collect "$other"] |
| set added 1 |
| if {$i != -1} { |
| # It's a register on the collection list |
| debug "register on collection list" |
| set add 0 |
| set list1 [lreplace $Collect $i $i] |
| set list2 [concat $Variables "$other"] |
| } else { |
| # It's a register on the variables list |
| debug "register on variable list" |
| set add 1 |
| set i [lsearch $Variables "$other"] |
| set list1 [lreplace $Variables $i $i] |
| set list2 [concat $Collect "$other"] |
| } |
| } |
| |
| set i [lsearch $Args $other] |
| if {$i != -1} { |
| set i [lsearch $Collect "$other"] |
| set added 1 |
| if {$i != -1} { |
| # It's an arg on the collection list |
| debug "arg on collection list" |
| set add 0 |
| set list1 [lreplace $Collect $i $i] |
| set list2 [concat $Variables "$other"] |
| } else { |
| # It's an arg on the variables list |
| debug "arg on variable list" |
| set add 1 |
| set i [lsearch $Variables "$other"] |
| set list1 [lreplace $Variables $i $i] |
| set list2 [concat $Collect "$other"] |
| } |
| } |
| |
| # Check for special tags |
| if {!$added} { |
| if {"[string tolower $other]" == "all locals"} { |
| set i [lsearch $Variables "All Locals"] |
| if {$i != -1} { |
| # It's "All Locals" on the variables list |
| set add 1 |
| set lists [all_locals 1] |
| set list1 [lindex $lists 0] |
| set list2 [lindex $lists 1] |
| } else { |
| # It's "All Locals" on the Collect list |
| set add 0 |
| set lists [all_locals 0] |
| set list1 [lindex $lists 0] |
| set list2 [lindex $lists 1] |
| } |
| } elseif {"[string tolower $other]" == "all registers"} { |
| set i [lsearch $Variables "All Registers"] |
| if {$i != -1} { |
| # It's "All Registers" on the Variables list |
| set add 1 |
| set lists [all_regs 1] |
| set list1 [lindex $lists 0] |
| set list2 [lindex $lists 1] |
| } else { |
| set add 0 |
| set lists [all_regs 0] |
| set list1 [lindex $lists 0] |
| set list2 [lindex $lists 1] |
| } |
| } elseif {"[string tolower $other]" == "all arguments"} { |
| set i [lsearch $Variables "All Arguments"] |
| if {$i != -1} { |
| # It's "All Arguments" on the Variables list |
| set add 1 |
| set lists [all_args 1] |
| set list1 [lindex $lists 0] |
| set list2 [lindex $lists 1] |
| } else { |
| set add 0 |
| set lists [all_args 0] |
| set list1 [lindex $lists 0] |
| set list2 [lindex $lists 1] |
| } |
| } elseif {"[string tolower $other]" == "collect stack"} { |
| set i [lsearch $Variables "Collect Stack"] |
| if {$i != -1} { |
| # It's "All Arguments" on the Variables list |
| set add 1 |
| set lists [all_args 1] |
| set list1 [lindex $lists 0] |
| set list2 [lindex $lists 1] |
| } else { |
| set add 0 |
| set lists [all_args 0] |
| set list1 [lindex $lists 0] |
| set list2 [lindex $lists 1] |
| } |
| } else { |
| # Check if this entry is on the Collect list |
| set i [lsearch $Collect $other] |
| if {$i != -1} { |
| # It's on the list -- remove it |
| set add 0 |
| set list1 [lreplace $Collect $i $i] |
| set list2 $Variables |
| } else { |
| # It's not on the list -- add it |
| |
| set other [string trim $other \ \r\t\n] |
| |
| # accept everything, send to gdb to validate |
| set ok 1 |
| |
| # memranges will be rejected right here |
| |
| if {[string range $other 0 1] == "\$("} { |
| tk_messageBox -type ok -icon error \ |
| -message "Expression syntax not supported" |
| set ok 0 |
| } |
| |
| # do all syntax checking later |
| if {$ok} { |
| #debug "Keeping \"$other\"" |
| # We MUST string out all spaces... |
| if {[regsub -all { } $other {} expression]} { |
| set other $expression |
| } |
| set add 1 |
| set list1 $Variables |
| set list2 [concat $Collect "$other"] |
| } else { |
| #debug "Discarding \"$other\"" |
| } |
| } |
| } |
| } |
| |
| # Clear the entry |
| $OtherEntry delete 0 end |
| |
| if {$add} { |
| set Variables $list1 |
| set Collect $list2 |
| } else { |
| set Variables $list2 |
| set Collect $list1 |
| } |
| fill_listboxes |
| } |
| } |
| |
| |
| # ------------------------------------------------------------------ |
| # METHOD: get_selections - get all the selected variables |
| # pass 0 to get the selections from the collect box |
| # Returns a list of: listbox in which the selections were |
| # obtained, last element selected on the list, and all the |
| # selected elements |
| # ------------------------------------------------------------------ |
| method get_selections {vars} { |
| |
| if {$vars} { |
| set widget $VariablesLB |
| } else { |
| set widget $CollectLB |
| } |
| |
| set elements [$widget curselection] |
| set list {} |
| set i 0 |
| foreach i $elements { |
| lappend list [$widget get $i] |
| } |
| |
| return [list $widget $i $elements] |
| } |
| |
| # ------------------------------------------------------------------ |
| # METHOD: cancel - cancel the dialog and do not set the trace |
| # ------------------------------------------------------------------ |
| method cancel {} { |
| ::delete object $this |
| } |
| |
| method remove_special {list items} { |
| |
| foreach item $items { |
| set i [lsearch $list $item] |
| if {$i != -1} { |
| set list [lreplace $list $i $i] |
| } else { |
| set i [lsearch $list \$$item] |
| if {$i != -1} { |
| set list [lreplace $list $i $i] |
| } |
| } |
| } |
| |
| return $list |
| } |
| |
| # ------------------------------------------------------------------ |
| # METHOD: ok - validate the tracepoint and install it |
| # ------------------------------------------------------------------ |
| method ok {} { |
| global _TStepCount |
| |
| # Add anything in the OtherEntry |
| change_other |
| |
| # Check that we are collecting data |
| if {[llength $Collect] == 0} { |
| # No data! |
| set msg "No data specified for the given action." |
| set answer [tk_messageBox -type ok -title "Tracepoint Error" \ |
| -icon error \ |
| -message $msg] |
| case $answer { |
| cancel { |
| cancel |
| } |
| ok { |
| return |
| } |
| } |
| } |
| |
| set i [lsearch $Collect "All Locals"] |
| if {$i != -1} { |
| set data [lreplace $Collect $i $i] |
| set data [concat $data {$loc}] |
| |
| # Remove all the locals from the list |
| set data [remove_special $data $Locals] |
| } else { |
| set data $Collect |
| } |
| |
| set i [lsearch $data "All Registers"] |
| if {$i != -1} { |
| set data [lreplace $data $i $i] |
| set data [concat $data {$reg}] |
| |
| # Remove all the locals from the list |
| set data [remove_special $data $Registers] |
| } |
| |
| set i [lsearch $data "All Arguments"] |
| if {$i != -1} { |
| set data [lreplace $data $i $i] |
| set data [concat $data {$arg}] |
| |
| # Remove all the locals from the list |
| set data [remove_special $data $Args] |
| } |
| |
| set i [lsearch $data "Collect Stack"] |
| if {$i != -1} { |
| set data [lreplace $data $i $i] |
| set data [concat $data [collect_stack]] |
| |
| } |
| |
| # Remove repeats |
| set d {} |
| foreach i $data { |
| if {![info exists check($i)]} { |
| set check($i) 1 |
| lappend d $i |
| } |
| } |
| |
| if {$WhileStepping} { |
| set steps $_TStepCount |
| } else { |
| set steps 0 |
| } |
| |
| if {"$Data" != {}} { |
| set command "modify" |
| } else { |
| set command "add" |
| } |
| |
| debug "DATA = $data" |
| eval $Callback $command $steps [list $data] |
| ::delete object $this |
| } |
| |
| |
| method collect_stack {} { |
| return $StackCollect |
| } |
| |
| method cmd {line} { |
| $line |
| } |
| |
| # PUBLIC DATA |
| public variable File |
| public variable Line {} |
| public variable WhileStepping 0 |
| public variable Number |
| public variable Callback |
| public variable Data {} |
| public variable Steps {} |
| public variable Address {} |
| |
| # PROTECTED DATA |
| protected variable WhileSteppingEntry |
| protected variable CollectLB |
| protected variable VariablesLB |
| protected variable Variables {} |
| protected variable Collect {} |
| protected variable Locals |
| protected variable Args |
| protected variable Registers |
| protected variable Others {} |
| protected variable AddButton |
| protected variable RemoveButton |
| protected variable OtherEntry |
| protected variable StackCollect {*(char*)$sp@64} |
| } |