MODULE OleData;
(**
project = "BlackBox"
organization = "www.oberon.ch"
contributors = "Oberon microsystems, Alexander Iljin"
version = "System/Rsrc/About"
copyright = "System/Rsrc/About"
license = "Docu/BB-License"
changes = ""
issues = ""
**)
IMPORT
SYSTEM, COM, WinOle, WinApi, Log,
Files, Strings, Meta, Dialog, Services, Ports, Stores, Models, Views, Properties, Containers,
HostPorts;
CONST
debug = FALSE;
(* opts *)
stream* = 0;
storage* = 1;
file* = 2;
info* = 16;
single* = 17;
select* = 18;
obfTag = 6F4F4443H;
TYPE
Exporter* = PROCEDURE (
v: Views.View; w, h, rx, ry: INTEGER; isSingle: BOOLEAN; VAR med: WinOle.STGMEDIUM);
Importer* = PROCEDURE (
VAR med: WinOle.STGMEDIUM; OUT v: Views.View; OUT w, h: INTEGER; OUT isSingle: BOOLEAN);
InfoImporter* = PROCEDURE (
VAR med: WinOle.STGMEDIUM; VAR type: Stores.TypeName;
OUT w, h, rx, ry: INTEGER; OUT isSingle: BOOLEAN);
IDataObject* = POINTER TO RECORD (WinOle.IDataObject)
view-: Views.View;
w-, h-, rx, ry: INTEGER;
isSingle, useSel: BOOLEAN;
type: Stores.TypeName
END;
Converter* = POINTER TO RECORD
next-: Converter;
imp-, exp-: Dialog.String;
type-: Stores.TypeName;
format-: WinOle.FORMATETC;
opts-: SET
END;
ExpVal = RECORD (Meta.Value) p: Exporter END;
ImpVal = RECORD (Meta.Value) p: Importer END;
InfoVal = RECORD (Meta.Value) p: InfoImporter END;
MetaFileContext = POINTER TO RECORD (Models.Context)
(*domain: Stores.Domain;*)
w, h: INTEGER
END;
MetaFileView = POINTER TO RECORD (Views.View)
view: Views.View;
END;
IEnumFORMATETC = POINTER TO RECORD (WinOle.IEnumFORMATETC)
cur: INTEGER;
num: INTEGER;
data: POINTER TO ARRAY OF RECORD c: WinOle.FORMATETC END;
END;
Info = POINTER TO InfoDesc;
InfoDesc = RECORD [untagged]
type: Stores.TypeName;
w, h, rx, ry: INTEGER;
isSingle: BOOLEAN;
END;
MemFile = POINTER TO RECORD (Files.File)
mem: WinApi.HGLOBAL;
len: INTEGER;
owner: BOOLEAN
END;
MemReader = POINTER TO RECORD (Files.Reader)
base: MemFile;
pos: INTEGER
END;
MemWriter = POINTER TO RECORD (Files.Writer)
base: MemFile;
pos: INTEGER;
END;
MemPtr = POINTER TO ARRAY [untagged] OF BYTE;
VAR
dataObj-: WinOle.IDataObject; (* for importers *)
convList-: Converter;
unit: INTEGER; (* screen resolution *)
(* Auxiliary procedures *)
PROCEDURE GenFormatEtc (format: SHORTINT; aspect: SET; tymed: SET; VAR f: WinOle.FORMATETC);
BEGIN
f.cfFormat := format;
f.ptd := NIL;
f.dwAspect := aspect;
f.lindex := -1;
f.tymed := tymed
END GenFormatEtc;
PROCEDURE GenMetafileMedium (
mf: WinApi.HMETAFILEPICT; unk: COM.IUnknown; VAR sm: WinOle.STGMEDIUM
);
BEGIN
sm.tymed := WinOle.TYMED_MFPICT;
sm.u.hMetaFilePict := mf;
sm.pUnkForRelease := unk
END GenMetafileMedium;
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 GenGlobalMedium (hg: WinApi.HGLOBAL; unk: COM.IUnknown; VAR sm: WinOle.STGMEDIUM);
BEGIN
sm.tymed := WinOle.TYMED_HGLOBAL;
sm.u.hGlobal := hg;
sm.pUnkForRelease := unk
END GenGlobalMedium;
PROCEDURE MediumStream (VAR sm: WinOle.STGMEDIUM): WinOle.IStream;
BEGIN
IF sm.tymed = WinOle.TYMED_ISTREAM THEN RETURN sm.u.pstm
ELSE RETURN NIL
END
END MediumStream;
PROCEDURE MediumGlobal (VAR sm: WinOle.STGMEDIUM): WinApi.HGLOBAL;
BEGIN
IF sm.tymed = WinOle.TYMED_HGLOBAL THEN RETURN sm.u.hGlobal
ELSE RETURN 0
END
END MediumGlobal;
PROCEDURE GetCommand (name: Dialog.String; VAR val: Meta.Value; VAR ok: BOOLEAN);
VAR i: Meta.Item;
BEGIN
Meta.LookupPath(name, i);
IF (i.obj = Meta.procObj) OR (i.obj = Meta.varObj) & (i.typ = Meta.procTyp) THEN
i.GetVal(val, ok)
ELSE ok := FALSE
END
END GetCommand;
PROCEDURE Eql (IN f, g: WinOle.FORMATETC): BOOLEAN;
BEGIN
RETURN (f.cfFormat = g.cfFormat) & (f.ptd = g.ptd) & (f.dwAspect = g.dwAspect)
& (f.lindex = g.lindex) & (f.tymed * g.tymed # {})
ENDEql;
PROCEDURE Equiv (IN f, g: WinOle.FORMATETC): BOOLEAN;
BEGIN
RETURN (f.cfFormat = g.cfFormat) & (f.ptd = g.ptd) & (f.dwAspect = g.dwAspect)
& (f.lindex = g.lindex)
END Equiv;
PROCEDURE Compatible (c: Converter; VAR view: Views.View; isSingle: BOOLEAN): BOOLEAN;
BEGIN
RETURN ((c.type = "") OR Services.Is(view, c.type))
& (~(single IN c.opts) OR isSingle)
& (~(select IN c.opts) OR ~isSingle)
END Compatible;
PROCEDURE Setup (data: IDataObject);
VAR v: Views.View; c: Containers.Controller; m: Containers.Model;
p: Properties.BoundsPref; dx, dy: INTEGER;
BEGIN
c := data.view(Containers.View).ThisController();
m := c.SelectionCopy();
(*
v := Services.Clone(data.view)(Views.View);
v.InitModel(m); v.CopyFrom(data.view);
*)
v := Views.CopyWithNewModel(data.view, m);
p.w := Views.undefined; p.h := Views.undefined; Views.HandlePropMsg(v, p);
data.view := v; data.w := p.w; data.h := p.h; data.useSel := FALSE
END Setup;
(* IEnumFORMATETC*)
PROCEDURE CreateIEnumFORMATETC (num: INTEGER; VAR data: ARRAY OF WinOle.FORMATETC;
VAR enum: WinOle.IEnumFORMATETC);
VAR i, n: INTEGER; new: IEnumFORMATETC;
BEGIN
NEW(new);
IF new # NIL THEN
new.cur := 0;
new.num := num;
NEW(new.data, num);
i := 0;
WHILE i < num DO new.data[i].c := data[i]; INC(i) END;
enum := new
END
END CreateIEnumFORMATETC;
PROCEDURE (this: IEnumFORMATETC) Next (num: INTEGER;
OUT elem: ARRAY [untagged] OF WinOle.FORMATETC; OUT [nil] fetched: INTEGER
): COM.RESULT;
VAR n: INTEGER;
BEGIN
n := 0;
IF VALID(fetched) THEN fetched := 0
ELSIF num # 1 THEN RETURN WinApi.E_POINTER
END;
IF this.cur < this.num THEN
WHILE (this.cur < this.num) & (num > 0) DO
elem[n] := this.data[this.cur].c;
INC(this.cur); INC(n); DEC(num)
END;
IF VALID(fetched) THEN fetched := n END;
RETURN WinApi.S_OK
END;
RETURN WinApi.S_FALSE
END Next;
PROCEDURE (this: IEnumFORMATETC) Skip (num: INTEGER): COM.RESULT;
BEGIN
IF this.cur + num < this.num THEN
INC(this.cur, num); RETURN WinApi.S_OK
ELSE RETURN WinApi.S_FALSE
END
END Skip;
PROCEDURE (this: IEnumFORMATETC) Reset (): COM.RESULT;
BEGIN
this.cur := 0; RETURN WinApi.S_OK
END Reset;
PROCEDURE (this: IEnumFORMATETC) Clone (OUT enum: WinOle.IEnumFORMATETC): COM.RESULT;
VAR new: IEnumFORMATETC;
BEGIN
NEW(new);
IF new # NIL THEN
new.num := this.num;
new.cur := this.cur;
new.data := this.data;
enum := new;
RETURN WinApi.S_OK
ELSE RETURN WinApi.E_OUTOFMEMORY
END
END Clone;
(* Metafile Pictures *)
(*
PROCEDURE (c: MetaFileContext) ThisDomain (): Stores.Domain;
BEGIN
RETURN c.domain
END ThisDomain;
*)
PROCEDURE (c: MetaFileContext) ThisModel (): Models.Model;
BEGIN
RETURN NIL
END ThisModel;
PROCEDURE (c: MetaFileContext) GetSize (OUT w, h: INTEGER);
BEGIN
w := c.w; h := c.h
END GetSize;
PROCEDURE (c: MetaFileContext) SetSize (w, h: INTEGER);
END SetSize;
PROCEDURE (c: MetaFileContext) Normalize (): BOOLEAN;
BEGIN
RETURN TRUE
END Normalize;
PROCEDURE (d: MetaFileView) Restore (f: Views.Frame; l, t, r, b: INTEGER);
BEGIN
Views.InstallFrame(f, d.view, 0, 0, 0, FALSE)
END Restore;
PROCEDURE (d: MetaFileView) GetNewFrame (VAR frame: Views.Frame);
VAR f: Views.RootFrame;
BEGIN
NEW(f); frame := f
END GetNewFrame;
PROCEDURE (d: MetaFileView) GetBackground (VAR color: Ports.Color);
BEGIN
color := Ports.background
END GetBackground;
(*
PROCEDURE (d: MetaFileView) PropagateDomain;
BEGIN
Stores.InitDomain(d.view, d.domain)
END PropagateDomain;
*)
PROCEDURE Paint (dc: WinApi.HDC; v: Views.View; w, h, unit: INTEGER);
VAR d: MetaFileView; c: MetaFileContext; p: HostPorts.Port; f: Views.RootFrame; g: Views.Frame;
(* m: Models.Model; *)
BEGIN
NEW(p);
p.Init(unit, Ports.screen);
p.SetSize(w, h);
p.SetDC(dc, 0);
NEW(c);
(*
m := v.ThisModel();
IF (m # NIL) & (m.domain # NIL) THEN
c.domain := m.domain
ELSE
c.domain := Models.NewDomain()
END;
*)
(*
IF v.domain # NIL THEN
c.domain := v.domain
ELSE
c.domain := Models.NewDomain()
END;
*)
c.w := w * p.unit;
c.h := h * p.unit;
NEW(d);
d.view := Views.CopyOf(v, Views.shallow);
Stores.Join(d, d.view);
d.InitContext(c);
d.view.InitContext(c);
(* Stores.InitDomain(d, c.domain); *)
(* Stores.InitDomain(d.view, c.domain); *)
Stores.InitDomain(d);
d.GetNewFrame(g); f := g(Views.RootFrame); f.ConnectTo(p);
Views.SetRoot(f, d, FALSE, {});
Views.AdaptRoot(f);
Views.RestoreRoot(f, 0, 0, c.w, c.h);
END Paint;
(* ---------- MemFiles ---------- *)
PROCEDURE (r: MemReader) Base (): Files.File;
BEGIN
RETURN r.base
END Base;
PROCEDURE (r: MemReader) Pos (): INTEGER;
BEGIN
RETURN r.pos
END Pos;
PROCEDURE (r: MemReader) SetPos (pos: INTEGER);
BEGIN
ASSERT(pos >= 0, 22); ASSERT(pos <= r.base.len, 21);
r.pos := pos; r.eof := FALSE
END SetPos;
PROCEDURE (r: MemReader) ReadByte (OUT x: BYTE);
VAR res: INTEGER; p: MemPtr;
BEGIN
ASSERT(r.base.mem # 0, 20);
IF r.pos < r.base.len THEN
p := SYSTEM.VAL(MemPtr, WinApi.GlobalLock(r.base.mem));
x := p[r.pos]; INC(r.pos);
res := WinApi.GlobalUnlock(r.base.mem)
ELSE
x := 0; r.eof := TRUE
END
END ReadByte;
PROCEDURE (r: MemReader) ReadBytes (VAR x: ARRAY OF BYTE; beg, len: INTEGER);
VAR res: INTEGER; p: MemPtr;
BEGIN
ASSERT(r.base.mem # 0, 20);
ASSERT(beg >= 0, 21);
IF len > 0 THEN
ASSERT(beg + len <= LEN(x), 23);
IF r.pos + len <= r.base.len THEN
p := SYSTEM.VAL(MemPtr, WinApi.GlobalLock(r.base.mem));
SYSTEM.MOVE(SYSTEM.ADR(p[r.pos]), SYSTEM.ADR(x[beg]), len);
INC(r.pos, len);
res := WinApi.GlobalUnlock(r.base.mem)
ELSE
r.eof := TRUE
END
ELSE ASSERT(len = 0, 22)
END
END ReadBytes;
PROCEDURE (w: MemWriter) Base (): Files.File;
BEGIN
RETURN w.base
END Base;
PROCEDURE (w: MemWriter) Pos (): INTEGER;
BEGIN
RETURN w.pos
END Pos;
PROCEDURE (w: MemWriter) SetPos (pos: INTEGER);
BEGIN
ASSERT(pos >= 0, 22); ASSERT(pos <= w.base.len, 21);
w.pos := pos
END SetPos;
PROCEDURE (w: MemWriter) WriteByte (x: BYTE);
VAR res, size: INTEGER; p: MemPtr;
BEGIN
ASSERT(w.base.mem # 0, 20);
IF w.pos >= w.base.len THEN
w.base.len := w.pos + 1;
size := WinApi.GlobalSize(w.base.mem);
IF size < w.base.len THEN
w.base.mem := WinApi.GlobalReAlloc(w.base.mem, w.base.len + 1024,
WinApi.GMEM_DDESHARE + WinApi.GMEM_MOVEABLE)
END
END;
p := SYSTEM.VAL(MemPtr, WinApi.GlobalLock(w.base.mem));
p[w.pos] := x; INC(w.pos);
res := WinApi.GlobalUnlock(w.base.mem)
END WriteByte;
PROCEDURE (w: MemWriter) WriteBytes (IN x: ARRAY OF BYTE; beg, len: INTEGER);
VAR res, size: INTEGER; p: MemPtr;
BEGIN
ASSERT(w.base.mem # 0, 20);
ASSERT(beg >= 0, 21);
IF len > 0 THEN
ASSERT(beg + len <= LEN(x), 23);
IF w.pos + len > w.base.len THEN
w.base.len := w.pos + len;
size := WinApi.GlobalSize(w.base.mem);
IF size < w.base.len THEN
w.base.mem := WinApi.GlobalReAlloc(w.base.mem, w.base.len + 1024,
WinApi.GMEM_DDESHARE + WinApi.GMEM_MOVEABLE)
END
END;
p := SYSTEM.VAL(MemPtr, WinApi.GlobalLock(w.base.mem));
SYSTEM.MOVE(SYSTEM.ADR(x[beg]), SYSTEM.ADR(p[w.pos]), len);
INC(w.pos, len);
res := WinApi.GlobalUnlock(w.base.mem)
ELSE ASSERT(len = 0, 22)
END
END WriteBytes;
PROCEDURE (f: MemFile) Length (): INTEGER;
BEGIN
RETURN f.len
END Length;
PROCEDURE (f: MemFile) NewReader (old: Files.Reader): Files.Reader;
VAR r: MemReader;
BEGIN
ASSERT(f.mem # 0, 20);
IF (old = NIL) OR ~(old IS MemReader) THEN NEW(r)
ELSE r := old(MemReader)
END;
r.base := f;
r.pos := 0; r.eof := FALSE;
RETURN r
END NewReader;
PROCEDURE (f: MemFile) NewWriter (old: Files.Writer): Files.Writer;
VAR w: MemWriter;
BEGIN
ASSERT(f.mem # 0, 20);
IF (old = NIL) OR ~(old IS MemWriter) THEN NEW(w)
ELSE w := old(MemWriter)
END;
w.base := f;
w.pos := f.len;
RETURN w
END NewWriter;
PROCEDURE (f: MemFile) Register (name: Files.Name; type: Files.Type; ask: BOOLEAN; OUT res: INTEGER);
BEGIN
res := -1
END Register;
PROCEDURE (f: MemFile) Close;
END Close;
PROCEDURE (f: MemFile) Flush;
END Flush;
PROCEDURE (f: MemFile) FINALIZE;
BEGIN
IF f.owner THEN f.mem := WinApi.GlobalFree(f.mem) END
END FINALIZE;
PROCEDURE NewMemFile (mem: WinApi.HGLOBAL; owner: BOOLEAN): Files.File;
VAR f: MemFile;
BEGIN
NEW(f);
f.mem := mem;
f.len := WinApi.GlobalSize(mem);
f.owner := owner;
RETURN f
END NewMemFile;
(* standard exporters *)
PROCEDURE ExportNative* (
v: Views.View; w, h, x, y: INTEGER; isSingle: BOOLEAN; VAR med: WinOle.STGMEDIUM
);
VAR hnd: WinApi.HGLOBAL; f: Files.File; wr: Stores.Writer; res: COM.RESULT;
BEGIN
ASSERT(med.tymed = {}, 20);
hnd := WinApi.GlobalAlloc(WinApi.GMEM_DDESHARE + WinApi.GMEM_MOVEABLE, 1024);
f := NewMemFile(hnd, FALSE);
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);
GenGlobalMedium(hnd, NIL, med)
END ExportNative;
PROCEDURE ExportInfo* (
v: Views.View; w, h, x, y: INTEGER; isSingle: BOOLEAN; VAR med: WinOle.STGMEDIUM
);
VAR hnd: WinApi.HGLOBAL; p: Info; res: INTEGER;
BEGIN
ASSERT(med.tymed = {}, 20);
hnd := WinApi.GlobalAlloc(WinApi.GMEM_DDESHARE + WinApi.GMEM_MOVEABLE, SIZE(InfoDesc));
IF hnd # 0 THEN
p := SYSTEM.VAL(Info, WinApi.GlobalLock(hnd));
Services.GetTypeName(v, p.type);
p.w := w; p.h := h; p.rx := x; p.ry := y;
p.isSingle := isSingle;
res := WinApi.GlobalUnlock(hnd);
GenGlobalMedium(hnd, NIL, med)
END
END ExportInfo;
PROCEDURE ExportPicture* (
v: Views.View; w, h, x, y: INTEGER; isSingle: BOOLEAN; VAR med: WinOle.STGMEDIUM
);
VAR dc: WinApi.HDC; mf: WinApi.HMETAFILE; mp: WinApi.PtrMETAFILEPICT;
rc: WinApi.RECT; res: INTEGER; hm: WinApi.HMETAFILEPICT;
bp: Properties.BoundsPref; sp: Properties.SizePref;
BEGIN
ASSERT(med.tymed = {}, 20);
IF (w = Views.undefined) OR (h = Views.undefined) THEN
bp.w := Views.undefined; bp.h := Views.undefined;
Views.HandlePropMsg(v, bp);
w := bp.w; h := bp.h
END;
IF (w = Views.undefined) OR (h = Views.undefined) THEN
sp.w := Views.undefined; sp.h := Views.undefined;
sp.fixedW := FALSE; sp.fixedH := FALSE;
Views.HandlePropMsg(v, sp);
w := sp.w; h := sp.h
END;
(*
w := w DIV (Ports.mm DIV 100); h := h DIV (Ports.mm DIV 100); (* w, h in mm/100 *)
*)
dc := WinApi.CreateMetaFileW(NIL);
IF dc # 0 THEN
res := WinApi.SetMapMode(dc, WinApi.MM_ANISOTROPIC);
res := WinApi.SetWindowOrgEx(dc, 0, 0, NIL);
res := WinApi.SetWindowExtEx(dc, w DIV unit, h DIV unit, NIL);
IF v # NIL THEN Paint(dc, v, w DIV unit, h DIV unit, unit) END;
mf := WinApi.CloseMetaFile(dc);
IF mf # 0 THEN
hm := WinApi.GlobalAlloc(
WinApi.GMEM_DDESHARE + WinApi.GMEM_MOVEABLE, SIZE(WinApi.METAFILEPICT));
IF hm # 0 THEN
mp := SYSTEM.VAL(WinApi.PtrMETAFILEPICT, WinApi.GlobalLock(hm));
mp.hMF := mf;
mp.mm := WinApi.MM_ANISOTROPIC;
mp.xExt := w DIV (Ports.mm DIV 100); (* himetric units *)
mp.yExt := h DIV (Ports.mm DIV 100);
res := WinApi.GlobalUnlock(hm);
GenMetafileMedium(hm, NIL, med)
ELSE res := WinApi.DeleteMetaFile(mf)
END
END
END
END ExportPicture;
(* standard importers *)
PROCEDURE ImportNative* (VAR med: WinOle.STGMEDIUM; OUT v: Views.View;
OUT w, h: INTEGER; OUT isSingle: BOOLEAN);
VAR hnd: WinApi.HGLOBAL; f: Files.File; r: Stores.Reader; s: Stores.Store;
tag, version, res: COM.RESULT; ch: SHORTCHAR;
BEGIN
v := NIL;
hnd := MediumGlobal(med);
med.u.hGlobal := 0;
f := NewMemFile(hnd, TRUE);
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 ImportNative;
PROCEDURE ImportInfo* (VAR med: WinOle.STGMEDIUM; VAR type: Stores.TypeName;
OUT w, h, rx, ry: INTEGER; OUT isSingle: BOOLEAN);
VAR s: Stores.Store; hnd: WinApi.HANDLE; p: Info; res: INTEGER;
BEGIN
hnd := MediumGlobal(med);
IF hnd # 0 THEN
p := SYSTEM.VAL(Info, WinApi.GlobalLock(hnd));
type := p.type;
w := p.w; h := p.h; rx := p.rx; ry := p.ry;
isSingle := p.isSingle;
res := WinApi.GlobalUnlock(hnd)
END
END ImportInfo;
(* IDataObject *)
PROCEDURE (this: IDataObject) GetData* (IN format: WinOle.FORMATETC;
OUT medium: WinOle.STGMEDIUM): COM.RESULT;
VAR c: Converter; val: ExpVal; ok: BOOLEAN;
BEGIN
c := convList;
WHILE (c # NIL) & ((c.exp = "")
OR ~Compatible(c, this.view, this.isSingle)
OR ~Eql(c.format, format)) DO c := c.next END;
IF c # NIL THEN
GetCommand(c.exp, val, ok);
medium.tymed := {};
IF ok THEN
IF this.useSel & ~(info IN c.opts) THEN Setup(this) END;
val.p(this.view, this.w, this.h, this.rx, this.ry, this.isSingle, medium);
RETURNWinApi.S_OK
ELSE
IF debug THEN Log.String(c.exp); Log.String(" failed"); Log.Ln END;
RETURN WinApi.E_UNEXPECTED
END
ELSE RETURN WinApi.DV_E_FORMATETC
END
END GetData;
PROCEDURE (this: IDataObject) GetDataHere* (IN format: WinOle.FORMATETC;
VAR medium: WinOle.STGMEDIUM): COM.RESULT;
VAR c: Converter; val: ExpVal; ok: BOOLEAN;
BEGIN
IF format.tymed * (WinOle.TYMED_ISTORAGE + WinOle.TYMED_ISTREAM) # {} THEN
c := convList;
WHILE (c # NIL) & ((c.exp = "")
OR ~Compatible(c, this.view, this.isSingle)
OR ~Eql(c.format, format)) DO c := c.next END;
IF (c # NIL) & (medium.tymed = c.format.tymed) THEN
GetCommand(c.exp, val, ok);
IF ok THEN
IF this.useSel & ~(info IN c.opts) THEN Setup(this) END;
val.p(this.view, this.w, this.h, this.rx, this.ry, this.isSingle, medium);
RETURN WinApi.S_OK
ELSE
IF debug THEN Log.String(c.exp); Log.String(" failed"); Log.Ln END;
RETURN WinApi.E_UNEXPECTED
END
ELSE RETURN WinApi.DV_E_FORMATETC
END
ELSE RETURN WinApi.DV_E_FORMATETC
END
END GetDataHere;
PROCEDURE (this: IDataObject) QueryGetData* (IN format: WinOle.FORMATETC): COM.RESULT;
VAR c: Converter;
BEGIN
c := convList;
WHILE (c # NIL) & ((c.exp = "")
OR ~Compatible(c, this.view, this.isSingle)
OR ~Eql(c.format, format)) DO c := c.next END;
IF c # NIL THEN RETURN WinApi.S_OK
ELSE RETURN WinApi.DV_E_FORMATETC
END
END QueryGetData;
PROCEDURE (this: IDataObject) GetCanonicalFormatEtc* (IN formatIn: WinOle.FORMATETC;
OUT formatOut: WinOle.FORMATETC): COM.RESULT;
BEGIN
RETURN WinApi.DATA_S_SAMEFORMATETC
END GetCanonicalFormatEtc;
PROCEDURE (this: IDataObject) SetData* (IN format: WinOle.FORMATETC;
IN medium: WinOle.STGMEDIUM; release: WinApi.BOOL): COM.RESULT;
BEGIN
RETURN WinApi.DV_E_FORMATETC
END SetData;
PROCEDURE (this: IDataObject) EnumFormatEtc* (direction: SET;
OUT enum: WinOle.IEnumFORMATETC): COM.RESULT;
VAR format: ARRAY 32 OF WinOle.FORMATETC; p: WinOle.IEnumFORMATETC;
n, i: INTEGER; c: Converter;
BEGIN
IF direction = WinOle.DATADIR_GET THEN
n := 0; c := convList;
WHILE (n < LEN(format)) & (c # NIL) DO
IF (c.exp # "") & Compatible(c, this.view, this.isSingle) THEN
format[n] := c.format; i := 0;
WHILE ~Equiv(format[i], c.format) DO INC(i) END;
IF i = n THEN INC(n)
ELSE format[i].tymed := format[i].tymed + c.format.tymed
END
END;
c := c.next
END;
IF n > 0 THEN
CreateIEnumFORMATETC(n, format, p);
IF p # NIL THEN enum := p; RETURN WinApi.S_OK
ELSE RETURN WinApi.E_OUTOFMEMORY
END
ELSE RETURN WinApi.E_FAIL
END
ELSE
RETURN WinApi.E_NOTIMPL
END
END EnumFormatEtc;
PROCEDURE (this: IDataObject) DAdvise* (IN format: WinOle.FORMATETC; flags: SET;
advSink: WinOle.IAdviseSink; OUT connection: INTEGER): COM.RESULT;
BEGIN
RETURN WinApi.E_FAIL
END DAdvise;
PROCEDURE (this: IDataObject) DUnadvise* (connection: INTEGER): COM.RESULT;
BEGIN
RETURN WinApi.E_FAIL
END DUnadvise;
PROCEDURE (this: IDataObject) EnumDAdvise* (OUT enum: WinOle.IEnumSTATDATA): COM.RESULT;
BEGIN
RETURN WinApi.E_FAIL
END EnumDAdvise;
(* import/export *)
PROCEDURE DataConvTo* (data: WinOle.IDataObject; type: Stores.TypeName): BOOLEAN;
VAR t: Stores.TypeName; c: Converter; v: Views.View; res: COM.RESULT; ok, s: BOOLEAN;
med: WinOle.STGMEDIUM; ival: InfoVal; w, h, x, y: INTEGER;
BEGIN
v := NIL; c := convList;
WHILE c # NIL DO
IF c.imp # "" THEN
IF (type = "") OR (c.type # "") & Services.Extends(c.type, type) THEN
IF data.QueryGetData(c.format) = WinApi.S_OK THEN RETURN TRUE END
ELSIF info IN c.opts THEN
res := data.GetData(c.format, med);
IF res >= 0 THEN
GetCommand(c.imp, ival, ok); t := "";
IF ok THEN ival.p(med, t, w, h, x, y, s)
ELSIF debug THEN Log.String(c.imp); Log.String(" failed (c)"); Log.Ln
END;
WinOle.ReleaseStgMedium(med);
IF t = type THEN RETURN TRUE END
END
END
END;
c := c.next
END;
RETURN FALSE
END DataConvTo;
PROCEDURE GetDataView* (data: WinOle.IDataObject; type: Stores.TypeName; OUT v: Views.View;
OUT w, h: INTEGER; OUT isSingle: BOOLEAN);
VAR t: Stores.TypeName; c: Converter; val: ImpVal; ival: InfoVal; ok, s: BOOLEAN;
res: COM.RESULT; med: WinOle.STGMEDIUM; x, y: INTEGER;
BEGIN
v := NIL; t := ""; c := convList;
WHILE (c # NIL) & (v = NIL) DO
IF c.imp # "" THEN
IF info IN c.opts THEN
IF type # "" THEN
res := data.GetData(c.format, med); t := "";
IF debug THEN Log.String("Get Data "); Log.String(c.imp); Log.String(c.exp); Log.Int(res); Log.Ln
END;
IF res >= 0 THEN
GetCommand(c.imp, ival, ok);
IF ok THEN ival.p(med, t, w, h, x, y, s)
ELSIF debug THEN Log.String(c.imp); Log.String(" failed (i)"); Log.Ln
END;
WinOle.ReleaseStgMedium(med)
END
END
ELSIF (type = "") OR (c.type # "") & Services.Extends(c.type, type)
OR (c.type = "") & (t # "") & Services.Extends(t, type) THEN
IF debug THEN Log.String("query"); Log.Int(data.QueryGetData(c.format)); Log.Ln END;
res := data.GetData(c.format, med);
IF debug THEN Log.String("Get Data "); Log.String(c.imp); Log.String(c.exp); Log.Int(res); Log.Ln END;
IF res >= 0 THEN
GetCommand(c.imp, val, ok);
IF ok THEN
dataObj := data; val.p(med, v, w, h, isSingle); dataObj := NIL
ELSIF debug THEN Log.String(c.imp); Log.String(" failed (g)"); Log.Ln
END;
WinOle.ReleaseStgMedium(med)
END
END
END;
c := c.next
END
END GetDataView;
PROCEDURE GetDataViewUsing* (data: WinOle.IDataObject; c: Converter; OUT v: Views.View;
OUT w, h: INTEGER; OUT isSingle: BOOLEAN);
VAR val: ImpVal; ok: BOOLEAN; res: COM.RESULT; med: WinOle.STGMEDIUM;
BEGIN
ASSERT(c # NIL, 20);
ASSERT(c.imp # "", 21);
ASSERT(~(info IN c.opts), 22);
v := NIL;
res := data.GetData(c.format, med);
IF debug THEN Log.String("Get Data "); Log.String(c.imp); Log.String(c.exp); Log.Int(res); Log.Ln END;
IF res >= 0 THEN
GetCommand(c.imp, val, ok);
IF ok THEN
dataObj := data; val.p(med, v, w, h, isSingle); dataObj := NIL
ELSIF debug THEN Log.String(c.imp); Log.String(" failed (g)"); Log.Ln
END;
WinOle.ReleaseStgMedium(med)
END
END GetDataViewUsing;
PROCEDURE GetTextDataView* (data: WinOle.IDataObject; OUT v: Views.View;
OUT w, h: INTEGER; OUT isSingle: BOOLEAN);
VAR c: Converter;
BEGIN
v := NIL; c := convList;
WHILE (c # NIL) & (c.imp # "OleData.ImportNative") DO c := c.next END;
IF c # NIL THEN GetDataViewUsing(data, c, v, w, h, isSingle) END;
IF v = NIL THEN
c := convList;
WHILE (c # NIL) & (c.imp # "HostTextConv.ImportDRichText") DO c := c.next END;
IF c # NIL THEN GetDataViewUsing(data, c, v, w, h, isSingle) END;
END;
IF v = NIL THEN
GetDataView(data, "", v, w, h, isSingle)
END
END GetTextDataView;
PROCEDURE GetDataType* (data: WinOle.IDataObject; OUT type: Stores.TypeName;
OUT w, h, x, y: INTEGER; OUT isSingle: BOOLEAN);
VAR t: Stores.TypeName; c: Converter; res: COM.RESULT; med: WinOle.STGMEDIUM;
ival: InfoVal; ok: BOOLEAN;
BEGIN
type := ""; c := convList;
WHILE (c # NIL) & (type = "") DO
IF c.imp # "" THEN
IF info IN c.opts THEN
res := data.GetData(c.format, med);
IF res >= 0 THEN
GetCommand(c.imp, ival, ok);
IF ok THEN ival.p(med, type, w, h, x, y, isSingle)
ELSIF debug THEN Log.String(c.imp); Log.String(" failed (t)"); Log.Ln
END;
WinOle.ReleaseStgMedium(med)
END
ELSIF c.type # "" THEN
IF data.QueryGetData(c.format) = WinApi.S_OK THEN
type := c.type; isSingle := FALSE;
w := 0; h := 0; x := 0; y := 0
END
END
END;
c := c.next
END
END GetDataType;
(* creation *)
PROCEDURE ViewData* (v: Views.View; w, h: INTEGER; isSingle: BOOLEAN): IDataObject;
VAR new: IDataObject;
BEGIN
NEW(new); new.view := v; new.w := w; new.h := h; new.rx := 0; new.ry := 0;
new.isSingle := isSingle; new.useSel := FALSE;
IF v # NIL THEN Services.GetTypeName(v, new.type) ELSE new.type := "*" END;
RETURN new
END ViewData;
PROCEDURE ViewDropData* (v: Views.View; w, h, rx, ry: INTEGER; isSingle, useSel: BOOLEAN): IDataObject;
VAR new: IDataObject;
BEGIN
IF useSel THEN
ASSERT(~isSingle, 20);
ASSERT(v IS Containers.View, 21);
ASSERT(v(Containers.View).ThisController() # NIL, 22)
END;
NEW(new); new.view := v; new.w := w; new.h := h; new.rx := rx; new.ry := ry;
new.isSingle := isSingle; new.useSel := useSel;
IF v # NIL THEN Services.GetTypeName(v, new.type) ELSE new.type := "*" END;
RETURN new
END ViewDropData;
PROCEDURE SetView* (data: IDataObject; v: Views.View; w, h: INTEGER);
BEGIN
data.view := v; data.w := w; data.h := h;
IF v # NIL THEN Services.GetTypeName(v, data.type) ELSE data.type := "*" END;
END SetView;
(* registration *)
PROCEDURE Register* (imp, exp, format: Dialog.String; type: Stores.TypeName; opts: SET);
VAR c, f: Converter; tymed: SET; cbf: SHORTINT;
BEGIN
tymed := WinOle.TYMED_HGLOBAL;
IF format = "TEXT" THEN cbf := WinApi.CF_TEXT
ELSIF format = "BITMAP" THEN cbf := WinApi.CF_BITMAP; tymed := WinOle.TYMED_GDI
ELSIF format = "METAFILEPICT" THEN cbf := WinApi.CF_METAFILEPICT; tymed := WinOle.TYMED_MFPICT
ELSIF format = "SYLK" THEN cbf := WinApi.CF_SYLK
ELSIF format = "DIF" THEN cbf := WinApi.CF_DIF
ELSIF format = "TIFF" THEN cbf := WinApi.CF_TIFF
ELSIF format = "OEMTEXT" THEN cbf := WinApi.CF_OEMTEXT
ELSIF format = "DIB" THEN cbf := WinApi.CF_DIB; tymed := WinOle.TYMED_GDI
ELSIF format = "PALETTE" THEN cbf := WinApi.CF_PALETTE
ELSIF format = "PENDATA" THEN cbf := WinApi.CF_PENDATA
ELSIF format = "RIFF" THEN cbf := WinApi.CF_RIFF
ELSIF format = "WAVE" THEN cbf := WinApi.CF_WAVE
ELSIF format = "UNICODETEXT" THEN cbf := WinApi.CF_UNICODETEXT
ELSIF format = "ENHMETAFILE" THEN cbf := WinApi.CF_ENHMETAFILE; tymed := WinOle.TYMED_ENHMF
ELSIF format = "HDROP" THEN cbf := WinApi.CF_HDROP
ELSIF format = "LOCALE" THEN cbf := WinApi.CF_LOCALE
ELSE cbf := SHORT(WinApi.RegisterClipboardFormatW(format))
END;
IF stream IN opts THEN tymed := WinOle.TYMED_ISTREAM
ELSIF storage IN opts THEN tymed := WinOle.TYMED_ISTORAGE
ELSIF file IN opts THEN tymed := WinOle.TYMED_FILE
END;
NEW(c); c.imp := imp; c.exp := exp; c.type := type; c.opts := opts;
GenFormatEtc(cbf, WinOle.DVASPECT_CONTENT, tymed, c.format);
IF convList = NIL THEN convList := c
ELSE f := convList;
WHILE f.next # NIL DO f := f.next END;
f.next := c
END
END Register;
(* debug *)
PROCEDURE DumpData* (data: WinOle.IDataObject);
VAR type: Stores.TypeName; c: Converter; val: ImpVal; ival: InfoVal; ok, s: BOOLEAN;
res: COM.RESULT; med: WinOle.STGMEDIUM; w, h, x, y: INTEGER; v: Views.View;
BEGIN
c := convList;
WHILE c # NIL DO
IF c.imp # "" THEN
res := data.QueryGetData(c.format);
IF res >= 0 THEN
Log.String(c.imp); Log.Char(" ");
res := data.GetData(c.format, med);
IF res >= 0 THEN
Log.String(" read ");
IF info IN c.opts THEN
Log.String("(i) ");
GetCommand(c.imp, ival, ok);
IF ok THEN
type := "";
ival.p(med, type, w, h, x, y, s);
Log.String(type);
Log.Int(w); Log.Int(h); Log.Int(x); Log.Int(y);
IF s THEN Log.String(" singleton") END
ELSE
Log.String("failed");
END
ELSE
GetCommand(c.imp, val, ok);
IF ok THEN
v := NIL;
dataObj := data; val.p(med, v, w, h, s); dataObj := NIL;
IF v # NIL THEN
Services.GetTypeName(v, type);
Log.String(type);
Log.Int(w); Log.Int(h);
IF s THEN Log.String(" singleton") END
ELSE
Log.String("NIL")
END
ELSE
Log.String("failed");
END
END;
WinOle.ReleaseStgMedium(med);
Log.Ln
END
END
END;
c := c.next
END
END DumpData;
PROCEDURE Init;
VAR res: INTEGER; dc: WinApi.HDC;
BEGIN
dc := WinApi.GetDC(0);
unit := 914400 DIV WinApi.GetDeviceCaps(dc, 90);
res := WinApi.ReleaseDC(0, dc)
END Init;
BEGIN
Init
END OleData.