Skip to content

Instantly share code, notes, and snippets.

Last active Jul 17, 2017
What would you like to do?
LZMA wrapper for Common Lisp
;; CFFI LZMA Wrapper
;; © Michał "phoe" Herda 2017
;; public domain
;; Use the attached file, which is a x64 Linux shared
;; object. To compile the shared library file yourself:
;; 1. Install the official LZMA SDK from Igor Pavlov.
;; 2. Modify /C/Util/Lzma/makefile.gcc, add -fPIC to CFLAGS.
;; 3. Issue make, which will build all object files.
;; 4. Build the .so file:
;; $ gcc -shared -O2 -Wall -D_7ZIP_ST -fPIC -o *.o
;; 5. Put the file anywhere you want and load it with CFFI.
(ql:quickload :cl-autowrap)
(defpackage :lzma (:use :cl :autowrap))
(in-package :lzma)
(import '(cffi:foreign-array-to-lisp cffi:mem-ref))
(c-include "/usr/include/lzma/LzmaDec.h")
(c-include "/usr/include/lzma/LzmaEnc.h")
(cffi:load-foreign-library "/usr/lib/x86_64-linux-gnu/")
(in-package :lzma)
(defcallback lzma-alloc :pointer ((allocptr :pointer) (size size-t))
(declare (ignore allocptr))
(cffi:foreign-alloc :char :count size))
(defcallback lzma-free :void ((allocptr :pointer) (address :pointer))
(declare (ignore allocptr))
(unless (cffi:null-pointer-p address)
(cffi:foreign-free address)))
(defvar *alloc-functions*
(let* ((ptr (cffi:foreign-alloc :pointer :count 2))
(struct (make-i-sz-alloc :ptr ptr)))
(setf (i-sz-alloc.alloc struct) (autowrap:callback 'lzma-alloc)
( struct) (autowrap:callback 'lzma-free))
(defun lzma-compress (array)
(let ((dest-len (truncate (max 1024 (* (length array) 1.5)))))
(src array `(:array :unsigned-char ,(length array)))
(with-many-alloc ((dest :unsigned-char dest-len)
(dest-len-ptr :unsigned-int 1))
(setf (cffi:mem-ref dest-len-ptr :unsigned-int) dest-len)
(%lzma-compress dest dest-len-ptr src (length array))))))
(defun %lzma-compress (dest dest-len src src-len)
(flet ((byte-array (length) `(:array :unsigned-char ,length))
(init-props (props input-size)
(let ((dict-size (min input-size (expt 2 20))))
(lzma-enc-props-init (c-lzma-enc-props-ptr props))
(setf (c-lzma-enc-props.dict-size props) dict-size
(c-lzma-enc-props.fb props) 40))))
(with-many-alloc ((props 'c-lzma-enc-props 1)
(props-size :unsigned-int)
(props-encoded :unsigned-char 5))
(init-props props src-len)
(setf (mem-ref props-size :unsigned-int) 5)
(let ((status (lzma-encode dest dest-len src src-len
props props-encoded props-size
0 (cffi:null-pointer)
(i-sz-alloc-ptr *alloc-functions*)
(i-sz-alloc-ptr *alloc-functions*))))
(unless (= status +sz-ok+)
(error "LZMA compression failed with code ~D." status))
(let ((output-length (mem-ref dest-len :unsigned-char)))
(values (foreign-array-to-lisp dest (byte-array output-length))
(foreign-array-to-lisp props-encoded (byte-array 5))
(defun lzma-decompress (array props-encoded unc-len)
(assert (< unc-len (* 256 1024 1024)))
(cffi:with-foreign-array (src array `(:array :unsigned-char ,(length array)))
(cffi:with-foreign-array (props props-encoded '(:array :unsigned-char 5))
(with-many-alloc ((e-lzma-status 'e-lzma-status 1)
(proc-out-size :unsigned-long 1)
(proc-in-size :unsigned-long 1)
(dest :unsigned-char (+ 1024 unc-len)))
(setf (mem-ref proc-out-size :unsigned-long) unc-len
(mem-ref proc-in-size :unsigned-long) (length array))
(let ((status (lzma-decode dest proc-out-size src proc-in-size
props 5 +lzma-finish-end+
(i-sz-alloc-ptr *alloc-functions*))))
(let ((act-len (mem-ref proc-out-size :unsigned-int)))
(unless (= unc-len act-len)
(error "Expected to uncompress ~D bytes, but got ~D bytes."
unc-len act-len))
(unless (= status +sz-ok+)
(error "LZMA compression failed with code ~D." status))
(foreign-array-to-lisp dest `(:array :unsigned-char ,unc-len))))))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment