trace.tcl

rtai-3.1-test3的源代码(Real-Time Application Interface )

#  This file is part of the XENOMAI project.
#
#  Copyright (C) 1997-2000 Realiant Systems.  All rights reserved.
#  Copyright (C) 2001,2002 Philippe Gerum <[e-mail]>.
# 
#  This program is free software; you can redistribute it and/or
#  modify it under the terms of the GNU General Public License 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(s): rpm
#  Contributor(s):
#
#  Adapted to XENOMAI by Philippe Gerum.

set MvmTracer:simulationState none
set MvmTracer:lineCount 0

proc MvmTracer:attach {context name private} {

    global $context.info MvmTracer:lineCount

    # register trace hook to get informed of major
    # context changes

    set $context.info(present) yes
    set $context.info(changed) true
    set $context.info(automark) 0
    set $context.info(usermark) 0
    set $context.info(options) {}
    set $context.info(threads,0) {}
    set $context.info(notebook) {}
    set $context.info(tracebuffer) {}
    set MvmTracer:lineCount 0

    return [list [list System $name] {}]
}

proc MvmTracer:detach {context} {

    global $context.info
    unset $context.info

    # tracer window may have not existed at all if
    # the tracer object has never been selected for
    # display. Then be conservative: catch exceptions
    # when cleaning up...

    catch {
	forgetEvent Application:event \
	    eventQueue:$context \
	    "MvmTracer:processEvent $context"
	destroy $context
    }
}

proc MvmTracer:show {context name} {

    if {[winfo exists $context]} {
	wm deiconify $context
	raise $context
	return
    }

    # trigger an information update about
    # which calls can be traced.
    TkRequest $context GetDashboardInfo all
}

proc MvmTracer:update {context name info} {

    global $context.info

# "update" is normally called only once during the simulation
# lifetime: when the trace object is first requested for display.

    if {[winfo exists $context]} {
	return
    }
    
    set $context.info(definition) $info

    toplevel $context
    wm title $context Traces
    cascadeWindow $context
    wm protocol $context WM_DELETE_WINDOW \
	"MvmTracer:withdraw $context"
    bind $context <Escape> "MvmTracer:withdraw $context"

    # make this window appear in the workspace's "Windows" menu for fast access
    TkRequest $context CacheWindowIn $context "Call traces"

    ## Menubar

    set mbar [frame $context.mbar -relief groove]
    pack $mbar -side top -fill x

    ### File

    menubutton $mbar.file -text File \
	-menu $mbar.file.m \
	-underline 0 \
	-takefocus 0
    menu $mbar.file.m -tearoff false

    $mbar.file.m add command -label "Save Log..." \
	-command "MvmTracer:saveLog $context" \
	-underline 0

    $mbar.file.m add command -label "Clear Log" \
	-command "MvmTracer:clearLog $context" \
	-underline 0

    $mbar.file.m add sep

    $mbar.file.m add command -label Close \
	-command "MvmTracer:withdraw $context" \
	-underline 0

    menubutton $mbar.select -text Selection \
	-menu $mbar.select.m \
	-underline 0 \
	-takefocus 0
    menu $mbar.select.m -tearoff false

    $mbar.select.m add command -label "Select All" \
	-command "MvmTracer:selectAll $context" \
	-underline 7

    $mbar.select.m add command -label "Select None" \
	-command "MvmTracer:selectNone $context" \
	-underline 7

    menubutton $mbar.options -text Options \
	-menu $mbar.options.m \
	-underline 0 \
	-takefocus 0
    menu $mbar.options.m -tearoff false

    $mbar.options.m add checkbutton -label " Trace callouts" \
	-indicatoron true \
	-variable $context.info(callouts) \
	-command "MvmTracer:optionChanged $context"

    $mbar.options.m add checkbutton -label " Break on error" \
	-indicatoron true \
	-variable $context.info(errorbrk) \
	-command "MvmTracer:optionChanged $context"

    $mbar.options.m add checkbutton -label " No filtering" \
	-indicatoron true \
	-variable $context.info(nofiltering) \
	-command "MvmTracer:optionChanged $context"

    $mbar.options.m add separator

    $mbar.options.m add checkbutton -label " Hide selectors" \
	-indicatoron true \
	-variable $context.info(hideselectors) \
	-command "MvmTracer:optionChanged $context hideselectors"

    ##

    pack $mbar.file $mbar.select $mbar.options -side left

    ## Paned Window

    tixPanedWindow $context.panew -orientation vertical -panerelief sunken
    pack $context.panew -side top -expand yes -fill both
    set p1 [$context.panew add p1 -min 200 -expand 0.40]
    set p2 [$context.panew add p2 -min 70 -max 70]
    set p3 [$context.panew add p3 -min 70 -expand 0.60]

    # o/s services notebook

    set $context.info(notebook) [tixNoteBook $p1.nb -ipadx 6 -ipady 6]
    pack $p1.nb -expand yes -fill both -padx 5 -pady 5 -side top
    set npage 0

    foreach callint $info {

	# add new tab for each call interface in notebook
	set tab [lindex $callint 0]
	set interface [lindex $callint 1]
	set $context.info(tracelist,$tab) {}

	$p1.nb add $npage -label $tab
	set w [$p1.nb subwidget $npage]
	incr npage

	tixCheckList $w.c -scrollbar auto -options {
	    hlist.indicator 1
	    hlist.indent 20
	}

	pack $w.c -expand yes -fill both -padx 4 -pady 4

	set $context.info(checklist,$tab) $w.c
	set hlist [$w.c subwidget hlist]
	set fnum 0

	foreach group $interface {
	    set family [lindex $group 0]
	    set services [lindex $group 1]
	    $hlist add $fnum -itemtype imagetext -text $family
	    $w.c setstatus $fnum on
	    set cnum 0
	    foreach call $services {
		$hlist add $fnum.$cnum -itemtype imagetext -text $call
		$w.c setstatus $fnum.$cnum off
		incr cnum
	    }
	    incr fnum
	}

	$w.c autosetmode
	$w.c config -browsecmd "MvmTracer:toggleTrace $context $w.c $tab"
	$w.c config -command "MvmTracer:toggleTrace $context $w.c $tab"

	set $context.info($w.c,disabled) [tixDisplayStyle imagetext -fg gray48 \
					      -refwindow [$w.c subwidget hlist]]
	set $context.info($w.c,normal) [tixDisplayStyle imagetext -fg black \
					    -refwindow [$w.c subwidget hlist]]
    }

    # button frames

    frame $p2.buttons -relief groove
    pack $p2.buttons -fill x -expand true
    set bf1 [frame $p2.buttons.f1]
    pack $bf1 -side left -padx 4
    set bf2 [frame $p2.buttons.f2]
    pack $bf2 -side right -padx 16
    set $context.info(buttons) $bf2

    ## focus combo

    set $context.info(focus) system
    set $context.info(focusname) {}

    tixComboBox $bf1.focus -label "Focus: " -dropdown true \
	-command "MvmTracer:setFocus $context" \
	-labelside top \
	-editable false \
	-variable $context.info(focusname) \
	-grab local \
	-history false \
	-options {
	    slistbox.scrollbar auto
	    listbox.height 12
	    listbox.width 25
	    label.width 7
	    label.anchor c
	}

    $bf1.focus subwidget entry configure -width 15
    $bf1.focus insert end system
    pack $bf1.focus -side right -padx 8
    set $context.info(focuscombo) $bf1.focus

     set img [fetchImage stepover]
     button $bf2.step -command "MvmTracer:step $context" -width 90
     set stepimg [makeCompoundImage Step $img]
     $bf2.step config -image $stepimg
     grid $bf2.step -column 0 -row 0

     set img [fetchImage cont]
     button $bf2.release -command "MvmTracer:release $context" -width 90
     set releaseimg [makeCompoundImage Cont $img]
     $bf2.release config -image $releaseimg
     grid $bf2.release -column 0 -row 1

     set img [fetchImage break]
     button $bf2.hold -command "MvmTracer:hold $context" -width 90
     set holdimg [makeCompoundImage Stop $img]
     $bf2.hold config -image $holdimg
     grid $bf2.hold -column 1 -row 0

     set img [fetchImage mark]
     button $bf2.mark -command "MvmTracer:mark $context yellow" -width 90
     set markimg [makeCompoundImage Mark $img]
     $bf2.mark config -image $markimg
     grid $bf2.mark -column 1 -row 1

    # trace buffer

    tixScrolledText $p3.traces -options {
	text.spacing1 0
	text.spacing3 0
	text.state disabled
	text.height 10
	text.wrap none
    }
    pack $p3.traces -expand yes -fill both
    set $context.info(tracebuffer) $p3.traces
    # force focus on the text widget upon Mouse-click 1. Having it disabled
    # seems to prevent the defaut binding to be applied. So help ourselves.
    set text [$p3.traces subwidget text]
    bind $text <1> "+ focus $text"

    set popup $p3.popup
    backmenu $popup -tearoff 0
    set menu [$popup subwidget menu]
    $menu add command -label "Search string" -command \
	"MvmTracer:searchText $context [$p3.traces subwidget text]"
    $popup bind [$p3.traces subwidget text]

    traceEvent Application:event \
	eventQueue:$context \
	"MvmTracer:processEvent $context"

    pushEvent Application:event TracerInitEvent
}

proc MvmTracer:toggleTrace {context chklist interface entry} {

    global $context.info

    set $context.info(changed) true

    if {[$chklist getstatus $entry] == "on"} {
	set state normal
    } else {
	set state disabled
    }

    if {[regexp -- "^\[^\.\]$" $entry] == 0} {
	# not a call family entry -- update the trace
	# list and return...

	set n [lsearch -exact [set $context.info(tracelist,$interface)] $entry]

	if {$state == "normal"} {
	    # trace enabled
	    if {$n == -1} {
		lappend $context.info(tracelist,$interface) $entry
	    }
	} {
	    # trace disabled
	    if {$n != -1} {
		set $context.info(tracelist,$interface) \
		    [lreplace [set $context.info(tracelist,$interface)] $n $n]
	    }
	}

	return
    }
    
    set hlist [$chklist subwidget hlist]

    foreach call [$hlist info children $entry] {
	$hlist entryconfig $call -state $state \
	    -style [set $context.info($chklist,$state)]
	set n [lsearch -exact [set $context.info(tracelist,$interface)] $call]
	if {$n != -1} {
	    if {$state == "disabled"} {
		# trace globally disabled
		set $context.info(tracelist,$interface) \
		    [lreplace [set $context.info(tracelist,$interface)] $n $n]
	    }
	} {
	    if {$state == "normal" && [$chklist getstatus $call] == "on"} {
		# trace globally re-enabled
		lappend $context.info(tracelist,$interface) $call
	    }
	}
    }
}

proc MvmTracer:updateThreads {context {reset true}} {

    global $context.info Project:settings

    set w [set $context.info(focuscombo)]

    # reset thread list
    set lbox [$w subwidget listbox]
    $lbox delete 0 end
    $lbox insert end system
    set threadlist [TkRequest $context GetThreads]
    set $context.info(threads) $threadlist

    foreach threaddef $threadlist {
	set name [lindex $threaddef 1]
	set body [lindex $threaddef 2]
	if {[set Project:settings(Options,threadQualify)] == 0 || $body == {}} {
	    set idstring $name
	} {
	    set idstring [format "%s(%s)" $body $name]
	}
	$w insert end $idstring
    }

    if {$reset == "true"} {
	# reset focus on system
	$w pick 0
    }
}

proc MvmTracer:setFocus {context focus} {

    global $context.info

    if {$focus == {}} {
	return
    }

    switch -- $focus {
	system {
	    set $context.info(focus) system
	}
	default {
	    set lbox [[set $context.info(focuscombo)] subwidget listbox]
	    set sel [$lbox curselection]
	    set threadlist [set $context.info(threads)]
	    set id [lindex [lindex $threadlist [expr $sel - 2]] 0]
	    set $context.info(focus) $id
	}
    }
}

proc MvmTracer:getConfiguration {context} {

    global $context.info

    set settings [array get $context.info tracelist,*]
    set n -1
    set conflist {}

    while {1} {
	set s [lindex $settings [incr n]]

	if {$s == {}} {
	    break
	}

	regexp -- "tracelist,(.*)" $s mvar iname

	set traces [lindex $settings [incr n]]
	set tracelist {}

	foreach call $traces {
	    set l [split $call .]
	    set grank [lindex $l 0]
	    set crank [lindex $l 1]

	    foreach interface [set $context.info(definition)] {
		if {[lindex $interface 0] == $iname} {
		    set callid $crank
		    foreach group [lindex $interface 1] {
			if {[incr grank -1] >= 0} {
			    incr callid [llength [lindex $group 1]]
			} {
			    lappend tracelist $callid
			    break
			}
		    }
		    break
		}
	    }
	}

	lappend conflist [list $iname $tracelist]
    }

    return $conflist
}

proc MvmTracer:setUpTraces {context} {

    global $context.info

    if {[set $context.info(changed)] == "false"} {
	# last setup remains valid -- no need to update
	# the traces at the simulator's level
	return
    }
    
    # "null" configurations must be sent too in order to
    # disable the previous settings at the simulator's level.
    set conflist [MvmTracer:getConfiguration $context]

    # build the trace option list
    set options {}
    foreach opt {callouts errorbrk nofiltering} {
	if {[set $context.info($opt)] == 1} {
	    lappend options $opt
	}
    }
    if {$options == {}} {
	set options {none}
    }

    TkRequest $context ConfigureDashboard "configure [list $options] $conflist"
    set $context.info(changed) false
}

proc MvmTracer:step {context} {

    global $context.info

    MvmTracer:setUpTraces $context
    set focus [set $context.info(focus)]
    TkRequest $context ConfigureDashboard [list step $focus]
    TkRequest $context ReleaseSimulation
}

proc MvmTracer:release {context} {

    global $context.info

    MvmTracer:setUpTraces $context
    set focus [set $context.info(focus)]
    TkRequest $context ConfigureDashboard [list release $focus]
    TkRequest $context ReleaseSimulation
}

proc MvmTracer:hold {context} {

    TkRequest $context HoldSimulation
}

proc MvmTracer:mark {context color {marker {}}} {

    global $context.info
    global Application:visualType

    set textw [[set $context.info(tracebuffer)] subwidget text]
    $textw configure -state normal
    set som [expr [$textw index end] - 1]
    if {$marker == {}} {
	set mark [incr $context.info(automark)]
	set marker [format "<<< %.3d >>>\n" $mark]
    } {
	set mark [incr $context.info(usermark)]
    }
    $textw insert end $marker