diff --git a/CHANGELOG b/CHANGELOG
index 66e1eea1bc0fc932a82db6c103c5fabcf0d73f51..c9ae47983678fa57a22956ed18d0773205ca05b4 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -1,5 +1,16 @@
2020-07-23 David Byers <david.byers@liu.se>
+ Fix issue #3:
+ * olc.el (olc-parse-code): Save match data.
+ (olc-is-valid): Save match data.
+ (olc-shorten-compound): Save match data.
+ (olc-recover-compound): Save match data.
+ (olc-is-valid): Rewrote as string operations.
+ (olc-value-mapping): Changed to defconst.
+ (olc-digit-mapping): Changed to defconst.
+ (olc-is-short): Operate on string.
+ (olc-is-full): Operate on string.
+
Fix issue #1 more properly:
* olc.el (olc-recover): Honor format arg when dealing with full
codes.
diff --git a/Makefile b/Makefile
index e84406c2838450399eb0e7c88d0abafb2e8e1f2f..8dca7ba2610800359c826c8d17a8e67046a3e168 100644
--- a/Makefile
+++ b/Makefile
@@ -25,6 +25,7 @@ all: olc.elc olc.info
check:
emacs --batch \
--eval "(setq-default indent-tabs-mode nil)" \
+ --eval "(setq-default fill-column 79)" \
-f package-initialize \
-l elisp-lint \
-f elisp-lint-files-batch \
@@ -42,8 +43,9 @@ olc.info: olc.texi
.PHONY: test
test:
( cd test && \
- emacs -batch \
+ emacs --batch \
-f package-initialize \
-l ../olc.el \
-l olctest.el \
- -f olctest-batch-test )
+ -f olctest-batch-test \
+ )
diff --git a/olc.el b/olc.el
index 3ebb070644ab0ec5e5b316175e70c6aafb9d19cf..3be5a31af07b0613a22e828bd31ecef5674f2927 100644
--- a/olc.el
+++ b/olc.el
@@ -72,10 +72,10 @@
;;; Base 20 digits:
-(defvar olc-value-mapping "23456789CFGHJMPQRVWX"
+(defconst olc-value-mapping "23456789CFGHJMPQRVWX"
"Mapping from values to olc base 20 digits.")
-(defvar olc-digit-mapping
+(defconst olc-digit-mapping
(let ((count 0))
(mapcan (lambda (letter)
(prog1 (list (cons letter count)
@@ -169,119 +169,151 @@ raise, and args for the raised error.
"Parse an open location code CODE."
(if (olc-parse-p code)
code
- (let ((pos 0)
- (pairs nil)
- (short nil)
- (precision nil)
- (grid nil)
- (padding 0))
-
- ;; Parse up to four initial pairs
- (catch 'break
- (while (< pos (length code))
- (olc-transform-error
- (args-out-of-range olc-parse-error
- "code too short" code (1+ pos))
- (cond ((eq (elt code pos) ?+) (throw 'break nil))
- ((eq (elt code pos) ?0) (throw 'break nil))
- ((= (length pairs) 4) (throw 'break nil))
- ((not (olc-valid-char (elt code pos)))
- (signal 'olc-parse-error
- (list "invalid character" pos code)))
- ((not (olc-valid-char (elt code (1+ pos))))
- (signal 'olc-parse-error
- (list "invalid character" (1+ pos) code)))
- (t (setq pairs (cons (cons (elt code pos)
- (elt code (1+ pos)))
- pairs)))))
- (setq pos (+ pos 2))))
-
- ;; Measure the padding
- (when (string-match "0+" code pos)
- (setq pos (match-end 0)
- padding (- (match-end 0) (match-beginning 0))))
-
- ;; Parse the separator
- (olc-transform-error
- (args-out-of-range olc-parse-error
- "code too short" code pos)
- (if (eq (elt code pos) ?+)
- (setq pos (1+ pos))
+ (save-match-data
+ (let ((pos 0)
+ (pairs nil)
+ (short nil)
+ (precision nil)
+ (grid nil)
+ (padding 0))
+
+ ;; Parse up to four initial pairs
+ (catch 'break
+ (while (< pos (length code))
+ (olc-transform-error
+ (args-out-of-range olc-parse-error
+ "code too short" code (1+ pos))
+ (cond ((eq (elt code pos) ?+) (throw 'break nil))
+ ((eq (elt code pos) ?0) (throw 'break nil))
+ ((= (length pairs) 4) (throw 'break nil))
+ ((not (olc-valid-char (elt code pos)))
+ (signal 'olc-parse-error
+ (list "invalid character" pos code)))
+ ((not (olc-valid-char (elt code (1+ pos))))
+ (signal 'olc-parse-error
+ (list "invalid character" (1+ pos) code)))
+ (t (setq pairs (cons (cons (elt code pos)
+ (elt code (1+ pos)))
+ pairs)))))
+ (setq pos (+ pos 2))))
+
+ ;; Measure the padding
+ (when (string-match "0+" code pos)
+ (setq pos (match-end 0)
+ padding (- (match-end 0) (match-beginning 0))))
+
+ ;; Parse the separator
+ (olc-transform-error
+ (args-out-of-range olc-parse-error
+ "code too short" code pos)
+ (if (eq (elt code pos) ?+)
+ (setq pos (1+ pos))
+ (signal 'olc-parse-error
+ (list "missing separator" pos code))))
+
+ ;; Check the length of the padding
+ (unless (and (= (% padding 2) 0)
+ (<= (+ padding (* 2 (length pairs))) 8))
(signal 'olc-parse-error
- (list "missing separator" pos code))))
+ (list "incorrect padding length" pos code)))
- ;; Check the length of the padding
- (unless (and (= (% padding 2) 0)
- (<= (+ padding (* 2 (length pairs))) 8))
- (signal 'olc-parse-error
- (list "incorrect padding length" pos code)))
+ ;; Determine if the code is shortened or not
+ (setq short (< (+ (* 2 (length pairs)) padding) 8))
- ;; Determine if the code is shortened or not
- (setq short (< (+ (* 2 (length pairs)) padding) 8))
+ ;; We cant be short and have padding (not sure why)
+ (when (and short (> padding 0))
+ (signal 'olc-parse-error
+ (list "padded codes can't be shortened" pos code)))
- ;; We cant be short and have padding (not sure why)
- (when (and short (> padding 0))
- (signal 'olc-parse-error
- (list "padded codes can't be shortened" pos code)))
+ ;; Determine the precision of the code
+ (setq precision (- 8 padding))
- ;; Determine the precision of the code
- (setq precision (- 8 padding))
+ ;; Parse what's after the separator
+ (when (< pos (length code))
+ (when (> padding 0)
+ (signal 'olc-parse-error
+ (list "padding followed by data" pos code)))
- ;; Parse what's after the separator
- (when (< pos (length code))
- (when (> padding 0)
- (signal 'olc-parse-error
- (list "padding followed by data" pos code)))
+ ;; Parse one more pair
+ (olc-transform-error
+ (args-out-of-range olc-parse-error
+ "code too short" code (1+ pos))
+ (setq pairs (cons (cons (elt code pos)
+ (elt code (1+ pos)))
+ pairs)
+ pos (+ 2 pos)
+ precision (+ 2 precision)))
+
+ ;; Parse grid
+ (while (< pos (length code))
+ (cond ((not (olc-valid-char (elt code pos)))
+ (signal 'olc-parse-error
+ (list "invalid character" pos code)))
+ ((>= (length grid) 5) (setq pos (1+ pos)))
+ (t (setq grid (cons (elt code pos) grid)
+ pos (1+ pos)
+ precision (1+ precision))))))
- ;; Parse one more pair
- (olc-transform-error
- (args-out-of-range olc-parse-error
- "code too short" code (1+ pos))
- (setq pairs (cons (cons (elt code pos)
- (elt code (1+ pos)))
- pairs)
- pos (+ 2 pos)
- precision (+ 2 precision)))
-
- ;; Parse grid
- (while (< pos (length code))
- (cond ((not (olc-valid-char (elt code pos)))
- (signal 'olc-parse-error
- (list "invalid character" pos code)))
- ((>= (length grid) 5) (setq pos (1+ pos)))
- (t (setq grid (cons (elt code pos) grid)
- pos (1+ pos)
- precision (1+ precision))))))
-
- ;; Check for an empty code
- (unless pairs
- (signal 'olc-parse-error (list "invalid code" 0 code)))
-
- ;; Return the result
- (olc-parse-create :pairs (nreverse pairs)
- :grid (nreverse grid)
- :short short
- :precision precision))))
+ ;; Check for an empty code
+ (unless pairs
+ (signal 'olc-parse-error (list "invalid code" 0 code)))
+
+ ;; Return the result
+ (olc-parse-create :pairs (nreverse pairs)
+ :grid (nreverse grid)
+ :short short
+ :precision precision)))))
;;; Public functions:
+(defconst olc-code-regexp (format "^\\([%s]*\\)\\(0*\\)\\+\\([%s]*\\)$"
+ olc-value-mapping
+ olc-value-mapping)
+ "Regular expression for parsing codes.")
+
(defun olc-is-valid (code)
"Return non-nil if CODE is a valid open location code."
- (condition-case nil
- (olc-parse-code code)
- (olc-parse-error nil)))
-
+ (or (olc-parse-p code)
+ (save-match-data
+ (let ((case-fold-search t))
+
+ ;; The code is decomposed into PAIRS PADDING "+" SUFFIX.
+ ;;
+ ;; Rules:
+ ;;
+ ;; - For all codes:
+ ;; - Pairs has an even (zero counts) length of at most 8.
+ ;; - Suffix is either zero or between 2 and 8 characters.
+ ;; - One or both of pairs and suffix must not be empty.
+ ;;
+ ;; - If there is padding:
+ ;; - The suffix must be empty
+ ;; - The length of pairs and padding combined must be 8
+
+ (when (string-match olc-code-regexp code)
+ (let ((pair-len (- (match-end 1) (match-beginning 1)))
+ (padd-len (- (match-end 2) (match-beginning 2)))
+ (suff-len (- (match-end 3) (match-beginning 3))))
+ (and (and (= 0 (% pair-len 2)) (<= pair-len 8)) ; Check pairs
+ (and (<= suff-len 8) (/= suff-len 1)) ; Check suffix
+ (> (+ pair-len suff-len) 0) ; Check for not empty
+ (or (= padd-len 0) ; Empty padding...
+ (and (= suff-len 0) ; ...or suffix
+ (= (+ padd-len pair-len) 8))))))))))
(defun olc-is-short (code)
"Return non-nil if CODE is a valid short open location code.
Note that nil means the code is either not short, or it is
invalid."
- (condition-case nil
- (olc-parse-short (olc-parse-code code))
- (olc-parse-error nil)))
+ (if (olc-parse-p code)
+ (olc-parse-short code)
+ (and (olc-is-valid code)
+ (or (< (length code) 9)
+ (and (>= (length code) 9)
+ (not (= (elt code 8) ?+)))))))
(defun olc-is-full (code)
@@ -289,9 +321,11 @@ invalid."
Note that nil means the code is either not long, or it is
invalid."
- (condition-case nil
- (not (olc-parse-short (olc-parse-code code)))
- (olc-parse-error nil)))
+ (if (olc-parse-p code)
+ (not (olc-parse-short code))
+ (and (olc-is-valid code)
+ (and (>= (length code) 9)
+ (= (elt code 8) ?+)))))
(defun olc-code-precision (code)
@@ -459,53 +493,54 @@ it can take some time to complete. If you can set the zoom level
to a single number, then it will make one call only, and is much
faster.
"
- (let* ((area (olc-decode code))
- (zoom-lo (cond ((numberp zoom) zoom)
- ((listp zoom) (elt zoom 0))
- (t (signal 'args-out-of-range zoom))))
- (zoom-hi (cond ((numberp zoom) (1+ zoom))
- ((listp zoom) (1+ (elt zoom 1)))
- (t (signal 'args-out-of-range zoom))))
- result)
- (catch 'result
- (while (< zoom-lo zoom-hi)
- (let* ((zoom (floor (+ zoom-lo zoom-hi) 2))
- (resp (request-response-data
- (request
- "https://nominatim.openstreetmap.org/reverse"
- :params `((lat . ,(olc-area-lat area))
- (lon . ,(olc-area-lon area))
- (zoom . ,zoom)
- (format . "json"))
- :parser #'json-read
- :sync t)))
- (tmp-code
- (when resp
- (olc-shorten code
- (string-to-number
- (alist-get 'lat resp))
- (string-to-number
- (alist-get 'lon resp))
- :limit limit)))
- (padlen (when (string-match "+" tmp-code)
- (- 8 (match-beginning 0)))))
-
- ;; Keep the shortest code we see that has at most limit
- ;; chars removed
- (when (and (<= padlen limit)
- (or (null result)
- (< (length tmp-code) (length (car result)))))
- (setq result (cons tmp-code
- (alist-get 'display_name resp))))
-
- ;; Zoom in or out
- (if (< padlen limit)
- (setq zoom-lo (1+ zoom))
- (setq zoom-hi zoom))))
- (if (and result (> 8 (progn (string-match "+" (car result))
- (match-end 0))))
- (concat (car result) " " (cdr result))
- code))))
+ (save-match-data
+ (let* ((area (olc-decode code))
+ (zoom-lo (cond ((numberp zoom) zoom)
+ ((listp zoom) (elt zoom 0))
+ (t (signal 'args-out-of-range zoom))))
+ (zoom-hi (cond ((numberp zoom) (1+ zoom))
+ ((listp zoom) (1+ (elt zoom 1)))
+ (t (signal 'args-out-of-range zoom))))
+ result)
+ (catch 'result
+ (while (< zoom-lo zoom-hi)
+ (let* ((zoom (floor (+ zoom-lo zoom-hi) 2))
+ (resp (request-response-data
+ (request
+ "https://nominatim.openstreetmap.org/reverse"
+ :params `((lat . ,(olc-area-lat area))
+ (lon . ,(olc-area-lon area))
+ (zoom . ,zoom)
+ (format . "json"))
+ :parser #'json-read
+ :sync t)))
+ (tmp-code
+ (when resp
+ (olc-shorten code
+ (string-to-number
+ (alist-get 'lat resp))
+ (string-to-number
+ (alist-get 'lon resp))
+ :limit limit)))
+ (padlen (when (string-match "+" tmp-code)
+ (- 8 (match-beginning 0)))))
+
+ ;; Keep the shortest code we see that has at most limit
+ ;; chars removed
+ (when (and (<= padlen limit)
+ (or (null result)
+ (< (length tmp-code) (length (car result)))))
+ (setq result (cons tmp-code
+ (alist-get 'display_name resp))))
+
+ ;; Zoom in or out
+ (if (< padlen limit)
+ (setq zoom-lo (1+ zoom))
+ (setq zoom-hi zoom))))
+ (if (and result (> 8 (progn (string-match "+" (car result))
+ (match-end 0))))
+ (concat (car result) " " (cdr result))
+ code)))))
(cl-defun olc-recover (code lat lon &key (format 'area))
@@ -561,51 +596,52 @@ not specified, the reference is assumed to be embedded into CODE.
If FORMAT is `area' (or any other value), the returned value is an
full open location code."
;; Make sure we can do requests
- (unless (fboundp 'request) (signal 'void-function 'request))
-
- ;; Check types (defer check of ref)
- (cl-check-type code stringp)
- (cl-check-type format (member latlon area nil))
-
- ;; Process code and check ref
- (cond ((string-match "^\\(\\S-+\\)\\s-+\\(.*\\)$" code)
- (progn (cl-check-type ref null)
- (setq ref (match-string 2 code)
- code (match-string 1 code))))
- ((olc-is-full code))
- (t (cl-check-type ref stringp)))
-
- ;; If the code is full then return it
- (if (olc-is-full code)
- (olc-recover code 0 0 :format format)
- (let ((resp (request "https://nominatim.openstreetmap.org/search"
- :params `((q . ,ref)
- (format . "json")
- (limit . 1))
- :parser #'json-read
- :sync t)))
-
- ;; Check that we got a response
- (unless (eq 200 (request-response-status-code resp))
- (signal 'olc-recover-error
- (list "error decoding reference"
- (request-response-status-code resp))))
-
- (let* ((data (elt (request-response-data resp) 0))
- (lat (alist-get 'lat data))
- (lon (alist-get 'lon data)))
-
- ;; Check that we have a lat and lon
- (unless (and lat lon)
+ (save-match-data
+ (unless (fboundp 'request) (signal 'void-function 'request))
+
+ ;; Check types (defer check of ref)
+ (cl-check-type code stringp)
+ (cl-check-type format (member latlon area nil))
+
+ ;; Process code and check ref
+ (cond ((string-match "^\\(\\S-+\\)\\s-+\\(.*\\)$" code)
+ (progn (cl-check-type ref null)
+ (setq ref (match-string 2 code)
+ code (match-string 1 code))))
+ ((olc-is-full code))
+ (t (cl-check-type ref stringp)))
+
+ ;; If the code is full then return it
+ (if (olc-is-full code)
+ (olc-recover code 0 0 :format format)
+ (let ((resp (request "https://nominatim.openstreetmap.org/search"
+ :params `((q . ,ref)
+ (format . "json")
+ (limit . 1))
+ :parser #'json-read
+ :sync t)))
+
+ ;; Check that we got a response
+ (unless (eq 200 (request-response-status-code resp))
(signal 'olc-recover-error
- (list "reference location missing lat or lon"
- data)))
-
- ;; Finally recover the code!
- (olc-recover code
- (string-to-number lat)
- (string-to-number lon)
- :format format)))))
+ (list "error decoding reference"
+ (request-response-status-code resp))))
+
+ (let* ((data (elt (request-response-data resp) 0))
+ (lat (alist-get 'lat data))
+ (lon (alist-get 'lon data)))
+
+ ;; Check that we have a lat and lon
+ (unless (and lat lon)
+ (signal 'olc-recover-error
+ (list "reference location missing lat or lon"
+ data)))
+
+ ;; Finally recover the code!
+ (olc-recover code
+ (string-to-number lat)
+ (string-to-number lon)
+ :format format))))))
(provide 'olc)
diff --git a/test/olctest.el b/test/olctest.el
index 062963e48b1912cf7b4852270db88adec470cb83..7a8e51dd98444e1d537dfd3a431af4dba7a0981e 100644
--- a/test/olctest.el
+++ b/test/olctest.el
@@ -62,6 +62,10 @@
(unless (string= exp act)
(olctest-record-failure :exp exp :act act :msg msg)))
+(cl-defun olctest-float= (&key exp act msg)
+ (unless (< (abs (- act exp)) olctest-decode-tolerance)
+ (olctest-record-failure :exp exp :act act :msg msg)))
+
(cl-defun olctest-equal (&key exp act msg)
(unless (equal exp act)
(olctest-record-failure :exp exp :act act :msg msg)))
@@ -160,27 +164,27 @@
"Test decoding."
(olctest-testcase "reference:decoding"
(olctest-run-csv ("decoding.csv" case)
- (let ((area (olc-decode (alist-get 'code case)))
- (exp-latlo (alist-get 'latLo case))
- (exp-lathi (alist-get 'latHi case))
- (exp-lonlo (alist-get 'lngLo case))
- (exp-lonhi (alist-get 'lngHi case))
- (exp-len (alist-get 'length case)))
- (unless (and (= exp-len (olc-code-precision (alist-get 'code case)))
- (< (abs (- (olc-area-latlo area) exp-latlo)) olctest-decode-tolerance)
- (< (abs (- (olc-area-lathi area) exp-lathi)) olctest-decode-tolerance)
- (< (abs (- (olc-area-lonlo area) exp-lonlo)) olctest-decode-tolerance)
- (< (abs (- (olc-area-lonhi area) exp-lonhi)) olctest-decode-tolerance))
- (olctest-record-failure
- :exp (format "%d,%f,%f,%f,%f" exp-len exp-latlo exp-lonlo exp-lathi exp-lonhi)
- :act (format "%d,%f,%f,%f,%f"
- (olc-code-precision (alist-get 'code case))
- (olc-area-latlo area)
- (olc-area-lonlo area)
- (olc-area-lathi area)
- (olc-area-lonhi area))
- :msg (alist-get 'lineno case)))))))
-
+ (let* ((code (alist-get 'code case))
+ (parse (condition-case nil (olc-parse-code code) (error nil)))
+ (area (and parse (olc-decode parse)))
+ (exp-latlo (alist-get 'latLo case))
+ (exp-lathi (alist-get 'latHi case))
+ (exp-lonlo (alist-get 'lngLo case))
+ (exp-lonhi (alist-get 'lngHi case))
+ (exp-len (alist-get 'length case))
+ (lineno (alist-get 'lineno case))
+ (pact-len (and parse (olc-code-precision parse)))
+ (sact-len (olc-code-precision code))
+ (msg (format "%d:%s:%%s" lineno code)))
+ (if (null area)
+ (olctest-record-failure :exp 'success :act 'parse-error :msg code)
+ (olctest-equal :act (olc-code-precision code) :exp exp-len :msg (format msg "len(string)"))
+ (olctest-equal :act (olc-code-precision parse) :exp exp-len :msg (format msg "len(parsed)"))
+ (olctest-float= :act (olc-area-latlo area) :exp exp-latlo :msg (format msg "latlo"))
+ (olctest-float= :act (olc-area-lathi area) :exp exp-lathi :msg (format msg "lathi"))
+ (olctest-float= :act (olc-area-lonlo area) :exp exp-lonlo :msg (format msg "lonlo"))
+ (olctest-float= :act (olc-area-lonhi area) :exp exp-lonhi :msg (format msg "lonhi"))
+ )))))
(defun olctest-shortcodes ()
"Test recovering."
@@ -211,13 +215,18 @@
(olctest-testcase "reference:validity"
(olctest-run-csv ("validityTests.csv" case)
(let* ((code (alist-get 'code case))
+ (parse (condition-case nil (olc-parse-code code) (error nil)))
(exp (list (alist-get 'isValid case)
(alist-get 'isShort case)
(alist-get 'isFull case)))
- (act (list (not (not (olc-is-valid code)))
- (not (not (olc-is-short code)))
- (not (not (olc-is-full code))))))
- (olctest-equal :exp exp :act act :msg code)))))
+ (sact (list (and parse (not (not (olc-is-valid code))))
+ (and parse (not (not (olc-is-short code))))
+ (and parse (not (not (olc-is-full code))))))
+ (pact (list (and parse (not (not (olc-is-valid parse))))
+ (and parse (not (not (olc-is-short parse))))
+ (and parse (not (not (olc-is-full parse)))))))
+ (olctest-equal :exp exp :act pact :msg (format "%s:parsed" code))
+ (olctest-equal :exp exp :act sact :msg (format "%s:string" code))))))
(defvar olctest-local-shorten-tests
@@ -238,6 +247,20 @@
(olctest-string= :exp shortcode :act actual :msg len)))))
+(defun olctest-issue-3 ()
+ (olctest-testcase "local:issue-3"
+ (olctest-equal :exp nil
+ :act (olc-is-short "22334455+")
+ :msg "S1")
+
+ (olctest-equal :exp t
+ :act (olc-is-short "334455+66")
+ :msg "S2")
+
+ (olctest-equal :exp nil
+ :act (olc-is-short "+12345678")
+ :msg "S3")))
+
(defun olctest-issue-1 ()
(olctest-testcase "local:issue-1"
(olctest-assert-error (:exp (wrong-type-argument) :msg "F1")
@@ -286,6 +309,7 @@
(olctest-shortcodes)
(olctest-validity)
(olctest-localtests)
+ (olctest-issue-3)
(olctest-issue-1)
))