Coverage report: /home/ellis/comp/core/lib/io/flate.lisp

KindCoveredAll%
expression374 4.1
branch04 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; io/flate.lisp --- Compressed IO Interface
2
 
3
 ;; Use compression (ZSTD) with Lisp objects and streams.
4
 
5
 ;;; Commentary:
6
 
7
 ;; compression ref: https://www.xach.com/lisp/salza2/ (compression only)
8
 
9
 ;; decompression ref: https://github.com/sharplispers/chipz (decompression only)
10
 
11
 ;; The libraries above are the current state-of-the-art for compression and
12
 ;; decompression in Common Lisp. They are portable packages which depend on
13
 ;; gray streams. They loosely cover deflate, zlib, gzip, and bzip2 data.
14
 
15
 ;; The compression backends are themselves hand-coded in Common Lisp, making
16
 ;; them excellent reference material. However, we don't have much use for the
17
 ;; compression backends offered.
18
 
19
 ;; We intend to almost exclusively support Zstd compression and decompression
20
 ;; using our ZSTD FFI Lisp system, so we'll make a new library - FLATE - which
21
 ;; provides a shared zstd compression/decompression to Lisp objects and
22
 ;; streams.
23
 
24
 ;;; Code:
25
 (in-package :io/flate)
26
 (zstd:load-zstd)
27
 
28
 ;;; Vars
29
 (defparameter *compression-buffer-size* 4096)
30
 (defparameter *decompression-buffer-size* 4096)
31
 (defparameter *default-compression-level* (zstd:zstd-defaultclevel))
32
 
33
 (defvar *compression-types* 
34
   (list :zstd :gzip :zlib :deflate)
35
   "List of available compression backend types available for use as the value of  *PREFERRED-COMPRESSION-TYPE*.")
36
 
37
 (defvar *preferred-compression-type* :zstd
38
   "Preferred compression backend used by this Lisp system. Must be one of
39
 *COMPRESSION-TYPES* and defaults to :ZSTD.")
40
 
41
 (defvar *compression-level* *default-compression-level*)
42
 (defvar *compressor* nil
43
   "The global COMPRESSOR object.")
44
 (defvar *decompressor* nil
45
   "The global DECOMPRESSOR object.")
46
 ;;; Utils
47
 
48
 ;;; Conditions
49
 (eval-always (deferror flate-error () () (:auto t)))
50
 
51
 (deferror compression-error (flate-error) () (:auto t))
52
 (deferror decompression-error (flate-error) () (:auto t))
53
 
54
 ;;; Proto
55
 (defgeneric decompress (output state input &key &allow-other-keys)
56
   (:documentation "Decompress INPUT using initial STATE, writing to OUTPUT. STATE is either a
57
 DECOMPRESSION-STATE object for deflate-based compression or a
58
 ZSTD-DECOMPRESSOR in the case of zstd."))
59
 
60
 (defgeneric compress (input state &key &allow-other-keys)
61
   (:documentation "Compress INPUT using initial STATE, which may be a COMPRESSION-STATE object
62
 for deflate-based compression or a ZSTD-COMPRESSOR in the case of zstd."))
63
 
64
 (defgeneric finish-compression (self)
65
   (:documentation "Finish the data format and flush all pending
66
   data in the bitstream."))
67
 
68
 (defgeneric finish-decompression (self)
69
   (:documentation "Flush all pending compressed input of decompressor SELF."))
70
 
71
 ;; TODO 2024-06-08: maybe move this to generic io/stream protocol - 'RESET'
72
 
73
 (defgeneric reset-compressor (self)
74
   (:documentation "Reset the state of compressor SELF."))
75
 (defgeneric reset-decompressor (self)
76
   (:documentation "Reset the state of decompressor SELF."))
77
 (defgeneric compress-octet (octet compressor)
78
   (:documentation "Add OCTET to the compressed data of COMPRESSOR."))
79
 
80
 (defgeneric compress-octet-vector (vector compressor &key start end)
81
   (:documentation "Add the octets of VECTOR to the compressed
82
   data of COMPRESSOR."))
83
 
84
 (defgeneric make-compressing-stream (key stream &key &allow-other-keys)
85
   (:documentation "Return a new COMPRESSING-STREAM of kind KEY, optionally wrapping STREAM."))
86
 (defgeneric make-decompressing-stream (key stream &key &allow-other-keys)
87
   (:documentation "Return a new DECOMPRESSING-STREAM of kind KEY, optionally wrapping STREAM."))
88
 
89
 (defgeneric compress-object (obj))
90
 (defgeneric decompress-object (obj))
91
 
92
 (defgeneric compression-level (obj))
93
 (defgeneric (setf compression-level) (new obj))
94
 
95
 (defgeneric compress-with (self obj &key &allow-other-keys))
96
 (defgeneric decompress-with (self obj &key &allow-other-keys))
97
 
98
 (defgeneric compress-octet-vector (vector compressor &key start end))
99
 (defgeneric decompress-octet-vector (vector decompressor &key start end))
100
 
101
 ;;; Compression
102
 (defclass compressor () ((output :initarg :output :accessor output)))
103
 
104
 (defclass compressing-stream (fundamental-binary-output-stream)
105
   ((compressor :initarg :compressor :accessor compressor)))
106
 
107
 (defmethod make-compressing-stream (compressor-class stream &rest args)
108
   (make-instance 'compressing-stream
109
     :compressor (apply 'make-instance compressor-class args)))
110
 
111
 (defmethod stream-write-sequence ((self compressing-stream) seq &optional start end)
112
   (unless (open-stream-p self)
113
     (error 'stream-closed-error :stream self))
114
   (let ((vector (if (typep seq 'vector)
115
                     seq
116
                     (coerce seq 'vector))))
117
     (compress-octet-vector vector (compressor self) :start start :end end))
118
   seq)
119
 
120
 ;;; Decompression
121
 (defclass decompressor () ((input :initarg :input :accessor input)))
122
 
123
 (defclass decompressing-stream (fundamental-binary-input-stream)
124
   ((decompressor :initarg :decompressor :accessor decompressor)))
125
 
126
 (defmethod make-decompressing-stream (decompressor-class stream &rest args)
127
   (make-instance 'decompressing-stream :decompressor (apply 'make-instance decompressor-class args)))
128
 
129
 ;;; Macros
130
 (defmacro with-compressor ((var class
131
                                 &rest initargs
132
                                 &key &allow-other-keys)
133
                            &body body)
134
   `(let ((,var (make-instance ,class ,@initargs)))
135
      (multiple-value-prog1 
136
          (progn ,@body)
137
        (finish-compression ,var))))
138
 
139
 (defmacro with-decompressor ((var class
140
                               &rest initargs
141
                               &key &allow-other-keys)
142
                              &body body)
143
   `(let ((,var (make-instance ,class ,@initargs)))
144
      (multiple-value-prog1
145
          (progn ,@body)
146
        (finish-decompression ,var))))