trace.tcl

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

    if {${Application:visualType} == "color"} {
	set eom [lindex [split $som .] 0].end
	$textw tag add mrk${mark} $som $eom
	$textw tag configure mrk${mark} -background $color
    }
    $textw configure -state disabled
    $textw see end
}

proc MvmTracer:output {context name msg attribute} {

    global Monitor:traceLogSize $context.info

    set tracebuf [set $context.info(tracebuffer)]
    if {$tracebuf == {}} {
	# tracer is not displayed -- discard traces
	return
    }
    set textw [$tracebuf subwidget text]

    if {${Monitor:traceLogSize} != 0} {
	# enforce log size limitation

	global MvmTracer:lineCount

	if {${Monitor:traceLogSize} <= ${MvmTracer:lineCount}} {
	    $textw configure -state normal
	    $textw delete 1.0 1.0+1line
	} {
	    # assume that an output is always done for a single line --
	    # this may be false! FIXME
	    incr MvmTracer:lineCount
	}
    }

    if {$attribute != {}} {
	# client has provided for an output attribute -- consider this
	# message as a mark. A color can be appended to the attribute
	# type, separated from it by a dash.

	foreach {type color} [split $attribute -] {
	    switch -- $type {
		callout {
		    if {$color == {}} {
			set color green
		    }
		    MvmTracer:mark $context $color $msg
		    return
		}
		alert {
		    if {$color == {}} {
			set color red
		    }
		    MvmTracer:mark $context $color $msg
		    return
		}
		highlight {
		    if {$color == {}} {
			set color yellow
		    }
		    MvmTracer:mark $context $color $msg
		    return
		}
	    }
	}
    }

    $textw configure -state normal
    $textw insert end $msg
    $textw configure -state disabled
    $textw see end
}

proc MvmTracer:saveLog {context} {

    global $context.info

    set w $context.savelog

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

    toplevel $w
    wm title $w "Save Trace Log"
    cascadeWindow $w $context
    
    set f [frame $w.f -relief sunken -bd 1]
    pack $f
    set $context.info(logfile) ""

    tixFileEntry $f.logfile -label "To file: " \
 	-variable $context.info(logfile) \
	-validatecmd "MvmTracer:valLogFileName" \
	-dialogtype tixFileSelectDialog \
 	-options {
 	    entry.width 25
 	    label.anchor e
	}
    pack $f.logfile -side top -anchor e -padx 10 -pady 10

    tixButtonBox $w.bbox -orientation horizontal -relief flat -bd 0
    $w.bbox add update -text Save \
 	-command "MvmTracer:saveLogOk $context"
    $w.bbox add cancel -text Cancel -command "destroy $w"
    pack $w.bbox -side bottom -fill x

    focus [$f.logfile subwidget entry]
}

proc MvmTracer:saveLogOk {context} {

    global $context.info

    set w $context.savelog
    $w.f.logfile update
    set filename [set $context.info(logfile)]

    if {$filename == ""} {
	tk_messageBox -parent $context \
	    -message "No log file selected" \
	    -type ok -icon error -title " "
	return
    }

    if {[file exists $filename] == 1} {
    	if {[tk_messageBox -parent $context \
		 -message "File already exists. Overwrite it?" \
		 -type yesnocancel -icon error -title " "] != "yes"} {
	    return
	}
    }

    if {[catch {open $filename w} fh]} {
	# File can't be written.
    	tk_messageBox -parent $context \
	    -message "Cannot write to file $filename" \
	    -type ok -icon error -title " "
	return
    }

    set textw [[set $context.info(tracebuffer)] subwidget text]
    puts -nonewline $fh [$textw get 1.0 end]
    close $fh
    destroy $w
}

proc MvmTracer:valLogFileName {path} {

    if {$path != ""} {
	if {[file isdirectory $path] == 1} {
	    return ""
	}
	if {[file extension $path] == {}} {
	    append path ".trk"
	}
    }

    return $path
}

proc MvmTracer:clearLog {context} {

    if {[tk_messageBox -parent $context \
	     -message "Are you sure? Please confirm." \
	     -type okcancel -icon error -title " "] != "ok"} {
	return
    }

    global $context.info MvmTracer:lineCount

    set $context.info(searchindex) @0,0
    set textw [[set $context.info(tracebuffer)] subwidget text]
    $textw configure -state normal
    $textw delete 1.0 end
    $textw configure -state disabled
    set MvmTracer:lineCount 0
}

