LZMA wrapper for Common Lisp

lzma.lisp

#|

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; CFFI LZMA Wrapper
;; © Michał "phoe" Herda 2017
;; public domain

;; Use the attached lzma.so 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 lzma.so *.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/lzma.so")

|#

(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)
          (i-sz-alloc.free struct) (autowrap:callback 'lzma-free))
    struct))

(defun lzma-compress (array)
  (let ((dest-len (truncate (max 1024 (* (length array) 1.5)))))
    (cffi:with-foreign-array
        (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))
                  src-len))))))

(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+
                                   e-lzma-status
                                   (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))))))))

lzma.so