cl-olefs

OLE File System tools for Common Lisp
git clone https://logand.com/git/cl-olefs.git/
Log | Files | Refs

commit 4ae3851eaea896105cfe7fb97457210649043cdb
parent 54ec6bcd626c46728bee10d20b9ae78e7186eb43
Author: Tomas Hlavaty <tom@logand.com>
Date:   Mon, 23 May 2011 22:35:20 +0200

more OfficeArtBlips added

Diffstat:
Mole.lisp | 64+++++++++++++++++++++++++++++++++++++++++++++++++++++++---------
1 file changed, 55 insertions(+), 9 deletions(-)

diff --git a/ole.lisp b/ole.lisp @@ -408,14 +408,36 @@ (make-instance 'shorter-stream :wrap ,wrap :size ,size) (lambda (,var) ,@body))) +(define-structure POINT () + (x dword) + (y dword)) + +(define-structure RECT () + (left dword) + (top dword) + (right dword) + (bottom dword)) + +(define-structure OfficeArtMetafileHeader () + (cbSize dword) + (rcBounds RECT) + (ptSize POINT) + (cbSave dword) + (compression byte :member '(#x00 #xfe)) + (filter byte :always #xfe)) + (defun read-record (stream dir &optional n) ;; TODO remove dir and n (let ((x (read-RecordHeader stream))) (with-slots (recVer recInstance recType recLen) x - (flet ((blip (ext) + (flet ((blip (ext guid2 &optional metafileHeader) (with-shorter-stream (in stream (RecordHeader.recLen x)) - (list x + (list x ;; TODO make struct (read-value 'guid in) - (read-value 'ubyte in) + (when (member recInstance guid2) + (read-value 'guid in)) + (if metafileHeader + (read-value 'OfficeArtMetafileHeader in) + (read-value 'ubyte in)) (with-open-file (out (format nil "~a/_~d.~a" dir n ext) :direction :output :if-does-not-exist :create @@ -427,14 +449,38 @@ (assert (zerop recVer)) (assert (zerop recInstance)) (list x (read-CurrentUserAtom stream)) - #+nil + #+nil ;; why recLen too small? (with-shorter-stream (in stream (RecordHeader.recLen x)) - (list x (read-CurrentUserAtom in)))) ;; why recLen too small? - ((#xF01E) ;; OfficeArtBlipPNG + (list x (read-CurrentUserAtom in)))) + ((#xF01A) ;; OfficeArtBlipEMF (assert (zerop recVer)) - (assert (member recInstance '(#x6e0 #x6e1))) - (values (blip "png") :png)) + (assert (member recInstance '(#x3d4 #x3d5))) + (values (blip "emf" '(#x3d5) t) :emf)) + ((#xF01B) ;; OfficeArtBlipWMF + (assert (zerop recVer)) + (assert (member recInstance '(#x216 #x217))) + (values (blip "wmf" '(#x217) t) :wmf)) + ((#xF01C) ;; OfficeArtBlipPICT + (assert (zerop recVer)) + (assert (member recInstance '(#x542 #x543))) + (values (blip "pict" '(#x543) t) :pict)) (#xF01D ;; OfficeArtBlipJPEG (assert (zerop recVer)) (assert (member recInstance '(#x46A #x46B #x6E2 #x6E3))) - (values (blip "jpeg") :jpeg))))))) + (values (blip "jpeg" '(#x46B #x6E3)) :jpeg)) + ((#xF01E) ;; OfficeArtBlipPNG + (assert (zerop recVer)) + (assert (member recInstance '(#x6e0 #x6e1))) + (values (blip "png"'(#x6e1)) :png)) + ((#xF01F) ;; OfficeArtBlipDIB + (assert (zerop recVer)) + (assert (member recInstance '(#x7a8 #x7a9))) + (values (blip "dib" '(#x7a9)) :dib)) + ((#xF029) ;; OfficeArtBlipTIFF + (assert (zerop recVer)) + (assert (member recInstance '(#x6e4 #x6e5))) + (values (blip "tiff" '(#x6e5)) :tiff)) + ((#xF02A) ;; OfficeArtBlipJPEG + (assert (zerop recVer)) + (assert (member recInstance '(#x46A #x46B #x6E2 #x6E3))) + (values (blip "jpeg" '(#x46B #x6E3)) :jpeg)))))))