proc MvmTracer:optionChanged {context {localopt {}}} {

    global $context.info

    if {$localopt != {}} {
	switch -- $localopt {
	    hideselectors {
		if {[set $context.info(hideselectors)] == 1} {
		    $context.panew forget p1
		} {
		    $context.panew manage p1 -before p2 -min 200 -expand 0.40
		}
	    }
	}
	return
    }

    set $context.info(changed) true
}

proc MvmTracer:processEvent {context name1 name2 op} {

    global $context.info

    set buttons [set $context.info(buttons)]

    while {[popEvent eventQueue:$context e] == "true"} {
	switch -- $e {

	    TracerInitEvent {
		global MvmTracer:simulationState

		set MvmTracer:simulationState \
		    [TkRequest $context GetSimulationState]

		switch -- ${MvmTracer:simulationState} {
		    released {
			# may not release/step simulation
			$buttons.release config -state disabled
			$buttons.step config -state disabled
			# may hold simulation
			$buttons.hold config -state normal
		    }
		    held {
			# may release/step simulation
			$buttons.release config -state normal
			$buttons.step config -state normal
			# may not hold simulation
			$buttons.hold config -state disabled
		    }
		    zombie {
			# may not release/step simulation
			$buttons.release config -state disabled
			$buttons.step config -state disabled
			# may not hold simulation
			$buttons.hold config -state disabled
			# cannot switch focuses
			[set $context.info(focuscombo)] config -state disabled
		    }
		}
		MvmTracer:restoreSettings $context
	    }

	    ThreadCreatedEvent -
	    ThreadDeletedEvent {
		MvmTracer:updateThreads $context false
	    }

	    DebuggeeReleasedEvent -
	    SimulationReleasedEvent {
		global MvmTracer:simulationState
		set MvmTracer:simulationState released
		# may not release/step simulation
		$buttons.release config -state disabled
		$buttons.step config -state disabled
		# may hold simulation
		$buttons.hold config -state normal
	    }

	    DebuggeeHeldEvent -
	    SimulationHeldEvent {
		global MvmTracer:simulationState
		if {${MvmTracer:simulationState} == "released"} {
		    # may release/step simulation
		    $buttons.release config -state normal
		    $buttons.step config -state normal
		    set MvmTracer:simulationState held
		}
		# may not hold simulation
		$buttons.hold config -state disabled
	    }

	    SimulationFinishedEvent {
		global MvmTracer:simulationState
		set MvmTracer:simulationState zombie
		# may not hold simulation
		$buttons.hold config -state disabled
		global $context.info
		# cannot switch focuses
		[set $context.info(focuscombo)] config -state disabled
	    }

	    ConfigurationChanged {
		# reload thread selector
		MvmTracer:updateThreads $context
 	    }

	    MonitorShutdownEvent {
		MvmTracer:saveSettings $context
	    }
	}
    }
}

proc MvmTracer:saveSettings {context} {

    global $context.info

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

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

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

	regexp -- "tracelist,(.*)" $s mvar iname
	set traces [lindex $entries [incr n]]
	lappend settings [list $iname $traces]
    }

    set options {}

    foreach opt {callouts errorbrk nofiltering hideselectors} {
	if {[set $context.info($opt)] == 1} {
	    lappend options $opt
	}
    }
    if {$options == {}} {
	set options {none}
    }

    set geometry [wm geometry $context]

    Project:setResource MonitorTraces [list $options $settings $geometry]
}

proc MvmTracer:restoreSettings {context} {

    global $context.info

    set setup [Project:getResource MonitorTraces]
    set options [lindex $setup 0]
    set settings [lindex $setup 1]
    set geometry [lindex $setup 2]

    # restore trace options
    foreach opt $options {
	set $context.info($opt) 1
    }

    # apply local options now
    if {[set $context.info(hideselectors)] == 1} {
	MvmTracer:optionChanged $context hideselectors
    }

    # restore trace settings
    foreach interface $settings {
	set tab [lindex $interface 0]
	set c [set $context.info(checklist,$tab)]
	foreach entry [lindex $interface 1] {
	    catch {
		$c setstatus $entry on
		MvmTracer:toggleTrace $context $c $tab $entry
	    }
	}
    }

    if {$geometry != {}} {
	wm geometry $context $geometry
    } {
	wm geometry $context 750x600
    }
}

