MODULE OleStorage;
(**

   project   = "BlackBox"
   organization   = "www.oberon.ch"
   contributors   = "Oberon microsystems"
   version   = "System/Rsrc/About"
   copyright   = "System/Rsrc/About"
   license   = "Docu/BB-License"
   changes   = ""
   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.dwLowDateTime := 0;
      statStg.mtime.dwHighDateTime := 0;
      statStg.ctime.dwLowDateTime := 0;
      statStg.ctime.dwHighDateTime := 0;
      statStg.atime.dwLowDateTime := 0;
      statStg.atime.dwHighDateTime := 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