Require gray-streams for ABCL in tests

Fixes #3

.github/workflows/build.yml

@@ -0,0 +1,51 @@
+on:
+  push:
+  pull_request:
+    branches: [ master ]
+
+jobs:
+  build:
+    name: Build ${{ matrix.lisp }} on ${{ matrix.os }}
+    strategy:
+      fail-fast: false
+      matrix:
+        lisp: [ sbcl-bin, allegro ]
+        os: [ ubuntu-latest ]
+    runs-on: ${{ matrix.os }}
+    steps:
+      - name: Windows specific settings
+        if: matrix.os == 'windows-latest'
+        run: |
+          git config --global core.autocrlf false
+          echo "ROSWELL_INSTALL_DIR=~/ros" >> "$GITHUB_ENV"
+          echo "~/ros/bin" >> $GITHUB_PATH
+      - uses: actions/checkout@v3
+      - name: cache .roswell
+        id: cache-dot-roswell
+        uses: actions/cache@v3
+        with:
+          path: ~/.roswell
+          key: ${{ runner.os }}-dot-roswell-${{ matrix.lisp }}-${{ hashFiles('**/*.asd') }}
+          restore-keys: |
+            ${{ runner.os }}-dot-roswell-${{ matrix.lisp }}-
+            ${{ runner.os }}-dot-roswell-
+      - name: install roswell
+        shell: bash
+        env:
+          LISP: ${{ matrix.lisp }}
+        run: curl -L https://raw.githubusercontent.com/roswell/roswell/master/scripts/install-for-ci.sh | sh
+      - name: run lisp
+        continue-on-error: true
+        shell: bash
+        run: |
+          ros -e '(format t "~a:~a on ~a~%...~%~%" (lisp-implementation-type) (lisp-implementation-version) (machine-type))'
+          ros -e '(format t " fixnum bits:~a~%" (integer-length most-positive-fixnum))'
+          ros -e "(ql:quickload 'trivial-features)" -e '(format t "features = ~s~%" *features*)'
+      - name: build deflate
+        shell: bash
+        run: |
+          ros -e '(ql:quickload "deflate")'
+      - name: test deflate
+        shell: bash
+        run: |
+          ros -e '(ql:quickload "deflate/test")' -e '(if (deflate-test:perform-all-tests) (uiop:quit 0) (uiop:quit 1))'

COPYING

@@ -1,4 +1,4 @@
-  Copyright (C) 2000-2010 PMSF IT Consulting Pierre R. Mai
+  Copyright (C) 2000-2023 PMSF IT Consulting Pierre R. Mai
 
   Permission is hereby granted, free of charge, to any person obtaining
   a copy of this software and associated documentation files (the
@@ -18,8 +18,3 @@
   OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
   ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
   OTHER DEALINGS IN THE SOFTWARE.
-
-  Except as contained in this notice, the name of the author shall
-  not be used in advertising or otherwise to promote the sale, use or
-  other dealings in this Software without prior written authorization
-  from the author.

NEWS

@@ -1,3 +1,30 @@
+Release 1.0.4
+=============
+
+ * Make dynamic huffman table decoding more robust against out of bounds
+   distance entries, based on a PR from @se-mz.
+ * Detect invalid distance codes 30/31, for symmetrical treatment of
+   invalid length and distance codes.
+ * Initialize sliding window buffer to all 0 to avoid data leakage for
+   backreferences outside of the already written stream.
+ * Revamp gzip header decoding to allow for checking of optional FHCRC
+   CRC16 header checksum when checksum checking is enabled.
+ * Improve optimize declarations, especially for LispWorks performance.
+ * Remove no longer needed muffle annotations for SBCL.
+ * Remove non-endorsement clause from license, making it pure MIT.
+ * Add testsuite to distribution
+
+Release 1.0.3
+=============
+
+ * Correct type declarations for LispWorks simple int32 vectors.
+
+Release 1.0.2
+=============
+
+ * Adjust package name specifications to belatedly support ACL in its
+   "modern-mode".
+
 Release 1.0.1
 =============
 

README.md

@@ -1,6 +1,8 @@
-This library is an implementation of Deflate (RFC 1951) decompression,
-with optional support for ZLIB-style (RFC 1950) and gzip-style (RFC
-1952) wrappers of deflate streams.  It currently does not handle
+[![.github/workflows/build.yml](https://github.com/pmai/Deflate/actions/workflows/build.yml/badge.svg)](https://github.com/pmai/Deflate/actions/workflows/build.yml)
+
+This library is an implementation of Deflate ([RFC 1951][]) decompression,
+with optional support for ZLIB-style ([RFC 1950][]) and gzip-style
+([RFC 1952][]) wrappers of deflate streams.  It currently does not handle
 compression, although this is a natural extension.
 
 The implementation should be portable across all ANSI compliant CL
@@ -19,3 +21,7 @@ in the file COPYING and the header of each source file.
 
 Please direct any feedback to pmai@pmsf.de.  A git repository of this
 library is available under http://github.com/pmai/Deflate/tree/master
+
+[RFC 1951]: https://tools.ietf.org/html/rfc1951
+[RFC 1950]: https://tools.ietf.org/html/rfc1950
+[RFC 1952]: https://tools.ietf.org/html/rfc1952

deflate-test.lisp

@@ -0,0 +1,326 @@
+;;;; Deflate --- RFC 1951 Deflate Decompression
+;;;;
+;;;; Copyright (C) 2000-2023 PMSF IT Consulting Pierre R. Mai.
+;;;;
+;;;; Permission is hereby granted, free of charge, to any person obtaining
+;;;; a copy of this software and associated documentation files (the
+;;;; "Software"), to deal in the Software without restriction, including
+;;;; without limitation the rights to use, copy, modify, merge, publish,
+;;;; distribute, sublicense, and/or sell copies of the Software, and to
+;;;; permit persons to whom the Software is furnished to do so, subject to
+;;;; the following conditions:
+;;;;
+;;;; The above copyright notice and this permission notice shall be
+;;;; included in all copies or substantial portions of the Software.
+;;;;
+;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+;;;; IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY CLAIM, DAMAGES OR
+;;;; OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
+;;;; ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+;;;; OTHER DEALINGS IN THE SOFTWARE.
+;;;;
+;;;; $Id$
+
+(cl:defpackage #:deflate-test
+  (:use #:common-lisp)
+  (:import-from
+   #+sbcl :sb-gray
+   #+allegro :excl
+   #+cmu :ext
+   #+(or clisp ecl mocl clasp) :gray
+   #+openmcl :ccl
+   #+lispworks :stream
+   #+(or abcl genera) :gray-streams
+   #+mezzano :mezzano.gray
+   #-(or sbcl allegro cmu clisp openmcl lispworks ecl clasp abcl mocl genera mezzano) ...
+   #:fundamental-binary-input-stream #:fundamental-binary-output-stream
+   #:stream-read-byte #:stream-write-byte)
+  #+ecl
+  (:shadowing-import-from :gray #:stream-element-type)
+  (:export
+   #:perform-all-tests
+   #:perform-deflate-tests
+   #:perform-zlib-tests
+   #:perform-gzip-tests
+   #:benchrun))
+
+(cl:in-package #:deflate-test)
+
+;;;; %File Description:
+;;;; 
+;;;; This file contains infrastructure for testing the deflate
+;;;; decompression library, as well as test suites for basic
+;;;; operation, corner cases, and error situations.
+;;;; 
+;;;; The main entry points are the functions perform-all-tests, and
+;;;; its cousins perform-deflate-tests, perform-zlib-tests and
+;;;; perform-gzip-tests, which perform the relevant tests for the
+;;;; given functionality, as well as benchrun, which is a simple
+;;;; helper used in benchmarking.
+;;;;
+;;;; Some of the test cases for deflate corner cases were derived
+;;;; from the test suite of Project Nayuki's deflate decompresser:
+;;;; https://www.nayuki.io/page/simple-deflate-decompressor
+;;;;
+
+;;;
+;;; Basic binary in/out streams
+;;;
+
+(defclass octet-input-stream (fundamental-binary-input-stream)
+  ((data :initarg :data :type (simple-array (unsigned-byte 8) (*)))
+   (position :initform 0)))
+
+(defmethod stream-element-type ((stream octet-input-stream))
+  '(unsigned-byte 8))
+
+(defmethod stream-read-byte ((stream octet-input-stream))
+  (with-slots (data position) stream
+    (if (< position (length data))
+        (prog1 (aref data position)
+          (incf position))
+        :eof)))
+
+(defclass octet-output-stream (fundamental-binary-output-stream)
+  ((data :accessor octet-output-stream-data
+         :initform (make-array '(100) :adjustable t :fill-pointer 0 :element-type '(unsigned-byte 8)) :type (vector (unsigned-byte 8)))))
+
+(defmethod stream-element-type ((stream octet-output-stream))
+  '(unsigned-byte 8))
+
+(defmethod stream-write-byte ((stream octet-output-stream) integer)
+  (with-slots (data) stream
+    (vector-push-extend integer data)
+    integer))
+
+;;;
+;;; Basic Test Primitives
+;;;
+
+(defun map-bits-to-bytes (bit-pattern)
+  (loop with result = (make-array (ceiling (length bit-pattern) 8) :element-type '(unsigned-byte 8))
+        with bit-length = (length bit-pattern)
+        for index upfrom 0 below (length result)
+        for bit-index = (* index 8)
+        do
+          (setf (aref result index)
+                (loop for value = 1 then (* value 2)
+                      for pos upfrom bit-index below (min bit-length (+ bit-index 8))
+                      sum (* (bit bit-pattern pos) value)))
+        finally
+          (return result)))
+
+(defun test-sequence (name bit-pattern reference &optional expected-error)
+  (handler-bind ((error #'(lambda (condition)
+                            (cond
+                             ((and expected-error (typep condition expected-error))
+                              (format t "SUCCESS: Expected Error: ~A~%" condition)
+                              (return-from test-sequence t))
+                             (t
+                              (format t "FAILURE: Unexpected Error: ~A~%" condition)
+                              (return-from test-sequence nil))))))
+    (format t "~&Test ~45A: " name)
+    (let ((input (map-bits-to-bytes bit-pattern)))
+      (loop with bit-length = (length bit-pattern)
+            for index upfrom 0 below (length input)
+            for bit-index = (* index 8)
+            do
+              (setf (aref input index)
+                    (loop for value = 1 then (* value 2)
+                          for pos upfrom bit-index below (min bit-length (+ bit-index 8))
+                          sum (* (bit bit-pattern pos) value))))
+      (with-open-stream (instream (make-instance 'octet-input-stream :data input))
+        (with-open-stream (outstream (make-instance 'octet-output-stream))
+          (deflate:inflate-stream instream outstream)
+          (cond
+           ((equalp (octet-output-stream-data outstream) reference)
+            (format t "SUCCESS: Expected Result: ~A~%" (octet-output-stream-data outstream))
+            t)
+           (t
+            (format t "FAILURE: Unexpected Result: ~A, expected ~A~%" (octet-output-stream-data outstream) reference)
+            nil)))))))
+
+(defun test-zlib-sequence (name input reference &optional expected-error)
+  (handler-bind ((error #'(lambda (condition)
+                            (cond
+                             ((and expected-error (typep condition expected-error))
+                              (format t "SUCCESS: Expected Error: ~A~%" condition)
+                              (return-from test-zlib-sequence t))
+                             (t
+                              (format t "FAILURE: Unexpected Error: ~A~%" condition)
+                              (return-from test-zlib-sequence nil))))))
+    (format t "~&Test ~45A: " name)
+    (let ((input (make-array (length input) :element-type '(unsigned-byte 8) :initial-contents input)))
+      (with-open-stream (instream (make-instance 'octet-input-stream :data input))
+        (with-open-stream (outstream (make-instance 'octet-output-stream))
+          (deflate:inflate-zlib-stream instream outstream :check-checksum t)
+          (cond
+           ((equalp (octet-output-stream-data outstream) reference)
+            (format t "SUCCESS: Expected Result: ~A~%" (octet-output-stream-data outstream))
+            t)
+           (t
+            (format t "FAILURE: Unexpected Result: ~A, expected ~A~%" (octet-output-stream-data outstream) reference)
+            nil)))))))
+
+(defun test-gzip-sequence (name input reference &optional expected-error)
+  (handler-bind ((error #'(lambda (condition)
+                            (cond
+                             ((and expected-error (typep condition expected-error))
+                              (format t "SUCCESS: Expected Error: ~A~%" condition)
+                              (return-from test-gzip-sequence t))
+                             (t
+                              (format t "FAILURE: Unexpected Error: ~A~%" condition)
+                              (return-from test-gzip-sequence nil))))))
+    (format t "~&Test ~45A: " name)
+    (let ((input (make-array (length input) :element-type '(unsigned-byte 8) :initial-contents input)))
+      (with-open-stream (instream (make-instance 'octet-input-stream :data input))
+        (with-open-stream (outstream (make-instance 'octet-output-stream))
+          (deflate:inflate-gzip-stream instream outstream :check-checksum t)
+          (cond
+           ((equalp (octet-output-stream-data outstream) reference)
+            (format t "SUCCESS: Expected Result: ~A~%" (octet-output-stream-data outstream))
+            t)
+           (t
+            (format t "FAILURE: Unexpected Result: ~A, expected ~A~%" (octet-output-stream-data outstream) reference)
+            nil)))))))
+
+;;;
+;;; Test Cases
+;;;
+
+(defun perform-deflate-tests ()
+  (format t "~2&Performing deflate tests~2%")
+  (macrolet ((every-form (&body body) `(let ((success t)) ,@(loop for form in body collect `(unless ,form (setq success nil))) success)))
+    (every-form
+     ;; Simple Tests
+     (test-sequence "Empty Uncompressed Block" #*1000000000000000000000001111111111111111 #())
+     (test-sequence "Two Empty Uncompressed Blocks" #*00000000000000000000000011111111111111111000000000000000000000001111111111111111 #())
+     (test-sequence "Two Empty Fixed Huffman Blocks" #*01000000001100000000 #())
+     (test-sequence "Two Empty Dynamic Huffman Blocks" #*0010000010000111100000010000000000000000000000000000000000000000000010000001111111110101011000110100000100001111000000100000000000000000000000000000000000000000000100000011111111101010110001 #())
+     (test-sequence "Fixed ABC Literal Block" #*1100111000101110010011100110000000 #(65 66 67))
+     (test-sequence "Fixed ABC Repeating Block" #*1100111000101110010011100110000001000100000001000100000000 #(65 66 67 65 66 67 65 66 67))
+     (test-sequence "Fixed ABC Repeating Overlapping Block" #*1100111000101110010011100110000111000100000000 #(65 66 67 65 66 67 65 66 67 65 66 67))
+     (test-sequence "Fixed ABC Repeating Out Of Range Block" #*1100111000101110010011100110001000001000000000 #(65 66 67 00 00 65 66 67 00 00 65 66 67))
+     (test-sequence "Dynamic ABC Literal Block" #*10100000000001111000000010010000000000000000000000000000000000010000000000100110110010101101111111101110010010000011011 #(65 66 67))
+     (test-sequence "Dynamic AB Repeating Block Dist 1" #*101100000000011110000000100100000000000000000000000000000000000100000100001101101101010111111111110001010101001000111010 #(65 66 66 66 66))
+     (test-sequence "Dynamic AB Repeating Block Dist 2" #*1010100010000111100000001001000000000000000000000000000000000001000001000011011011010101111111111100010101000100001000111010 #(65 66 65 66 65 66))
+
+     (test-sequence "EOF Start Of Block" #* #() 'end-of-file)
+     (test-sequence "Reserved Block Type" #*11100000 #() 'deflate:deflate-decompression-error)
+     (test-sequence "EOF In Block Type" #*10 #() 'end-of-file)
+     (test-sequence "Uncompressed Empty" #*1000000000000000000000001111111111111111 #())
+     (test-sequence "Uncompressed ThreeBytes" #*1000000011000000000000000011111111111111101000000010100011000100 #(#x05 #x14 #x23))
+     (test-sequence "Uncompressed TwoBlocks" #*00000000010000000000000010111111111111111010000000101000100000001000000000000000011111111111111111000100 #(#x05 #x14 #x23))
+     (test-sequence "Uncompressed EOF Before Length" #*100000 #() 'end-of-file)
+     (test-sequence "Uncompressed EOF In Length" #*100000000000000000 #() 'end-of-file)
+     (test-sequence "Uncompressed Mismatched Length" #*1000000000100000000100001111100100110101 #() 'deflate:deflate-decompression-error)
+     (test-sequence "Uncompressed EOF In Data" #*10011111011000000000000010011111111111111010101001110111 #() 'end-of-file)
+     (test-sequence "Uncompressed Block No Final Block" #*0000000000000000000000001111111111111111 #() 'end-of-file)
+     (test-sequence "Uncompressed Block No Discard Bits" #*0101100100001101000011111111110000000100010000000000000010111111111111111101010110110011 #(#x90 #xA1 #xFF #xAB #xCD))
+     (test-sequence "Fixed Huffman Empty" #*1100000000 #())
+     (test-sequence "Fixed Huffman Literals" #*1100011000010110000101111111100100001110000001111111110000000 #(#x00 #x80 #x8F #x90 #xC0 #xFF))
+     (test-sequence "Fixed Huffman Non Overlapping Run" #*1100011000000110001001100100000001000100000000 #(#x00 #x01 #x02 #x00 #x01 #x02))
+     (test-sequence "Fixed Huffman Overlapping Run 0" #*110001100010000010000000000000 #(#x01 #x01 #x01 #x01 #x01))
+     (test-sequence "Fixed Huffman Overlapping Run 1" #*11010111110101111110000011000010000000 #(#x8E #x8F #x8E #x8F #x8E #x8F #x8E))
+     (test-sequence "Fixed Huffman Invalid Length Code 286" #*11011000110 #() 'deflate:deflate-decompression-error)
+     (test-sequence "Fixed Huffman Invalid Length Code 287" #*11011000111 #() 'deflate:deflate-decompression-error)
+     (test-sequence "Fixed Huffman Invalid Distance Code 30" #*11000110000000000111110 #() 'deflate:deflate-decompression-error)
+     (test-sequence "Fixed Huffman Invalid Distance Code 31" #*11000110000000000111111 #() 'deflate:deflate-decompression-error)
+     (test-sequence "Fixed Huffman EOF In Huffman Symbol" #*11000000 #() 'end-of-file)
+     (test-sequence "Fixed Huffman EOF In Run Extension Bits" #*1100011000000011011 #() 'end-of-file)
+     (test-sequence "Fixed Huffman EOF In Distance Extension Bits" #*11000110000110001010000000000010100000 #() 'end-of-file)
+     (test-sequence "Dynamic Huffman Empty" #*10100000100001111000000100000000000000000000000000000000000000000000100000011111111101010110001 #())
+     (test-sequence "Dynamic Huffman Empty No Distance Code" #*1010000000000011100000010001000000000000000000000000000000000000000001001111111001010111111101 #())
+     (test-sequence "Dynamic Huffman Code Length Repeat At Start" #*101000000000001111000000000000000000000000000000000000000000000000001001 #() 'deflate:deflate-decompression-error)
+     (test-sequence "Dynamic Huffman Too Many Code Length Items" #*10100000000000111000000100000000000000000000000000000000000000000000100001111111110011011 #() 'deflate:deflate-decompression-error)
+     (test-sequence "Dynamic Huffman Overfull Code 0" #*101000000000000001001001000000000000000000000000  #() 'deflate:deflate-decompression-error)
+     (test-sequence "Dynamic Huffman Overfull Code 1"#*101000000000000001001001001000000000000000000000  #() 'end-of-file) ;; Should maybe be deflate:deflate-decompression-error
+     (test-sequence "Dynamic Huffman Unpaired Code" #*101000000000000001000101100000000000000000000000 #() 'deflate:deflate-decompression-error)
+     (test-sequence "Dynamic Huffman Empty Code" #*101000000000000000000000000000000000000000000000 #() 'deflate:deflate-decompression-error)
+     (test-sequence "Dynamic Huffman Underfull Code 0" #*101000000000000000000001000000000000000000000000 #() 'end-of-file) ;; Should maybe be deflate:deflate-decompression-error
+     (test-sequence "Dynamic Huffman Underfull Code 1"#*101000000000000000101000000000000000000000000000 #() 'end-of-file) ;; Should maybe be deflate:deflate-decompression-error
+     (test-sequence "Dynamic Huffman One Distance Code" #*101100000000001110000000100100000000000000000000000000000000000100000100010111111111111001011011001101100 #(#x01 #x01 #x01 #x01))
+     (test-sequence "Dynamic Huffman One Distance Code Invalid" #*101100000000001110000000100100000000000000000000000000000000000100000100010111111111111001011011001101110101100 #(#x01 #x01 #x01 #x01) 'deflate:deflate-decompression-error)
+     (test-sequence "Dynamic Huffman Use Of Null Distance Code" #*101100000000001110000000100100000000000000000000000000000000000100000101011111111111010101101100010110000000000000000 #() 'deflate:deflate-decompression-error))))
+
+(defun perform-zlib-tests ()
+  (format t "~2&Performing zlib tests~2%")
+  (macrolet ((every-form (&body body) `(let ((success t)) ,@(loop for form in body collect `(unless ,form (setq success nil))) success)))
+    (every-form
+     (test-zlib-sequence "Small File"
+                         #(#x78 #x01 #x73 #x49 #xCD #xCD #xE7 #x02 #x00 #x05 #x1C #x01 #x90)
+                         #(#x44 #x65 #x6D #x6F #x0A))
+     (test-zlib-sequence "Small File, Wrong FCHECK"
+                         #(#x78 #x07 #x73 #x49 #xCD #xCD #xE7 #x02 #x00 #x05 #x1C #x01 #x90)
+                         #(#x44 #x65 #x6D #x6F #x0A) 'deflate:zlib-decompression-error)
+     (test-zlib-sequence "Small File, Invalid Adler32"
+                         #(#x78 #x01 #x73 #x49 #xCD #xCD #xE7 #x02 #x00 #x00 #x00 #x00 #x00)
+                         #(#x44 #x65 #x6D #x6F #x0A) 'deflate:zlib-decompression-error)
+     (test-zlib-sequence "Small File, Dict"
+                         #(#x78 #x20 #xDE #xAD #xBE #xFF #x73 #x49 #xCD #xCD #xE7 #x02 #x00 #x00 #x00 #x00 #x00)
+                         #(#x44 #x65 #x6D #x6F #x0A) 'deflate:zlib-decompression-error)
+     (test-zlib-sequence "Small File, Dict, Invalid Adler32"
+                         #(#x78 #x20 #xDE #xAD #xBE #xFF #x73 #x49 #xCD #xCD #xE7 #x02 #x00 #x00 #x00 #x00 #x00)
+                         #(#x44 #x65 #x6D #x6F #x0A) 'deflate:zlib-decompression-error)
+     (test-zlib-sequence "Samll File, Wrong CM"
+                         #(#x77 #x09 #x73 #x49 #xCD #xCD #xE7 #x02 #x00 #x05 #x1C #x01 #x90)
+                         #(#x44 #x65 #x6D #x6F #x0A) 'deflate:zlib-decompression-error)
+     (test-zlib-sequence "Empty File"
+                         #(#x78 #x01 #x01 #x00 #x00 #xff #xff #x00 #x00 #x00 #x01)
+                         #())
+     (test-zlib-sequence "Empty File, Invalid Adler32"
+                         #(#x78 #x01 #x01 #x00 #x00 #xff #xff #x05 #x1C #x01 #x90)
+                         #() 'deflate:zlib-decompression-error))))
+
+(defun perform-gzip-tests ()
+  (format t "~2&Performing gzip tests~2%")
+  (macrolet ((every-form (&body body) `(let ((success t)) ,@(loop for form in body collect `(unless ,form (setq success nil))) success)))
+    (every-form
+     (test-gzip-sequence "Small File, FNAME"
+                         #(#x1F #x8B #x08 #x08 #x0F #x66 #x6A #x64 #x02 #x03 #x74 #x65 #x73 #x74 #x2E #x74 #x78 #x74 #x00
+                                #x73 #x49 #xCD #xCD #xE7 #x02 #x00 #xA0 #xC8 #x16 #x25 #x05 #x00 #x00 #x00)
+                         #(#x44 #x65 #x6D #x6F #x0A))
+     (test-gzip-sequence "Small File, FNAME, FCOMMENT, FEXTRA"
+                         #(#x1F #x8B #x08 #x1D #x0F #x66 #x6A #x64 #x02 #x03 #x06 #x00 #xDE #xAD #x02 #x00 #xBE #xEF #x74 #x65 #x73 #x74 #x2E #x74 #x78 #x74 #x00
+                                #x4D #x79 #x20 #x43 #x6F #x6D #x6D #x65 #x6E #x74 #x00 #x73 #x49 #xCD #xCD #xE7 #x02 #x00 #xA0 #xC8 #x16 #x25 #x05 #x00 #x00 #x00)
+                         #(#x44 #x65 #x6D #x6F #x0A))
+     (test-gzip-sequence "Small File, FNAME, Invalid CRC32"
+                         #(#x1F #x8B #x08 #x09 #x0F #x66 #x6A #x64 #x02 #x03 #x74 #x65 #x73 #x74 #x2E #x74 #x78 #x74 #x00
+                                #x73 #x49 #xCD #xCD #xE7 #x02 #x00 #xA0 #xA8 #x16 #x25 #x05 #x00 #x00 #x00)
+                         #(#x44 #x65 #x6D #x6F #x0A)
+                         'deflate:gzip-decompression-error)
+     (test-gzip-sequence "Small File, FNAME, Wrong CM"
+                         #(#x1F #x8B #x05 #x08 #x0F #x66 #x6A #x64 #x02 #x03 #x74 #x65 #x73 #x74 #x2E #x74 #x78 #x74 #x00
+                                #x73 #x49 #xCD #xCD #xE7 #x02 #x00 #xA0 #xC8 #x16 #x25 #x05 #x00 #x00 #x00)
+                         #(#x44 #x65 #x6D #x6F #x0A)
+                         'deflate:gzip-decompression-error)
+     (test-gzip-sequence "Empty, FCOMMENT, No FHCRC CRC16"
+                         #(#x1f #x8b #x08 #x10 #x00 #x09 #x6e #x88 #x00 #xff #x48 #x65 #x6c #x6c #x6f #x00 #x01 #x00 #x00 #xff #xff #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00)
+                         #())
+     (test-gzip-sequence "Empty, FCOMMENT, FHCRC CRC16"
+                         #(#x1f #x8b #x08 #x12 #x00 #x09 #x6e #x88 #x00 #xff #x48 #x65 #x6c #x6c #x6f #x00 #x99 #xd6 #x01 #x00 #x00 #xff #xff #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00)
+                         #())
+     (test-gzip-sequence "Empty, FCOMMENT, FHCRC Invalid CRC16"
+                         #(#x1f #x8b #x08 #x12 #x00 #x09 #x6e #x88 #x00 #xff #x48 #x65 #x6c #x6c #x6f #x00 #x49 #xd6 #x01 #x00 #x00 #xff #xff #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00)
+                         #() 'deflate:gzip-decompression-error))))
+
+(defun perform-all-tests ()
+  (macrolet ((every-form (&body body) `(let ((success t)) ,@(loop for form in body collect `(unless ,form (setq success nil))) success)))
+    (every-form
+     (perform-deflate-tests)
+     (perform-zlib-tests)
+     (perform-gzip-tests))))
+
+;;;
+;;; Benchmarking helper
+;;;
+
+(defun benchrun (file destination &optional check-checksum)
+  (declare (optimize (speed 3)))
+  (with-open-file (stream file :element-type '(unsigned-byte 8))
+    (with-open-file (output destination :direction :output
+                            :if-exists :supersede
+                            :element-type '(unsigned-byte 8))
+      (deflate:inflate-gzip-stream stream output :check-checksum check-checksum))))

deflate.asd

@@ -1,6 +1,6 @@
 ;;;; Deflate --- RFC 1951 Deflate Decompression
 ;;;;
-;;;; Copyright (C) 2000-2010 PMSF IT Consulting Pierre R. Mai.
+;;;; Copyright (C) 2000-2023 PMSF IT Consulting Pierre R. Mai.
 ;;;;
 ;;;; Permission is hereby granted, free of charge, to any person obtaining
 ;;;; a copy of this software and associated documentation files (the
@@ -21,15 +21,8 @@
 ;;;; ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
 ;;;; OTHER DEALINGS IN THE SOFTWARE.
 ;;;;
-;;;; Except as contained in this notice, the name of the author shall
-;;;; not be used in advertising or otherwise to promote the sale, use or
-;;;; other dealings in this Software without prior written authorization
-;;;; from the author.
-;;;; 
 ;;;; $Id$
 
-(cl:in-package "CL-USER")
-
 ;;;; %File Description:
 ;;;; 
 ;;;; This file contains the system definition form for the
@@ -37,7 +30,16 @@
 ;;;; ASDF system definition facility.
 ;;;; 
 
-(asdf:defsystem "deflate"
-    :description "Deflate Decompression Library"
-    :author "Pierre R. Mai <pmai@pmsf.de>"
-    :components ((:file "deflate")))
+(defsystem "deflate"
+  :description "Deflate Decompression Library"
+  :author "Pierre R. Mai <pmai@pmsf.de>"
+  :maintainer "Pierre R. Mai <pmai@pmsf.de>"
+  :licence "MIT"
+  :version "1.0.4"
+  :components ((:file "deflate"))
+  :in-order-to ((test-op (test-op "deflate/test"))))
+
+(defsystem "deflate/test"
+  :depends-on ("deflate" #+abcl (:require :gray-streams))
+  :components ((:file "deflate-test"))
+  :perform (test-op (o c) (symbol-call '#:deflate-test '#:perform-all-tests)))

deflate.lisp

@@ -1,6 +1,6 @@
 ;;;; Deflate --- RFC 1951 Deflate Decompression
 ;;;;
-;;;; Copyright (C) 2000-2010 PMSF IT Consulting Pierre R. Mai.
+;;;; Copyright (C) 2000-2023 PMSF IT Consulting Pierre R. Mai.
 ;;;;
 ;;;; Permission is hereby granted, free of charge, to any person obtaining
 ;;;; a copy of this software and associated documentation files (the
@@ -21,22 +21,17 @@
 ;;;; ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
 ;;;; OTHER DEALINGS IN THE SOFTWARE.
 ;;;;
-;;;; Except as contained in this notice, the name of the author shall
-;;;; not be used in advertising or otherwise to promote the sale, use or
-;;;; other dealings in this Software without prior written authorization
-;;;; from the author.
-;;;; 
 ;;;; $Id$
 
-(cl:defpackage "DEFLATE"
-  (:use "COMMON-LISP")
+(cl:defpackage #:deflate
+  (:use #:common-lisp)
   (:export #:decompression-error #:deflate-decompression-error
            #:zlib-decompression-error #:gzip-decompression-error
            #:inflate-stream
            #:inflate-zlib-stream #:parse-zlib-header #:parse-zlib-footer
            #:inflate-gzip-stream #:parse-gzip-header #:parse-gzip-footer))
 
-(cl:in-package "DEFLATE")
+(cl:in-package #:deflate)
 
 ;;;; %File Description:
 ;;;; 
@@ -111,8 +106,7 @@
   (declare (type (unsigned-byte 32) crc)
            (type (simple-array (unsigned-byte 8) (*)) buffer)
            (type fixnum end)
-           (optimize (speed 3) (debug 0) (space 0) (safety 0))
-           #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note))
+           (optimize (speed 3) (debug 0) (space 0) (safety 0)))
   (let ((s1 (ldb (byte 16 0) crc))
         (s2 (ldb (byte 16 16) crc)))
     (declare (type (unsigned-byte 32) s1 s2))
@@ -133,7 +127,7 @@
   "CRC-32 Polynomial as per RFC 1952.")
 
 (declaim (ftype #-lispworks (function () (simple-array (unsigned-byte 32) (256)))
-                #+lispworks (function () (sys:simple-int32-vector 256))
+                #+lispworks (function () sys:simple-int32-vector)
                 generate-crc32-table))
 (defun generate-crc32-table ()
   (let ((result #-lispworks (make-array 256 :element-type '(unsigned-byte 32))
@@ -159,8 +153,7 @@
   (declare (type (unsigned-byte 32) crc)
            (type (simple-array (unsigned-byte 8) (*)) buffer)
            (type fixnum end)
-           (optimize (speed 3) (debug 0) (space 0) (safety 0))
-           #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note))
+           (optimize (speed 3) (debug 0) (space 0) (safety 0)))
   (let ((table (load-time-value (generate-crc32-table)))
         (cur (logxor crc #xffffffff)))
     (declare (type (simple-array (unsigned-byte 32) (256)) table)
@@ -182,7 +175,7 @@
         (cur (sys:int32-lognot (sys:integer-to-int32 
                                 (dpb (ldb (byte 32 0) crc) (byte 32 0) 
                                      (if (logbitp 31 crc) -1 0))))))
-    (declare (type (sys:simple-int32-vector 256) table)
+    (declare (type sys:simple-int32-vector table)
              (type sys:int32 cur))
     (dotimes (i end)
       (declare (type fixnum i))
@@ -204,7 +197,7 @@
 
 (defstruct sliding-window-stream
   (stream nil :type stream :read-only t)
-  (buffer (make-array +sliding-window-size+ :element-type '(unsigned-byte 8)) 
+  (buffer (make-array +sliding-window-size+ :element-type '(unsigned-byte 8) :initial-element 0)
    :type (simple-array (unsigned-byte 8) (#.+sliding-window-size+)) :read-only t)
   (buffer-end 0 :type fixnum)
   (checksum nil :type symbol :read-only t)
@@ -213,7 +206,7 @@
 (declaim (inline sliding-window-stream-write-byte))
 (defun sliding-window-stream-write-byte (stream byte)
   (declare (type sliding-window-stream stream) (type (unsigned-byte 8) byte)
-           #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note))
+           (optimize (speed 3) (debug 0) (space 0) (safety 0)))
   "Write a single byte to the sliding-window-stream."
   (let ((end (sliding-window-stream-buffer-end stream)))
     (declare (type fixnum end))
@@ -233,7 +226,7 @@
                         +sliding-window-size+))))
       (setq end 0))
     (setf (aref (sliding-window-stream-buffer stream) end) byte
-          (sliding-window-stream-buffer-end stream) (1+ end))))
+          (sliding-window-stream-buffer-end stream) (the fixnum (1+ end)))))
 
 (defun sliding-window-stream-flush (stream)
   (declare (type sliding-window-stream stream))
@@ -257,7 +250,8 @@
                       :end end))))
 
 (defun sliding-window-stream-copy-bytes (stream distance length)
-  (declare (type sliding-window-stream stream) (type fixnum distance length))
+  (declare (type sliding-window-stream stream) (type fixnum distance length)
+           (optimize (speed 3) (debug 0) (space 0) (safety 0)))
   "Copy a number of bytes from the current sliding window."
   (let* ((end (sliding-window-stream-buffer-end stream))
          (start (mod (- end distance) +sliding-window-size+))
@@ -267,7 +261,7 @@
     (dotimes (i length)
       (sliding-window-stream-write-byte
        stream
-       (aref buffer (mod (+ start i) +sliding-window-size+))))))
+       (aref buffer (mod (the fixnum (+ start i)) +sliding-window-size+))))))
 
 ;;;
 ;;; Helper Data Structures: Bit-wise Input Stream
@@ -310,7 +304,7 @@
 (declaim (inline bit-stream-copy-block))
 (defun bit-stream-copy-block (stream out-stream)
   (declare (type bit-stream stream) (type sliding-window-stream out-stream)
-           (optimize (speed 3) (safety 0) (space 0) (debug 0)))
+           (optimize (speed 3) (debug 0) (space 0) (safety 0)))
   "Copy a given block of bytes directly from the underlying stream."
   ;; Skip any remaining unprocessed bits
   (setf (bit-stream-bits stream) 0
@@ -386,7 +380,7 @@ the code lengths of each symbol given in the input array."
 (declaim (inline read-huffman-code))
 (defun read-huffman-code (bit-stream decode-tree)
   (declare (type bit-stream bit-stream) (type decode-tree decode-tree)
-           (optimize (speed 3) (safety 0) (space 0) (debug 0)))
+           (optimize (speed 3) (debug 0) (space 0) (safety 0)))
   "Read the next huffman code word from the given bit-stream and
 return its decoded symbol, for the huffman code given by decode-tree."
   (loop with length-count of-type (simple-array fixnum (*)) 
@@ -445,17 +439,29 @@ lengths for further processing."
            (setf (aref result index) code)
            (incf index))
         (16
+           (when (= index 0)
+             (error 'deflate-decompression-error
+                    :format-control "Length entries start with a repetition!"))
            (let ((length (+ 3 (bit-stream-read-bits bit-stream 2))))
+             (unless (<= (+ index length) count)
+               (error 'deflate-decompression-error
+                      :format-control "Length entries expand out of bounds."))
              (dotimes (i length)
                (setf (aref result (+ index i)) (aref result (1- index))))
              (incf index length)))
         (17
            (let ((length (+ 3 (bit-stream-read-bits bit-stream 3))))
+             (unless (<= (+ index length) count)
+               (error 'deflate-decompression-error
+                      :format-control "Length entries expand out of bounds."))
              (dotimes (i length)
                (setf (aref result (+ index i)) 0))
              (incf index length)))
         (18
            (let ((length (+ 11 (bit-stream-read-bits bit-stream 7))))
+             (unless (<= (+ index length) count)
+               (error 'deflate-decompression-error
+                      :format-control "Length entries expand out of bounds."))
              (dotimes (i length)
                (setf (aref result (+ index i)) 0))
              (incf index length)))))))
@@ -511,8 +517,13 @@ the corresponding decode-trees for literals/length and distance codes."
   "Decode the given distance symbol into a proper distance specification."
   (cond
     ((<= symbol 3) (1+ symbol))
+    ((<= 30 symbol 31)
+     (error 'deflate-decompression-error
+            :format-control "Strange Distance Code in bitstream: ~D"
+            :format-arguments (list symbol)))
     (t
      (multiple-value-bind (order offset) (truncate symbol 2)
+       (declare (type (unsigned-byte 4) order offset))
        (let* ((extra-bits (1- order))
               (factor (ash 1 extra-bits)))
          (+ (1+ (ash 1 order))
@@ -523,6 +534,9 @@ the corresponding decode-trees for literals/length and distance codes."
                              lit-decode-tree dist-decode-tree)
   "Decode the huffman code block using the huffman codes given by 
 lit-decode-tree and dist-decode-tree."
+  (declare (type bit-stream bit-stream) (type sliding-window-stream window-stream)
+           (type decode-tree lit-decode-tree dist-decode-tree)
+           (optimize (speed 3) (debug 0) (space 0) (safety 0)))
   (do ((symbol (read-huffman-code bit-stream lit-decode-tree)
                (read-huffman-code bit-stream lit-decode-tree)))
       ((= symbol 256))
@@ -611,78 +625,91 @@ return values (or nil if any given field is not present).  Checks the
 header for magic values and correct flags settings and signals a
 gzip-decompression-error in case of incorrect or unsupported magic
 values or flags."
-  (let ((id1 (read-byte input-stream))
-        (id2 (read-byte input-stream))
-        (compression-method (read-byte input-stream))
-        (flags (read-byte input-stream)))
-    (unless (and (= id1 +gzip-header-id1+) (= id2 +gzip-header-id2+))
-      (error 'gzip-decompression-error
-             :format-control
-             "Header missing magic values ~2,'0X,~2,'0X (got ~2,'0X,~2,'0X instead)!"
-             :format-arguments (list +gzip-header-id1+ +gzip-header-id2+ id1 id2)))
-    (unless (= compression-method 8)
-      (error 'gzip-decompression-error
-             :format-control "Unknown compression-method in Header ~2,'0X!"
-             :format-arguments (list compression-method)))
-    (unless (zerop (ldb (byte 3 5) flags))
-      (error 'gzip-decompression-error
-             :format-control "Unknown flags in Header ~2,'0X!"
-             :format-arguments (list flags)))
-    (values compression-method
-            ;; FTEXT
-            (= 1 (ldb (byte 1 0) flags))
-            ;; MTIME
-            (parse-gzip-mtime input-stream)
-            ;; XFLAGS
-            (read-byte input-stream)
-            ;; OS
-            (read-byte input-stream)
-            ;; FEXTRA
-            (unless (zerop (ldb (byte 1 2) flags))
-              (parse-gzip-extra input-stream))
-            ;; FNAME
-            (unless (zerop (ldb (byte 1 3) flags))
-              (parse-gzip-string input-stream))
-            ;; FCOMMENT
-            (unless (zerop (ldb (byte 1 4) flags))
-              (parse-gzip-string input-stream))
-            ;; CRC16
-            (unless (zerop (ldb (byte 1 1) flags))
-              (+ (read-byte input-stream)
-                 (* (read-byte input-stream 256)))))))
-
-(defun parse-gzip-mtime (input-stream)
-  (let ((time (+ (read-byte input-stream)
-                 (* (read-byte input-stream) 256)
-                 (* (read-byte input-stream) 256 256)
-                 (* (read-byte input-stream) 256 256 256))))
-    (if (zerop time)
-        nil
-        (+ time 2208988800))))
-
-(defun parse-gzip-extra (input-stream)
-  (let* ((length (+ (read-byte input-stream) (* (read-byte input-stream) 256)))
-         (result (make-array length :element-type '(unsigned-byte 8))))
-    (read-sequence result input-stream)
-    result))
-
-(defun parse-gzip-string (input-stream)
-  (with-output-to-string (string)
-    (loop for value = (read-byte input-stream)
-          until (zerop value)
-          do (write-char (code-char value) string))))
-          
-(defun parse-gzip-checksum (input-stream)
-  (+ (read-byte input-stream)
-     (* (read-byte input-stream) 256)
-     (* (read-byte input-stream) 256 256)
-     (* (read-byte input-stream) 256 256 256)))
+  (let ((crc32 +crc-32-start-value+))
+    (labels ((crc-read-buffer (len)
+               (let ((buffer (make-array len :element-type '(unsigned-byte 8))))
+                 (unless (= (read-sequence buffer input-stream) len)
+                   (error 'gzip-decompression-error
+                          :format-control "Unexpected End Of File during GZIP Header parsing!"
+                          :format-arguments nil))
+                 (setq crc32 (update-crc32-checksum crc32 buffer len))
+                 buffer))
+             (crc-read-byte ()
+               (let ((buffer (crc-read-buffer 1)))
+                 (aref buffer 0)))
+             (crc-read-word ()
+               (let ((buffer (crc-read-buffer 2)))
+                 (+ (aref buffer 0)
+                    (* (aref buffer 1) 256))))
+             (crc-read-dword ()
+               (let ((buffer (crc-read-buffer 4)))
+                 (+ (aref buffer 0)
+                    (* (aref buffer 1) 256)
+                    (* (aref buffer 2) 256 256)
+                    (* (aref buffer 3) 256 256 256))))
+             (crc-read-string ()
+               (with-output-to-string (string)
+                 (loop with buffer = (make-array 1 :element-type '(unsigned-byte 8))
+                       for value = (read-byte input-stream)
+                       do
+                         (setf (aref buffer 0) value)
+                         (setq crc32 (update-crc32-checksum crc32 buffer 1))
+                         (if (zerop value)
+                               (return t)
+                           (write-char (code-char value) string))))))
+      (let ((id1 (crc-read-byte))
+            (id2 (crc-read-byte))
+            (compression-method (crc-read-byte))
+            (flags (crc-read-byte)))
+        (unless (and (= id1 +gzip-header-id1+) (= id2 +gzip-header-id2+))
+          (error 'gzip-decompression-error
+                 :format-control
+                 "Header missing magic values ~2,'0X,~2,'0X (got ~2,'0X,~2,'0X instead)!"
+                 :format-arguments (list +gzip-header-id1+ +gzip-header-id2+ id1 id2)))
+        (unless (= compression-method 8)
+          (error 'gzip-decompression-error
+                 :format-control "Unknown compression-method in Header ~2,'0X!"
+                 :format-arguments (list compression-method)))
+        (unless (zerop (ldb (byte 3 5) flags))
+          (error 'gzip-decompression-error
+                 :format-control "Unknown flags in Header ~2,'0X!"
+                 :format-arguments (list flags)))
+        (values compression-method
+                ;; FTEXT
+                (= 1 (ldb (byte 1 0) flags))
+                ;; MTIME
+                (let ((time (crc-read-dword)))
+                  (unless (zerop time)
+                    (+ time 2208988800)))
+                ;; XFLAGS
+                (crc-read-byte)
+                ;; OS
+                (crc-read-byte)
+                ;; FEXTRA
+                (unless (zerop (ldb (byte 1 2) flags))
+                  (crc-read-buffer (crc-read-word)))
+                ;; FNAME
+                (unless (zerop (ldb (byte 1 3) flags))
+                  (crc-read-string))
+                ;; FCOMMENT
+                (unless (zerop (ldb (byte 1 4) flags))
+                  (crc-read-string))
+                ;; CRC16
+                (unless (zerop (ldb (byte 1 1) flags))
+                  (+ (read-byte input-stream)
+                     (* (read-byte input-stream) 256)))
+                ;; Calculated CRC16
+                (ldb (byte 16 0) crc32))))))
 
 (defun parse-gzip-footer (input-stream)
   "Parse the GZIP-style footer as per RFC 1952 from the input-stream and
 return the CRC-32 checksum and ISIZE fields contained in the footer as
 its return values."
-  (values (parse-gzip-checksum input-stream)
+  (values ;; CRC-32
+          (+ (read-byte input-stream)
+             (* (read-byte input-stream) 256)
+             (* (read-byte input-stream) 256 256)
+             (* (read-byte input-stream) 256 256 256))
           ;; ISIZE
           (+ (read-byte input-stream)
              (* (read-byte input-stream) 256)
@@ -758,20 +785,24 @@ expanded data matches the CRC-32 checksum, unless the check-checksum
 keyword argument is set to true, in which case the checksum is checked
 internally and a gzip-decompression-error is signalled if they don't
 match."
-  (multiple-value-bind (cm ftext mtime xfl os fextra fname fcomment)
+  (multiple-value-bind (cm ftext mtime xfl os fextra fname fcomment crc16-old crc16-new)
       (parse-gzip-header input-stream)
     (declare (ignore ftext xfl os fextra))
     (unless (= cm 8)
       (error 'gzip-decompression-error
              :format-control "Unknown compression method ~D!"
              :format-arguments (list cm)))
+    (when (and check-checksum crc16-old (/= crc16-old crc16-new))
+      (error 'gzip-decompression-error
+             :format-control "CRC-16 Checksum mismatch in header: ~4,'0X != ~4,'0X!"
+             :format-arguments (list crc16-old crc16-new)))
     (let ((checksum-new (inflate-stream input-stream output-stream 
-                                        :checksum (when check-checksum :crc-32)))
-          (checksum-old (parse-gzip-footer input-stream)))
-      ;; Handle Checksums
-      (when (and check-checksum (not (= checksum-old checksum-new)))
-        (error 'gzip-decompression-error
-               :format-control
-               "Checksum mismatch for decompressed stream: ~8,'0X != ~8,'0X!"
-               :format-arguments (list checksum-old checksum-new)))
-      (values checksum-old fname mtime fcomment))))
+                                        :checksum (when check-checksum :crc-32))))
+      (multiple-value-bind (checksum-old isize) (parse-gzip-footer input-stream)
+        ;; Handle Checksums
+        (when (and check-checksum (not (= checksum-old checksum-new)))
+          (error 'gzip-decompression-error
+                 :format-control
+                 "Checksum mismatch for decompressed stream: ~8,'0X != ~8,'0X!"
+                 :format-arguments (list checksum-old checksum-new)))
+        (values checksum-old fname mtime fcomment isize crc16-old crc16-new)))))