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"
#---------- loading and parsing the vessel notes ----------
proc load-notes {} {
- global notes_loc notes
- catch { unset notes }
+ global notes_loc notes_data
if {[regexp {^\w+\:} $notes_loc]} {
vwait idletasks
- debug "FETCHING NOTES"
+ debug "FETCHING NOTES $notes_loc"
::http::geturl $notes_loc
switch -glob [::http::status].[::http::ncode] {
ok.200 { }
ok.* { error "retrieving vessel-notes $url: [::http::code]" }
* { error "retrieving vessel-notes $url: [::http::error]" }
}
- set notes_data [::http::data]
+ set newdata [::http::data]
::http::cleanup
} else {
+ debug "READING NOTES $notes_loc"
set vn [open $notes_loc]
- set notes_data [read $vn]
+ set newdata [read $vn]
close $vn
}
+ set notes_data $newdata
+}
+
+proc parse-notes {} {
+ global notes_data notes
+ catch { unset notes }
foreach l [split $notes_data "\n"] {
regsub -all {\t+} $l "\t" l
manyset [split $l "\t"] vname vid owner note
#---------- user interface ----------
proc widgets-setup {} {
- global canvas debug acqdeffont
+ global canvas debug acquire_deffont
frame .f -border 1 -relief groove
set canvas .f.c
button .ctrl.zoom.in -text + -font {Courier 16} -command {zoom *2}
pack .ctrl.zoom.out .ctrl.zoom.in -side left
- frame .ctrl.acquire
- button .ctrl.acquire.do -text Acquire -command acquire
+ parser-control-create .ctrl.acquire \
+ acquire Acquire \
+ "Clipboard parsing error" \
+
+ pack .ctrl.acquire -side top -pady 2
- frame .ctrl.acquire.resframe -width 120 -height 32
- button .ctrl.acquire.resframe.res -text {} -anchor nw \
+ parser-control-create .ctrl.notes \
+ notes "Reload notes" \
+ "Vessel notes loading error" \
+
+ pack .ctrl.notes -side top -pady 2
+
+ wm geometry . 1024x480
+}
+
+proc parser-control-create {w base invokebuttontext etl_title} {
+ frame $w
+ button $w.do -text $invokebuttontext -command invoke_$base
+
+ frame $w.resframe -width 120 -height 32
+ button $w.resframe.res -text {} -anchor nw \
-padx 1 -pady 1 -borderwidth 0 -justify left
- glset acqdeffont [.ctrl.acquire.resframe.res cget -font]
- place .ctrl.acquire.resframe.res -relx 0.5 -y 0 -anchor n
- # -relheight 1.0 -relwidth 1.0
+ glset deffont_$base [$w.resframe.res cget -font]
+ place $w.resframe.res -relx 0.5 -y 0 -anchor n
- pack .ctrl.acquire.do -side top
- pack .ctrl.acquire.resframe -side top -expand y -fill both
- pack .ctrl.acquire -side top
+ pack $w.do -side top
+ pack $w.resframe -side top -expand y -fill both
- toplevel .err_acquire
- wm withdraw .err_acquire
- wm title .err_acquire "where-vessels clipboard parsing error"
+ set eb .err_$base
+ toplevel $eb
+ wm withdraw $eb
+ wm title $eb "$etl_title - where-vessels"
- label .err_acquire.title -text "Clipboard parsing error"
- pack .err_acquire.title -side top
+ label $eb.title -text $etl_title
+ pack $eb.title -side top
- button .err_acquire.close -text Close -command {wm withdraw .err_acquire}
- pack .err_acquire.close -side bottom
+ button $eb.close -text Close -command [list wm withdraw $eb]
+ pack $eb.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
+ frame $eb.emsg -bd 2 -relief groove
+ label $eb.emsg.lab -text "Error:"
+ text $eb.emsg.text -height 1
+ pack $eb.emsg.text -side bottom
+ pack $eb.emsg.lab -side left
- pack .err_acquire.emsg -side top -pady 2
+ pack $eb.emsg -side top -pady 2
- frame .err_acquire.text -bd 2 -relief groove
- pack .err_acquire.text -side bottom -pady 2
+ frame $eb.text -bd 2 -relief groove
+ pack $eb.text -side bottom -pady 2
- label .err_acquire.text.lab -text "Clipboard contents:"
+ label $eb.text.lab
+
+ text $eb.text.text \
+ -xscrollcommand [list $eb.text.xscroll set] \
+ -yscrollcommand [list $eb.text.yscroll set]
+ $eb.text.text tag configure error \
+ -background red -foreground white
+
+ scrollbar $eb.text.xscroll -orient horizontal \
+ -command [list $eb.text.text xview]
+ scrollbar $eb.text.yscroll -orient vertical \
+ -command [list $eb.text.text yview]
+
+ grid configure $eb.text.lab -row 0 -column 0 -sticky w
+ grid configure $eb.text.text -row 1 -column 0
+ grid configure $eb.text.yscroll -sticky ns -row 1 -column 1
+ grid configure $eb.text.xscroll -sticky ew -row 2 -column 0
+}
- text .err_acquire.text.text \
- -xscrollcommand {.err_acquire.text.xscroll set} \
- -yscrollcommand {.err_acquire.text.yscroll set}
+proc parser-control-ok-core {w base background show} {
+ debug "parser-control-ok-core $w $base $background $show"
+ upvar #0 deffont_$base deffont
+ $w.resframe.res configure \
+ -background $background -disabledforeground black -font $deffont \
+ -state disabled -command {} \
+ -text $show
+}
+proc parser-control-ok {w base show} {
+ parser-control-ok-core $w $base green $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} {
+ debug "parser-control-failed-core $w $base $summary $fulldesc"
+ set eb .err_$base
- 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}
+ $eb.emsg.text delete 0.0 end
+ $eb.emsg.text insert end $summary
- 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
+ $eb.text.lab configure -text $fulldesc
+ $eb.text.text delete 0.0 end
+ $eb.text.text insert end $fulldata
- wm geometry . 1024x480
+ regsub -all {.{18}} $tiny "&\n" ewrap
+
+ $w.resframe.res configure \
+ -background red -foreground white -font fixed \
+ -state normal -command [list wm deiconify $eb] \
+ -text $ewrap
+}
+
+proc parser-control-failed-expected {w base emsg lno ei fulldesc newdata} {
+ set eb .err_$base
+
+ set line [lindex [split $ei "\n"] 0]
+ debug "parser-control-failed-expected: $w $base: $lno: $emsg\n $line"
+
+ parser-control-failed-core $w $base \
+ "err: [string trim $emsg]: \"$line\"" \
+ "at line $lno: $emsg" \
+ $fulldesc $newdata
+
+ $eb.text.text tag add error $lno.0 $lno.end
+ $eb.text.text see $lno.0
}
proc zoom {extail} {
draw
}
-proc acquire_showerror {} {
- global acqerr
- tk_messageBox -type ok \
- -title "where-vessels: clipboard parsing error" \
- -message $acqerr
-}
-
-proc acquire {} {
- global clipboard acqdeffont acqerr errorInfo
- set old $clipboard
- set nclipboard [clipboard get]
+proc reparse {base varname fulldesc okshow noneshow set parse} {
+ upvar #0 $varname var
+ set old $var
+ uplevel 1 $set
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 "
+ uplevel 1 $parse
+ if {[string length [string trim $var]]} {
+ parser-control-ok .ctrl.$base $base $okshow
+ } else {
+ parser-control-none .ctrl.$base $base $noneshow
+ }
}] 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 {wm deiconify .err_acquire} \
- -text $ewrap
- set clipboard $old
- parse-clipboard
+ parser-control-failed-expected .ctrl.$base $base \
+ $emsg $lno $ei $fulldesc $var
+ set var $old
+ uplevel 1 $parse
}
+}
+
+proc invoke_acquire {} {
+ global clipboard
+ reparse acquire \
+ clipboard "Clipboard contents:" { acquired ok } { no vessels } \
+ { set clipboard [clipboard get] } \
+ { parse-clipboard }
draw
}
+proc invoke_notes {} {
+ global notes_data errorInfo notes_loc
+
+ 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 }
+ draw
+}
#---------- main program ----------
widgets-setup
load-notes
+parse-notes
parse-clipboard
draw