diff --git a/host/chez/host-static.ss b/host/chez/host-static.ss index 1ae92a5..1c574d3 100644 --- a/host/chez/host-static.ss +++ b/host/chez/host-static.ss @@ -514,9 +514,31 @@ (error #f "NoSuchElementException"))))))) ;; ---- String / BigInteger / MapEntry constructors ---------------------------- -;; (String. x) / (String. bytes): a bytevector decodes UTF-8; else stringify. +;; (String. bytes [charset]) decodes bytes (a bytevector OR a jolt byte-array) +;; with the named charset (UTF-8 default; ISO-8859-1/latin1/ascii = one byte per +;; char); else stringify. clj-http-lite's body coercion is (String. ^[B body cs). +(define (string-charset-name rest) + (if (pair? rest) + (let ((c (car rest))) + (cond ((string? c) c) + ((and (jhost? c) (string=? (jhost-tag c) "charset")) + (let ((p (assq 'name (jhost-state c)))) (if p (jolt-str-render-one (cdr p)) "UTF-8"))) + (else "UTF-8"))) + "UTF-8")) +(define (decode-bytevector bv rest) + (let ((cs (ascii-string-down (string-charset-name rest)))) + (cond + ((or (string=? cs "utf-8") (string=? cs "utf8")) (utf8->string bv)) + ((or (string=? cs "iso-8859-1") (string=? cs "latin1") (string=? cs "iso8859-1") + (string=? cs "us-ascii") (string=? cs "ascii")) + (list->string (map integer->char (bytevector->u8-list bv)))) + (else (guard (e (#t (list->string (map integer->char (bytevector->u8-list bv))))) (utf8->string bv)))))) (register-class-ctor! "String" - (lambda (x . _) (cond ((bytevector? x) (utf8->string x)) ((string? x) x) (else (jolt-str-render-one x))))) + (lambda (x . rest) + (cond ((bytevector? x) (decode-bytevector x rest)) + ((and (jolt-array? x) (eq? (jolt-array-kind x) 'byte)) (decode-bytevector (na-bytearray->bv x) rest)) + ((string? x) x) + (else (jolt-str-render-one x))))) (register-class-ctor! "BigInteger" (lambda (v) (parse-int-or-throw v 10 "BigInteger"))) (register-class-ctor! "MapEntry" (lambda (k v) (make-map-entry k v))) diff --git a/host/chez/natives-array.ss b/host/chez/natives-array.ss index 5f53cee..895fd85 100644 --- a/host/chez/natives-array.ss +++ b/host/chez/natives-array.ss @@ -46,10 +46,20 @@ (else (make-jolt-array (list->vector (map (lambda (c) (if (char? c) c (integer->char (exact (truncate c))))) (seq->list (jolt-seq a)))) 'char)))) +;; (byte-array n [init]) | (byte-array coll). Also coerces the host's OTHER byte +;; carrier — a Chez bytevector (what String/.getBytes produce) — and a string's +;; UTF-8 bytes, so bytevector and byte-array interconvert across interop seams. (define (na-byte-array a . rest) - (if (number? a) - (make-jolt-array (make-vector (exact (na-idx a)) (na-byte-of (if (pair? rest) (car rest) 0))) 'byte) - (make-jolt-array (list->vector (map na-byte-of (seq->list (jolt-seq a)))) 'byte))) + (cond + ((number? a) (make-jolt-array (make-vector (exact (na-idx a)) (na-byte-of (if (pair? rest) (car rest) 0))) 'byte)) + ((bytevector? a) (make-jolt-array (list->vector (bytevector->u8-list a)) 'byte)) + ((string? a) (make-jolt-array (list->vector (bytevector->u8-list (string->utf8 a))) 'byte)) + (else (make-jolt-array (list->vector (map na-byte-of (seq->list (jolt-seq a)))) 'byte)))) +;; jolt byte-array -> Chez bytevector (for String decode / utf8->string). +(define (na-bytearray->bv arr) + (let* ((v (jolt-array-vec arr)) (n (vector-length v)) (bv (make-bytevector n))) + (do ((i 0 (+ i 1))) ((= i n)) (bytevector-u8-set! bv i (bitwise-and (exact (vector-ref v i)) #xff))) + bv)) (define (na-make-array a . rest) ; (make-array len) | (make-array type len ...) (make-jolt-array (make-vector (exact (na-idx (if (number? a) a (car rest)))) jolt-nil) 'object)) (define (na-into-array a . rest) (na-from-seq (if (pair? rest) (car rest) a) 'object)) diff --git a/test/chez/unit.edn b/test/chez/unit.edn index 53d2f2f..4593704 100644 --- a/test/chez/unit.edn +++ b/test/chez/unit.edn @@ -465,4 +465,11 @@ {:suite "hostshim" :expr "(do (__register-class-ctor! \"Box4\" (fn [] (jolt.host/tagged-table :my/box4))) (__register-instance-check! (fn [cn val] (if (= cn \"Box4\") (= :my/box4 (jolt.host/ref-get val :jolt/type)) nil))) (instance? Box4 \"not-a-box\"))" :expected "false"} {:suite "hostshim" :expr "(jolt.host/table? (jolt.host/tagged-table :t))" :expected "true"} {:suite "hostshim" :expr "(jolt.host/table? \"x\")" :expected "false"} + {:suite "bytes" :expr "(seq (byte-array \"hi\"))" :expected "(104 105)"} + {:suite "bytes" :expr "(seq (byte-array (.getBytes \"AB\" \"UTF-8\")))" :expected "(65 66)"} + {:suite "bytes" :expr "(alength (byte-array (.getBytes \"hello\" \"UTF-8\")))" :expected "5"} + {:suite "bytes" :expr "(String. (byte-array [104 105]))" :expected "hi"} + {:suite "bytes" :expr "(String. (byte-array [104 105]) \"UTF-8\")" :expected "hi"} + {:suite "bytes" :expr "(int (first (String. (byte-array [200]) \"ISO-8859-1\")))" :expected "200"} + {:suite "bytes" :expr "(String. (.getBytes \"round\" \"UTF-8\") \"UTF-8\")" :expected "round"} ]