Ole/Mod/Storage.odc

MODULE OleStorage;
(**
	project	= "BlackBox"
	organization	= "www.oberon.ch"
	contributors	= "Oberon microsystems"
	version	= "System/Rsrc/About"
	copyright	= "System/Rsrc/About"
	license	= "Docu/BB-License"
	changes	= "
	- YYYYMMDD, nn, ...
	"
	issues	= "
	- ...
	"

**)

	IMPORT Log,
		SYSTEM, COM, WinApi, WinOle, Files, Stores, Views;
	
	CONST
		debug = FALSE;
		obfTag = 6F4F4443H;
		
	TYPE
		ILockBytes = POINTER TO RECORD (WinOle.ILockBytes)
			org: INTEGER;
			len: INTEGER;	(* org + len <= file.Length() *)
			file: Files.File;	(* file # NIL *)
			rd: Files.Reader;	(* (rd # NIL) & (rd.Base() = file) *)
			wr: Files.Writer	(* (wr = NIL) OR (wr.Base() = file) *)
		END;
	
		StreamFile = POINTER TO RECORD (Files.File)
			stream: WinOle.IStream;
			org: LONGINT;
			len: INTEGER;
			pos: INTEGER	(* actual seek pos of stream *)
		END;
		
		StreamReader = POINTER TO RECORD (Files.Reader)
			base: StreamFile;
			pos: INTEGER
		END;
		
		StreamWriter = POINTER TO RECORD (Files.Writer)
			base: StreamFile;
			pos: INTEGER;
		END;
	
	
	(* ---------- ILockBytes ---------- *)
	
	PROCEDURE (this: ILockBytes) ReadAt (offset: LONGINT; buf: WinApi.PtrVoid;
															len: INTEGER; OUT [nil] read: INTEGER): COM.RESULT;
		TYPE P = POINTER TO ARRAY [untagged] 2000000000 OF BYTE;
		VAR p: P;
	BEGIN
		IF debug THEN
			Log.String("read@"); Log.Int(SHORT(offset)); Log.Int(len);
		END;
		IF (len > 0) & (offset < this.len) THEN
			this.rd.SetPos(SHORT(this.org + offset));
			IF offset + len > this.len THEN len := SHORT(this.len - offset) END;
			p := SYSTEM.VAL(P, buf);
			this.rd.ReadBytes(p^, 0, len)
		ELSE len := 0
		END;
		IF VALID(read) THEN read := len END;
		IF debug THEN
			Log.Int(len);
			Log.Int(p[0]); Log.Int(p[1]); Log.Int(p[2]); Log.Int(p[3]); 
			Log.Ln
		END;
		RETURN WinApi.S_OK
	END ReadAt;
	
	PROCEDURE (this: ILockBytes) WriteAt (offset: LONGINT; buf: WinApi.PtrVoid;
																len: INTEGER; OUT [nil] written: INTEGER): COM.RESULT;
		TYPE P = POINTER TO ARRAY [untagged] 2000000000 OF BYTE;
		VAR res: COM.RESULT; p: P;
	BEGIN
		p := SYSTEM.VAL(P, buf);
		IF debug THEN
			Log.String("write@"); Log.Int(SHORT(offset)); Log.Int(len);
			Log.Int(p[0]); Log.Int(p[1]); Log.Int(p[2]); Log.Int(p[3]); 
			Log.Ln
		END;
		IF this.wr # NIL THEN
			IF len > 0 THEN
				IF offset > this.len THEN res := this.SetSize(offset) END;
				this.wr.SetPos(SHORT(this.org + offset));
				this.wr.WriteBytes(p^, 0, len);
				IF offset + len > this.len THEN this.len := SHORT(offset + len) END
			ELSE len := 0
			END;
			IF VALID(written) THEN written := len END;
			IF debug THEN Log.String("written"); Log.Ln END;
			RETURN WinApi.S_OK
		ELSE
			IF VALID(written) THEN written := 0 END;
			RETURN WinApi.STG_E_ACCESSDENIED
		END
	END WriteAt;
	
	PROCEDURE (this: ILockBytes) Flush (): COM.RESULT;
		TYPE A4 = ARRAY 4 OF BYTE;
	BEGIN
		IF debug THEN Log.String("flush"); Log.Ln END;
		IF this.wr # NIL THEN
			this.wr.SetPos(this.org - 4);
			this.wr.WriteBytes(SYSTEM.VAL(A4, this.len), 0, 4);
			this.file.Flush();
			this.wr.SetPos(this.org + this.len)
		ELSE
			this.rd.SetPos(this.org + this.len)
		END;
		IF debug THEN Log.String("flushed"); Log.Ln END;
		RETURN WinApi.S_OK
	END Flush;
	
	PROCEDURE (this: ILockBytes) SetSize (size: LONGINT): COM.RESULT;
		VAR len: INTEGER; buf: ARRAY 256 OF BYTE;
	BEGIN
		IF debug THEN Log.String("set size"); Log.Int(SHORT(size)); Log.Ln END;
		IF this.wr # NIL THEN
			IF size > this.len THEN	(* enlarge file *)
				this.wr.SetPos(this.org + this.len);
				len := SHORT(size - this.len);
				WHILE len > 256 DO this.wr.WriteBytes(buf, 0, 256); DEC(len, 256) END;
				this.wr.WriteBytes(buf, 0, len);
			END;
			this.len := SHORT(size);
			RETURN WinApi.S_OK
		ELSE RETURN WinApi.STG_E_ACCESSDENIED
		END
	END SetSize;
	
	PROCEDURE (this: ILockBytes) LockRegion (offset, len: LONGINT; lockType: SET): COM.RESULT;
	BEGIN
		RETURN WinApi.STG_E_INVALIDFUNCTION
	END LockRegion;
	
	PROCEDURE (this: ILockBytes) UnlockRegion (offset, len: LONGINT; lockType: SET): COM.RESULT;
	BEGIN
		RETURN WinApi.STG_E_INVALIDFUNCTION
	END UnlockRegion;
	
	PROCEDURE (this: ILockBytes) Stat (OUT statStg: WinOle.STATSTG; statflag: INTEGER): COM.RESULT;
	BEGIN
		IF debug THEN Log.String("stat"); Log.Ln END;
		statStg.pwcsName := NIL;
		statStg.type := WinOle.STGTY_LOCKBYTES;
		statStg.cbSize := this.len;
		statStg.mtime := 0;
		statStg.ctime := 0;
		statStg.atime := 0;
		statStg.grfMode := WinOle.STGM_DIRECT + WinOle.STGM_CREATE + WinOle.STGM_SHARE_EXCLUSIVE;
		IF this.wr # NIL THEN statStg.grfMode := statStg.grfMode + WinOle.STGM_READWRITE
		ELSE statStg.grfMode := statStg.grfMode + WinOle.STGM_READ
		END;
		statStg.grfLocksSupported := {};
		statStg.clsid := WinOle.GUID_NULL;
		statStg.grfStateBits := {};
		statStg.dwStgFmt := WinOle.STGFMT_FILE;
		IF debug THEN Log.String("stat end"); Log.Ln END;
		RETURN WinApi.S_OK
	END Stat;
	
	
	(* ---------- StreamReader ---------- *)
	
	PROCEDURE (r: StreamReader) Base (): Files.File;
	BEGIN
		RETURN r.base
	END Base;
	
	PROCEDURE (r: StreamReader) Pos (): INTEGER;
	BEGIN
		RETURN r.pos
	END Pos;
	
	PROCEDURE (r: StreamReader) SetPos (pos: INTEGER);
		VAR res: COM.RESULT;
	BEGIN
		ASSERT(pos >= 0, 22); ASSERT(pos <= r.base.len, 21);
		r.pos := pos; r.eof := FALSE
	END SetPos;
	
	PROCEDURE (r: StreamReader) ReadByte (OUT x: BYTE);
		VAR res: COM.RESULT;
	BEGIN
		IF r.pos < r.base.len THEN
			IF r.pos # r.base.pos THEN
				res := r.base.stream.Seek(r.base.org + r.pos, WinOle.STREAM_SEEK_SET, NIL);
				r.base.pos := r.pos
			END;
			res := r.base.stream.Read(SYSTEM.ADR(x), 1, NIL);
			INC(r.pos); INC(r.base.pos);
		ELSE
			x := 0; r.eof := TRUE
		END
	END ReadByte;
	
	PROCEDURE (r: StreamReader) ReadBytes (VAR x: ARRAY OF BYTE; beg, len: INTEGER);
		VAR res: COM.RESULT;
	BEGIN
		ASSERT(beg >= 0, 21);
		IF len > 0 THEN
			ASSERT(beg + len <= LEN(x), 23);
			IF r.pos + len <= r.base.len THEN
				IF r.pos # r.base.pos THEN
					res := r.base.stream.Seek(r.base.org + r.pos, WinOle.STREAM_SEEK_SET, NIL);
					r.base.pos := r.pos
				END;
				res := r.base.stream.Read(SYSTEM.ADR(x[beg]), len, NIL);
				INC(r.pos, len); INC(r.base.pos, len)
			ELSE
				r.eof := TRUE
			END
		ELSE ASSERT(len = 0, 22)
		END
	END ReadBytes;
	
	
	(* ---------- StreamWriter ---------- *)
	
	PROCEDURE (w: StreamWriter) Base (): Files.File;
	BEGIN
		RETURN w.base
	END Base;
	
	PROCEDURE (w: StreamWriter) Pos (): INTEGER;
	BEGIN
		RETURN w.pos
	END Pos;
	
	PROCEDURE (w: StreamWriter) SetPos (pos: INTEGER);
		VAR res: COM.RESULT;
	BEGIN
		ASSERT(pos >= 0, 22); ASSERT(pos <= w.base.len, 21);
		w.pos := pos
	END SetPos;
	
	PROCEDURE (w: StreamWriter) WriteByte (x: BYTE);
		VAR res: COM.RESULT;
	BEGIN
		IF w.pos # w.base.pos THEN
			res := w.base.stream.Seek(w.base.org + w.pos, WinOle.STREAM_SEEK_SET, NIL);
			w.base.pos := w.pos
		END;
		res := w.base.stream.Write(SYSTEM.ADR(x), 1, NIL);
		INC(w.pos); INC(w.base.pos);
		IF w.pos > w.base.len THEN w.base.len := w.pos END
	END WriteByte;
	
	PROCEDURE (w: StreamWriter) WriteBytes (IN x: ARRAY OF BYTE; beg, len: INTEGER);
		VAR res: COM.RESULT;
	BEGIN
		ASSERT(beg >= 0, 21);
		IF len > 0 THEN
			ASSERT(beg + len <= LEN(x), 23);
			IF w.pos # w.base.pos THEN
				res := w.base.stream.Seek(w.base.org + w.pos, WinOle.STREAM_SEEK_SET, NIL);
				w.base.pos := w.pos
			END;
			res := w.base.stream.Write(SYSTEM.ADR(x[beg]), len, NIL);
			INC(w.pos, len); INC(w.base.pos, len); 
			IF w.pos > w.base.len THEN w.base.len := w.pos END
		ELSE ASSERT(len = 0, 22)
		END
	END WriteBytes;
	
	
	(* ---------- StreamFile ---------- *)
	
	PROCEDURE (f: StreamFile) Length (): INTEGER;
	BEGIN
		RETURN f.len
	END Length;
	
	PROCEDURE (f: StreamFile) NewReader (old: Files.Reader): Files.Reader;
		VAR r: StreamReader;
	BEGIN
		ASSERT(f.stream # NIL, 20);
		NEW(r); r.base := f;
		r.pos := 0; r.eof := FALSE;
		RETURN r
	END NewReader;
	
	PROCEDURE (f: StreamFile) NewWriter (old: Files.Writer): Files.Writer;
		VAR w: StreamWriter;
	BEGIN
		ASSERT(f.stream # NIL, 20);
		NEW(w); w.base := f;
		w.pos := f.len;
		RETURN w
	END NewWriter;
	
	PROCEDURE (f: StreamFile) Flush;
		VAR res: COM.RESULT;
	BEGIN
		ASSERT(f.stream # NIL, 20);
		res := f.stream.Commit(WinOle.STGC_DEFAULT)
	END Flush;
	
	PROCEDURE (f: StreamFile) Close;
	BEGIN
		IF f.stream # NIL THEN
			f.Flush;
			f.stream := NIL;
		END
	END Close;
	
	PROCEDURE (f: StreamFile) Register (name: Files.Name; type: Files.Type; ask: BOOLEAN; OUT res: INTEGER);
	BEGIN
		res := 10
	END Register;
	
	
	(* ---------- file creation ---------- *)
	
	PROCEDURE NewStreamFile* (stream: WinOle.IStream): Files.File;
		VAR f: StreamFile; res: COM.RESULT; y: LONGINT;
	BEGIN
		NEW(f);
		f.stream := stream;
		res := stream.Seek(0, WinOle.STREAM_SEEK_CUR, f.org);
		res := stream.Seek(0, WinOle.STREAM_SEEK_END, y);
		DEC(y, f.org);
		IF y > MAX(INTEGER) THEN y := MAX(INTEGER) END;
		f.len := SHORT(y);
		res := stream.Seek(f.org, WinOle.STREAM_SEEK_SET, NIL);
		f.pos := 0;
		RETURN f
	END NewStreamFile;
	
	PROCEDURE NewWriteILockBytes* (wr: Files.Writer): WinOle.ILockBytes;
		VAR new: ILockBytes;
	BEGIN
		IF debug THEN Log.String("new write"); Log.Ln END;
		NEW(new);
		IF new = NIL THEN RETURN NIL END;
		wr.WriteByte(0); wr.WriteByte(0); wr.WriteByte(0); wr.WriteByte(0); 	(* length *)
		new.len := 0;
		new.org := wr.Pos();
		new.file := wr.Base();
		new.rd := new.file.NewReader(NIL);
		new.wr := wr;
		RETURN new
	END NewWriteILockBytes;
	
	PROCEDURE NewReadILockBytes* (rd: Files.Reader): WinOle.ILockBytes;
		TYPE A4 = ARRAY 4 OF BYTE;
		VAR new: ILockBytes;
	BEGIN
		IF debug THEN Log.String("new read"); Log.Ln END;
		NEW(new);
		IF new = NIL THEN RETURN NIL END;
		rd.ReadBytes(SYSTEM.VAL(A4, new.len), 0, 4);
		new.org := rd.Pos();
		new.file := rd.Base();
		new.rd := rd;
		new.wr := NIL;
		RETURN new
	END NewReadILockBytes;
	
	
	(* stream import/export *)
	
	PROCEDURE GenStreamMedium (stm: WinOle.IStream; unk: COM.IUnknown; VAR sm: WinOle.STGMEDIUM);
	BEGIN
		sm.tymed := WinOle.TYMED_ISTREAM;
		sm.u.pstm := stm;
		sm.pUnkForRelease := unk
	END GenStreamMedium;
	
	PROCEDURE MediumStream (VAR sm: WinOle.STGMEDIUM): WinOle.IStream;
	BEGIN
		ASSERT(sm.tymed = WinOle.TYMED_ISTREAM, 20);
		RETURN SYSTEM.VAL(WinOle.IStream, sm.u.pstm)
	END MediumStream;
	
	PROCEDURE ExportToStream* (stream: WinOle.IStream; v: Views.View; w, h: INTEGER; isSingle: BOOLEAN);
		VAR f: Files.File; wr: Stores.Writer; res: COM.RESULT;
	BEGIN
		res := stream.Seek(0, WinOle.STREAM_SEEK_SET, NIL);
		f := NewStreamFile(stream);
		wr.ConnectTo(f);
		wr.SetPos(0);
		wr.WriteInt(obfTag);
		wr.WriteInt(0);
		wr.WriteInt(w);
		wr.WriteInt(h);
		IF isSingle THEN wr.WriteSChar(1X) ELSE wr.WriteSChar(0X) END;
		wr.WriteStore(v);
		f.Close
	END ExportToStream;
	
	PROCEDURE ExportOberon* (
		v: Views.View; w, h, x, y: INTEGER; isSingle: BOOLEAN; VAR med: WinOle.STGMEDIUM
	);
		VAR stream: WinOle.IStream; res: COM.RESULT;
	BEGIN
		IF med.tymed = WinOle.TYMED_ISTREAM THEN	(* use old stream *)
			stream := MediumStream(med)
		ELSE	(* create new temporary stream *)
			res := WinOle.CreateStreamOnHGlobal(0, 1, stream);
			GenStreamMedium(stream, NIL, med)
		END;
		ExportToStream(stream, v, w, h, isSingle)
	END ExportOberon;
	
	PROCEDURE ImportFromStream* (stream: WinOle.IStream;  VAR v: Views.View;
											VAR w, h: INTEGER; VAR isSingle: BOOLEAN);
		VAR f: Files.File; r: Stores.Reader; s: Stores.Store; tag, version, res: COM.RESULT; ch: SHORTCHAR;
	BEGIN
		v := NIL;
		res := stream.Seek(0, WinOle.STREAM_SEEK_SET, NIL);
		f := NewStreamFile(stream);
		r.ConnectTo(f); r.SetPos(0);
		r.ReadInt(tag);
		IF tag = obfTag THEN
			r.ReadInt(version);
			r.ReadInt(w);
			r.ReadInt(h);
			r.ReadSChar(ch); isSingle := ch # 0X;
			r.ReadStore(s);
			v := s(Views.View)
		END
	END ImportFromStream;
	
	PROCEDURE ImportOberon* (VAR med: WinOle.STGMEDIUM; VAR v: Views.View;
											VAR w, h: INTEGER; VAR isSingle: BOOLEAN);
		VAR stream: WinOle.IStream;
	BEGIN
		stream := MediumStream(med);
		ImportFromStream(stream, v, w, h, isSingle)
	END ImportOberon;

END OleStorage.


	OleStorage?
	
	DevDecoder.Decode OleStorage