CORE: flexible UTF-8 encoding error handling (#361)

Also a bit faster.

Author: 0-8-15

modules/ln_core/utf8string.scm

@@ -57,20 +57,20 @@ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 (define utf8string? string?)
 (define utf8string=? string=?)
 (define utf8string-append string-append)
-(define utf8string-copy string-copy) 
+(define utf8string-copy string-copy)
 
 (define (utf8string-length src) (length (utf8string->unicode src)))
 
 (define (utf8string-ref s idx) (integer->utf8char (list-ref (utf8string->unicode s) idx)))
 
-(define (utf8string . cs) 
+(define (utf8string . cs)
   (let ((utf8cs (map char->utf8char cs)))
    (apply string-append utf8cs)))
 
-(define (make-utf8string n . c) 
+(define (make-utf8string n . c)
   (let ((utf8c (char->utf8char (if (fx= (length c) 1) (car c) " "))))
-    (let loop ((i 0)(s ""))
-      (if (fx= i n) s 
+    (let loop ((i 0) (s ""))
+      (if (fx= i n) s
         (loop (fx+ i 1) (string-append s utf8c))))))
 
 (define (utf8string->list s) (map integer->utf8char (utf8string->unicode s)))
@@ -108,17 +108,17 @@ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 (define utf8string-explode (lambda (str seplst)
   (let ((utf8seplst (map char->utf8char seplst)))
     (let loop ((strlst (utf8string->list str))(tmp "")(res '()))
-      (if (= (length strlst) 0) (append res 
+      (if (= (length strlst) 0) (append res
         (if (> (utf8string-length tmp) 0) (list tmp) '()))
         (let ((chop? (member (car strlst) utf8seplst)))
           (loop (cdr strlst) (if chop? "" (utf8string-append tmp (utf8string (car strlst))))
-            (if chop? (append res (list tmp) 
+            (if chop? (append res (list tmp)
                (list (utf8string (car strlst)))) res))))))))
 
 (define (utf8string-split str sep)
   (let ((utf8sep (char->utf8char sep)))
     (let loop ((cs (utf8string->list str))(subres "")(res '()))
-      (if (= (length cs) 0) (if (> (utf8string-length subres) 0) 
+      (if (= (length cs) 0) (if (> (utf8string-length subres) 0)
         (append res (list subres)) res)
         (let* ((c (car cs))
                (split? (utf8char=? c utf8sep)))
@@ -138,20 +138,20 @@ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
          (c1 (if (zero? pat-len) #f (utf8string-ref pattern 0)))
          (c2 (if (<= pat-len 1) #f (utf8string-ref pattern 1))))
     (cond
-     ((not c1) 0)    
+     ((not c1) 0)
      ((not c2) (utf8string-index str c1 cmp))
      (else (let outer ((pos 0))
           (cond
 	    ((> pos search-span) #f)
             ((not (cmp c1 (utf8string-ref str pos)))
-                (outer (+ 1 pos)))	
+                (outer (+ 1 pos)))
             ((not (cmp c2 (utf8string-ref str (+ 1 pos))))
                 (outer (+ 1 pos)))
             (else (let inner ((i-pat 2) (i-str (+ 2 pos)))
-               (if (>= i-pat pat-len) pos 
+               (if (>= i-pat pat-len) pos
                   (if (cmp (utf8string-ref pattern i-pat) (utf8string-ref str i-str))
                         (inner (+ 1 i-pat) (+ 1 i-str))
-                        (outer (+ 1 pos))))))))))))	
+                        (outer (+ 1 pos))))))))))))
 
 (define (utf8string-contains str pattern) (utf8string:contains str pattern utf8char=?))
 (define (utf8string-contains-ci str pattern) (utf8string:contains str pattern utf8char-ci=?))
@@ -164,7 +164,7 @@ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
         (utf8newchr (char->utf8char newchr)))
     (let loop ((oldcs (utf8string->list str))(newcs '()))
       (if (= (length oldcs) 0) (list->utf8string newcs)
-        (loop (cdr oldcs) (append newcs  
+        (loop (cdr oldcs) (append newcs
           (list (if (utf8char=? (car oldcs) utf8oldchr) utf8newchr (car oldcs)))))))))
 
 (define utf8string-replace-substring string-replace-substring)
@@ -177,53 +177,84 @@ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
       (let* ((moveindex (- (length first) 1))
              (newfirst (list-head first moveindex))
              (newsecond (append (list (list-ref first moveindex)) second))
-             (neww (max (utf8string-length (utf8string-mapconcat newfirst " ")) 
+             (neww (max (utf8string-length (utf8string-mapconcat newfirst " "))
                (utf8string-length (utf8string-mapconcat newsecond " ")))))
         (if (< neww bestw)
           (loop newfirst newsecond neww)
           (list (utf8string-mapconcat first " ") (utf8string-mapconcat second " ")))))))
 
 ;; -------------------------------
 ;; unicode<->utf8 translation
-;; adopted from http://ccm.sherry.jp/cleite/ (public domain)
-
-(define (utf8string->unicode src)
-  (define (decode l)
-    (if (null? l) l
-      (cond ((fx= 0 (bitwise-and (car l) #x80))
-               (cons (car l)
-                     (decode (list-tail l 1))))
-            ((fx= #xC0 (bitwise-and (car l) #xE0))
-               (cons (bitwise-ior (arithmetic-shift (bitwise-and (list-ref l 0) #x1F) 6)
-                                  (bitwise-and (list-ref l 1) #x3F))
-                     (decode (list-tail l 2))))
-            ((fx= #xE0 (bitwise-and (car l) #xF0))
-                (cons (bitwise-ior (arithmetic-shift (bitwise-and (list-ref l 0) #x0F) 12)
-                                   (arithmetic-shift (bitwise-and (list-ref l 1) #x3F)  6)
-                                   (bitwise-and (list-ref l 2) #x3F))
-                      (decode (list-tail l 3))))
-            ((fx= #xF0 (bitwise-and (car l) #xF8))
-                (cons (bitwise-ior (arithmetic-shift (bitwise-and (list-ref l 0) #x07) 18)
-                                   (arithmetic-shift (bitwise-and (list-ref l 1) #x3F) 12)
-                                   (arithmetic-shift (bitwise-and (list-ref l 2) #x3F)  6)
-                                   (bitwise-and (list-ref l 3) #x3F))
-                      (decode (list-tail l 4))))
-            ((fx= #xF8 (bitwise-and (car l) #xFC))
-                (cons (bitwise-ior (arithmetic-shift (bitwise-and (list-ref l 0) #x03) 24)
-                                   (arithmetic-shift (bitwise-and (list-ref l 1) #x3F) 18)
-                                   (arithmetic-shift (bitwise-and (list-ref l 2) #x3F) 12)
-                                   (arithmetic-shift (bitwise-and (list-ref l 3) #x3F)  6)
-                                   (bitwise-and (list-ref l 4) #x3F))
-                      (decode (list-tail l 5))))
-            ((fx= #xFC (bitwise-and (car l) #xFE))
-                (cons (bitwise-ior (arithmetic-shift (bitwise-and (list-ref l 0) #x01) 30)
-                                   (arithmetic-shift (bitwise-and (list-ref l 1) #x3F) 24)
-                                   (arithmetic-shift (bitwise-and (list-ref l 2) #x3F) 18)
-                                   (arithmetic-shift (bitwise-and (list-ref l 3) #x3F) 12)
-                                   (arithmetic-shift (bitwise-and (list-ref l 4) #x3F)  6)
-                                   (bitwise-and (list-ref l 5) #x3F))
-                      (decode (list-tail l 6)))))))
-     (decode (map char->integer (string->list src))))
+
+(define utf8string->unicode:on-encoding-error
+  (let ((handler #f))
+    (define (utf8string->unicode:on-encoding-error-replace str idx) #xfffd)
+    (define (utf8string->unicode:on-encoding-error-raise-error str idx)
+      (error "UTF-8 char encoding error" str idx))
+    (define (utf8string->unicode:on-encoding-error-log+replace str idx)
+      (log-error "UTF-8 char encoding error" str idx)
+      #xfffd)
+    (define (select key)
+      (set!
+       handler
+       (if (procedure? key)
+           key
+           (case key
+             ((replace #f) utf8string->unicode:on-encoding-error-replace)
+             ((log+replace) utf8string->unicode:on-encoding-error-log+replace)
+             (else utf8string->unicode:on-encoding-error-raise-error)))))
+    (select 'error)
+    (lambda args
+      (if (null? args) handler (select (car args))))))
+
+(define (utf8string->unicode str #!optional (encoding-error #t))
+  (define (on-encoding-error i)
+    (cond
+     ((not encoding-error) #xfffd) ;; deliver replacement charater
+     ((procedure? encoding-error) (encoding-error str i)) ;; delegate to caller
+     (else ((utf8string->unicode:on-encoding-error) str i)))) ;; delegate to registered
+  (let next-char ((i 0))
+    (if (fx>= i (string-length str)) '()
+        (let* ((c (string-ref str i))
+               (c1 (char->integer c)))
+                (receive (size m1)
+                    (cond
+                     ((fx< c1 #x80) (values 1 #x7f))
+                     ((fx< c1 #xe0) (values 2 #x0f))
+                     ((fx< c1 #xf0) (values 3 #x0f))
+                     ((fx< c1 #xf8) (values 4 #x07))
+                     ((fx< c1 #xfc) (values 5 #x03))
+                     (else (values 6 #x01)))
+                  (if (fx= size 1)
+                      (cons c1 (next-char (fx+ i 1)))
+                      (let ((limit (fx+ i size)))
+                        (let subc ((j (fx+ i 1)) (r (bitwise-and c1 m1)))
+                          (cond
+                           ((fx>= j limit) (cons r (next-char limit)))
+                           ((fx>= j (string-length str)) (list (on-encoding-error j)))
+                           (else
+                            (let ((cc (char->integer (string-ref str j))))
+                              (if (or (fx< cc #x80) (fx>= cc #xc0))
+                                  (let ((r (on-encoding-error j))) ;; 1st force handling
+                                    (cons r (next-char j)))
+                                  (subc
+                                   (fx+ j 1)
+                                   (bitwise-ior
+                                    (arithmetic-shift r 6)
+                                    (bitwise-and cc #x3F)))))))))))))))
+
+(define (utf8string->unicode/fallback str #!key (fallback #f))
+  ;; A version, which replaces string causing convertion erros with a
+  ;; hopefuly safe fallback.
+  (let ((use-fallback (list 0))) ;; just a well known value
+    (with-exception-catcher
+     (lambda (exn)
+       (if (eq? exn use-fallback)
+           (case fallback
+             ((#f) (map char->integer (string->list str)))
+             (else (fallback str)))
+           (raise exn)))
+     (lambda () (utf8string->unicode str (lambda (str i) (raise use-fallback)))))))
 
 (define (unicode->utf8string src)
   (cond ((integer? src)