Common Lisp Source Engine VPK Reader.

;; LISP library for reading Valve Pak Files used by the Source Engine.
(defconstant file-identifier #x55aa1234)

(defconstant archive-index/no-archive #x7fff
  "This constant indicates that a file is stored immediately after the directory tree and not stored in an archive-file.")

(defun read-vpk (input-byte-stream &aux (vpk-list (list 'version nil 'directory-tree (list 'size nil 'tree nil))))
  "Reads a VPK header, directory, and footer sections returns it described as a list. Does not read archive files."

  (equalp file-identifier (let ((identifier (list 0 0 0 0)) (number 0) (index 0))
    (read-sequence identifier input-byte-stream)
    (map 'nil (lambda (b) (setf (ldb (byte 8 index) number) b) (incf index 8)) identifier)
    number
    ))

  (let ((version (list 0 0 0 0)) (number 0) (index 0))
    (read-sequence version input-byte-stream)
    (map 'nil (lambda (b) (setf (ldb (byte 8 index) number) b) (incf index 8)) version)
    (setf (getf vpk-list 'version) number)
    )

  (setf (getf (getf vpk-list 'directory-tree) 'size)
        (read-integer-seq-stream (list 0 0 0 0) input-byte-stream))

  (if (>= (getf vpk-list 'version) 2)
      (setf
       (getf vpk-list 'file-data-section-size)
       (read-integer-seq-stream (list 0 0 0 0) input-byte-stream)
       (getf vpk-list 'archive-md5-section-size)
       (read-integer-seq-stream (list 0 0 0 0) input-byte-stream)
       (getf vpk-list 'external-md5-section-size)
       (read-integer-seq-stream (list 0 0 0 0) input-byte-stream)
       (getf vpk-list 'signature-section-size)
       (read-integer-seq-stream (list 0 0 0 0) input-byte-stream))
      )
  ;; Read the file contents.
  ;; 1. The extension
  ;; 2. The path
  ;; 3. The file name.
  (flet
      ((binary-string-to-string ()
	 (do ((by-list '() (nconc by-list (list (read-byte input-byte-stream))))
	      )
	     ((eq (car (last by-list)) 0) (map 'string #'code-char by-list))))
       (read-file-entry () "Returns an entry for a file in a VPK and moves the stream reader after preload data."
	 (let*
	     ((crc (read-integer-seq-stream (list 0 0 0 0) input-byte-stream))
	      (preload-bytes (read-integer-seq-stream (list 0 0) input-byte-stream))
	      (archive-index (read-integer-seq-stream (list 0 0) input-byte-stream))
	      (entry-offset (read-integer-seq-stream (list 0 0 0 0) input-byte-stream))
	      (entry-length (read-integer-seq-stream (list 0 0 0 0) input-byte-stream))
	      (end-seq-bytes (list nil nil))
	      (preload-data (make-list preload-bytes)))
	   (read-sequence preload-data input-byte-stream)
	   (tagbody temp
	      (read-sequence end-seq-bytes input-byte-stream)
	      (if (equal end-seq-bytes (list #xFF #xFF))
		t (go temp)))
	   (list 'crc crc 'preload-data (list 'size preload-bytes 'text preload-data) 'archive-index archive-index 'entry-offset entry-offset 'entry-length entry-length))
	 ))


    (setf (getf (getf vpk-list 'directory-tree) 'tree)
	  (do* ((extension-name nil (binary-string-to-string))
		(extension-entry nil (list 'paths
					   (if (string-equal extension-name "�")
					     nil
					     (do* (
					       (path-name nil (binary-string-to-string))
					       (path-entry nil (list 'files
								     (if (string-equal path-name "�")
								       nil
								       (do* ((file-name nil (binary-string-to-string))
									     (file-entry nil (if (string-equal file-name "�") nil (read-file-entry)))
									     (file-list (list) (append file-list (list (cons file-name file-entry)))))
									    ((string-equal file-name "�") file-list)
									 ))))
					       (path-list nil (append path-list
								      (list (cons path-name path-entry))))
					       )
					      ((string-equal path-name "�") path-list)
					   ))))
		(extension-list (list)
				(append extension-list
					(list (cons extension-name extension-entry)))))
	       ((string-equal extension-name "�") extension-list)
	    ))
    )
  (if (>= (getf vpk-list 'version) 2)
    t
    (return-from read-vpk vpk-list)
    )

  (file-position input-byte-stream (+ (file-position input-byte-stream) (getf vpk-list 'file-data-section-size)))
  (file-position input-byte-stream (+ (file-position input-byte-stream) (getf vpk-list 'archive-md5-section-size) ))
  ;; Content checksum
  (if (= (getf vpk-list 'external-md5-section-size) 48)
    (progn
      (file-position input-byte-stream (+ (file-position input-byte-stream)  (getf vpk-list 'external-md5-section-size)))
      (setf (getf (getf vpk-list 'directory-tree) 'checksum) (read-integer-seq-stream (make-list 16 :initial-element 0) input-byte-stream))
      (setf (getf (getf vpk-list 'directory-tree) 'archive-md5-section-checksum) (read-integer-seq-stream (make-list 16 :initial-element 0) input-byte-stream))
      (setf (getf vpk-list 'unknown) (read-integer-seq-stream (make-list 16 :initial-element 0) input-byte-stream))
      )
    )
  (if (> (getf vpk-list 'signature-section-size) 0)
    (progn
      (file-position input-byte-stream (+ (file-position input-byte-stream)  (getf vpk-list 'signature-section-size)))
      (setf (getf (getf vpk-list 'signature) 'public-key) (read-integer-seq-stream (make-list (read-integer-seq-stream (list 0 0 0 0) input-byte-stream) :initial-element 0) input-byte-stream))
      (setf (getf (getf vpk-list 'signature) 'signature) (read-integer-seq-stream (make-list (read-integer-seq-stream (list 0 0 0 0) input-byte-stream) :initial-element 0) input-byte-stream))
      )
    )
  ;; Return the result property-list for the VPK.
  vpk-list
  )

;; Documentation
(setf (documentation 'archive 'specification) "A file which stores data chunk for a Chunk-separated VPK. They are numbered based on the index of a particular VPK .")
;; Utilities.

(defun convert-byte-list-to-integer (byte-list &aux (iterator 0) (number 0))
  (map 'nil (lambda (byt) (setf (ldb (byte 8 iterator) number) byt) (incf iterator 8)) byte-list)
  number
  )

(defun read-integer-seq-stream (byte-list input-byte-stream)
  (let ((by-list byte-list))
    (read-sequence by-list input-byte-stream)
    (convert-byte-list-to-integer by-list)))