Better clipboard parsing error reports

diff --git a/yarrg/where-vessels b/yarrg/where-vessels
index ecf1e063156bbd3ddee66d3359da8a4ab5b6b1da..061d5db48f163837779ee0cf8fb6ba1c8f4d299b 100755 (executable)
--- 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