commit 73b8f84f68d0391ccb4bbd9f2ab294b17f7c8f7b
parent 6d8daadaf1067381b20503f30e53260136b1d236
Author: Tomas Hlavaty <tom@logand.com>
Date: Mon, 3 Sep 2012 14:05:53 +0200
io refactoring, read-* functions defined
Diffstat:
| M | cdef.lisp | | | 22 | ++++++++++++++-------- |
| M | olefs.lisp | | | 104 | ++++++++++++++++++++++++++++++++++++++++++++----------------------------------- |
2 files changed, 72 insertions(+), 54 deletions(-)
diff --git a/cdef.lisp b/cdef.lisp
@@ -15,13 +15,19 @@
(destructuring-bind (type1 size) type
(list 'vector type1 (if (numberp size) size '*)))))
-(defun slot-type-definition-for-reader (type)
- (if (atom type)
- `(',type)
- (destructuring-bind (type1 size) type
- (if (numberp size)
- `('(,type1 ,size))
- `((list ',type1 ,size))))))
+(defun slot-type-read (type)
+ (cond
+ ((eq 'ubyte type)
+ `(read-byte stream))
+ ((atom type)
+ `(,(intern (format nil "READ-~a" type)) stream))
+ ((eq 'ubyte (car type))
+ `(read-byte-vector stream ,(cadr type)))
+ (t
+ `(read-vector stream ,(cadr type) ',(car type)
+ ',(intern (format nil "READ-~a" (car type)))))))
+
+;;(slot-type-read #+nil 'dword #+nil '(byte 6) '(wchar 6))
(defun slot-reader-let-definition (name type &key compute always member)
(list
@@ -29,7 +35,7 @@
(flet ((value ()
(cond
(compute compute)
- (t `(read-value ,@(slot-type-definition-for-reader type) stream)))))
+ (t (slot-type-read type)))))
(cond
(always `(let ((x ,(value))) (assert (equal x ,always)) x))
(member `(let ((x ,(value))) (assert (member x ,member)) x))
diff --git a/olefs.lisp b/olefs.lisp
@@ -17,35 +17,47 @@
:element-type '(unsigned-byte 8)
:initial-element 0))
-(defun read-value (type stream)
- (if (atom type)
- (ecase type
- (ubyte (read-byte stream))
- (achar (read-byte stream))
- (ushort (logior (read-byte stream)
- (ash (read-byte stream) 8)))
- (wchar (logior (read-byte stream)
- (ash (read-byte stream) 8)))
- (dword (logior (read-byte stream)
- (ash (read-byte stream) 8)
- (ash (read-byte stream) 16)
- (ash (read-byte stream) 24)))
- (ulonglong (logior (read-byte stream)
- (ash (read-byte stream) 8)
- (ash (read-byte stream) 16)
- (ash (read-byte stream) 24)
- (ash (read-byte stream) 32)
- (ash (read-byte stream) 40)
- (ash (read-byte stream) 48)
- (ash (read-byte stream) 56)))
- (filetime (read-value 'ulonglong stream))
- (guid (read-value '(ubyte 16) stream)))
- (destructuring-bind (element-type size) type
- (let ((x (make-array size
- :element-type element-type
- :initial-element 0)))
- (dotimes (i size x)
- (setf (aref x i) (read-value element-type stream)))))))
+(defun read-ushort (stream)
+ (logior (read-byte stream)
+ (ash (read-byte stream) 8)))
+
+(defun read-dword (stream)
+ (logior (read-byte stream)
+ (ash (read-byte stream) 8)
+ (ash (read-byte stream) 16)
+ (ash (read-byte stream) 24)))
+
+(defun read-ulonglong (stream)
+ (logior (read-byte stream)
+ (ash (read-byte stream) 8)
+ (ash (read-byte stream) 16)
+ (ash (read-byte stream) 24)
+ (ash (read-byte stream) 32)
+ (ash (read-byte stream) 40)
+ (ash (read-byte stream) 48)
+ (ash (read-byte stream) 56)))
+
+(defun read-achar (stream)
+ (read-byte stream))
+
+(defun read-wchar (stream)
+ (read-ushort stream))
+
+(defun read-filetime (stream)
+ (read-ulonglong stream))
+
+(defun read-byte-vector (stream n)
+ (let ((x (make-array n :element-type '(unsigned-byte 8) :initial-element 0)))
+ (read-sequence x stream)
+ x))
+
+(defun read-guid (stream)
+ (read-byte-vector stream 16))
+
+(defun read-vector (stream n element-type reader)
+ (let ((x (make-array n :element-type element-type :initial-element 0)))
+ (dotimes (i n x)
+ (setf (aref x i) (funcall reader stream)))))
(define-structure ole-header ()
(signature (ubyte 8))
@@ -136,26 +148,26 @@
(cons x (rec (aref fat x))))))
(rec location)))
-(defun read-values (array type stream &optional (start 0) end)
+(defun read-values (array reader stream &optional (start 0) end)
(loop
for i from start below (or end (length array))
- do (setf (aref array i) (read-value type stream))))
+ do (setf (aref array i) (funcall reader 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)
+ (read-values x 'read-dword stream 0 109)
(loop
with m = #.(1- (/ 512 4))
for n = (ole-header.first-difat-sector-location header)
- then (read-value 'dword stream)
+ then (read-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))))
+ (read-values x 'read-dword stream i (+ m i))))
x))
(defun read-fat (difat stream)
@@ -166,7 +178,7 @@
(let ((s (aref difat i)))
(unless (= +freesect+ s)
(seek-sector s stream)
- (read-values x 'dword stream (* m i) (* m (1+ i))))))))
+ (read-values x 'read-dword stream (* m i) (* m (1+ i))))))))
(defun read-directories (chain stream)
(let* ((m #.(/ 512 128))
@@ -185,9 +197,9 @@
(i -1))
(dolist (s chain x)
(seek-sector s stream)
- ;;TODO block read (read-values x 'dword stream (* m i) (* m (1+ i)))
+ ;;TODO block read (read-values x 'read-dword stream (* m i) (* m (1+ i)))
(dotimes (j m)
- (setf (aref x (incf i)) (read-value 'dword stream))))))
+ (setf (aref x (incf i)) (read-dword stream))))))
(defun traverse-directories (ole-file callback)
(let ((d (ole-file.directories ole-file)))
@@ -463,12 +475,12 @@
(y (make-blip
:header x
:ext ext
- :guid (read-value 'guid in)
+ :guid (read-guid in)
:guid2 (when (member recInstance guid2)
- (read-value 'guid in))
+ (read-guid in))
:metafileHeader (if metafileHeader
- (read-value 'OfficeArtMetafileHeader in)
- (read-value 'ubyte in)))))
+ (read-OfficeArtMetafileHeader in)
+ (read-byte in)))))
(when fn
(funcall fn y in))
(unless (eql end (file-position stream))
@@ -705,13 +717,13 @@
(with-output-to-string (s)
(loop
for j from 0 below (RecordHeader.recLen h) by 2
- do (format s "~a" (utf-char (read-value 'ushort in))))))
+ do (format s "~a" (utf-char (read-ushort in))))))
texts))
(t
(out "<p>")
(loop
for j from 0 below (RecordHeader.recLen h) by 2
- do (out "~a" (utf-char (read-value 'ushort in))))
+ do (out "~a" (utf-char (read-ushort in))))
(out "</p>~%")))))
(#.RT_TextBytesAtom ;; ascii
(unless (or (member #.RT_PROGTAGS parents :key 'RecordHeader.recType)
@@ -735,7 +747,7 @@
do (out "~a" (ascii-char (read-byte in))))
(out "</p>~%")))))
(#.RT_OUTLINETEXTREFATOM
- (let* ((index (1+ (read-value 'dword in)))
+ (let* ((index (1+ (read-dword in)))
(text (caddr
(find-if (lambda (x)
(and (= slide-no (car x))
@@ -750,7 +762,7 @@
(loop
while (< (file-position s) len)
do (let ((opid (read-OfficeArtFOPTEOPID s))
- (value (read-value 'dword s)))
+ (value (read-dword s)))
;;(out "<p>...... ~s ~s</p>~%" opid value)
(when (OfficeArtFOPTEOPID.fComplex opid)
(decf len value))
@@ -836,7 +848,7 @@
(out "<p>")
(loop
for j from 0 below (RecordHeader.recLen h) by 2
- do (out "~a" (utf-char (read-value 'ushort in))))
+ do (out "~a" (utf-char (read-ushort in))))
(out "</p>~%"))
(#.RT_TextBytesAtom ;; ascii
(out "<p>")
