X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~yarrgweb/git?a=blobdiff_plain;f=yarrg%2Fwhere-vessels;h=66d8527a6a6d88784491efcb9d41487b599676c9;hb=c221fee571a483c7ff5a51703a228c254cb050f3;hp=32b70f36b990531ea2377fbc021ff239f9babe59;hpb=515910e46919673912ec15b00e060353d14ad1d5;p=ypp-sc-tools.db-test.git

diff --git a/yarrg/where-vessels b/yarrg/where-vessels
index 32b70f3..66d8527 100755
--- a/yarrg/where-vessels
+++ b/yarrg/where-vessels
@@ -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,21 +157,91 @@ 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 notes
+
+    set nmissing [llength $note_missings]
+    debug "display-note-infos $nmissing [array size notes]"
+
+    if {[llength $note_infos]} {
+	set tiny "[llength $note_infos] warnings"
+    } elseif {$nmissing && [array size notes]} {
+	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"
+	set last_island {}
+	foreach info [lsort $note_missings] {
+	    manyset $info island name vid
+	    if {[string compare $island $last_island]} {
+		append infodata "# $island:\n"
+		set last_island $island
+	    }
+	    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
+    set abbrev {}
+    switch -exact [errexpect-arrayget vi inPort] {
+	true		{ }
+	false		{ append abbrev ? }
+	default		{ errexpect-error "unexpected inPort" }
+    }
     switch -exact [errexpect-arrayget vi vesselClass] {
 	smsloop		{ set sz 00sl }
 	lgsloop		{ set sz 01ct }
@@ -186,7 +256,7 @@ proc vessel {vin} {
 	grandfrig	{ set sz 10gf }
 	default		{ errexpect-error "unknown class" }
     }
-    set abbrev $sz
+    append abbrev $sz
     switch -exact [errexpect-arrayget vi vesselSubclass] {
 	null		{ }
 	icy		{ append abbrev F }
@@ -199,26 +269,35 @@ proc vessel {vin} {
 	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
+    set vid [errexpect-arrayget vi vesselId]
+    upvar #0 notes($vid) note
+    set realname [errexpect-arrayget vi vesselName]
+    set island [errexpect-arrayget vi islandName]
+
+    set owner {}
+    set xabbrev {}
     if {[info exists note]} {
-	manyset $note owner xabbrev
-	if {![string compare $owner $pirate]} {
-	    append abbrev =
-	} else {
-	    append abbrev -
+	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 length $owner]} {
+	    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 $island $realname $vid]
     }
-    set kk "[errexpect-arrayget vi islandName] $abbrev"
+    lappend newnotes [list $vid $realname $owner $xabbrev]
+    
+    set kk "$island $abbrev"
     upvar #0 count($kk) k
     if {![info exists k]} { set k 0 }
     incr k
@@ -226,10 +305,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 +337,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 +452,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 +470,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 +491,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 +522,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 +536,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 +556,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 +564,15 @@ 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 emsg ei} {
+    global errorInfo
+    parser-control-failed-core $w $base \
+	black yellow 1 \
+	$emsg $emsg "Details and stack trace:" $ei
 }
 
-proc reparse {base varname fulldesc okshow noneshow set parse} {
+proc reparse {base varname old fulldesc okshow noneshow parse ok} {
     upvar #0 $varname var
-    set old $var
-    uplevel 1 $set
     manyset [errexpect-catch {
 	uplevel 1 $parse
 	if {[string length [string trim $var]]} {
@@ -535,33 +586,103 @@ proc reparse {base varname fulldesc okshow noneshow set parse} {
 	    $emsg $lno $ei $fulldesc $var
 	set var $old
 	uplevel 1 $parse
+    } else {
+	uplevel 1 $ok
     }
 }
 
+#---------- 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
+    global clipboard errorInfo
+    set old $clipboard
+
+    if {[catch {
+	set clipboard [clipboard get]
+    } emsg]} {
+	parser-control-failed-unexpected .ctrl.acquire acquire \
+	    $emsg "fetching clipboard:\n\n$errorInfo"
+	return
+    }
+
     reparse acquire \
-	clipboard "Clipboard contents:" { acquired ok } { no vessels } \
-	{ set clipboard [clipboard get] } \
-	{ parse-clipboard }
+	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 "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
-	    }
-	} \
-	{ parse-notes }
+    reparse notes \
+	notes_data $old "Vessel notes:" "loaded ok" { no notes } {
+	    parse-notes
+	    parse-clipboard
+	} {
+	    display-note-infos
+	}
     draw
 }
 
@@ -573,8 +694,7 @@ httpclientsetup where-vessels
 load-chart
 widgets-setup
 
-load-notes
-parse-notes
-parse-clipboard
+set notes_data {}
+after idle invoke_notes
 
 draw