;; jeg tror det er noe galt med input, og derfor at den returnerer ;; data_error og ikke klarer fylle bufferen mere. dette må ryddes opp i 😭 (import (only chicken.port make-input-port make-output-port) (only chicken.type :)) ;;; ;;; ;;; important internal note: chicken's GC must not be allowed to run ;;; between assignments to next_in and next_out struct members and ;;; inflate/deflate calls. (import chicken.foreign srfi-4 (only chicken.memory.representation number-of-bytes) (only chicken.gc set-finalizer!) (only chicken.locative make-locative) (only chicken.port make-input-port make-output-port set-port-name!) (only chicken.io read-string! write-string) (only chicken.memory move-memory!)) (foreign-declare "#include ") (define zlib-level/default (foreign-value "Z_DEFAULT_COMPRESSION" int)) (define zlib-level/no (foreign-value "Z_NO_COMPRESSION" int)) (define zlib-level/best (foreign-value "Z_BEST_COMPRESSION" int)) (define zlib-level/fast (foreign-value "Z_BEST_SPEED" int)) (define zlib-flush/no (foreign-value "Z_NO_FLUSH" int)) (define zlib-flush/partial (foreign-value "Z_PARTIAL_FLUSH" int)) (define zlib-flush/sync (foreign-value "Z_SYNC_FLUSH" int)) (define zlib-flush/full (foreign-value "Z_FULL_FLUSH" int)) (define zlib-flush/finish (foreign-value "Z_FINISH" int)) (define zlib-flush/block (foreign-value "Z_BLOCK" int)) (define zlib-flush/trees (foreign-value "Z_TREES" int)) (define zlib-mem-level/max (foreign-value "MAX_MEM_LEVEL" int)) (define zlib-wbits/max (foreign-value "MAX_WBITS" int)) (define zlib-method/deflated (foreign-value "Z_DEFLATED" int)) (define zlib-strategy/default (foreign-value "Z_DEFAULT_STRATEGY" int)) (define zlib-strategy/filtered (foreign-value "Z_FILTERED" int)) (define zlib-strategy/huffman-only (foreign-value "Z_HUFFMAN_ONLY" int)) (define zlib-strategy/rle (foreign-value "Z_RLE" int)) (define zlib-strategy/fixed (foreign-value "Z_FIXED" int)) (define sizeof-z_stream (foreign-value "sizeof(z_stream)" size_t)) (define (zlib-level->int x) (if (number? x) x (case x ((#f default) zlib-level/default) ((no) zlib-level/no) ((best) zlib-level/best) ((fast best-speed) zlib-level/fast) (else (error 'zlib-level->int "unknown zlib compresison level, expecting 0-9 or: #f/default no best fast" x))))) (define (zlib-flush->int x) (if (number? x) x (case x ((no #f) zlib-flush/no) ((partial) zlib-flush/partial) ((sync) zlib-flush/sync) ((full) zlib-flush/full) ((finish) zlib-flush/finish) ((block) zlib-flush/block) ((trees) zlib-flush/trees) (else (error 'zlib-flush->int "unknown zlib flush, expecting number? or: no/#f partial sync full finish block trees" x))))) (define (zlib-mem-level->int x) (if (number? x) x (case x ((max #f) zlib-mem-level/max) (else (error 'zlib-mem-level->int "unknown zlib mem-level, expecting number (of bytes) or max/#f" x))))) (define (zlib-window-bits->int x) (if (number? x) x (case x ((max #f) zlib-wbits/max) (else (error 'zlib-window-bits->int "unknown zlib window-bits -8..-15 for raw deflate, 8..15 for zlib streams or: #f/max" x))))) (define (zlib-method->int x) (if (number? x) x (case x ((deflated default #f) zlib-method/deflated) (else (error 'zlib-method->int "unknown zlib method, expecting number? or the only currently supported method: #f/default/deflated" x))))) (define (zlib-strategy->int x) (if (number? x) x (case x ((default #f) zlib-strategy/default) ((filtered) zlib-strategy/filtered) ((huffman-only) zlib-strategy/huffman-only) ((rle) zlib-strategy/rle) ((fixed) zlib-strategy/fixed) (else (error 'zlib-strategy->int "unknown zlib strategy, expecting number? or: #f/default filtered huffman-only rle fixed" x))))) (define-record-type (%make-zstream struct) zstream? (struct zstream-struct zstream-struct-set!)) ;; (define-record-printer ;; (lambda (x port) ;; (display "#" port))) (define-foreign-type z_streamp (c-pointer "z_stream") (lambda (record) (location (zstream-struct record)))) (define (zlib-error->symbol value) (cond ((= value (foreign-value "Z_OK" int)) 'ok) ((= value (foreign-value "Z_STREAM_END" int)) 'stream-end) ((= value (foreign-value "Z_NEED_DICT" int)) 'need-dict) ((= value (foreign-value "Z_ERRNO" int)) 'errno) ((= value (foreign-value "Z_STREAM_ERROR" int)) 'stream-error) ((= value (foreign-value "Z_DATA_ERROR" int)) 'data-error) ((= value (foreign-value "Z_MEM_ERROR" int)) 'mem-error) ((= value (foreign-value "Z_BUF_ERROR" int)) 'buf-error) ((= value (foreign-value "Z_VERSION_ERROR" int)) 'version-error) (else (list 'unknown value)))) (define (zlib-check ret location) (if (or (= ret (foreign-value "Z_OK" int)) (= ret (foreign-value "Z_STREAM_END" int)) (= ret (foreign-value "Z_BUF_ERROR" int))) ret (error location "zlib error" (zlib-error->symbol ret)))) (define zstream-avail-in (foreign-lambda* unsigned-int ((z_streamp z)) "return(z->avail_in);")) (define zstream-avail-out (foreign-lambda* unsigned-int ((z_streamp z)) "return(z->avail_out);")) ;; ======================================== INFLATE ======================================== (define (inflate-init window-bits) ;; ,-- no gc! (let ((z (%make-zstream (make-u8vector sizeof-z_stream 0 #t #t)))) (zlib-check ((foreign-lambda int "inflateInit2" z_streamp int) z (zlib-window-bits->int window-bits)) 'inflate-init) z)) (define (inflate-free! z) (when (zstream-struct z) ;; <-- avoid freeing twice! (zlib-check ((foreign-lambda int "inflateEnd" z_streamp) z) 'inflate-free!) (zstream-struct-set! z #f))) ;; returns two values: ;; - new out position ;; - new in position (define (inflate! z out ostart oend in istart iend flush) ;;(warning "inflate: " (list (number-of-bytes out) ostart oend) (list (number-of-bytes in) istart iend)) (let ((ret (zlib-check ( (foreign-lambda* int ((z_streamp z) (scheme-pointer out) (unsigned-int ostart) (unsigned-int oavail) (scheme-pointer in) (unsigned-int istart) (unsigned-int iavail) (int flush)) " z->avail_in = iavail; z->next_in = &(((unsigned char*) in)[istart]); z->avail_out = oavail; z->next_out = &(((unsigned char*)out)[ostart]); // fprintf(stderr, \"\\x1b[33minflate pre avail_in=%d avail_out=%d\\x1b[0m (flush = %d)+\\n\", z->avail_in, z->avail_out, flush); int ret = inflate(z, flush); // fprintf(stderr, \"\\x1b[33minflate pos avail_in=%d avail_out=%d\\x1b[0m (ret = %d)\\n\", z->avail_in, z->avail_out, ret); return(ret);") z out ostart (- oend ostart) in istart (- iend istart) (zlib-flush->int flush)) 'inflate!))) (values (- oend (zstream-avail-out z)) (- iend (zstream-avail-in z))))) ;; copy-pasted from the zstd egg (define (zlib-decompressing-input-port ip #!key window-bits ;; transit buffer for uncompressed data: (buffer (make-string 4096))) (unless (> (number-of-bytes buffer) 0) (error 'zlib-decompressing-input-port "scratch buffer cannot be empty" (number-of-bytes buffer))) (let ((z (inflate-init window-bits)) (eif? #f) ;; <-- signals no more data available for ip (ipos 0) (iend 0)) ;; fill buffer with input data from ip. returns number of ;; additional bytes read into buffer. 0 indicates we have either ;; room for no more input or the input port has reached its eof. (define (fill-buffer!) (if eif? 0 (if (or (>= iend (number-of-bytes buffer)) ;; input buffer is full (zero? iend)) ;; input buffer is empty (begin ;; keep ipos at 0: (when (> ipos 0) (when (> ipos iend) (error "internal error")) (move-memory! buffer buffer (- iend ipos) ipos 0) (set! iend (- iend ipos)) (set! ipos 0)) (let ((num (- (number-of-bytes buffer) iend))) (if (zero? num) ;; no point trying to read 0 bytes 0 ;; ,-- insert into buffer starting here (let ((read (read-string! num buffer ip iend))) (set! iend (+ iend read)) (when (zero? read) (set! eif? #t)) read)))) 0))) ;; call algorithm one or more times, trying to fill dst with len ;; bytes. returns bytes populated into dst, may be smaller than ;; len as we approach eof, and will equal zero when we reached ;; eof. (define (read! dst len opos1) (fill-buffer!) ;; <-- ensures we have > 0 input bytes to z (if (zero? len) 0 ;; <-- this gets inflate grumpy (let ((oend (+ opos1 len))) (let loop ((opos opos1)) (receive (opos ipos0) (inflate! z dst opos oend buffer ipos iend (if eif? 'finish #f)) (set! ipos ipos0) (if (< opos oend) ;; <-- need more data? (if eif? (- opos opos1) (if (zero? (fill-buffer!)) (- opos opos1) ;; <-- don't try reading when we have no more (loop opos))) (- opos opos1))))))) (let ((eof? #f)) ;; <-- port's eof is separate from eif? when port is closed "prematurely" (let* ((buff (make-string 1)) (read-char (lambda () (cond (eof? #!eof) ((> (read! buff 1 0) 0) (string-ref buff 0)) (else #!eof)))) (peek #f) (zip (make-input-port ;; read-char (lambda () (if peek (let ((char peek)) (set! peek #f) char) (read-char))) ;; char-ready? (lambda () #t) ;; close (lambda () (set! eof? #t) (when z (inflate-free! z)) (set! z #f) (set! buffer "") #f) ;; peek-char (lambda () (unless peek (set! peek (read-char))) (when (eq? #!eof peek) (set! eof? #t)) peek) ;; read-string! (lambda (port len str offset) '(print "port read-string: " len " offset " offset) (if eof? 0 (if peek (begin (string-set! str offset peek) (set! peek #f) (+ 1 (read! str (- len 1) (+ offset 1)))) (read! str len offset))))))) (set-port-name! zip "(zlib-decompressing)") zip)))) ;; ======================================== DEFLATE ======================================== ;; from zlib.h: ;; ;; All dynamically allocated data structures for this stream are ;; freed. This function discards any unprocessed input and does not ;; flush any pending output. ;; ;; hence, I decided to name this free as it's not "end" as in ;; end-of-file. (define (deflate-free! z) (when (zstream-struct z) ;; <-- avoid freeing twice! (zlib-check ((foreign-lambda int "deflateEnd" z_streamp) z) 'deflate-free!) (zstream-struct-set! z #f))) (define (deflate-init level method window-bits mem-level strategy set-finalizer) ;; the z_stream struct must not be moved around by the garbage collector because: ;; https://github.com/madler/zlib/blob/84045903ee415efbfaf6d3d443224c2f3a1daea0/deflate.c#L437 ;; ,-- no gc! (let ((z (%make-zstream (make-u8vector sizeof-z_stream 0 #t #t)))) (zlib-check ( (foreign-lambda int "deflateInit2" z_streamp int int int int int) z (zlib-level->int level) (zlib-method->int method) (zlib-window-bits->int window-bits) (zlib-mem-level->int mem-level) (zlib-strategy->int strategy)) 'deflate-init) (set-finalizer z))) ;; we consumed our buffer (define zstream-avail-out-clear! (foreign-lambda* void ((z_streamp z) (unsigned-long val)) "z->avail_out = 0;")) ;; identical to inflate, but call deflate(...) instead. return values: ;; ;; - new out position (next ostart) ;; - new in position (next istart) (define (deflate! z out ostart oend in istart iend flush) (let ((ret (zlib-check ( (foreign-lambda* int ((z_streamp z) (scheme-pointer out) (unsigned-int ostart) (unsigned-int olen) (scheme-pointer in) (unsigned-int istart) (unsigned-int ilen) (int flush)) " z->avail_in = ilen; z->next_in = &(((unsigned char*) in)[istart]); z->avail_out = olen; z->next_out = &(((unsigned char*)out)[ostart]); // printf(\"\\x1b[33mdeflate pre avail_in=%d avail_out=%d\\x1b[0m (flush = %d)\\n\", z->avail_in, z->avail_out, flush); int ret = deflate(z, flush); // printf(\"\\x1b[33mdeflate pos avail_in=%d avail_out=%d\\x1b[0m (ret = %d)\\n\", z->avail_in, z->avail_out, ret); return(ret);") z out ostart (- oend ostart) in istart (- iend istart) (zlib-flush->int flush)) 'deflate!))) (values (- oend (zstream-avail-out z)) (- iend (zstream-avail-in z))))) (define (zlib-compressing-output-port port #!key level method window-bits mem-level strategy (set-finalizer (lambda (x) (set-finalizer! x deflate-free!))) ;; ,-- scratch space for transferring strings (buffer (make-string 4096))) (let ((z (deflate-init level method window-bits mem-level strategy set-finalizer)) (buffer-nob (number-of-bytes buffer))) ;; push string str into the deflate algorithm. this will update ;; z's internal state and maybe put data in our buffer. (define (feed! str flush) (let loop ((ipos 0)) (receive (opos ipos) (deflate! z buffer 0 buffer-nob str ipos (number-of-bytes str) flush) (write-string buffer opos port) (when (or (and (eq? 'finish flush) (> opos 0)) ;; <-- no more input, but maybe more output left (< ipos (number-of-bytes str))) ;; <-- need to process more of our input (loop ipos))))) (let ((op (make-output-port (lambda (str) (feed! str 'no)) ;; write (lambda () (feed! "" 'finish)) ;; close ;; from zlib.h: ;; ;; Flushing may degrade compression for some ;; compression algorithms and so it should be ;; used only when necessary. ;; ;; I don't think that's what most ;; users would want. Let's just ;; postpone all decisions for now ... (lambda () #t)))) (set-port-name! op "(zlib-compressing)") op))) (: open-zlib-compressed-output-port (deprecated zlib-compressing-output-port)) (: open-zlib-compressed-input-port (deprecated zlib-decompressing-input-port)) (define open-zlib-compressed-output-port zlib-compressing-output-port) (define open-zlib-compressed-input-port zlib-decompressing-input-port)