proc MvmTracer:searchText {context textw} {

    global $context.info

    if {[catch {set sel [$textw get sel.first sel.last]}] == 0} {
	set pretyped $sel
    } {
	set pretyped {}
    }

    set w $context.rewin

    if {[winfo exists $w]} {
	wm deiconify $w
	raise $w
	set e [$w.f.re subwidget entry]
	if {$pretyped != {}} {
	    $e delete 0 end
	    $e insert end $pretyped
	}
	focus $e
	return
    }

    toplevel $w
    wm protocol $w WM_DELETE_WINDOW "wm withdraw $w"
    wm title $w "Search String"
    wm resizable $w 0 0
    cascadeWindow $w $context

    set f [frame $w.f -bd 1 -relief sunken]
    pack $f -side top -fill both -expand yes

    tixLabelEntry $f.re -label "Find:" \
	-options {
	    label.anchor w
	    entry.width 22
	}

    set e [$f.re subwidget entry]
    pack $f.re -pady 5 -anchor w -padx 5
    bind $e <Return> "MvmTracer:findString $context $textw"
    bind $e <Escape> "wm withdraw $w"
    $e insert end $pretyped

    set f2 [frame $f.opt -relief flat -bd 0]
    pack $f2 -fill both -expand yes

    set $context.info(searchwhence) -forward
    set $context.info(searchindex) @0,0

    radiobutton $f2.bck -text backward \
	-variable $context.info(searchwhence) \
	-relief flat -bd 2 -pady 0 -anchor w \
	-value -backward

    radiobutton $f2.fwd -text forward \
	-variable $context.info(searchwhence) \
	-relief flat -bd 2 -pady 0 -anchor w \
	-value -forward

    pack $f2.fwd $f2.bck -side right -padx 5

    set status [frame $w.status -height 20 -relief sunken -bd 1]
    pack $w.status -fill x -expand no
    label $w.status.msg
    pack $w.status.msg -side left

    tixButtonBox $w.bbox -orientation horizontal -relief flat -bd 0
    $w.bbox add search -text Search -command "MvmTracer:findString $context $textw"
    $w.bbox add clear -text Clear -command "$e delete 0 end"
    $w.bbox add dismiss -text Close -command "wm withdraw $w"
    pack $w.bbox -expand no -fill x

    focus $e
}

proc MvmTracer:findString {context textw} {

    global $context.info

    set w $context.rewin
    set e [$w.f.re subwidget entry]
    set whence [set $context.info(searchwhence)]
    set sow [set $context.info(searchindex)]
    set s [$e get]

    if {$s == {}} {
	return
    }

    if {[catch { set sow \
 		     [$textw search $whence -exact -count n -- $s $sow] }] == 0} {
	if {$sow != {}} {
	    set eow [lindex [split $sow .] 0].[expr [lindex [split $sow .] 1] + $n]
	    $textw tag remove sel 1.0 end
	    $textw tag add sel $sow $eow
	    $textw see $sow
	    if {$whence == "-forward"} {
		set $context.info(searchindex) $eow
	    } {
		set $context.info(searchindex) $sow
	    }
	    $w.status.msg config -text {}
	    return
	}
    }

    $w.status.msg config -text "\"[$e get]\" not found."
    bell
}

proc MvmTracer:withdraw {context} {

    if {[winfo exists $context.rewin]} {
	wm withdraw $context.rewin
    }

    wm withdraw $context
}

proc MvmTracer:selectAll {context} {

    global $context.info

    set nb [set $context.info(notebook)]
    set cpage [$nb raised]
    set tab [$nb pagecget $cpage -label]
    set c [set $context.info(checklist,$tab)]
    set callint [lindex [set $context.info(definition)] $cpage]
    set interface [lindex $callint 1]
    set fnum 0

    foreach group $interface {
	set services [lindex $group 1]
	set cnum 0
	foreach call $services {
	    set entry $fnum.$cnum
	    $c setstatus $entry on
	    MvmTracer:toggleTrace $context $c $tab $entry
	    incr cnum
	}
	incr fnum
    }
}

proc MvmTracer:selectNone {context} {

    global $context.info

    set nb [set $context.info(notebook)]
    set cpage [$nb raised]
    set tab [$nb pagecget $cpage -label]
    set c [set $context.info(checklist,$tab)]
    set callint [lindex [set $context.info(definition)] $cpage]
    set interface [lindex $callint 1]
    set fnum 0

    foreach group $interface {
	set services [lindex $group 1]
	set cnum 0
	foreach call $services {
	    set entry $fnum.$cnum
	    $c setstatus $entry off
	    MvmTracer:toggleTrace $context $c $tab $entry
	    incr cnum
	}
	incr fnum
    }
}