Ticket #1182: utf8-validation-2.diff

tests/utf8-test.scm

@@ -1 +1 @@
 
 (use test utf8 utf8-srfi-13 utf8-srfi-14)
+(import (prefix (only scheme string list->string) byte-))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; R5RS
@@ -547 +548 @@
 (test-assert (char-set-contains? char-set:full #\a))
 (test-assert (char-set-contains? char-set:full (string-ref "あ" 0)))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; utf8-validation
+
+(test-assert "stray continuation byte"
+             (not (valid-string? (byte-string #\x (integer->char #b10101010) #\x))))
+
+(test-assert "overlong"
+             (not (valid-string? (byte-list->string `(#\x ,@(map integer->char '(#b11000000 #b10100111)) #\x)))))
+
+(test-assert "incomplete"
+             (not (valid-string? (byte-string #\x (integer->char #b11000001)))))
+
+(test-assert (valid-string? "Є"))
+(test-assert (valid-string? "☭"))
+(test-assert (valid-string? "😈"))
+(test-assert (valid-string? "xЄ☭😈x"))
+
 (test-end)

utf8-lolevel.scm

@@ -38 +38 @@
    utf8-string-ref utf8-string-set! utf8-string-length
    utf8-substring
    utf8-string->list utf8-prev-char utf8-next-char
-   make-utf8-string
+   make-utf8-string utf8-string?
    with-substring-offsets with-two-substring-offsets
    ;; string-pointers
    make-string-pointer string-pointer? sp-copy
@@ -381 +381 @@
                                       (bitwise-and #b00111111 b2))
                          (- i 1))))))))))))
 
+(define (char<= a b c)
+  (and (char<=? a b)
+       (char<=? b c)))
+
+(define (utf8-tail? c)
+  (char<= #\x80 c #\xBF))
+
+(define (utf8-2? c0 c1)
+  (and (char<= #\xC2 c0 #\xDF)
+       (utf8-tail? c1)))
+
+(define (utf8-3? c0 c1 c2)
+  (and (utf8-tail? c2)
+       (cond ((char=? c0 #\xE0)
+              (char<= #\xA0 c1 #\xBF))
+             ((char<= #\xE1 c0 #\xEC)
+              (utf8-tail? c1))
+             ((char=? c0 #\xED)
+              (char<= #\x80 c1 #\x9F))
+             ((char<= #\xEE c0 #\xEF)
+              (utf8-tail? c1))
+             (else #f))))
+
+(define (utf8-4? c0 c1 c2 c3)
+  (and (utf8-tail? c2)
+       (utf8-tail? c3)
+       (cond ((char=? c0 #\xF0)
+              (char<= #\x90 c1 #\xBF))
+             ((char<= #\xF1 c0 #\xF3)
+              (utf8-tail? c1))
+             ((char=? c0 #\xF4)
+              (char<= #\x80 c1 #\x8F))
+             (else #f))))
+
+(define (utf8-string? str)
+  (let ((len (string-length str)))
+    (let loop ((pos 0))
+      (or (fx= pos len)
+          (let ((c0 (string-ref str pos)))
+            (let-syntax ((validate (syntax-rules ()
+                                     ((_ valid? c ... n)
+                                      (and (fx<= n (fx- len pos))
+                                           (valid? c0 (string-ref str (fx+ pos c)) ...)
+                                           (loop (fx+ pos n)))))))
+              (if (char<=? c0 #\x7F)
+                  (loop (fx+ pos 1))
+                  (case (utf8-start-byte->length (char->integer c0))
+                    ((2) (validate utf8-2? 1 2))
+                    ((3) (validate utf8-3? 1 2 3))
+                    ((4) (validate utf8-4? 1 2 3 4))
+                    (else #f)))))))))
+
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (define-syntax in-utf8-string

utf8.scm

@@ -225 +225 @@
   string-match string-match-positions string-match-offsets
   string-search string-search-positions string-search-offsets
   ;; new
-  string-set
+  string-set valid-string?
   )
 
 (import (rename (except scheme
@@ -258 +258 @@
                 (string-substitute* byte-string-substitute*)
                 (string-split-fields byte-string-split-fields))
         ports
-        utf8-lolevel)
+        (rename utf8-lolevel
+                (utf8-string? valid-string?)))
 
 (require-library regex utf8-lolevel)