cl-olefs

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

commit 8a5eae39e8469fe599d5b816f0b917ac80e1153f
parent 66c536a30845f98e483dbcc54999f41aa326ee70
Author: Tomas Hlavaty <tom@logand.com>
Date:   Fri, 13 May 2011 01:31:30 +0200

gray ole-entry-stream implemented

Diffstat:
Mole.asd | 2+-
Mole.lisp | 116++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-
2 files changed, 116 insertions(+), 2 deletions(-)

diff --git a/ole.asd b/ole.asd @@ -11,6 +11,6 @@ :author "Tomas Hlavaty" :maintainer "Tomas Hlavaty" :licence "" - :depends-on () + :depends-on (:trivial-gray-streams :alexandria) :serial t :components ((:file "ole"))) diff --git a/ole.lisp b/ole.lisp @@ -295,7 +295,12 @@ (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) ;; TODO mini stream, mfat? + (sector-chain (ole-file.fat ole-file) ;; mfat? + (ole-entry.starting-sector-location + (aref (ole-file.directories ole-file) 0))) + filename + (ole-entry.stream-size entry)) (save-chain (ole-file.stream ole-file) (sector-chain (ole-file.fat ole-file) (ole-entry.starting-sector-location entry)) @@ -317,3 +322,112 @@ (ole-entry-name-to-string (ole-entry.name entry) (ole-entry.name-length entry)))))))))) + +(defclass ole-entry-stream (trivial-gray-streams:fundamental-binary-input-stream) + ((ole-file :initarg :ole-file) + (ole-entry :initarg :ole-entry) + (offset :initform 0) + (sector-offset :initform -1) + (remaining) + (buffer) + (chain))) + +(defmethod initialize-instance :after ((instance ole-entry-stream) &rest initargs) + (declare (ignore initargs)) + (with-slots (ole-file ole-entry remaining buffer chain) instance + (setf remaining (ole-entry.stream-size ole-entry) + buffer (make-array 512 :element-type '(unsigned-byte 8)) + chain (sector-chain + (ole-file.fat ole-file) + (ole-entry.starting-sector-location ole-entry))))) + +(defmethod trivial-gray-streams-system::stream-element-type ((stream ole-entry-stream)) + '(unsigned-byte 8)) + +(defmethod trivial-gray-streams:stream-read-byte ((stream ole-entry-stream)) + (with-slots (ole-file offset sector-offset remaining buffer chain) stream + (cond + ((plusp remaining) + (incf offset) + (decf remaining) + (unless (< -1 sector-offset 512) + (let ((x (pop chain))) + (when x + (let ((ole-stream (ole-file.stream ole-file))) + (seek-sector x ole-stream) + (read-sequence buffer ole-stream)))) + (setq sector-offset 0)) + (prog1 (aref buffer sector-offset) + (incf sector-offset))) + (t :eof))) + #+nil + (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) ;; mfat + (ole-entry.starting-sector-location + (aref (ole-file.directories ole-file) 0))) + filename + (ole-entry.stream-size entry)) + (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 call-with-ole-entry-stream (stream fn) + (with-open-stream (x stream) + (funcall fn x))) + +(defmacro with-ole-entry-stream ((var ole-file ole-entry) &body body) + `(call-with-ole-entry-stream + (make-instance 'ole-entry-stream :ole-file ,ole-file :ole-entry ,ole-entry) + (lambda (,var) ,@body))) + + +(define-structure OfficeArtRecordHeader () + (recVer ushort :always 0) + (recInstance ushort :member '(#x46A #x46B #x6E2 #x6E3)) + (recType ushort :always #xF01D) + (recLen ushort)) + +(define-structure OfficeArtBlipJPEG () + ;;(rh OfficeArtRecordHeader) + (rgbUid1 guid) + (rgbUid2 guid ;;:optional '(when (member recInstance '(#x46B #x6E3))) + ) + (tag ubyte) + #+nil(BLIBFileData)) + +(defun extract-ole-file2 (filename) + (with-ole-file (ole-file filename) + (traverse-directories + ole-file + (lambda (entry id level) + (declare (ignore id level)) + (case (ole-entry.object-type entry) + ;;(1 "storage") + (2 ;; stream + (let ((entry-name (ole-entry-name-to-string + (ole-entry.name entry) + (ole-entry.name-length entry)))) + (with-ole-entry-stream (in ole-file entry) + (with-open-file (out (format nil "/tmp/a/~a" entry-name) + :direction :output + :if-does-not-exist :create + :if-exists :supersede + :element-type '(unsigned-byte 8)) + (alexandria:copy-stream in out))) + (when (equal "Pictures" entry-name) + (with-ole-entry-stream (in ole-file entry) + (print (read-OfficeArtRecordHeader in)) + (print (read-value 'guid in)) + (read-value 'ubyte in) + (with-open-file (out "/tmp/a/a.jpeg" + :direction :output + :if-does-not-exist :create + :if-exists :supersede + :element-type '(unsigned-byte 8)) + (alexandria:copy-stream in out))))))))))) +