commit 66c536a30845f98e483dbcc54999f41aa326ee70
parent 158965da77d54119c640ce76720b6be8e9b5bacb
Author: Tomas Hlavaty <tom@logand.com>
Date: Tue, 10 May 2011 22:46:56 +0200
can traverse directories and save big fat chains
Diffstat:
| M | ole.lisp | | | 246 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++------------------------- |
1 file changed, 168 insertions(+), 78 deletions(-)
diff --git a/ole.lisp b/ole.lisp
@@ -3,11 +3,12 @@
(in-package :ole)
+(defconstant +unused-sector+ 0)
(defconstant +maxregsect+ #xfffffffa)
(defconstant +difsect+ #xfffffffc)
(defconstant +fatsect+ #xfffffffd)
(defconstant +endofchain+ #xfffffffe)
-(defconstant +freesect #xffffffff)
+(defconstant +freesect+ #xffffffff)
(defconstant +maxregsig+ #xfffffffa)
(defconstant +nostream+ #xffffffff)
@@ -20,6 +21,7 @@
(deftype filetime () '(unsigned-byte 64))
(deftype guid () '(vector ubyte 16))
+#+nil
(defconstant clsid-null (make-array 16
:element-type '(unsigned-byte 8)
:initial-element 0))
@@ -91,7 +93,7 @@
(number-of-difat-sectors dword))
(define-structure ole-entry ()
- (name (wchar 32))
+ (name (wchar 32))
(name-length ushort)
(object-type ubyte)
(color-flag ubyte)
@@ -105,21 +107,20 @@
(starting-sector-location dword)
(stream-size ulonglong))
+(defun ole-entry-name-to-string (name length)
+ (coerce (mapcar #'code-char (coerce (subseq name 0 (1- (/ length 2))) 'list))
+ 'string))
+
(defun print-ole-entry (ole-entry stream)
(print-unreadable-object (ole-entry stream :type t :identity t)
- (format stream "~s ~s ~a ~sB @~s"
- (coerce
- (mapcar #'code-char
- (coerce (subseq (ole-entry.name ole-entry)
- 0
- (1- (/ (ole-entry.name-length ole-entry) 2)))
- 'list))
- 'string)
+ (format stream "~s ~a ~a ~sB @~s"
+ (ole-entry-name-to-string (ole-entry.name ole-entry)
+ (ole-entry.name-length ole-entry))
(ecase (ole-entry.object-type ole-entry)
- (0 :unknown-or-unallocated) ;; unknown
- (1 :storage-object) ;; directory
- (2 :stream-object) ;; file
- (5 :root-storage-object)) ;; root
+ (0 "unknown")
+ (1 "storage")
+ (2 "stream")
+ (5 "root"))
(ecase (ole-entry.color-flag ole-entry)
(0 "red")
(1 "black"))
@@ -134,14 +135,9 @@
(assert (file-position stream position))
location))
-(defun seek-sector-entry (ole-file location id)
- (assert (<= 0 id 3))
- (assert (file-position (ole-file.stream ole-file)
- (+ (location-position location) (* (/ 512 4) id)))))
-
(defun check-ole-header (x)
(assert (equalp #(#xd0 #xcf #x11 #xe0 #xa1 #xb1 #x1a #xe1) (ole-header.signature x)))
- (assert (equalp clsid-null (ole-header.clsid x)))
+ ;;(assert (equalp clsid-null (ole-header.clsid x)))
(assert (eql #xfffe (ole-header.byte-order x)))
(assert (equalp #(0 0 0 0 0 0) (ole-header.reserved x)))
;; TODO
@@ -153,77 +149,171 @@
(assert (eql 0 (ole-header.transaction-signature-number x)))
(assert (eql 4096 (ole-header.mini-stream-cutoff-size x)))
;;(assert (eql #xfffffffe (first-mini-fat-sector-location x)))
- #+nil(assert (eql #xfffffffe (first-difat-sector-location x)))
- #+nil(assert (eql 0 (number-of-difat-sectors x))))
+ (unless (plusp (ole-header.number-of-difat-sectors x))
+ (assert (eql #xfffffffe (ole-header.first-difat-sector-location x)))))
+
+(defstruct (ole-file (:conc-name ole-file.))
+ filename stream header difat fat directory-chain directories mfat-chain mfat)
+
+(defun sector-chain (fat location)
+ (labels ((rec (x)
+ (case x
+ ;;(#.+unused-sector+)
+ ;;(+maxregsect+)
+ (#.+difsect+)
+ (#.+fatsect+)
+ (#.+endofchain+)
+ (#.+freesect+)
+ (t
+ (assert (and #+nil(< +unused-sector+ x) (<= 0 x +maxregsect+)))
+ (cons x (rec (aref fat x)))))))
+ (rec location)))
+
+(defun read-values (array type stream &optional (start 0) end)
+ (loop
+ for i from start below (or end (length array))
+ do (setf (aref array i) (read-value type stream))))
+
+(defun read-difat (header stream)
+ (let ((x (make-array (+ 109
+ (* #.(/ (- 512 4) 4)
+ (ole-header.number-of-difat-sectors header)))
+ :element-type 'dword)))
+ (read-values x 'dword stream 0 109)
+ (loop
+ with m = #.(1- (/ 512 4))
+ for n = (ole-header.first-difat-sector-location header)
+ then (read-value 'dword stream)
+ for i = 109 then (+ m i)
+ until (= +endofchain+ n)
+ do (progn
+ (seek-sector n stream)
+ (read-values x 'dword stream i (+ m i))))
+ x))
+
+(defun read-fat (difat stream)
+ (let* ((m #.(/ 512 4))
+ (n (length difat))
+ (x (make-array (* m n) :element-type 'dword)))
+ (dotimes (i n x)
+ (let ((s (aref difat i)))
+ (unless (= +freesect+ s)
+ (seek-sector s stream)
+ (read-values x 'dword stream (* m i) (* m (1+ i))))))))
+
+(defun read-directories (chain stream)
+ (let* ((m #.(/ 512 128))
+ (x (make-array (* m (length chain))
+ :element-type '(or null ole-entry)
+ :initial-element nil))
+ (i -1))
+ (dolist (s chain x)
+ (seek-sector s stream)
+ (dotimes (j m)
+ (setf (aref x (incf i)) (read-ole-entry stream))))))
-(defstruct (ole-file (:conc-name ole-file.)) filename stream header bat-sectors bat)
+(defun read-mfat (chain stream)
+ (let* ((m #.(/ 512 4))
+ (x (make-array (* m (length chain)) :element-type 'dword))
+ (i -1))
+ (dolist (s chain x)
+ (seek-sector s stream)
+ ;;TODO block read (read-values x 'dword stream (* m i) (* m (1+ i)))
+ (dotimes (j m)
+ (setf (aref x (incf i)) (read-value 'dword stream))))))
+
+(defun traverse-directories (ole-file callback)
+ (let ((d (ole-file.directories ole-file)))
+ (labels ((rec (n level)
+ (let ((e (aref d n)))
+ (unless (zerop (ole-entry.object-type e))
+ (funcall callback e n level)
+ (let ((id (ole-entry.left-sibling-id e)))
+ (when (<= id +maxregsig+)
+ (rec id level)))
+ (let ((id (ole-entry.child-id e)))
+ (when (<= id +maxregsig+)
+ (rec id (1+ level))))
+ (let ((id (ole-entry.right-sibling-id e)))
+ (when (<= id +maxregsig+)
+ (rec id level)))))))
+ (rec 0 0))))
(defun call-with-ole-file (filename fn)
(with-open-file (stream filename :element-type '(unsigned-byte 8))
(let* ((header (read-ole-header stream))
- (bat-sectors (loop
- for i from 0 below (ole-header.number-of-fat-sectors header)
- collect (read-value 'dword stream)))
- (bat (let ((x (make-array (* 512 (ole-header.number-of-fat-sectors header))
- :element-type 'dword)))
- x))
+ (difat (read-difat header stream))
+ (fat (read-fat difat stream))
+ (directory-chain (sector-chain
+ fat
+ (ole-header.first-directory-sector-location header)))
+ (directories (read-directories directory-chain stream))
+ (mfat-chain (sector-chain
+ fat
+ (ole-header.first-mini-fat-sector-location header)))
+ (mfat (read-mfat mfat-chain stream))
(ole-file (make-ole-file
:filename filename
:stream stream
:header header
- :bat-sectors bat-sectors
- :bat bat)))
+ :difat difat
+ :fat fat
+ :directory-chain directory-chain
+ :directories directories
+ :mfat-chain mfat-chain
+ :mfat mfat)))
+ (describe ole-file)
(check-ole-header (ole-file.header ole-file))
- (loop ;; read bat
- for location in (ole-file.bat-sectors ole-file)
- for n = -1
- do (progn
- (seek-sector location (ole-file.stream ole-file))
- (dotimes (i (/ 512 4))
- (setf (aref (ole-file.bat ole-file) (incf n))
- (read-value 'dword (ole-file.stream ole-file))))))
+ (describe header)
+ (terpri)
+ (traverse-directories ole-file
+ (lambda (entry id level)
+ (declare (ignore id))
+ (dotimes (i level)
+ (write-string " "))
+ (print-ole-entry entry *standard-output*)
+ (terpri)))
+ ;; TODO small block chain for root entry
(funcall fn ole-file))))
(defmacro with-ole-file ((ole-file filename) &body body)
`(call-with-ole-file ,filename (lambda (,ole-file) ,@body)))
-(defun ls-ole (filename)
+(defun save-chain (ole-stream chain filename length)
+ (with-open-file (s filename
+ :direction :output
+ :if-does-not-exist :create
+ :if-exists :supersede
+ :element-type '(unsigned-byte 8))
+ (let ((buf (make-array 512 :element-type '(unsigned-byte 8))))
+ (dolist (x chain)
+ (seek-sector x ole-stream)
+ (let ((n (read-sequence buf ole-stream)))
+ (decf length n)
+ (write-sequence buf s :end (if (plusp length) n (+ length 512))))))))
+
+(defun save-entry-stream (ole-file entry filename)
+ (if (<= (ole-entry.stream-size entry)
+ (ole-header.mini-stream-cutoff-size (ole-file.header ole-file)))
+ :mfat ;; TODO mini stream
+ (save-chain (ole-file.stream ole-file)
+ (sector-chain (ole-file.fat ole-file)
+ (ole-entry.starting-sector-location entry))
+ filename
+ (ole-entry.stream-size entry))))
+
+(defun extract-ole-file (filename)
(with-ole-file (ole-file filename)
- (let ((stream (ole-file.stream ole-file)))
- (labels ((indent (n)
- (dotimes (i n)
- (write-string " ")))
- (rec (location id level)
- ;;(seek-sector location stream)
- (seek-sector-entry ole-file location id)
- (let ((x (read-ole-entry stream)))
- (indent level)
- (print id)
- (print-ole-entry x *standard-output*)
- #+nil
- (let ((y x))
- (loop
- for id = (ole-entry.left-sibling-id y) then (ole-entry.left-sibling-id y)
- while (<= id +maxregsig+)
- do (rec location id level)
- #+nil(progn
- (seek-sector-entry location 128 id s)
- (setq y (read-structure 'directory-entry s))
- (format t "L~s:~s ~s~%" level id y))))
- (let ((id (ole-entry.child-id x)))
- (when (<= id +maxregsig+)
- ;;(seek-sector-entry ole-file location id)
- (rec location id (1+ level))))
- #+nil
- (let ((y x))
- (loop
- for id = (ole-entry.right-sibling-id y) then (ole-entry.right-sibling-id y)
- while (<= id +maxregsig+)
- do (rec location id level)
- #+nil(progn
- (seek-sector-entry location 128 id s)
- (setq y (read-structure 'directory-entry s))
- (format t "R~s:~s ~s~%" level id y)))))))
- (rec (ole-header.first-directory-sector-location (ole-file.header ole-file))
- 0
- 0)))))
+ (traverse-directories
+ ole-file
+ (lambda (entry id level)
+ (declare (ignore id level))
+ (case (ole-entry.object-type entry)
+ ;;(1 "storage")
+ (2 ;; stream
+ (save-entry-stream ole-file
+ entry
+ (format nil "/tmp/~a"
+ (ole-entry-name-to-string
+ (ole-entry.name entry)
+ (ole-entry.name-length entry))))))))))
