core-extra/gui/exceptions.tcl

array set g_exceptions {}
global execMode
if { $execMode == "interactive" } {
    set g_img_cel [image create photo -file $CORE_DATA_DIR/icons/tiny/cel.gif]
}
set g_cel_blink_state "off"

# receive an exception into the g_exceptions array from an Exception Message
proc receiveException { valuelist } {
    global g_exceptions EXCEPTION_LEVELS execMode
    set idx [expr {1 + [array size g_exceptions]}]
    array set g_exceptions [list $idx $valuelist]
    array set vals $valuelist
    # print exception message on stdout if in batch mode
    if { $execMode == "batch" } { 
	puts "\nFrom $vals(src): $vals(txt)"

	# Abort the session if a fatal exception is reported
	if { $vals(level) <= [lsearch -exact $EXCEPTION_LEVELS "FATAL" ] } {
	    global g_current_session g_abort_session
	    set g_abort_session 1
	}
    }
    # exceptions with level ERROR or FATAL will throw the CEL
    if { $vals(level) <= [lsearch -exact $EXCEPTION_LEVELS "ERROR"] } {
	throwCEL false
	if { $vals(level) <= [lsearch -exact $EXCEPTION_LEVELS "FATAL" ] } {
	    blinkCEL start
	}
    }
}

# turn on/off the CEL in the bottom right indicator area
proc throwCEL { clear } {
    global execMode
    if { $execMode != "interactive" } { return }
    global g_img_cel

    if { $clear } {
	.bottom.indicators configure -image "" -width 5
    } else {
	if { [.bottom.indicators cget -image] == "" } {
	    .bottom.indicators configure -image $g_img_cel -width 42
	}
    }
}

# blink the CEL on and off for fatal errors
proc blinkCEL { cmd } {
    global execMode
    if { $execMode != "interactive" } { return }
    # keep track of state so this can be called multiple times
    global g_cel_blink_state
    if { $cmd == "start" } {
	if { $g_cel_blink_state != "off" } { return } ;# already on
	set g_cel_blink_state "on"
    } elseif { $cmd == "stop" } {
	if { $g_cel_blink_state != "on" } { return } ;# already off
	set g_cel_blink_state "off"
    }

    if { $g_cel_blink_state == "off" } {
	throwCEL true
	return
    }

    if { [.bottom.indicators cget -image] == "" } {
	set clear false ;# CEL is off, turn it on
    } else {
	set clear true ;# CEL is on, turn it off
    }
    throwCEL $clear
    after 750 blinkCEL "blink"
}

# clear the g_exceptions array and the CEL
proc clearExceptions { tree txt } {
    global g_exceptions
    array unset g_exceptions
    array set g_exceptions {}
    if  { $tree != "" } {
	exceptionsPopulateTree $tree $txt
    }
}

