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	= "
	- 20061012, ai, Updated procedures MemFile.NewReader and MemFile.NewWriter to reuse existing riders
	- 20070130, bh, Unicode support
	- 20141226, center #22, HostFiles.NewWriter violating the specification
	- 20210116, bbcb, #045, restore Files interface to 1.6 
	"
	issues	= "
	- ...
	"

**)


	IMPORT
		SYSTEM, COM, WinOle, WinApi, Log,
		Files, Strings, Meta, Dialog, Services, Ports, Stores, Models,
		Views, Properties, Containers,
		HostPorts := WinPorts;
		
		
	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 # {})
	END  Eql;
	
	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);
				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
	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 # "WinTextConv.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.
