Merge pull request #169 from jolt-lang/spike/chez-bootstrap
Library class-shim host hooks + FFI byte I/O; remove built-in http-client
This commit is contained in:
Dmitri Sotnikov
GitHub
commit
74cdd3c1a0
11 changed files with 232 additions and 170 deletions
|
|
@ -20,7 +20,6 @@
|
|||
(load "host/chez/seed/image.ss")
|
||||
(load "host/chez/compile-eval.ss")
|
||||
(load "host/chez/png.ss") ; jolt.png — a baked namespace before the snapshot
|
||||
(load "host/chez/http-client.ss") ; jolt.http-client (libcurl)
|
||||
(load "host/chez/loader.ss")
|
||||
;; jolt.ffi host primitives (memory / library loading) load AFTER the loader's
|
||||
;; baked-ns snapshot, so a library's (require '[jolt.ffi]) still loads jolt.ffi's
|
||||
|
|
|
|||
|
|
@ -80,6 +80,23 @@
|
|||
(def-var! "jolt.ffi" "read-bytes" ffi-read-bytes)
|
||||
(def-var! "jolt.ffi" "write-bytes" ffi-write-bytes)
|
||||
|
||||
;; --- byte-array buffer I/O (binary-faithful) --------------------------------
|
||||
;; Move raw bytes between a jolt byte-array (jolt-array kind 'byte) and foreign
|
||||
;; memory, byte-exact (no UTF-8 / latin1 decode) — for socket recv/send and the
|
||||
;; zlib / OpenSSL buffers an HTTP client passes through. read-array returns a
|
||||
;; fresh byte-array of n bytes; write-array copies a byte-array's bytes into ptr
|
||||
;; and returns the count.
|
||||
(define (ffi-read-array ptr n)
|
||||
(let* ((n (jnum->exact n)) (p (jnum->exact ptr)) (v (make-vector n 0)))
|
||||
(do ((i 0 (+ i 1))) ((= i n)) (vector-set! v i (foreign-ref 'unsigned-8 p i)))
|
||||
(make-jolt-array v 'byte)))
|
||||
(define (ffi-write-array ptr arr)
|
||||
(let* ((v (jolt-array-vec arr)) (n (vector-length v)) (p (jnum->exact ptr)))
|
||||
(do ((i 0 (+ i 1))) ((= i n)) (foreign-set! 'unsigned-8 p i (bitwise-and (exact (vector-ref v i)) #xff)))
|
||||
n))
|
||||
(def-var! "jolt.ffi" "read-array" ffi-read-array)
|
||||
(def-var! "jolt.ffi" "write-array" ffi-write-array)
|
||||
|
||||
;; --- string / bytevector marshaling ------------------------------------------
|
||||
;; A C string result already comes back as a jolt string (the `string` foreign
|
||||
;; type). For a `void*` that points at a NUL-terminated C string, read it here.
|
||||
|
|
|
|||
|
|
@ -49,7 +49,16 @@
|
|||
("Charset" . "java.nio.charset.Charset") ("Base64" . "java.util.Base64")
|
||||
("Exception" . "java.lang.Exception")
|
||||
("IllegalArgumentException" . "java.lang.IllegalArgumentException")
|
||||
("IllegalStateException" . "java.lang.IllegalStateException")
|
||||
("RuntimeException" . "java.lang.RuntimeException")
|
||||
("UnsupportedOperationException" . "java.lang.UnsupportedOperationException")
|
||||
("InterruptedException" . "java.lang.InterruptedException")
|
||||
("IOException" . "java.io.IOException")
|
||||
("UnknownHostException" . "java.net.UnknownHostException")
|
||||
("ConnectException" . "java.net.ConnectException")
|
||||
("SocketTimeoutException" . "java.net.SocketTimeoutException")
|
||||
("MalformedURLException" . "java.net.MalformedURLException")
|
||||
("SSLException" . "javax.net.ssl.SSLException")
|
||||
("Throwable" . "java.lang.Throwable")))
|
||||
(for-each
|
||||
(lambda (pair) (def-var! "clojure.core" (car pair) (cdr pair)))
|
||||
|
|
@ -74,4 +83,11 @@
|
|||
'("java.lang.Long" "java.lang.Integer" "java.lang.Double" "java.lang.Float"
|
||||
"java.lang.Number" "java.lang.String" "java.lang.Boolean" "java.lang.Character"
|
||||
"java.lang.Object"
|
||||
;; exception classes compared against (class e): (= java.net.SocketTimeoutException (class e))
|
||||
"java.lang.Exception" "java.lang.Throwable" "java.lang.RuntimeException"
|
||||
"java.lang.IllegalArgumentException" "java.lang.IllegalStateException"
|
||||
"java.lang.UnsupportedOperationException" "java.io.IOException"
|
||||
"java.net.UnknownHostException" "java.net.ConnectException"
|
||||
"java.net.SocketTimeoutException" "java.net.MalformedURLException"
|
||||
"javax.net.ssl.SSLException"
|
||||
"clojure.lang.Keyword" "clojure.lang.Symbol" "clojure.lang.Ratio" "clojure.lang.Atom"))
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
@ -561,7 +583,9 @@
|
|||
(let loop ((l lst) (i 0)) (if (null? l) bv (begin (bytevector-u8-set! bv i (car l)) (loop (cdr l) (+ i 1)))))))
|
||||
(register-class-statics! "URLEncoder" (list (cons "encode" url-encode)))
|
||||
(register-class-statics! "URLDecoder" (list (cons "decode" url-decode)))
|
||||
(register-class-statics! "Charset" (list (cons "forName" (lambda (nm) (make-jhost "charset" (list (cons 'name nm)))))))
|
||||
;; Charset/forName yields the canonical name STRING (not an opaque object) so it
|
||||
;; threads straight into (.getBytes s cs) / (String. bytes cs), which take a name.
|
||||
(register-class-statics! "Charset" (list (cons "forName" (lambda (nm) (jolt-str-render-one nm)))))
|
||||
|
||||
;; ---- Base64 (RFC 4648) ------------------------------------------------------
|
||||
(define b64-alphabet "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
|
||||
|
|
@ -657,4 +681,57 @@
|
|||
(def-var! "clojure.core" "__register-class-ctor!"
|
||||
(lambda (name proc) (register-class-ctor! name proc) jolt-nil))
|
||||
(def-var! "clojure.core" "__register-class-statics!"
|
||||
(lambda (name members) (register-class-statics! name (jmap->static-alist members)) jolt-nil))
|
||||
(lambda (name members) (register-class-statics! name (jmap->static-alist members)) jolt-nil))
|
||||
|
||||
;; ---- tagged-table method dispatch + pluggable instance? --------------------
|
||||
;; A jolt library can build stateful host objects with (jolt.host/tagged-table
|
||||
;; tag) and dispatch (.method obj ...) to handlers registered here, keyed by the
|
||||
;; table's "jolt/type" tag — the htable analogue of the jhost method registry
|
||||
;; above. jolt-lang/http-client uses this to emulate java.net URL /
|
||||
;; HttpURLConnection / java.io byte streams so clj-http-lite runs unchanged.
|
||||
(define tagged-methods-tbl (make-hashtable string-hash string=?)) ; tag-key -> (method-ht)
|
||||
(define (tag->method-key tag)
|
||||
(if (keyword-t? tag)
|
||||
(let ((ns (keyword-t-ns tag)))
|
||||
(if (and ns (not (jolt-nil? ns))) (string-append ns "/" (keyword-t-name tag)) (keyword-t-name tag)))
|
||||
(jolt-str-render-one tag)))
|
||||
(define (register-tagged-methods! tag members)
|
||||
(let* ((key (tag->method-key tag))
|
||||
(h (or (hashtable-ref tagged-methods-tbl key #f)
|
||||
(let ((nh (make-hashtable string-hash string=?)))
|
||||
(hashtable-set! tagged-methods-tbl key nh) nh))))
|
||||
(for-each (lambda (p) (hashtable-set! h (car p) (cdr p))) members)))
|
||||
|
||||
;; htable arm: dispatch (.method obj a*) through the table's tag method registry;
|
||||
;; an unregistered method falls through (sorted colls are htables too).
|
||||
(define %hs-rmd-htable record-method-dispatch)
|
||||
(set! record-method-dispatch
|
||||
(lambda (obj method-name rest-args)
|
||||
(let ((tag (and (htable? obj) (hashtable-ref (htable-h obj) "jolt/type" #f))))
|
||||
(let* ((mh (and tag (hashtable-ref tagged-methods-tbl (tag->method-key tag) #f)))
|
||||
(f (and mh (hashtable-ref mh method-name #f))))
|
||||
(if f
|
||||
(apply f obj (if (jolt-nil? rest-args) '() (seq->list rest-args)))
|
||||
(%hs-rmd-htable obj method-name rest-args))))))
|
||||
|
||||
(def-var! "clojure.core" "__register-class-methods!"
|
||||
(lambda (tag members) (register-tagged-methods! tag (jmap->static-alist members)) jolt-nil))
|
||||
|
||||
;; Pluggable instance? — a library registers (fn [class-name-string val] -> true
|
||||
;; | false | nil); nil means "not my class, fall through". First non-nil wins.
|
||||
(define user-instance-checks '())
|
||||
(define %hs-instance-check instance-check)
|
||||
(set! instance-check
|
||||
(lambda (type-sym val)
|
||||
(let ((tname (symbol-t-name type-sym)))
|
||||
(let loop ((fs user-instance-checks))
|
||||
(if (null? fs)
|
||||
(%hs-instance-check type-sym val)
|
||||
(let ((r ((car fs) tname val)))
|
||||
(if (jolt-nil? r) (loop (cdr fs)) (if (jolt-truthy? r) #t #f))))))))
|
||||
(def-var! "clojure.core" "instance-check" instance-check)
|
||||
(def-var! "clojure.core" "__register-instance-check!"
|
||||
(lambda (f) (set! user-instance-checks (append user-instance-checks (list f))) jolt-nil))
|
||||
|
||||
;; (jolt.host/table? x) — is x a host tagged-table (the Janet-table replacement)?
|
||||
(def-var! "jolt.host" "table?" (lambda (x) (if (htable? x) #t #f)))
|
||||
|
|
@ -176,3 +176,12 @@
|
|||
((htable-sorted-set? obj) '("PersistentTreeSet" "Sorted" "IPersistentSet"
|
||||
"Set" "java.util.Set" "Collection" "IPersistentCollection" "Object"))
|
||||
(else (%h-value-host-tags obj)))))
|
||||
|
||||
;; (class e) on a throwable tagged-table (a library's ex-info envelope carrying a
|
||||
;; JVM :class, e.g. jolt-lang/http-client's UnknownHostException) reads that
|
||||
;; class name, so clojure.test's (thrown? Class …) / (= Class (class e)) match.
|
||||
(define %h-class jolt-class)
|
||||
(set! jolt-class (lambda (x)
|
||||
(let ((c (and (htable? x) (hashtable-ref (htable-h x) "class" #f))))
|
||||
(if (and c (string? c)) c (%h-class x)))))
|
||||
(def-var! "clojure.core" "class" jolt-class)
|
||||
|
|
|
|||
|
|
@ -1,160 +0,0 @@
|
|||
;; http-client.ss (jolt-90sp) — jolt.http-client: a synchronous HTTP client.
|
||||
;;
|
||||
;; Backed by the system `curl` binary rather than a direct libcurl FFI: on Apple
|
||||
;; Silicon curl_easy_setopt is variadic and its value arg goes on the stack, where
|
||||
;; Chez's fixed-signature foreign-procedure can't place it (it would need a
|
||||
;; compiled C shim per platform). Shelling to curl uses the same mature native
|
||||
;; library — TLS, redirects, gzip and all — with no build step and identical
|
||||
;; behavior across platforms. Returns a Ring-ish {:status :headers :body}.
|
||||
;;
|
||||
;; def-var!'d into the jolt.http-client namespace; loaded by the CLI before the
|
||||
;; loader snapshot, so (require '[jolt.http-client]) resolves with no source file.
|
||||
|
||||
;; single-quote an argument for the outer `sh -c` (loader.ss's sh-quote isn't
|
||||
;; loaded yet at this point).
|
||||
(define (hc-shq s)
|
||||
(string-append "'"
|
||||
(apply string-append
|
||||
(map (lambda (c) (if (char=? c #\') "'\\''" (string c))) (string->list s)))
|
||||
"'"))
|
||||
|
||||
(define hc-status-sentinel "\nJOLTHTTPSTATUS:")
|
||||
|
||||
(define kw-method (keyword #f "method"))
|
||||
(define kw-url (keyword #f "url"))
|
||||
(define kw-headers (keyword #f "headers"))
|
||||
(define kw-body (keyword #f "body"))
|
||||
(define kw-insecure (keyword #f "insecure?"))
|
||||
(define kw-follow (keyword #f "follow?"))
|
||||
(define kw-timeout (keyword #f "timeout-ms"))
|
||||
(define kw-status (keyword #f "status"))
|
||||
(define kw-query (keyword #f "query-params"))
|
||||
(define kw-ctype (keyword #f "content-type"))
|
||||
|
||||
;; :content-type :json -> "application/json"; a string passes through.
|
||||
(define (hc-ctype->str ct)
|
||||
(cond ((keyword? ct)
|
||||
(let ((n (keyword-t-name ct)))
|
||||
(cond ((string=? n "json") "application/json")
|
||||
((string=? n "xml") "application/xml")
|
||||
((string=? n "form") "application/x-www-form-urlencoded")
|
||||
(else n))))
|
||||
(else (jolt-str-render-one ct))))
|
||||
|
||||
;; A per-request header file path, unique across processes (PID) and threads (a
|
||||
;; mutex-guarded monotonic counter). The previous unguarded `set!` + `mod 90000`
|
||||
;; raced: concurrent callers could compute the same path and clobber each other's
|
||||
;; -D header dump. getpid is a fast, non-blocking foreign call.
|
||||
(define c-getpid (begin (load-shared-object #f) (foreign-procedure "getpid" () int)))
|
||||
(define hc-tmp-mutex (make-mutex))
|
||||
(define hc-tmp-counter 0)
|
||||
(define (hc-tmp-path)
|
||||
(let ((n (with-mutex hc-tmp-mutex (set! hc-tmp-counter (+ hc-tmp-counter 1)) hc-tmp-counter)))
|
||||
(string-append (or (getenv "TMPDIR") "/tmp") "/jolt-http-"
|
||||
(number->string (c-getpid)) "-" (number->string n) ".hdr")))
|
||||
|
||||
(define (hc-trim s)
|
||||
(let* ((n (string-length s))
|
||||
(a (let lp ((i 0)) (if (and (< i n) (char-whitespace? (string-ref s i))) (lp (+ i 1)) i)))
|
||||
(b (let lp ((i n)) (if (and (> i a) (char-whitespace? (string-ref s (- i 1)))) (lp (- i 1)) i))))
|
||||
(substring s a b)))
|
||||
(define (hc-lines s)
|
||||
(let loop ((i 0) (start 0) (acc '()))
|
||||
(cond ((>= i (string-length s)) (reverse (if (> i start) (cons (substring s start i) acc) acc)))
|
||||
((char=? (string-ref s i) #\newline)
|
||||
(loop (+ i 1) (+ i 1) (if (> i start) (cons (substring s start i) acc) acc)))
|
||||
(else (loop (+ i 1) start acc)))))
|
||||
;; raw header dump (curl -D) -> a jolt map {lowercased-name -> value}. With
|
||||
;; redirects there are several blocks; the LAST status line resets the map so the
|
||||
;; final response's headers win.
|
||||
(define (hc-parse-headers text)
|
||||
(let ((m (jolt-hash-map)))
|
||||
(for-each
|
||||
(lambda (raw)
|
||||
(let ((line (hc-trim raw)))
|
||||
(cond
|
||||
((= 0 (string-length line)) #t)
|
||||
((and (>= (string-length line) 5) (string=? (substring line 0 5) "HTTP/"))
|
||||
(set! m (jolt-hash-map))) ; new response block
|
||||
(else
|
||||
(let ((ci (let scan ((i 0)) (cond ((>= i (string-length line)) #f)
|
||||
((char=? (string-ref line i) #\:) i)
|
||||
(else (scan (+ i 1)))))))
|
||||
(when (and ci (> ci 0))
|
||||
(set! m (jolt-assoc m (ascii-string-down (hc-trim (substring line 0 ci)))
|
||||
(hc-trim (substring line (+ ci 1) (string-length line)))))))))))
|
||||
(hc-lines text))
|
||||
m))
|
||||
|
||||
(define (hc-split-status out)
|
||||
;; out ends with "\nJOLTHTTPSTATUS:<code>"; return (values body code-int).
|
||||
(let ((idx (let ((sl (string-length hc-status-sentinel)) (ol (string-length out)))
|
||||
(let scan ((i (- ol sl)))
|
||||
(cond ((< i 0) #f)
|
||||
((string=? (substring out i (+ i sl)) hc-status-sentinel) i)
|
||||
(else (scan (- i 1))))))))
|
||||
(if idx
|
||||
(values (substring out 0 idx)
|
||||
(or (string->number (hc-trim (substring out (+ idx (string-length hc-status-sentinel))
|
||||
(string-length out)))) 0))
|
||||
(values out 0))))
|
||||
|
||||
(define (hc-request method url opts)
|
||||
(when (or (not url) (jolt-nil? url)) (error #f "jolt.http-client: missing :url"))
|
||||
(let* ((headers (jolt-get opts kw-headers))
|
||||
(body (let ((x (jolt-get opts kw-body))) (and (not (jolt-nil? x)) x)))
|
||||
(insecure? (jolt-truthy? (jolt-get opts kw-insecure)))
|
||||
(follow? (let ((x (jolt-get opts kw-follow))) (or (jolt-nil? x) (jolt-truthy? x))))
|
||||
(timeout (let ((x (jolt-get opts kw-timeout))) (if (jolt-nil? x) 30 (quotient (jnum->exact x) 1000))))
|
||||
(hdrfile (hc-tmp-path))
|
||||
(parts (list "curl -sS"
|
||||
(if follow? "-L" "")
|
||||
(if insecure? "-k" "")
|
||||
"--max-time" (number->string (max 1 timeout))
|
||||
"-D" (hc-shq hdrfile)
|
||||
"-X" (hc-shq (string-upcase method))
|
||||
"-w" (hc-shq (string-append hc-status-sentinel "%{http_code}"))
|
||||
"--compressed"))
|
||||
(ctype (let ((x (jolt-get opts kw-ctype))) (and (not (jolt-nil? x)) (hc-ctype->str x))))
|
||||
(parts (if ctype (append parts (list "-H" (hc-shq (string-append "Content-Type: " ctype)))) parts))
|
||||
(parts (if (pmap? headers)
|
||||
(append parts (pmap-fold headers
|
||||
(lambda (k v acc)
|
||||
(cons "-H" (cons (hc-shq (string-append (jolt-str-render-one k) ": "
|
||||
(jolt-str-render-one v))) acc)))
|
||||
'()))
|
||||
parts))
|
||||
;; query-params: let curl URL-encode them onto the URL (-G appends as the
|
||||
;; query string for a GET).
|
||||
(qp (let ((x (jolt-get opts kw-query))) (and (pmap? x) x)))
|
||||
(parts (if qp
|
||||
(append parts
|
||||
(cons "-G"
|
||||
(pmap-fold qp (lambda (k v acc)
|
||||
(cons "--data-urlencode"
|
||||
(cons (hc-shq (string-append (jolt-str-render-one k) "="
|
||||
(jolt-str-render-one v))) acc)))
|
||||
'())))
|
||||
parts))
|
||||
(parts (if body (append parts (list "--data-binary" (hc-shq (jolt-str-render-one body)))) parts))
|
||||
(parts (append parts (list (hc-shq (jolt-str-render-one url)))))
|
||||
(cmd (let join ((xs parts) (s "")) (if (null? xs) s
|
||||
(join (cdr xs) (if (string=? (car xs) "") s (string-append s (if (string=? s "") "" " ") (car xs)))))))
|
||||
(out (jolt-sh-out cmd)))
|
||||
(let-values (((bdy code) (hc-split-status out)))
|
||||
(let ((hdr-text (guard (e (#t "")) (read-file-string hdrfile))))
|
||||
(guard (e (#t #f)) (delete-file hdrfile))
|
||||
(jolt-hash-map kw-status code
|
||||
kw-headers (hc-parse-headers hdr-text)
|
||||
kw-body bdy)))))
|
||||
|
||||
;; --- public jolt.http-client API --------------------------------------------
|
||||
(define (hc-verb method) (lambda (url . opt) (hc-request method url (if (pair? opt) (car opt) (jolt-hash-map)))))
|
||||
(def-var! "jolt.http-client" "request"
|
||||
(lambda (opts) (hc-request (let ((m (jolt-get opts kw-method))) (if (jolt-nil? m) "GET" (jolt-str-render-one m)))
|
||||
(jolt-get opts kw-url) opts)))
|
||||
(def-var! "jolt.http-client" "get" (hc-verb "GET"))
|
||||
(def-var! "jolt.http-client" "head" (hc-verb "HEAD"))
|
||||
(def-var! "jolt.http-client" "post" (hc-verb "POST"))
|
||||
(def-var! "jolt.http-client" "put" (hc-verb "PUT"))
|
||||
(def-var! "jolt.http-client" "delete" (hc-verb "DELETE"))
|
||||
|
|
@ -151,10 +151,32 @@
|
|||
((reader-jhost? rdr) (drain-reader rdr))
|
||||
(else (jolt-str-render-one rdr))))))
|
||||
|
||||
;; (slurp src :encoding "...") — pull the charset from the trailing kwargs.
|
||||
(define (slurp-encoding opts)
|
||||
(let loop ((o opts))
|
||||
(cond ((or (null? o) (null? (cdr o))) '())
|
||||
((and (keyword-t? (car o)) (string=? (keyword-t-name (car o)) "encoding"))
|
||||
(list (jolt-str-render-one (cadr o))))
|
||||
(else (loop (cddr o))))))
|
||||
;; drain a byte input-stream shim (tagged-table) one byte at a time to a bytevector.
|
||||
(define (drain-byte-stream src)
|
||||
(let loop ((acc '()))
|
||||
(let ((b (record-method-dispatch src "read" jolt-nil)))
|
||||
(if (or (jolt-nil? b) (and (number? b) (< b 0)))
|
||||
(u8-list->bytevector (reverse acc))
|
||||
(loop (cons (bitwise-and (jnum->exact b) #xff) acc))))))
|
||||
(define (jolt-slurp src . opts)
|
||||
(cond
|
||||
((jfile? src) (read-file-string (jfile-path src)))
|
||||
((reader-jhost? src) (drain-reader src))
|
||||
;; bytes (a bytevector or a jolt byte-array): decode with :encoding (UTF-8
|
||||
;; default). clj-http-lite slurps response-body byte arrays.
|
||||
((bytevector? src) (decode-bytevector src (slurp-encoding opts)))
|
||||
((and (jolt-array? src) (eq? (jolt-array-kind src) 'byte))
|
||||
(decode-bytevector (na-bytearray->bv src) (slurp-encoding opts)))
|
||||
;; a byte input-stream shim (e.g. clj-http-lite's :as :stream body): drain it.
|
||||
((and (htable? src) (jolt-truthy? (jolt-ref-get src (keyword "jolt" "input-stream"))))
|
||||
(decode-bytevector (drain-byte-stream src) (slurp-encoding opts)))
|
||||
((string? src) (read-file-string src))
|
||||
(else (error #f "slurp: unsupported source" src))))
|
||||
|
||||
|
|
@ -230,6 +252,9 @@
|
|||
((jolt-nil? x) jolt-nil)
|
||||
((and (jhost? x) (member (jhost-tag x) '("string-reader" "pushback-reader" "writer")))
|
||||
(record-method-dispatch x "close" jolt-nil) jolt-nil)
|
||||
;; a library's stream shim (tagged-table) closes via its registered .close
|
||||
;; method (a no-op for in-memory streams); absent method -> no-op.
|
||||
((htable? x) (guard (e (#t jolt-nil)) (record-method-dispatch x "close" jolt-nil)) jolt-nil)
|
||||
((jfile? x) jolt-nil)
|
||||
(else
|
||||
(let ((closef (jolt-get x (keyword #f "close") jolt-nil)))
|
||||
|
|
@ -284,4 +309,11 @@
|
|||
((file-exists? (string-append (car roots) "/" nm)) (make-jfile (string-append (car roots) "/" nm)))
|
||||
(else (loop (cdr roots)))))))
|
||||
(def-var! "clojure.java.io" "resource" jolt-io-resource)
|
||||
(def-var! "clojure.java.io" "as-url" (lambda (x) (if (and (jhost? x) (string=? (jhost-tag x) "url")) x (make-url (jolt-str-render-one x)))))
|
||||
;; as-url honors a library-registered URL class (e.g. jolt-lang/http-client's full
|
||||
;; java.net.URL shim) so io/as-url and (URL. spec) agree; else the file-only jhost.
|
||||
(def-var! "clojure.java.io" "as-url"
|
||||
(lambda (x)
|
||||
(cond ((and (jhost? x) (string=? (jhost-tag x) "url")) x)
|
||||
((htable? x) x)
|
||||
(else (let ((ctor (lookup-class class-ctors-tbl "URL")))
|
||||
(if ctor (ctor (jolt-str-render-one x)) (make-url (jolt-str-render-one x))))))))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
@ -195,3 +205,29 @@
|
|||
(cons "chunk" na-chunk) (cons "chunk-cons" na-chunk-cons)
|
||||
(cons "chunk-first" na-chunk-first) (cons "chunk-rest" na-chunk-rest)
|
||||
(cons "chunk-next" na-chunk-next) (cons "chunked-seq?" na-chunked-seq?)))
|
||||
|
||||
;; --- clojure.java.io/copy ---------------------------------------------------
|
||||
;; Copy src -> dst, JVM-style. Raw bytes (byte-array / bytevector / string) and a
|
||||
;; jhost reader write in one shot; any other source (a stream shim with a .read
|
||||
;; method, e.g. jolt-lang/http-client's ByteArrayInputStream) drains via .read
|
||||
;; into a byte-array buffer and .write to dst — both reached through method
|
||||
;; dispatch, so a library's tagged-table streams work without the host knowing
|
||||
;; their layout. Lives here (not io.ss) because io.ss loads before byte-array.
|
||||
(define (jolt-io-copy src dst . _opts)
|
||||
(define (write-all! bytes)
|
||||
(record-method-dispatch dst "write" (list->cseq (list bytes 0 (vector-length (jolt-array-vec bytes))))))
|
||||
(cond
|
||||
((or (bytevector? src) (string? src)
|
||||
(and (jolt-array? src) (eq? (jolt-array-kind src) 'byte)))
|
||||
(write-all! (na-byte-array src)))
|
||||
((and (jhost? src) (member (jhost-tag src) '("string-reader" "pushback-reader")))
|
||||
(write-all! (na-byte-array (drain-reader src))))
|
||||
(else
|
||||
(let ((buf (na-byte-array 8192)))
|
||||
(let loop ()
|
||||
(let ((n (record-method-dispatch src "read" (list->cseq (list buf 0 8192)))))
|
||||
(when (and (number? n) (> (jnum->exact n) 0))
|
||||
(record-method-dispatch dst "write" (list->cseq (list buf 0 n)))
|
||||
(loop)))))))
|
||||
jolt-nil)
|
||||
(def-var! "clojure.java.io" "copy" jolt-io-copy)
|
||||
|
|
|
|||
|
|
@ -117,7 +117,17 @@
|
|||
(string=? (ascii-string-down s) (ascii-string-down (arg 0))))
|
||||
((string=? method "compareTo")
|
||||
(let ((o (arg 0))) (cond ((string<? s o) -1.0) ((string>? s o) 1.0) (else 0.0))))
|
||||
((string=? method "getBytes") (string->utf8 s))
|
||||
((string=? method "getBytes")
|
||||
;; (.getBytes s) / (.getBytes s charset). UTF-8 default; ISO-8859-1/latin1/
|
||||
;; ascii encode one byte per char (clj-http-lite's body-encoding path).
|
||||
(if (null? rest)
|
||||
(string->utf8 s)
|
||||
(let ((cn (ascii-string-down (if (string? (arg 0)) (arg 0) (jolt-str-render-one (arg 0))))))
|
||||
(if (member cn '("iso-8859-1" "latin1" "iso8859-1" "us-ascii" "ascii"))
|
||||
(let* ((n (string-length s)) (bv (make-bytevector n)))
|
||||
(do ((i 0 (+ i 1))) ((= i n) bv)
|
||||
(bytevector-u8-set! bv i (bitwise-and (char->integer (string-ref s i)) #xff))))
|
||||
(string->utf8 s)))))
|
||||
((string=? method "matches") (if (irregex-match (str-irx (arg 0)) s) #t #f))
|
||||
((string=? method "replaceAll") (irregex-replace/all (str-irx (arg 0)) s (arg 1)))
|
||||
((string=? method "replaceFirst") (irregex-replace (str-irx (arg 0)) s (arg 1)))
|
||||
|
|
|
|||
|
|
@ -39,6 +39,19 @@
|
|||
(let [v (jolt.ffi/read p :int)] (jolt.ffi/free p) v))"))))
|
||||
(ok "sizeof :pointer is a word" (let ((n (jnum->exact (ev "(jolt.ffi/sizeof :pointer)")))) (or (= n 8) (= n 4))))
|
||||
|
||||
;; byte-array buffer I/O: write a byte-array into foreign memory and read it back
|
||||
;; byte-exact (high bytes preserved, no UTF-8 mangling).
|
||||
(ok "byte-array roundtrip (binary-faithful)"
|
||||
(jolt-truthy?
|
||||
(ev "(let [src (byte-array [0 65 200 255 10])
|
||||
p (jolt.ffi/alloc 5)]
|
||||
(jolt.ffi/write-array p src)
|
||||
(let [back (jolt.ffi/read-array p 5)]
|
||||
(jolt.ffi/free p)
|
||||
(and (= 5 (alength back))
|
||||
(= 0 (aget back 0)) (= 65 (aget back 1))
|
||||
(= 200 (aget back 2)) (= 255 (aget back 3)) (= 10 (aget back 4)))))")))
|
||||
|
||||
;; a :blocking foreign call is collect-safe: a thread parked in it must not pin
|
||||
;; the stop-the-world collector. (collect) here would throw "cannot collect when
|
||||
;; multiple threads are active" if usleep weren't emitted __collect_safe.
|
||||
|
|
|
|||
|
|
@ -459,4 +459,17 @@
|
|||
{:suite "deftype-mutable" :expr "(do (defprotocol IB (gv [_]) (sv [_ v])) (deftype B [^:unsynchronized-mutable val] IB (gv [_] val) (sv [_ v] (set! val v))) (let [b (->B 1)] (sv b 42) (gv b)))" :expected "42"}
|
||||
{:suite "deftype-mutable" :expr "(do (defprotocol IC (bump [_]) (cur [_])) (deftype C [^:unsynchronized-mutable n] IC (bump [this] (set! n (inc n)) n) (cur [_] n)) (let [c (->C 5)] (bump c) (bump c) (bump c) (cur c)))" :expected "8"}
|
||||
{:suite "deftype-mutable" :expr "(do (defprotocol IH (g [_]) (s [_ v])) (deftype H [^:volatile-mutable st] IH (g [_] st) (s [this v] (set! (.-st this) v))) (let [h (->H :old)] (s h :new) (g h)))" :expected ":new"}
|
||||
{:suite "hostshim" :expr "(do (__register-class-ctor! \"Box1\" (fn [v] (let [t (jolt.host/tagged-table :my/box)] (jolt.host/ref-put! t :v v) t))) (__register-class-methods! :my/box {\"getV\" (fn [self] (jolt.host/ref-get self :v))}) (.getV (Box1. 42)))" :expected "42"}
|
||||
{:suite "hostshim" :expr "(do (__register-class-ctor! \"Box2\" (fn [v] (let [t (jolt.host/tagged-table :my/box2)] (jolt.host/ref-put! t :v v) t))) (__register-class-methods! :my/box2 {\"add\" (fn [self n] (+ n (jolt.host/ref-get self :v)))}) (.add (Box2. 10) 5))" :expected "15"}
|
||||
{:suite "hostshim" :expr "(do (__register-class-ctor! \"Box3\" (fn [] (jolt.host/tagged-table :my/box3))) (__register-instance-check! (fn [cn val] (if (= cn \"Box3\") (= :my/box3 (jolt.host/ref-get val :jolt/type)) nil))) (instance? Box3 (Box3.)))" :expected "true"}
|
||||
{: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"}
|
||||
]
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue