where-vessels: show errorInfo in acq error

[ypp-sc-tools.main.git] / yarrg / where-vessels

diff --git a/yarrg/where-vessels b/yarrg/where-vessels
index 43d4a60db0cda0fb3e2af0608cc94e524622176b..ecf1e063156bbd3ddee66d3359da8a4ab5b6b1da 100755 (executable)
--- a/yarrg/where-vessels
+++ b/yarrg/where-vessels
@@ -1,9 +1,36 @@
 #!/usr/bin/wish
+# show your vessels on a map
+
+# This is part of ypp-sc-tools, a set of third-party tools for assisting
+# players of Yohoho Puzzle Pirates.
+#
+# Copyright (C) 2009 Ian Jackson <ijackson@chiark.greenend.org.uk>
+#
+# This program is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program.  If not, see <http://www.gnu.org/licenses/>.
+#
+# Yohoho and Puzzle Pirates are probably trademarks of Three Rings and
+# are used without permission.  This program is not endorsed or
+# sponsored by Three Rings.
+
+
 
 source yarrglib.tcl
 source panner.tcl
 package require http
 
+#---------- general utilities ----------
+
 set debug 0
 proc debug {m} {
     global debug
@@ -15,6 +42,13 @@ proc badusage {m} {
     exit 1
 }
 
+proc glset {n val} {
+    upvar #0 $n var
+    set var $val
+}
+
+#---------- argument parsing ----------
+
 proc nextarg {} {
     global ai argv
     if {$ai >= [llength $argv]} {
@@ -25,11 +59,6 @@ proc nextarg {} {
     return $v
 }
 
-proc glset {n val} {
-    upvar #0 $n var
-    set var $val
-}
-
 set notes_loc vessel-notes
 set scraper {./yppedia-ocean-scraper --chart}
 
@@ -66,6 +95,9 @@ proc argdefaults {} {
     lappend scraper $ocean
 }
 
+
+#---------- loading and parsing the vessel notes ----------
+
 proc load-notes {} {
     global notes_loc notes
     catch { unset notes }
@@ -95,6 +127,8 @@ proc load-notes {} {
 }
 
 
+#---------- loading and parsing the clipboard (vessel locations) ----------
+
 proc vessel {vin} {
        global pirate notes_used
        upvar 1 $vin vi
@@ -187,6 +221,9 @@ proc load-clipboard-file {fn} {
     close $f
 }
 
+
+#---------- loading and parsing the chart ----------
+
 proc load-chart {} {
     global chart scraper
     debug "FETCHING CHART"
@@ -241,6 +278,8 @@ proc chart-got/league {x1 y1 x2 y2 kind} {
 proc draw {} {
     global chart count isleloc canvas
     
+    $canvas delete all
+
     foreach l [split $chart "\n"] {
 #      debug "CHART-GOT $l"
        set proc [lindex $l 0]
@@ -280,8 +319,10 @@ proc draw {} {
 }
 
 
+#---------- user interface ----------
+
 proc widgets-setup {} {
-    global canvas debug
+    global canvas debug acqdeffont
 
     frame .f -border 1 -relief groove
     set canvas .f.c
@@ -305,20 +346,66 @@ proc widgets-setup {} {
     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
+
+    frame .ctrl.acquire.resframe -width 120 -height 32
+    button .ctrl.acquire.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
+
+    pack .ctrl.acquire.do -side top
+    pack .ctrl.acquire.resframe -side top -expand y -fill both
+    pack .ctrl.acquire -side top
+
     wm geometry . 1024x480
 }
 
-
 proc zoom {extail} {
     global scale canvas
     set nscale [expr "\$scale $extail"]
     debug "ZOOM $scale $nscale"
     if {$nscale < 1 || $nscale > 200} return
     set scale $nscale
-    $canvas delete all
     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
+    if {[catch {
+       set clipboard [clipboard get]
+       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
+       .ctrl.acquire.resframe.res configure \
+           -background red -foreground white -font fixed \
+           -state normal -command acquire_showerror \
+           -text $ewrap
+       set clipboard $old
+       parse-clipboard
+    }
+    draw
+}
+
+
+#---------- main program ----------
 
 parseargs
 argdefaults