From: Ian Jackson <ian@liberator.relativity.greenend.org.uk>
Date: Sat, 12 Dec 2009 21:12:02 +0000 (+0000)
Subject: Better clipboard parsing error reports
X-Git-Tag: 6.3.0~2
X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~yarrgweb/git?p=ypp-sc-tools.web-live.git;a=commitdiff_plain;h=231a72dea02e7c025689ea691c12e4f73d4ac420

Better clipboard parsing error reports
---

diff --git a/yarrg/where-vessels b/yarrg/where-vessels
index ecf1e06..061d5db 100755
--- a/yarrg/where-vessels
+++ b/yarrg/where-vessels
@@ -47,6 +47,41 @@ proc glset {n val} {
     set var $val
 }
 
+#---------- expecting certain errors ----------
+
+proc errexpect-setline {lno line} {
+    glset errexpect_lno $lno
+    glset errexpect_line $line
+}
+
+proc errexpect-error {m} {
+    global errexpect_line errexpect_lno
+    error $m "$errexpect_line\n" [list YARRG-ERREXPECT $errexpect_lno]
+}
+
+proc errexpect-arrayget {arrayvar key} {
+    upvar 1 $arrayvar av
+    debug "VARS [array names av]"
+    upvar 1 ${arrayvar}($key) v
+    if {[info exists v]} { return $v }
+    errexpect-error "undefined $key"
+}
+
+proc errexpect-catch {code} {
+    global errorInfo errorCode
+    set rc [catch {
+	uplevel 1 $code
+    } rv]
+    debug "ERREXPECT CATCH |$rc|$rv|$errorCode|$errorInfo|"
+    if {$rc==1 && ![string compare YARRG-ERREXPECT [lindex $errorCode 0]]} {
+	return [list 1 $rv [lindex $errorCode 1] $errorInfo]
+    } elseif {$rc==0} {
+	return [list 0 $rv]
+    } else {
+	return -code $rc -errorinfo $errorInfo -errorcode $errorCode $rv
+    }
+}
+
 #---------- argument parsing ----------
 
 proc nextarg {} {
@@ -130,57 +165,58 @@ proc load-notes {} {
 #---------- loading and parsing the clipboard (vessel locations) ----------
 
 proc vessel {vin} {
-	global pirate notes_used
-	upvar 1 $vin vi
-	switch -exact $vi(vesselClass) {
-		smsloop		{ set sz 00sl }
-		lgsloop		{ set sz 01ct }
-		dhow		{ set sz 02dh }
-		longship	{ set sz 03ls }
-		baghlah		{ set sz 04bg }
-		merchbrig	{ set sz 05mb }
-		warbrig		{ set sz 06wb }
-		xebec		{ set sz 07xe }
-		warfrig		{ set sz 08wf }
-		merchgal	{ set sz 09mg }
-		grandfrig	{ set sz 10gf }
-		default		{ error "$vi(vesselClass) ?" }
-	}
-	set abbrev $sz
-	switch -exact $vi(vesselSubclass) {
-		null		{ }
-		icy		{ append abbrev F }
-		default		{ error "$vi(vesselSubclass) ?" }
-	}
-	switch -exact $vi(isLocked)/$vi(isBattleReady) {
-		true/false	{ append abbrev 2- }
-		false/false	{ append abbrev 1+ }
-		false/true	{ append abbrev 0* }
-		default		{ error "$vi(isLocked)/$vi(isBattleReady) ?" }
-	}
-	switch -exact $vi(inPort) {
-		true		{ }
-		false		{ append abbrev ? }
-		default		{ error "$vi(inPort) ?" }
-	}
-	set nk $vi(vesselId).$vi(vesselName)
-	upvar #0 notes($nk) note
-	if {[info exists note]} {
-	    manyset $note owner xabbrev
-	    if {![string compare $owner $pirate]} {
-		append abbrev =
-	    } else {
-		append abbrev -
-	    }
-	    append abbrev $xabbrev
-	    set notes_used($nk) 1
+    global pirate notes_used
+    upvar 1 $vin vi
+    switch -exact [errexpect-arrayget vi vesselClass] {
+	smsloop		{ set sz 00sl }
+	lgsloop		{ set sz 01ct }
+	dhow		{ set sz 02dh }
+	longship	{ set sz 03ls }
+	baghlah		{ set sz 04bg }
+	merchbrig	{ set sz 05mb }
+	warbrig		{ set sz 06wb }
+	xebec		{ set sz 07xe }
+	warfrig		{ set sz 08wf }
+	merchgal	{ set sz 09mg }
+	grandfrig	{ set sz 10gf }
+	default		{ errexpect-error "unknown class" }
+    }
+    set abbrev $sz
+    switch -exact [errexpect-arrayget vi vesselSubclass] {
+	null		{ }
+	icy		{ append abbrev F }
+	default		{ errexpect-error "unknown subclass ?" }
+    }
+    switch -exact [errexpect-arrayget vi isLocked]/[ \
+                   errexpect-arrayget vi isBattleReady] {
+	true/false	{ append abbrev 2- }
+	false/false	{ append abbrev 1+ }
+	false/true	{ append abbrev 0* }
+	default		{ errexpect-error "unexpected isLocked/isBattleReady" }
+    }
+    switch -exact [errexpect-arrayget vi inPort] {
+	true		{ }
+	false		{ append abbrev ? }
+	default		{ errexpect-error "unexpected inPort" }
+    }
+    set nk [errexpect-arrayget vi vesselId].[errexpect-arrayget vi vesselName]
+    upvar #0 notes($nk) note
+    if {[info exists note]} {
+	manyset $note owner xabbrev
+	if {![string compare $owner $pirate]} {
+	    append abbrev =
 	} else {
-	    debug "UNKNOWN $nk"
+	    append abbrev -
 	}
-	set kk "$vi(islandName) $abbrev"
-	upvar #0 count($kk) k
-	if {![info exists k]} { set k 0 }
-	incr k
+	append abbrev $xabbrev
+	set notes_used($nk) 1
+    } else {
+	debug "UNKNOWN $nk"
+    }
+    set kk "[errexpect-arrayget vi islandName] $abbrev"
+    upvar #0 count($kk) k
+    if {![info exists k]} { set k 0 }
+    incr k
 }
 
 set clipboard {}
@@ -194,12 +230,17 @@ proc parse-clipboard {} {
     set manyitemre "^\\\[ $itemre ( (?: ,\\ $itemre)* ) \\]\$"
     debug $manyitemre
 
+    set lno 0
     foreach l [split $clipboard "\n"] {
+	incr lno
+	errexpect-setline $lno $l
 	if {![string length $l]} continue
 	catch { unset vi }
 	while 1 {
 		if {![regexp -expanded $manyitemre $l dummy \
-			thiskey thisval rhs]} { error "$l ?" }
+			thiskey thisval rhs]} {
+		    errexpect-error "badly formatted"
+		}
 		set vi($thiskey) $thisval
 		if {![string length $rhs]} break
 		regsub {^, } $rhs {} rhs
@@ -360,6 +401,43 @@ proc widgets-setup {} {
     pack .ctrl.acquire.resframe -side top -expand y -fill both
     pack .ctrl.acquire -side top
 
+    toplevel .err_acquire
+    wm withdraw .err_acquire
+    wm title .err_acquire "where-vessels clipboard parsing error"
+
+    label .err_acquire.title -text "Clipboard parsing error"
+    pack .err_acquire.title -side top
+
+    button .err_acquire.close -text Close -command {wm withdraw .err_acquire}
+    pack .err_acquire.close -side bottom
+
+    frame .err_acquire.emsg -bd 2 -relief groove
+    label .err_acquire.emsg.lab -text "Error:"
+    text .err_acquire.emsg.text -height 1
+    pack .err_acquire.emsg.text -side bottom
+    pack .err_acquire.emsg.lab -side left
+
+    pack .err_acquire.emsg -side top -pady 2
+
+    frame .err_acquire.text -bd 2 -relief groove
+    pack .err_acquire.text -side bottom -pady 2
+    
+    label .err_acquire.text.lab -text "Clipboard contents:"
+
+    text .err_acquire.text.text \
+	-xscrollcommand {.err_acquire.text.xscroll set} \
+	-yscrollcommand {.err_acquire.text.yscroll set}
+
+    scrollbar .err_acquire.text.xscroll -orient horizontal \
+	-command {.err_acquire.text.text xview}
+    scrollbar .err_acquire.text.yscroll -orient vertical \
+	-command {.err_acquire.text.text yview}
+
+    grid configure .err_acquire.text.lab -row 0 -column 0 -sticky w
+    grid configure .err_acquire.text.text -row 1 -column 0
+    grid configure .err_acquire.text.yscroll -sticky ns -row 1 -column 1
+    grid configure .err_acquire.text.xscroll -sticky ew -row 2 -column 0
+
     wm geometry . 1024x480
 }
 
@@ -382,21 +460,34 @@ proc acquire_showerror {} {
 proc acquire {} {
     global clipboard acqdeffont acqerr errorInfo
     set old $clipboard
-    if {[catch {
-	set clipboard [clipboard get]
+    set nclipboard [clipboard get]
+    manyset [errexpect-catch {
+	set clipboard $nclipboard
 	parse-clipboard
 	.ctrl.acquire.resframe.res configure \
 	    -background blue -disabledforeground black -font $acqdeffont \
 	    -state disabled -command {} \
 	    -text " acquired ok "
-    } emsg]} {
-	set acqerr "clipboard parsing failed: $emsg"
-	puts stderr $acqerr
-	append acqerr "\n$errorInfo"
-	regsub -all {.{18}} "error: [string trim $emsg]" "&\n" ewrap
+    }] failed emsg lno ei
+    if {$failed} {
+	set line [lindex [split $ei "\n"] 0]
+	puts stderr "clipboard parsing failed: line $lno: $emsg\n $line"
+	regsub -all {.{18}} "bad: [string trim $emsg]: \"$line\"" "&\n" ewrap
+
+	.err_acquire.emsg.text delete 0.0 end
+	.err_acquire.emsg.text insert end "at line $lno: $emsg"
+
+	.err_acquire.text.text delete 0.0 end
+	.err_acquire.text.text insert end $nclipboard
+
+	.err_acquire.text.text tag add error $lno.0 $lno.end
+	.err_acquire.text.text tag configure error \
+	    -background red -foreground white
+	.err_acquire.text.text see $lno.0	
+	
 	.ctrl.acquire.resframe.res configure \
 	    -background red -foreground white -font fixed \
-	    -state normal -command acquire_showerror \
+	    -state normal -command {wm deiconify .err_acquire} \
 	    -text $ewrap
 	set clipboard $old
 	parse-clipboard