chiark / gitweb /
where-vessels: http fixes, error handling fixes, for alpha release 6.3.0
authorIan Jackson <ian@liberator.relativity.greenend.org.uk>
Sun, 13 Dec 2009 00:17:34 +0000 (00:17 +0000)
committerIan Jackson <ian@liberator.relativity.greenend.org.uk>
Sun, 13 Dec 2009 00:17:34 +0000 (00:17 +0000)
yarrg/where-vessels

index 32b70f3..0376796 100755 (executable)
@@ -135,16 +135,16 @@ proc argdefaults {} {
 proc load-notes {} {
     global notes_loc notes_data
     if {[regexp {^\w+\:} $notes_loc]} {
-       vwait idletasks
+       update
        debug "FETCHING NOTES $notes_loc"
-       ::http::geturl $notes_loc
-       switch -glob [::http::status].[::http::ncode] {
+       set req [::http::geturl $notes_loc]
+       switch -glob [::http::status $req].[::http::ncode $req] {
            ok.200 { }
-           ok.* { error "retrieving vessel-notes $url: [::http::code]" }
-           * { error "retrieving vessel-notes $url: [::http::error]" }
+           ok.* { error "retrieving vessel-notes: [::http::code $req]" }
+           * { error "Retrieving vessel-notes: [::http::error $req]" }
        }
-       set newdata [::http::data]
-       ::http::cleanup
+       set newdata [::http::data $req]
+       ::http::cleanup $req
     } else {
        debug "READING NOTES $notes_loc"
        set vn [open $notes_loc]
@@ -157,20 +157,77 @@ proc load-notes {} {
 proc parse-notes {} {
     global notes_data notes
     catch { unset notes }
+
+    set lno 0
     foreach l [split $notes_data "\n"] {
-       regsub -all {\t+} $l "\t" l
-       manyset [split $l "\t"] vname vid owner note
-       set nk $vid.$vname
-       debug "SET NOTE $nk"
-       set notes($nk) [list $owner $note]
+       incr lno
+       errexpect-setline $lno $l
+       set l [string trim $l]
+       if {![string length $l]} continue
+       if {[regexp {^\#} $l]} continue
+       if {![regexp -expanded \
+                 {^ (\d+) (?: \s+([^=]*?) )? \s*
+                     (?: = \s* (\S+)
+                      (?: \s+ (\S+) )?)? $} \
+                 $l dummy vid vname owner note]} {
+             errexpect-error "badly formatted"
+       }
+       set vname [string trim $vname]
+       if {[info exists notes($vid)]} {
+           errexpect-error "duplicate vesselid $vid"
+       }
+       set notes($vid) [list $lno $vname $owner $note]
     }
 }
 
+proc note-info {lno vid name description} {
+    global note_infos
+    lappend note_infos [list $lno $vid $name $description]
+}
+
+proc display-note-infos {} {
+    global note_infos note_missings
+
+    set nmissing [llength $note_missings]
+    if {[llength $note_infos]} {
+       set tiny "[llength $note_infos] warnings"
+    } elseif {$nmissing} {
+       set tiny "$nmissing missing"
+    } else {
+       return
+    }
+
+    set infodata {}
+
+    foreach info $note_infos {
+       manyset $info lno vid name description
+       append infodata "vessel"
+       append infodata " $vid"
+       if {[string length $name]} { append infodata " $name" }
+       append infodata ": " $description "\n"
+    }
+
+    if {$nmissing} {
+       append infodata "$nmissing vessels not mentioned in notes:\n"
+       foreach info $note_missings {
+           manyset $info vid name
+           append infodata [format "%-9d %-29s =\n" $vid $name]
+       }
+    }
+
+    parser-control-failed-core .ctrl.notes notes \
+       white blue 0 \
+       $tiny \
+       "[llength $note_infos] warnings;\
+         $nmissing vessels missing" \
+       "Full description of warnings and missing vessels:" \
+       $infodata
+}
 
 #---------- loading and parsing the clipboard (vessel locations) ----------
 
 proc vessel {vin} {
-    global pirate notes_used
+    global pirate notes_used note_missings newnotes
     upvar 1 $vin vi
     switch -exact [errexpect-arrayget vi vesselClass] {
        smsloop         { set sz 00sl }
@@ -204,20 +261,31 @@ proc vessel {vin} {
        false           { append abbrev ? }
        default         { errexpect-error "unexpected inPort" }
     }
-    set nk [errexpect-arrayget vi vesselId].[errexpect-arrayget vi vesselName]
-    upvar #0 notes($nk) note
+    set vid [errexpect-arrayget vi vesselId]
+    upvar #0 notes($vid) note
+    set realname [errexpect-arrayget vi vesselName]
+
+    set owner {}
+    set xabbrev {}
     if {[info exists note]} {
-       manyset $note owner xabbrev
+       manyset $note lno notename owner xabbrev
+       if {[string compare -nocase $realname $notename]} {
+           note-info $lno $vid $realname \
+               "notes say name is $notename - perhaps renamed"
+       }
        if {![string compare $owner $pirate]} {
            append abbrev =
        } else {
            append abbrev -
        }
        append abbrev $xabbrev
-       set notes_used($nk) 1
+       set notes_used($vid) 1
+
     } else {
-       debug "UNKNOWN $nk"
+       lappend note_missings [list $vid $realname]
     }
+    lappend newnotes [list $vid $realname $owner $xabbrev]
+    
     set kk "[errexpect-arrayget vi islandName] $abbrev"
     upvar #0 count($kk) k
     if {![info exists k]} { set k 0 }
@@ -226,10 +294,14 @@ proc vessel {vin} {
 
 set clipboard {}
 proc parse-clipboard {} {
-    global clipboard count notes notes_used
+    global clipboard count notes notes_used newnotes
 
     catch { unset count }
     catch { unset notes_used }
+    glset note_infos {}
+    glset note_missings {}
+
+    set newnotes {}
     
     set itemre { (\w+) = ([^=]*) }
     set manyitemre "^\\\[ $itemre ( (?: ,\\ $itemre)* ) \\]\$"
@@ -254,9 +326,13 @@ proc parse-clipboard {} {
        vessel vi
     }
 
-    foreach nk [lsort [array names notes]] {
-       if {![info exists notes_used($nk)]} {
-           debug "IGNORED NOTE $nk"
+    if {[llength $newnotes]} {
+       foreach vid [lsort [array names notes]] {
+           if {![info exists notes_used($vid)]} {
+               manyset $notes($vid) lno notename
+               note-info $lno $vid $notename \
+                   "vessel in notes no longer found"
+           }
        }
     }
 }
@@ -365,47 +441,7 @@ proc draw {} {
 }
 
 
-#---------- user interface ----------
-
-proc widgets-setup {} {
-    global canvas debug acquire_deffont
-
-    frame .f -border 1 -relief groove
-    set canvas .f.c
-    canvas $canvas
-    pack $canvas -expand 1 -fill both
-    pack .f -expand 1 -fill both -side left
-
-    frame .ctrl
-    pack .ctrl -side right
-
-    debug "BBOX [$canvas bbox all]"
-
-    panner::canvas-scroll-bbox .f.c
-    panner::create .ctrl.pan .f.c 120 120 $debug
-
-    pack .ctrl.pan -side top -pady 10 -padx 5
-    frame .ctrl.zoom
-    pack .ctrl.zoom -side top
-
-    button .ctrl.zoom.out -text - -font {Courier 16} -command {zoom /2}
-    button .ctrl.zoom.in  -text + -font {Courier 16} -command {zoom *2}
-    pack .ctrl.zoom.out .ctrl.zoom.in -side left
-
-    parser-control-create .ctrl.acquire \
-       acquire Acquire \
-       "Clipboard parsing error" \
-       
-    pack .ctrl.acquire -side top -pady 2
-
-    parser-control-create .ctrl.notes \
-       notes "Reload notes" \
-       "Vessel notes loading error" \
-       
-    pack .ctrl.notes -side top -pady 2
-
-    wm geometry . 1024x480
-}
+#---------- parser error reporting ----------
 
 proc parser-control-create {w base invokebuttontext etl_title} {
     frame $w
@@ -423,7 +459,7 @@ proc parser-control-create {w base invokebuttontext etl_title} {
     set eb .err_$base
     toplevel $eb
     wm withdraw $eb
-    wm title $eb "$etl_title - where-vessels"
+    wm title $eb "where-vessels - $etl_title"
 
     label $eb.title -text $etl_title
     pack $eb.title -side top
@@ -444,7 +480,7 @@ proc parser-control-create {w base invokebuttontext etl_title} {
     
     label $eb.text.lab
 
-    text $eb.text.text \
+    text $eb.text.text -width 85 \
        -xscrollcommand [list $eb.text.xscroll set] \
        -yscrollcommand [list $eb.text.yscroll set]
     $eb.text.text tag configure error \
@@ -475,8 +511,10 @@ proc parser-control-ok {w base show} {
 proc parser-control-none {w base show} {
     parser-control-ok-core $w $base blue $show
 }
-proc parser-control-failed-core {w base tiny summary fulldesc fulldata} {
+proc parser-control-failed-core {w base foreground background smallfont
+                                tiny summary fulldesc fulldata} {
     debug "parser-control-failed-core $w $base $summary $fulldesc"
+    upvar #0 deffont_$base deffont
     set eb .err_$base
 
     $eb.emsg.text delete 0.0 end
@@ -487,9 +525,15 @@ proc parser-control-failed-core {w base tiny summary fulldesc fulldata} {
     $eb.text.text insert end $fulldata
 
     regsub -all {.{18}} $tiny "&\n" ewrap
-       
+
+    if {$smallfont} {
+       set font fixed
+    } else {
+       set font $deffont
+    }
+
     $w.resframe.res configure \
-       -background red -foreground white -font fixed \
+       -background $background -foreground $foreground -font $font \
        -state normal -command [list wm deiconify $eb] \
        -text $ewrap
 }
@@ -501,6 +545,7 @@ proc parser-control-failed-expected {w base emsg lno ei fulldesc newdata} {
     debug "parser-control-failed-expected: $w $base: $lno: $emsg\n $line"
 
     parser-control-failed-core $w $base \
+       white red 1 \
        "err: [string trim $emsg]: \"$line\"" \
        "at line $lno: $emsg" \
        $fulldesc $newdata
@@ -508,20 +553,14 @@ proc parser-control-failed-expected {w base emsg lno ei fulldesc newdata} {
     $eb.text.text tag add error $lno.0 $lno.end
     $eb.text.text see $lno.0   
 }
-
-proc zoom {extail} {
-    global scale canvas
-    set nscale [expr "\$scale $extail"]
-    debug "ZOOM $scale $nscale"
-    if {$nscale < 1 || $nscale > 200} return
-    set scale $nscale
-    draw
+proc parser-control-failed-unexpected {w base tiny summary fulldesc fulldata} {
+    parser-control-failed-core $w $base \
+       black yellow 1 \
+       $tiny $summary $fulldesc $fulldata
 }
 
-proc reparse {base varname fulldesc okshow noneshow set parse} {
+proc reparse {base varname old fulldesc okshow noneshow parse} {
     upvar #0 $varname var
-    set old $var
-    uplevel 1 $set
     manyset [errexpect-catch {
        uplevel 1 $parse
        if {[string length [string trim $var]]} {
@@ -538,30 +577,90 @@ proc reparse {base varname fulldesc okshow noneshow set parse} {
     }
 }
 
+#---------- main user interface ----------
+
+proc widgets-setup {} {
+    global canvas debug pirate ocean
+
+    frame .f -border 1 -relief groove
+    set canvas .f.c
+    canvas $canvas
+    pack $canvas -expand 1 -fill both
+    pack .f -expand 1 -fill both -side left
+
+    frame .ctrl
+    pack .ctrl -side right
+
+    debug "BBOX [$canvas bbox all]"
+
+    panner::canvas-scroll-bbox .f.c
+    panner::create .ctrl.pan .f.c 120 120 $debug
+
+    pack .ctrl.pan -side top -pady 10 -padx 5
+    frame .ctrl.zoom
+    pack .ctrl.zoom -side top
+
+    button .ctrl.zoom.out -text - -font {Courier 16} -command {zoom /2}
+    button .ctrl.zoom.in  -text + -font {Courier 16} -command {zoom *2}
+    pack .ctrl.zoom.out .ctrl.zoom.in -side left
+
+    parser-control-create .ctrl.acquire \
+       acquire Acquire \
+       "Clipboard parsing error" \
+       
+    pack .ctrl.acquire -side top -pady 2
+
+    parser-control-create .ctrl.notes \
+       notes "Reload notes" \
+       "Vessel notes loading report" \
+       
+    pack .ctrl.notes -side top -pady 2
+
+    wm geometry . 1024x480
+    wm title . "where-vessels - $pirate on the $ocean ocean"
+}
+
+proc zoom {extail} {
+    global scale canvas
+    set nscale [expr "\$scale $extail"]
+    debug "ZOOM $scale $nscale"
+    if {$nscale < 1 || $nscale > 200} return
+    set scale $nscale
+    draw
+}
+
 proc invoke_acquire {} {
     global clipboard
+    set old $clipboard
+    set clipboard [clipboard get]
+
     reparse acquire \
-       clipboard "Clipboard contents:" { acquired ok } { no vessels } \
-       { set clipboard [clipboard get] } \
+       clipboard $old "Clipboard contents:" { acquired ok } { no vessels } \
        { parse-clipboard }
+
+    display-note-infos
     draw
 }
 
 proc invoke_notes {} {
     global notes_data errorInfo notes_loc
+    set old $notes_data
+    
+    if {[catch {
+       load-notes
+    } emsg]} {
+       parser-control-failed-unexpected .ctrl.notes notes \
+           $emsg $emsg "Details and stack trace:" \
+           "loading $notes_loc:\n\n$errorInfo"
+       return
+    }
 
-    reparse notes notes_data "Vessel notes:" "notes reloaded" { no notes } \
-       {
-           if {[catch {
-               load-notes
-           } emsg]} {
-               parser-control-failed-core .ctrl.notes notes \
-                   $emsg $emsg "Details and stack trace:" \
-                   "loading $notes_loc:\n\n$errorInfo"
-               return
-           }
-       } \
+    reparse notes \
+       notes_data $old "Vessel notes:" "loaded ok" { no notes } \
        { parse-notes }
+
+    parse-clipboard
+    display-note-infos
     draw
 }
 
@@ -573,8 +672,7 @@ httpclientsetup where-vessels
 load-chart
 widgets-setup
 
-load-notes
-parse-notes
-parse-clipboard
+set notes_data {}
+after idle invoke_notes
 
 draw