commit 54ec6bcd626c46728bee10d20b9ae78e7186eb43
parent 918afce41d645676f46db099cd818b034a2c5228
Author: Tomas Hlavaty <tom@logand.com>
Date: Sat, 21 May 2011 18:47:07 +0200
png and jpeg extraction from powerpoint files works
Diffstat:
| A | cdef.lisp | | | 56 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | enums.lisp | | | 220 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| M | ole.asd | | | 7 | +++++-- |
| M | ole.lisp | | | 258 | ++++++++++++++++++++++++++++++++++++++++--------------------------------------- |
| A | package.lisp | | | 2 | ++ |
5 files changed, 414 insertions(+), 129 deletions(-)
diff --git a/cdef.lisp b/cdef.lisp
@@ -0,0 +1,56 @@
+(in-package :ole)
+
+(deftype achar () '(unsigned-byte 8))
+(deftype ubyte () '(unsigned-byte 8))
+(deftype ushort () '(unsigned-byte 16))
+(deftype wchar () '(unsigned-byte 16))
+(deftype dword () '(unsigned-byte 32))
+(deftype ulonglong () '(unsigned-byte 64))
+(deftype filetime () '(unsigned-byte 64))
+(deftype guid () '(vector ubyte 16))
+
+(defun slot-type-definition (type)
+ (if (atom type)
+ type
+ (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-reader-let-definition (name type &key compute always member)
+ (list
+ name
+ (flet ((value ()
+ (cond
+ (compute compute)
+ (t `(read-value ,@(slot-type-definition-for-reader type) stream)))))
+ (cond
+ (always `(let ((x ,(value))) (assert (equal x ,always)) x))
+ (member `(let ((x ,(value))) (assert (member x ,member)) x))
+ (t (value))))))
+
+(defmacro define-structure (name options &rest slots)
+ (declare (ignore options))
+ `(progn
+ (defstruct (,name (:conc-name ,(intern (format nil "~a." name))))
+ ,@(loop
+ for slot in slots
+ collect (list (car slot)
+ nil
+ :type (slot-type-definition (cadr slot)))))
+ (defun ,(intern (format nil "READ-~a" name)) (stream)
+ (let* (,@(loop
+ for slot in slots
+ collect (apply 'slot-reader-let-definition slot)))
+ (,(intern (format nil "MAKE-~a" name))
+ ,@(loop
+ for slot in slots
+ appending (list
+ (intern (symbol-name (car slot)) :keyword)
+ (car slot))))))))
diff --git a/enums.lisp b/enums.lisp
@@ -0,0 +1,220 @@
+(in-package :ole)
+
+(defconstant RT_Document #x03E8)
+(defconstant RT_DocumentAtom #x03E9)
+(defconstant RT_EndDocumentAtom #x03EA)
+(defconstant RT_Slide #x03EE)
+(defconstant RT_SlideAtom #x03EF)
+(defconstant RT_Notes #x03F0)
+(defconstant RT_NotesAtom #x03F1)
+(defconstant RT_Environment #x03F2)
+(defconstant RT_SlidePersistAtom #x03F3)
+(defconstant RT_MainMaster #x03F8)
+(defconstant RT_SlideShowSlideInfoAtom #x03F9)
+(defconstant RT_SlideViewInfo #x03FA)
+(defconstant RT_GuideAtom #x03FB)
+(defconstant RT_ViewInfoAtom #x03FD)
+(defconstant RT_SlideViewInfoAtom #x03FE)
+(defconstant RT_VbaInfo #x03FF)
+(defconstant RT_VbaInfoAtom #x0400)
+(defconstant RT_SlideShowDocInfoAtom #x0401)
+(defconstant RT_Summary #x0402)
+(defconstant RT_DocRoutingSlipAtom #x0406)
+(defconstant RT_OutlineViewInfo #x0407)
+(defconstant RT_SorterViewInfo #x0408)
+(defconstant RT_ExternalObjectList #x0409)
+(defconstant RT_ExternalObjectListAtom #x040A)
+(defconstant RT_DrawingGroup #x040B)
+(defconstant RT_Drawing #x040C)
+(defconstant RT_GridSpacing10Atom #x040D)
+(defconstant RT_RoundTripTheme12Atom #x040E)
+(defconstant RT_RoundTripColorMapping12Atom #x040F)
+(defconstant RT_NamedShows #x0410)
+(defconstant RT_NamedShow #x0411)
+(defconstant RT_NamedShowSlidesAtom #x0412)
+(defconstant RT_NotesTextViewInfo9 #x0413)
+(defconstant RT_NormalViewSetInfo9 #x0414)
+(defconstant RT_NormalViewSetInfo9Atom #x0415)
+(defconstant RT_RoundTripOriginalMainMasterId12Atom #x041C)
+(defconstant RT_RoundTripCompositeMasterId12Atom #x041D)
+(defconstant RT_RoundTripContentMasterInfo12Atom #x041E)
+(defconstant RT_RoundTripShapeId12Atom #x041F)
+(defconstant RT_RoundTripHFPlaceholder12Atom #x0420)
+(defconstant RT_RoundTripContentMasterId12Atom #x0422)
+(defconstant RT_RoundTripOArtTextStyles12Atom #x0423)
+(defconstant RT_RoundTripHeaderFooterDefaults12Atom #x0424)
+(defconstant RT_RoundTripDocFlags12Atom #x0425)
+(defconstant RT_RoundTripShapeCheckSumForCL12Atom #x0426)
+(defconstant RT_RoundTripNotesMasterTextStyles12Atom #x0427)
+(defconstant RT_RoundTripCustomTableStyles12Atom #x0428)
+(defconstant RT_List #x07D0)
+(defconstant RT_FontCollection #x07D5)
+(defconstant RT_FontCollection10 #x07D6)
+(defconstant RT_BookmarkCollection #x07E3)
+(defconstant RT_SoundCollection #x07E4)
+(defconstant RT_SoundCollectionAtom #x07E5)
+(defconstant RT_Sound #x07E6)
+(defconstant RT_SoundDataBlob #x07E7)
+(defconstant RT_BookmarkSeedAtom #x07E9)
+(defconstant RT_ColorSchemeAtom #x07F0)
+(defconstant RT_BlipCollection9 #x07F8)
+(defconstant RT_BlipEntity9Atom #x07F9)
+(defconstant RT_ExternalObjectRefAtom #x0BC1)
+(defconstant RT_PlaceholderAtom #x0BC3)
+(defconstant RT_ShapeAtom #x0BDB)
+(defconstant RT_ShapeFlags10Atom #x0BDC)
+(defconstant RT_RoundTripNewPlaceholderId12Atom #x0BDD)
+(defconstant RT_OutlineTextRefAtom #x0F9E)
+(defconstant RT_TextHeaderAtom #x0F9F)
+(defconstant RT_TextCharsAtom #x0FA0)
+(defconstant RT_StyleTextPropAtom #x0FA1)
+(defconstant RT_MasterTextPropAtom #x0FA2)
+(defconstant RT_TextMasterStyleAtom #x0FA3)
+(defconstant RT_TextCharFormatExceptionAtom #x0FA4)
+(defconstant RT_TextParagraphFormatExceptionAtom #x0FA5)
+(defconstant RT_TextRulerAtom #x0FA6)
+(defconstant RT_TextBookmarkAtom #x0FA7)
+(defconstant RT_TextBytesAtom #x0FA8)
+(defconstant RT_TextSpecialInfoDefaultAtom #x0FA9)
+(defconstant RT_TextSpecialInfoAtom #x0FAA)
+(defconstant RT_DefaultRulerAtom #x0FAB)
+(defconstant RT_StyleTextProp9Atom #x0FAC)
+(defconstant RT_TextMasterStyle9Atom #x0FAD)
+(defconstant RT_OutlineTextProps9 #x0FAE)
+(defconstant RT_OutlineTextPropsHeader9Atom #x0FAF)
+(defconstant RT_TextDefaults9Atom #x0FB0)
+(defconstant RT_StyleTextProp10Atom #x0FB1)
+(defconstant RT_TextMasterStyle10Atom #x0FB2)
+(defconstant RT_OutlineTextProps10 #x0FB3)
+(defconstant RT_TextDefaults10Atom #x0FB4)
+(defconstant RT_OutlineTextProps11 #x0FB5)
+(defconstant RT_StyleTextProp11Atom #x0FB6)
+(defconstant RT_FontEntityAtom #x0FB7)
+(defconstant RT_FontEmbedDataBlob #x0FB8)
+(defconstant RT_CString #x0FBA)
+(defconstant RT_MetaFile #x0FC1)
+(defconstant RT_ExternalOleObjectAtom #x0FC3)
+(defconstant RT_Kinsoku #x0FC8)
+(defconstant RT_Handout #x0FC9)
+(defconstant RT_ExternalOleEmbed #x0FCC)
+(defconstant RT_ExternalOleEmbedAtom #x0FCD)
+(defconstant RT_ExternalOleLink #x0FCE)
+(defconstant RT_BookmarkEntityAtom #x0FD0)
+(defconstant RT_ExternalOleLinkAtom #x0FD1)
+(defconstant RT_KinsokuAtom #x0FD2)
+(defconstant RT_ExternalHyperlinkAtom #x0FD3)
+(defconstant RT_ExternalHyperlink #x0FD7)
+(defconstant RT_SlideNumberMetaCharAtom #x0FD8)
+(defconstant RT_HeadersFooters #x0FD9)
+(defconstant RT_HeadersFootersAtom #x0FDA)
+(defconstant RT_TextInteractiveInfoAtom #x0FDF)
+(defconstant RT_ExternalHyperlink9 #x0FE4)
+(defconstant RT_RecolorInfoAtom #x0FE7)
+(defconstant RT_ExternalOleControl #x0FEE)
+(defconstant RT_SlideListWithText #x0FF0)
+(defconstant RT_AnimationInfoAtom #x0FF1)
+(defconstant RT_InteractiveInfo #x0FF2)
+(defconstant RT_InteractiveInfoAtom #x0FF3)
+(defconstant RT_UserEditAtom #x0FF5)
+(defconstant RT_CurrentUserAtom #x0FF6)
+(defconstant RT_DateTimeMetaCharAtom #x0FF7)
+(defconstant RT_GenericDateMetaCharAtom #x0FF8)
+(defconstant RT_HeaderMetaCharAtom #x0FF9)
+(defconstant RT_FooterMetaCharAtom #x0FFA)
+(defconstant RT_ExternalOleControlAtom #x0FFB)
+(defconstant RT_ExternalMediaAtom #x1004)
+(defconstant RT_ExternalVideo #x1005)
+(defconstant RT_ExternalAviMovie #x1006)
+(defconstant RT_ExternalMciMovie #x1007)
+(defconstant RT_ExternalMidiAudio #x100D)
+(defconstant RT_ExternalCdAudio #x100E)
+(defconstant RT_ExternalWavAudioEmbedded #x100F)
+(defconstant RT_ExternalWavAudioLink #x1010)
+(defconstant RT_ExternalOleObjectStg #x1011)
+(defconstant RT_ExternalCdAudioAtom #x1012)
+(defconstant RT_ExternalWavAudioEmbeddedAtom #x1013)
+(defconstant RT_AnimationInfo #x1014)
+(defconstant RT_RtfDateTimeMetaCharAtom #x1015)
+(defconstant RT_ExternalHyperlinkFlagsAtom #x1018)
+(defconstant RT_ProgTags #x1388)
+(defconstant RT_ProgStringTag #x1389)
+(defconstant RT_ProgBinaryTag #x138A)
+(defconstant RT_BinaryTagDataBlob #x138B)
+(defconstant RT_PrintOptionsAtom #x1770)
+(defconstant RT_PersistDirectoryAtom #x1772)
+(defconstant RT_PresentationAdvisorFlags9Atom #x177A)
+(defconstant RT_HtmlDocInfo9Atom #x177B)
+(defconstant RT_HtmlPublishInfoAtom #x177C)
+(defconstant RT_HtmlPublishInfo9 #x177D)
+(defconstant RT_BroadcastDocInfo9 #x177E)
+(defconstant RT_BroadcastDocInfo9Atom #x177F)
+(defconstant RT_EnvelopeFlags9Atom #x1784)
+(defconstant RT_EnvelopeData9Atom #x1785)
+(defconstant RT_VisualShapeAtom #x2AFB)
+(defconstant RT_HashCodeAtom #x2B00)
+(defconstant RT_VisualPageAtom #x2B01)
+(defconstant RT_BuildList #x2B02)
+(defconstant RT_BuildAtom #x2B03)
+(defconstant RT_ChartBuild #x2B04)
+(defconstant RT_ChartBuildAtom #x2B05)
+(defconstant RT_DiagramBuild #x2B06)
+(defconstant RT_DiagramBuildAtom #x2B07)
+(defconstant RT_ParaBuild #x2B08)
+(defconstant RT_ParaBuildAtom #x2B09)
+(defconstant RT_LevelInfoAtom #x2B0A)
+(defconstant RT_RoundTripAnimationAtom12Atom #x2B0B)
+(defconstant RT_RoundTripAnimationHashAtom12Atom #x2B0D)
+(defconstant RT_Comment10 #x2EE0)
+(defconstant RT_Comment10Atom #x2EE1)
+(defconstant RT_CommentIndex10 #x2EE4)
+(defconstant RT_CommentIndex10Atom #x2EE5)
+(defconstant RT_LinkedShape10Atom #x2EE6)
+(defconstant RT_LinkedSlide10Atom #x2EE7)
+(defconstant RT_SlideFlags10Atom #x2EEA)
+(defconstant RT_SlideTime10Atom #x2EEB)
+(defconstant RT_DiffTree10 #x2EEC)
+(defconstant RT_Diff10 #x2EED)
+(defconstant RT_Diff10Atom #x2EEE)
+(defconstant RT_SlideListTableSize10Atom #x2EEF)
+(defconstant RT_SlideListEntry10Atom #x2EF0)
+(defconstant RT_SlideListTable10 #x2EF1)
+(defconstant RT_CryptSession10Container #x2F14)
+(defconstant RT_FontEmbedFlags10Atom #x32C8)
+(defconstant RT_FilterPrivacyFlags10Atom #x36B0)
+(defconstant RT_DocToolbarStates10Atom #x36B1)
+(defconstant RT_PhotoAlbumInfo10Atom #x36B2)
+(defconstant RT_SmartTagStore11Container #x36B3)
+(defconstant RT_RoundTripSlideSyncInfo12 #x3714)
+(defconstant RT_RoundTripSlideSyncInfoAtom12 #x3715)
+(defconstant RT_TimeConditionContainer #xF125)
+(defconstant RT_TimeNode #xF127)
+(defconstant RT_TimeCondition #xF128)
+(defconstant RT_TimeModifier #xF129)
+(defconstant RT_TimeBehaviorContainer #xF12A)
+(defconstant RT_TimeAnimateBehaviorContainer #xF12B)
+(defconstant RT_TimeColorBehaviorContainer #xF12C)
+(defconstant RT_TimeEffectBehaviorContainer #xF12D)
+(defconstant RT_TimeMotionBehaviorContainer #xF12E)
+(defconstant RT_TimeRotationBehaviorContainer #xF12F)
+(defconstant RT_TimeScaleBehaviorContainer #xF130)
+(defconstant RT_TimeSetBehaviorContainer #xF131)
+(defconstant RT_TimeCommandBehaviorContainer #xF132)
+(defconstant RT_TimeBehavior #xF133)
+(defconstant RT_TimeAnimateBehavior #xF134)
+(defconstant RT_TimeColorBehavior #xF135)
+(defconstant RT_TimeEffectBehavior #xF136)
+(defconstant RT_TimeMotionBehavior #xF137)
+(defconstant RT_TimeRotationBehavior #xF138)
+(defconstant RT_TimeScaleBehavior #xF139)
+(defconstant RT_TimeSetBehavior #xF13A)
+(defconstant RT_TimeCommandBehavior #xF13B)
+(defconstant RT_TimeClientVisualElement #xF13C)
+(defconstant RT_TimePropertyList #xF13D)
+(defconstant RT_TimeVariantList #xF13E)
+(defconstant RT_TimeAnimationValueList #xF13F)
+(defconstant RT_TimeIterateData #xF140)
+(defconstant RT_TimeSequenceData #xF141)
+(defconstant RT_TimeVariant #xF142)
+(defconstant RT_TimeAnimationValue #xF143)
+(defconstant RT_TimeExtTimeNodeContainer #xF144)
+(defconstant RT_TimeSlaveContainer #xF145)
diff --git a/ole.asd b/ole.asd
@@ -6,11 +6,14 @@
(in-package :ole-system)
(defsystem :ole
- :description "Ole for Common Lisp."
+ :description "OLE for Common Lisp."
:version ""
:author "Tomas Hlavaty"
:maintainer "Tomas Hlavaty"
:licence ""
:depends-on (:trivial-gray-streams :alexandria)
:serial t
- :components ((:file "ole")))
+ :components ((:file "package")
+ (:file "cdef")
+ (:file "enums")
+ (:file "ole")))
diff --git a/ole.lisp b/ole.lisp
@@ -1,8 +1,7 @@
-(defpackage :ole
- (:use :cl))
-
(in-package :ole)
+;;; MS-CFB Compound File Binary File Format
+
(defconstant +unused-sector+ 0)
(defconstant +maxregsect+ #xfffffffa)
(defconstant +difsect+ #xfffffffc)
@@ -13,14 +12,6 @@
(defconstant +maxregsig+ #xfffffffa)
(defconstant +nostream+ #xffffffff)
-(deftype ubyte () '(unsigned-byte 8))
-(deftype ushort () '(unsigned-byte 16))
-(deftype wchar () '(unsigned-byte 16))
-(deftype dword () '(unsigned-byte 32))
-(deftype ulonglong () '(unsigned-byte 64))
-(deftype filetime () '(unsigned-byte 64))
-(deftype guid () '(vector ubyte 16))
-
#+nil
(defconstant clsid-null (make-array 16
:element-type '(unsigned-byte 8)
@@ -30,6 +21,7 @@
(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)
@@ -55,24 +47,6 @@
(dotimes (i size x)
(setf (aref x i) (read-value element-type stream)))))))
-(defmacro define-structure (name options &rest slots)
- (declare (ignore options))
- `(progn
- (defstruct (,name (:conc-name ,(intern (format nil "~a." name))))
- ,@(loop
- for (name2 type) in slots
- collect (list name2
- nil
- :type (if (atom type)
- type
- (cons 'vector type)))))
- (defun ,(intern (format nil "READ-~a" name)) (stream)
- (,(intern (format nil "MAKE-~a" name))
- ,@(loop
- for (name2 type) in slots
- appending `(,(intern (symbol-name name2) :keyword)
- (read-value ',type stream)))))))
-
(define-structure ole-header ()
(signature (ubyte 8))
(clsid guid)
@@ -157,16 +131,9 @@
(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)))))))
+ (unless (member x (list +difsect+ +fatsect+ +endofchain+ +freesect+))
+ (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)
@@ -262,10 +229,11 @@
:directories directories
:mfat-chain mfat-chain
:mfat mfat)))
- (describe ole-file)
+ ;;(describe ole-file)
(check-ole-header (ole-file.header ole-file))
- (describe header)
- (terpri)
+ ;;(describe header)
+ ;;(terpri)
+ #+nil
(traverse-directories ole-file
(lambda (entry id level)
(declare (ignore id))
@@ -279,52 +247,8 @@
(defmacro with-ole-file ((ole-file filename) &body body)
`(call-with-ole-file ,filename (lambda (,ole-file) ,@body)))
-(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)))
- (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))
- filename
- (ole-entry.stream-size entry))))
-
-(defun extract-ole-file (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
- (save-entry-stream ole-file
- entry
- (format nil "/tmp/~a"
- (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)
+(defclass ole-entry-stream (trivial-gray-streams:fundamental-binary-input-stream
+ trivial-gray-streams:trivial-gray-stream-mixin)
((ole-file :initarg :ole-file)
(ole-entry :initarg :ole-entry)
(offset :initform 0)
@@ -358,6 +282,10 @@
(defmethod trivial-gray-streams::stream-element-type ((stream ole-entry-stream))
'(unsigned-byte 8))
+(defmethod trivial-gray-streams:stream-file-position ((stream ole-entry-stream))
+ (with-slots (offset) stream
+ offset))
+
(defmethod trivial-gray-streams:stream-read-byte ((stream ole-entry-stream))
(with-slots (ole-file ole-entry offset chain mchain sector buffer size) stream
(assert (not (minusp offset)))
@@ -388,49 +316,125 @@
(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)
+(defun extract-ole-file (filename &optional (dir "/tmp"))
(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-open-file (html (format nil "~a/index.html" dir)
+ :direction :output
+ :if-does-not-exist :create
+ :if-exists :supersede
+ :element-type 'character)
+ (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)
- (print (read-OfficeArtRecordHeader in))
- (print (read-value 'guid in))
- (read-value 'ubyte in)
- (with-open-file (out "/tmp/a/a.jpeg"
+ (with-open-file (out (format nil "~a/~a" dir entry-name)
:direction :output
:if-does-not-exist :create
:if-exists :supersede
:element-type '(unsigned-byte 8))
- (alexandria:copy-stream in out)))))))))))
+ (alexandria:copy-stream in out)))
+ #+nil
+ (when (equal "Current User" entry-name)
+ (with-ole-entry-stream (in ole-file entry)
+ (print (read-record dir in))))
+ (when (equal "Pictures" entry-name)
+ (with-ole-entry-stream (in ole-file entry)
+ (loop
+ for n from 1
+ while t ;; TODO until eof!
+ do (multiple-value-bind (blib kind)
+ (read-record in dir n)
+ (format html "<p><img src=\"_~d.~(~a~)\">~%" n kind)))))))))))))
+
+;;; MS-PPT PowerPoint (.ppt) Binary File Format
+
+(define-structure RecordHeader ()
+ (%dummy1 ubyte)
+ (%dummy2 ubyte)
+ (recVer t :compute (logand #x0f %dummy1))
+ (recInstance t :compute (logior (ash %dummy2 4) (ash %dummy1 -4)))
+ (recType ushort)
+ (recLen dword))
+
+(define-structure CurrentUserAtom ()
+ (size dword :always #x14)
+ (headerToken dword)
+ (offsetToCurrentEdit dword)
+ (lenUserName ushort)
+ (docFileVersion ushort)
+ (majorVersion ubyte)
+ (minorVersion ubyte)
+ (unused ushort)
+ (ansiUserName (achar lenUserName))
+ (relVersion dword)
+ (unicodeUserName (wchar lenUserName)))
+
+;;; MS-ODRAW Office Drawing Binary File Format
+
+(defclass shorter-stream (trivial-gray-streams:fundamental-binary-input-stream
+ trivial-gray-streams:trivial-gray-stream-mixin)
+ ((wrap :initarg :wrap)
+ (size :initarg :size)
+ (offset :initform 0)))
+
+(defmethod trivial-gray-streams::stream-element-type ((stream shorter-stream))
+ '(unsigned-byte 8))
+
+(defmethod trivial-gray-streams:stream-file-position ((stream shorter-stream))
+ (with-slots (offset) stream
+ offset))
+
+(defmethod trivial-gray-streams:stream-read-byte ((stream shorter-stream))
+ (with-slots (wrap size offset) stream
+ (cond
+ ((< offset size)
+ (incf offset)
+ (read-byte wrap))
+ (t :eof))))
+
+(defun call-with-shorter-stream (stream fn)
+ (with-open-stream (x stream)
+ (funcall fn x)))
+
+(defmacro with-shorter-stream ((var wrap size) &body body)
+ `(call-with-shorter-stream
+ (make-instance 'shorter-stream :wrap ,wrap :size ,size)
+ (lambda (,var) ,@body)))
+(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)
+ (with-shorter-stream (in stream (RecordHeader.recLen x))
+ (list x
+ (read-value 'guid in)
+ (read-value 'ubyte in)
+ (with-open-file (out (format nil "~a/_~d.~a" dir n ext)
+ :direction :output
+ :if-does-not-exist :create
+ :if-exists :supersede
+ :element-type '(unsigned-byte 8))
+ (alexandria:copy-stream in out))))))
+ (ecase recType
+ (#.RT_CurrentUserAtom
+ (assert (zerop recVer))
+ (assert (zerop recInstance))
+ (list x (read-CurrentUserAtom stream))
+ #+nil
+ (with-shorter-stream (in stream (RecordHeader.recLen x))
+ (list x (read-CurrentUserAtom in)))) ;; why recLen too small?
+ ((#xF01E) ;; OfficeArtBlipPNG
+ (assert (zerop recVer))
+ (assert (member recInstance '(#x6e0 #x6e1)))
+ (values (blip "png") :png))
+ (#xF01D ;; OfficeArtBlipJPEG
+ (assert (zerop recVer))
+ (assert (member recInstance '(#x46A #x46B #x6E2 #x6E3)))
+ (values (blip "jpeg") :jpeg)))))))
diff --git a/package.lisp b/package.lisp
@@ -0,0 +1,2 @@
+(defpackage :ole
+ (:use :cl))
