gistfile1.lisp

;; -*- mode:common-lisp -*-

(defun map-file (filename &rest flags)
  "Maps FILENAME, returns the opened stream, base aligned address and length."
  (let ((s (apply #'open filename :mapped t flags)))
    (values s (slot-value s 'excl::buffer) (file-length s))))

;; Read unaligned little-endian numbers
(defun read-u8  (base off)
  (sys:memref base off 0 :unsigned-byte))
(defun read-u16 (base off)
  (+ (sys:memref base off 0 :unsigned-byte)
     (ash (sys:memref base off 1 :unsigned-byte) 8)))
(defun read-u32 (base off)
  (+ (sys:memref base off 0 :unsigned-byte)
     (ash (sys:memref base off 1 :unsigned-byte) 8)
     (ash (sys:memref base off 2 :unsigned-byte) 16)
     (ash (sys:memref base off 3 :unsigned-byte) 24)))

;; Fetch string from memory
(defun read-str (base off len)
  (native-to-string (+ (ff:aligned-to-address base) off) :length len))


(defun find-end-of-central-directory (base size)
  "Find the end-of-central-directory record, returns the offset of the first
   central directory, and the number of central directory records."
  (macrolet ((search-for (byte success fail)
               `(cond ((= off 0) (error "Zip central directory not found"))
                      ((= (read-u8 base off) ,byte) (,success (- off 1)))
                      (t (,fail (- off 1))))))
    (labels ((byte1 (off) (search-for #x06 byte2 byte1))
             (byte2 (off) (search-for #x05 byte3 byte1))
             (byte3 (off) (search-for #x4b byte4 byte1))
             (byte4 (off) (search-for #x50 done byte1))
             (done (off)
               (incf off)
               (unless (= (read-u16 base (+ off 4)) 0) ; # of this disk
                 (error "Multi-disk archive isn't supported"))
               (values (read-u32 base (+ off 16))   ; offset of central directory
                       (read-u16 base (+ off 10))))) ; # of central directory recs
      (byte1 (- size 1)))))

(defun read-central-directory-record (base off)
  "Read a central directory record at offset OFF, returns a list of next offset and infos."
  (unless (= (read-u32 base off) #x02014b50)
    (error "Corrupted central directory record at offset ~s (~x)" off (read-u32 base off)))
  (let ((version-made       (read-u16 base (+ off 4)))
        (version-required   (read-u16 base (+ off 6)))
        (compression-method (read-u16 base (+ off 10)))
        (uncompressed-size  (read-u16 base (+ off 24)))
        (filename-len       (read-u16 base (+ off 28)))
        (extra-len          (read-u16 base (+ off 30)))
        (comment-len        (read-u16 base (+ off 32))))
    (list (+ off 46 filename-len extra-len comment-len)
          (read-str base (+ off 46) filename-len)
          uncompressed-size
          (case compression-method
            (0 'uncompressed)
            (1 'unshrinking)
            ((2 3 4 5) `(expanding ,compression-method))
            (6 'imploding)
            (7 'tokenizing)
            (8 'deflating)
            (9 'enhanced-deflating)
            (12 'bzip2)
            (14 'lzma)
            (97 'wavpack)
            (98 'ppmd)
            (otherwise `(unknown ,compression-method)))
          version-made
          version-required)))

(defun parse-central-directory (base size)
  (multiple-value-bind (off count) (find-end-of-central-directory base size)
    (format t "offset=~x count=~s~%" off count)
    (loop for i from 0 below count
       for (next . info) = (read-central-directory-record base off)
       collect info
       do (setf off next))))

(defun zipinfo (filename)
  (multiple-value-bind (stream base size) (map-file filename)
    (unwind-protect (parse-central-directory base size)
      (close stream))))