From 0133a79929da1c6bcbd524b6e7d23decdfc80198 Mon Sep 17 00:00:00 2001 From: Ian Jackson Date: Sun, 13 Dec 2009 00:17:34 +0000 Subject: [PATCH] where-vessels: http fixes, error handling fixes, for alpha release --- yarrg/where-vessels | 288 +++++++++++++++++++++++++++++--------------- 1 file changed, 193 insertions(+), 95 deletions(-) diff --git a/yarrg/where-vessels b/yarrg/where-vessels index 32b70f3..0376796 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,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 -- 2.30.2