# show the CEL dialog for viewing a list of exceptions
proc popupExceptions {} {
    global g_img_cel CORE_STATE_DIR
    set w .popupExceptions
    catch {destroy $w}
    toplevel $w
    wm transient $w .
    wm title $w "CEL"

    ttk::frame $w.top
    ttk::label $w.top.icon -image $g_img_cel
    ttk::label $w.top.lab -text "Check Emulation Light"
    pack $w.top.icon $w.top.lab -side left -padx 4
    pack $w.top -side top -padx 4 -pady 4

    ttk::frame $w.mid
    ttk::treeview $w.mid.tree -columns {time level node source} -show headings \
	-yscroll "$w.mid.vsb set" -xscroll "$w.mid.hsb set"
    ttk::scrollbar $w.mid.vsb -orient vertical -command "$w.mid.tree yview"
    ttk::scrollbar $w.mid.hsb -orient horizontal -command "$w.mid.tree xview"
    pack $w.mid -side top -fill both -expand true -padx 4 -pady 4
    grid $w.mid.tree $w.mid.vsb -in $w.mid -sticky nsew
    grid $w.mid.hsb -in $w.mid -sticky nsew
    grid column $w.mid 0 -weight 1
    grid row $w.mid 0 -weight 1

    ttk::frame $w.detail
    text $w.detail.txt -height 10 -yscrollcommand "$w.detail.vsb set"
    ttk::scrollbar $w.detail.vsb -orient vertical -command "$w.detail.txt yview"
    pack $w.detail -side top -fill both -expand true -padx 4 -pady 4
    grid $w.detail.txt $w.detail.vsb -in $w.detail -sticky nsew
    grid column $w.detail 0 -weight 1
    grid row $w.detail 0 -weight 1

    bind $w.mid.tree <<TreeviewSelect>> \
	"exceptionSelect $w.mid.tree $w.detail.txt"

    ttk::frame $w.btn
    set clearhicmd "drawNodeCircle {} {} {} {} excphi"
    set clearexcpcmd "clearExceptions $w.mid.tree $w.detail.txt"
    set closecmd "destroy $w; $clearhicmd"
    bind $w <Key-Escape> $closecmd
    ttk::button $w.btn.reset -text "Reset CEL" \
	-command "throwCEL true; blinkCEL stop; $clearhicmd; $clearexcpcmd"
    ttk::button $w.btn.log -text "View core-daemon log" \
	-command "popupFileView $CORE_STATE_DIR/log/core-daemon.log"
    ttk::button $w.btn.nlog -text "View node log" -state disabled
    ttk::button $w.btn.close -text "Close" -command $closecmd
    pack $w.btn.reset $w.btn.log $w.btn.nlog $w.btn.close -side left
    pack $w.btn -side top -padx 4 -pady 4

    # populate treeview
    set widths { 150 40 40 60 }; set i 0
    foreach col {time level node source} {
	$w.mid.tree heading $col -text $col
	set width [lindex $widths $i]; incr i
	$w.mid.tree column $col -width $width
    }
    exceptionsPopulateTree $w.mid.tree $w.detail.txt
}

# populate the given TreeView with a list of exceptions from g_exceptions
proc exceptionsPopulateTree { tree txt } {
    global g_exceptions

    set items [$tree children {}]
    $tree delete $items
    $txt delete 0.0 end

    foreach idx [lsort -integer [array names g_exceptions]] {
	array set vals $g_exceptions($idx)
	set level [exceptionLevelText $vals(level)]
	$tree insert {} end -id $idx \
		-values [list $vals(date) "$level ($vals(level))" \
			$vals(num) $vals(src)]
    }
}

# user has clicked on an exception from the TreeView, display the details
proc exceptionSelect { tree txt } {
    global g_exceptions g_current_session
    set idx [$tree selection]
    set btn .popupExceptions.btn.nlog

    $txt delete 0.0 end
    drawNodeCircle "" "" "" "" excphi

    if { ![info exists g_exceptions($idx)] } {
	puts "missing exception data"
	return
    }
    array set vals $g_exceptions($idx)
    $txt insert end "DATE: $vals(date)\n"
    set level [exceptionLevelText $vals(level)]
    $txt insert end "LEVEL: $level ($vals(level))\n"
    set node ""
    if { $vals(num) >= 0 } {
	set node "n$vals(num)"
	global $node
	if { [info exists $node] } {
	    drawNodeCircle $node 30 red excphi ""
	    set node [getNodeName $node]
	    $btn configure -command \
	    	"popupFileView /tmp/pycore.$g_current_session/$node.log"
	    $btn state !disabled
	} else {
	    $btn state disabled
	}
    } else {
	$btn state disabled
    }
    $txt insert end "NODE: $vals(num)\t($node)\n"
    $txt insert end "SESSION: $vals(sess)\n"
    $txt insert end "SOURCE: $vals(src)\n"
    $txt insert end "\n$vals(txt)\n\n"
    if { $vals(opaque) != "" } {
	$txt insert end "\nOPAQUE: $vals(opaque)\n\n"
    }
}

proc exceptionLevelText { level } {
    global EXCEPTION_LEVELS ;# from api.tcl
    if { $level < 0 || $level >= [llength $EXCEPTION_LEVELS] } {
	return "UNKNOWN"
    } else {
	return [lindex $EXCEPTION_LEVELS $level]
    }
}