MODULE DevTypeLibs;
(**
project = "BlackBox"
organization = "www.oberon.ch"
contributors = "Oberon microsystems"
version = "System/Rsrc/About"
copyright = "System/Rsrc/About"
license = "Docu/BB-License"
changes = ""
issues = ""
**)
(* Code that is only reached with wrapper in options. Code that is not reached with wrapper in options. *)
IMPORT COM, WinOle, WinOleAut, TextModels, TextMappers;
CONST
(* options *)
browse = 1; interface = 2; wrapper = 3;
inAuto = 12; inAll = 13;
outAuto = 14; outAll = 15;
source = 31;
(* kind *)
value = 1; var = 2; varin = 3; varout = 4;
(* conv type *)
ret = 1; get = 2; par = 3; refpar = 4;
(* pseudo types *)
enumerator = -1; record = -2; union = -3; module = -4; class = -5; ptrVoid = -6;
VAR
modules: ARRAY 16, 64 OF CHAR;
noMod: INTEGER;
retName: ARRAY 156 OF CHAR;
PROCEDURE WriteBSTR (s: WinOle.BSTR; VAR out: TextMappers.Formatter);
BEGIN
IF s # NIL THEN out.WriteString(s$) END
END WriteBSTR;
PROCEDURE WriteGuid (VAR guid: COM.GUID; VAR out: TextMappers.Formatter);
BEGIN
out.WriteChar("{");
out.WriteIntForm((guid[2] MOD 256 + 256 * guid[3]) MOD 65536, TextMappers.hexadecimal, 4, "0", FALSE);
out.WriteIntForm((guid[0] MOD 256 + 256 * guid[1]) MOD 65536, TextMappers.hexadecimal, 4, "0", FALSE);
out.WriteChar("-");
out.WriteIntForm((guid[4] MOD 256 + 256 * guid[5]) MOD 65536, TextMappers.hexadecimal, 4, "0", FALSE);
out.WriteChar("-");
out.WriteIntForm((guid[6] MOD 256 + 256 * guid[7]) MOD 65536, TextMappers.hexadecimal, 4, "0", FALSE);
out.WriteChar("-");
out.WriteIntForm((guid[8]) MOD 256, TextMappers.hexadecimal, 2, "0", FALSE);
out.WriteIntForm((guid[9]) MOD 256, TextMappers.hexadecimal, 2, "0", FALSE);
out.WriteChar("-");
out.WriteIntForm((guid[10]) MOD 256, TextMappers.hexadecimal, 2, "0", FALSE);
out.WriteIntForm((guid[11]) MOD 256, TextMappers.hexadecimal, 2, "0", FALSE);
out.WriteIntForm((guid[12]) MOD 256, TextMappers.hexadecimal, 2, "0", FALSE);
out.WriteIntForm((guid[13]) MOD 256, TextMappers.hexadecimal, 2, "0", FALSE);
out.WriteIntForm((guid[14]) MOD 256, TextMappers.hexadecimal, 2, "0", FALSE);
out.WriteIntForm((guid[15]) MOD 256, TextMappers.hexadecimal, 2, "0", FALSE);
out.WriteChar("}")
END WriteGuid;
PROCEDURE^ GetInfoType (tinfo: WinOleAut.ITypeInfo; OUT type: INTEGER; OUT info: WinOleAut.ITypeInfo);
PROCEDURE GetDescType (IN desc: WinOleAut.TYPEDESC; tinfo: WinOleAut.ITypeInfo;
OUT type: INTEGER; OUT info: WinOleAut.ITypeInfo);
VAR res: COM.RESULT; t: INTEGER; i: WinOleAut.ITypeInfo;
BEGIN
type := desc.vt;
IF type = WinOle.VT_USERDEFINED THEN
res := tinfo.GetRefTypeInfo(desc.u.hreftype, i);
GetInfoType(i, type, info)
ELSIF type = WinOle.VT_PTR THEN
GetDescType(desc.u.lptdesc, tinfo, t, i);
IF (i # NIL) & ((t = WinOle.VT_DISPATCH) OR (t = WinOle.VT_UNKNOWN))
OR (t = WinOle.VT_VARIANT) OR (t = WinOle.VT_SAFEARRAY) THEN type := t; info := i
ELSIF t = WinOle.VT_VOID THEN type := ptrVoid
END
END
END GetDescType;
PROCEDURE GetInfoType (tinfo: WinOleAut.ITypeInfo; OUT type: INTEGER; OUT info: WinOleAut.ITypeInfo);
VAR res: COM.RESULT; attr: WinOleAut.PtrTYPEATTR; i: INTEGER; flags: SET;
ti: WinOleAut.ITypeInfo; t: WinOleAut.HREFTYPE;
BEGIN
info := tinfo; res := tinfo.GetTypeAttr(attr);
CASE attr.typekind OF
| WinOleAut.TKIND_ENUM: type := WinOle.VT_I4
| WinOleAut.TKIND_RECORD: type := record
| WinOleAut.TKIND_UNION: type := union
| WinOleAut.TKIND_MODULE: type := module
| WinOleAut.TKIND_INTERFACE: type := WinOle.VT_UNKNOWN
| WinOleAut.TKIND_DISPATCH: type := WinOle.VT_DISPATCH
| WinOleAut.TKIND_ALIAS: GetDescType(attr.tdescAlias, tinfo, type, info)
| WinOleAut.TKIND_COCLASS:
type := class; i := 0;
WHILE (i < attr.cImplTypes) & (type = class) DO
res := tinfo.GetImplTypeFlags(i, flags);
IF (WinOleAut.IMPLTYPEFLAG_FDEFAULT * flags # {} )
& (WinOleAut.IMPLTYPEFLAG_FSOURCE * flags = {} ) THEN
res := tinfo.GetRefTypeOfImplType(i, t); ASSERT(res >= 0, 101);
res := tinfo.GetRefTypeInfo(t, ti); ASSERT(res >= 0, 102);
GetInfoType(ti, type, info)
END;
INC(i)
END
END;
tinfo.ReleaseTypeAttr(attr)
END GetInfoType;
PROCEDURE WriteVariant (VAR v: WinOleAut.VARIANT; VAR out: TextMappers.Formatter);
BEGIN
IF ODD(v.vt DIV WinOle.VT_ARRAY) THEN
out.WriteSString("array ");
(* to be completed *)
ELSIF ODD(v.vt DIV WinOle.VT_BYREF) THEN
out.WriteSString("ref ");
CASE v.vt MOD 4096 OF
| WinOle.VT_UI1: out.WriteInt(ORD(v.u.pbVal[0]))
| WinOle.VT_I2: out.WriteInt(v.u.piVal[0])
| WinOle.VT_I4:
IF v.u.plVal[0] = 80000000H THEN out.WriteString("80000000H")
ELSE out.WriteInt(v.u.plVal[0])
END
| WinOle.VT_R4: out.WriteReal(v.u.pfltVal[0])
| WinOle.VT_R8: out.WriteReal(v.u.pdblVal[0])
| WinOle.VT_BOOL:
IF v.u.pboolVal[0] = 0 THEN out.WriteSString("FALSE") ELSE out.WriteSString("TRUE") END
| WinOle.VT_CY: out.WriteReal(v.u.pcyVal[0] / 10000)
| WinOle.VT_DATE: out.WriteReal(v.u.pdate[0])
| WinOle.VT_BSTR: out.WriteChar('"'); WriteBSTR(v.u.pbstrVal[0], out); out.WriteChar('"')
| WinOle.VT_ERROR: out.WriteIntForm(v.u.pscode[0], TextMappers.hexadecimal, 9, "0", TRUE)
| WinOle.VT_DISPATCH: out.WriteSString("IDispatch")
| WinOle.VT_UNKNOWN: out.WriteSString("IUnknown")
ELSE out.WriteSString("undefined ("); out.WriteInt(v.vt MOD 4096); out.WriteChar(")")
END
ELSE
CASE v.vt MOD 4096 OF
| WinOle.VT_NULL: out.WriteSString("NIL")
| WinOle.VT_UI1: out.WriteInt(ORD(v.u.bVal))
| WinOle.VT_I2: out.WriteInt(v.u.iVal)
| WinOle.VT_I4:
IF v.u.lVal = 80000000H THEN out.WriteString("80000000H")
ELSE out.WriteInt(v.u.lVal)
END
| WinOle.VT_R4: out.WriteReal(v.u.fltVal)
| WinOle.VT_R8: out.WriteReal(v.u.dblVal)
| WinOle.VT_BOOL:
IF v.u.boolVal = 0 THEN out.WriteSString("FALSE") ELSE out.WriteSString("TRUE") END
| WinOle.VT_CY: out.WriteReal(v.u.cyVal / 10000)
| WinOle.VT_DATE: out.WriteReal(v.u.date)
| WinOle.VT_BSTR: out.WriteChar('"'); WriteBSTR(v.u.bstrVal, out); out.WriteChar('"')
| WinOle.VT_ERROR: out.WriteIntForm(v.u.scode, TextMappers.hexadecimal, 9, "0", TRUE)
| WinOle.VT_DISPATCH: out.WriteSString("IDispatch")
| WinOle.VT_UNKNOWN: out.WriteSString("IUnknown")
ELSE out.WriteSString("undefined ("); out.WriteInt(v.vt MOD 4096); out.WriteChar(")")
END
END
END WriteVariant;
PROCEDURE WriteTypeName (
tinfo: WinOleAut.ITypeInfo; convert, isThis: BOOLEAN; VAR out: TextMappers.Formatter
);
VAR ti: WinOleAut.ITypeInfo; lib: WinOleAut.ITypeLib; i, n, vt: INTEGER;
res: COM.RESULT; s: WinOle.BSTR; mod, name: ARRAY 64 OF CHAR; flags: SET;
BEGIN
res := tinfo.GetContainingTypeLib(lib, i); ASSERT(res >= 0, 102);
res := lib.GetDocumentation(-1, s, NIL, NIL, NIL); ASSERT(res >= 0, 105);
mod := s$; WinOleAut.SysFreeString(s);
res := tinfo.GetDocumentation(-1, s, NIL, NIL, NIL); ASSERT(res >= 0, 106);
(* !!! *)
name := s$; WinOleAut.SysFreeString(s);
IF convert THEN
IF mod = "stdole" THEN
IF name = "IDispatch" THEN mod := "CtlT"; name := "Object"
ELSE mod := "CtlStdType"
END
ELSE
GetInfoType(tinfo, vt, ti);
IF vt = WinOle.VT_UNKNOWN THEN mod := "CtlT"; name := "IUnknown"
ELSE mod := "Ctl" + mod
END
END;
END;
i := 0; WHILE (i < noMod) & (modules[i] # mod) DO INC(i) END;
IF i = noMod THEN modules[i] := mod$; INC(noMod) END;
IF i # 0 THEN out.WriteString(mod); out.WriteChar(".") END;
IF isThis THEN out.WriteString("This") END;
out.WriteString(name)
END WriteTypeName;
PROCEDURE WriteHandleName (
t: WinOleAut.HREFTYPE; tinfo: WinOleAut.ITypeInfo; opts: SET; VAR out: TextMappers.Formatter
);
VAR res: COM.RESULT; type: WinOleAut.ITypeInfo;
BEGIN
res := tinfo.GetRefTypeInfo(t, type); (* ASSERT(res >= 0, 100); *)
IF res >= 0 THEN
WriteTypeName(type, wrapper IN opts, FALSE, out)
ELSE
out.WriteSString("???("); out.WriteInt(res); out.WriteChar(")")
END
END WriteHandleName;
PROCEDURE WriteType (
VAR t: WinOleAut.TYPEDESC; tinfo: WinOleAut.ITypeInfo; opts: SET; VAR out: TextMappers.Formatter
);
VAR i, vt: INTEGER; ti: WinOleAut.ITypeInfo;
BEGIN
CASE t.vt OF
| WinOle.VT_I2: out.WriteSString("SHORTINT")
| WinOle.VT_I4: out.WriteSString("INTEGER")
| WinOle.VT_R4: out.WriteSString("SHORTREAL")
| WinOle.VT_R8: out.WriteSString("REAL")
| WinOle.VT_CY:
IF wrapper IN opts THEN out.WriteSString("CtlT.OleCy") ELSE out.WriteSString("CURRENCY") END
| WinOle.VT_DATE:
IF wrapper IN opts THEN out.WriteSString("CtlT.OleDate") ELSE out.WriteSString("DATE") END
| WinOle.VT_BSTR:
IF wrapper IN opts THEN out.WriteSString("CtlT.Strg") ELSE out.WriteSString("WinOle.BSTR") END
| WinOle.VT_DISPATCH:
IF wrapper IN opts THEN out.WriteSString("CtlT.Object")
ELSE out.WriteSString("WinOleAut.IDispatch")
END
| WinOle.VT_ERROR: out.WriteSString("CtlT.RESULT")
| WinOle.VT_BOOL:
IF wrapper IN opts THEN out.WriteSString("BOOLEAN")
ELSE out.WriteSString("WinOle.VARIANT_BOOL")
END
| WinOle.VT_VARIANT:
IF wrapper IN opts THEN out.WriteSString("CtlT.Any") ELSE out.WriteSString("WinOleAut.VARIANT") END
| WinOle.VT_UNKNOWN: out.WriteSString("CtlT.IUnknown")
| WinOle.VT_DECIMAL: out.WriteSString("DECIMAL")
| WinOle.VT_I1: out.WriteSString("BYTE")
| WinOle.VT_UI1: out.WriteSString("BYTE")
| WinOle.VT_UI2: out.WriteSString("SHORTINT")
| WinOle.VT_UI4: out.WriteSString("INTEGER")
| WinOle.VT_I8: out.WriteSString("LONGINT")
| WinOle.VT_UI8: out.WriteSString("LONGINT")
| WinOle.VT_INT: out.WriteSString("INTEGER")
| WinOle.VT_UINT: out.WriteSString("INTEGER")
| WinOle.VT_VOID:
IF browse IN opts THEN out.WriteSString("VOID") ELSE out.WriteSString("RECORD END") END
| WinOle.VT_HRESULT: out.WriteSString("CtlT.RESULT")
| WinOle.VT_PTR:
GetDescType(t, tinfo, vt, ti);
IF vt = ptrVoid THEN out.WriteSString("CtlT.PtrVoid")
ELSIF vt # WinOle.VT_PTR THEN WriteType(t.u.lptdesc, tinfo, opts, out)
ELSE out.WriteSString("POINTER TO "); WriteType(t.u.lptdesc^, tinfo, opts, out)
END
| WinOle.VT_SAFEARRAY:
IF wrapper IN opts THEN out.WriteSString("CtlT.Any")
ELSE out.WriteSString("ARRAY [safe] OF "); WriteType(t.u.lptdesc^, tinfo, opts, out)
END
| WinOle.VT_CARRAY: out.WriteSString("ARRAY ");
i := 0;
WHILE i < t.u.lpadesc.cDims DO
out.WriteInt(t.u.lpadesc.rgbounds[i].cElements); out.WriteChar(" "); INC(i)
END;
out.WriteSString("OF "); WriteType(t.u.lpadesc.tdescElem, tinfo, opts, out)
| WinOle.VT_USERDEFINED: WriteHandleName(t.u.hreftype, tinfo, opts, out)
| WinOle.VT_LPSTR:
IF wrapper IN opts THEN out.WriteSString("CtlT.Strg") ELSE out.WriteSString("PtrSTR") END
| WinOle.VT_LPWSTR:
IF wrapper IN opts THEN out.WriteSString("CtlT.Strg") ELSE out.WriteSString("PtrWSTR") END
| enumerator: out.WriteSString("CtlT.Enumerator")
END
END WriteType;
PROCEDURE WriteShortType (VAR t: WinOleAut.TYPEDESC; tinfo: WinOleAut.ITypeInfo; VAR out: TextMappers.Formatter);
VAR vt: INTEGER; ti: WinOleAut.ITypeInfo; res: COM.RESULT;
BEGIN
GetDescType(t, tinfo, vt, ti);
CASE vt OF
| WinOle.VT_I2: out.WriteSString("SInt")
| WinOle.VT_I4: out.WriteSString("Int")
| WinOle.VT_R4: out.WriteSString("SReal")
| WinOle.VT_R8: out.WriteSString("Real")
| WinOle.VT_CY: out.WriteSString("Cy")
| WinOle.VT_DATE: out.WriteSString("Date")
| WinOle.VT_BSTR: out.WriteSString("Str")
| WinOle.VT_DISPATCH: out.WriteSString("Obj")
| WinOle.VT_ERROR: out.WriteSString("Res")
| WinOle.VT_BOOL: out.WriteSString("Bool")
| WinOle.VT_VARIANT: out.WriteSString("Any")
| WinOle.VT_UNKNOWN: out.WriteSString("Intfce")
| WinOle.VT_DECIMAL: out.WriteSString("Decimal")
| WinOle.VT_I1: out.WriteSString("Byte")
| WinOle.VT_UI1: out.WriteSString("Byte")
| WinOle.VT_UI2: out.WriteSString("SInt")
| WinOle.VT_UI4: out.WriteSString("Int")
| WinOle.VT_I8: out.WriteSString("LInt")
| WinOle.VT_UI8: out.WriteSString("LInt")
| WinOle.VT_INT: out.WriteSString("Int")
| WinOle.VT_UINT: out.WriteSString("Int")
| WinOle.VT_VOID: out.WriteSString("Void")
| WinOle.VT_HRESULT: out.WriteSString("Res")
| WinOle.VT_PTR: out.WriteSString("Pointer")
| WinOle.VT_SAFEARRAY: out.WriteSString("Any"); (* t.u.lptdesc *)
| WinOle.VT_CARRAY: out.WriteSString("Array");
| WinOle.VT_USERDEFINED: HALT(100)
| WinOle.VT_LPSTR: out.WriteSString("Str")
| WinOle.VT_LPWSTR: out.WriteSString("Str")
| enumerator: out.WriteSString("Enum")
| ptrVoid: out.WriteSString("Int")
| record: out.WriteSString("Record")
| union: out.WriteSString("Union")
| module: out.WriteSString("Module")
| class: out.WriteSString("Class")
END
END WriteShortType;
PROCEDURE WriteTypeFlags (flags: SHORTINT; VAR out: TextMappers.Formatter);
BEGIN
IF ODD(flags DIV WinOleAut.TYPEFLAG_FAPPOBJECT) THEN out.WriteSString(", appObject") END;
IF ODD(flags DIV WinOleAut.TYPEFLAG_FCANCREATE) THEN out.WriteSString(", createable") END;
IF ODD(flags DIV WinOleAut.TYPEFLAG_FLICENSED) THEN out.WriteSString(", licensed") END;
IF ODD(flags DIV WinOleAut.TYPEFLAG_FPREDECLID) THEN out.WriteSString(", predeclared") END;
IF ODD(flags DIV WinOleAut.TYPEFLAG_FHIDDEN) THEN out.WriteSString(", hidden") END;
IF ODD(flags DIV WinOleAut.TYPEFLAG_FCONTROL) THEN out.WriteSString(", control") END;
IF ODD(flags DIV WinOleAut.TYPEFLAG_FDUAL) THEN out.WriteSString(", dual") END;
IF ODD(flags DIV WinOleAut.TYPEFLAG_FNONEXTENSIBLE) THEN out.WriteSString(", nonextensible") END;
IF ODD(flags DIV WinOleAut.TYPEFLAG_FOLEAUTOMATION) THEN out.WriteSString(", oleauto") END
END WriteTypeFlags;
PROCEDURE WriteTypeConv
(t: WinOleAut.TYPEDESC; tinfo: WinOleAut.ITypeInfo;
type, n: INTEGER; VAR out: TextMappers.Formatter);
VAR ti: WinOleAut.ITypeInfo; vt: INTEGER;
BEGIN
GetDescType(t, tinfo, vt, ti);
IF (vt = WinOle.VT_DISPATCH) & (ti # NIL) THEN
WriteTypeName(ti, TRUE, TRUE, out);
IF type = ret THEN out.WriteSString("(CtlC.VarAny("); out.WriteString(retName); out.WriteString("))")
ELSIF type = get THEN out.WriteSString("(CtlC.GetAny(this, "); out.WriteInt(n); out.WriteSString("))")
ELSIF type = par THEN out.WriteSString("(CtlC.VarAny(par["); out.WriteInt(n); out.WriteSString("]))")
ELSE (* type = refpar *) out.WriteSString("(CtlC.VarRefAny(par["); out.WriteInt(n); out.WriteSString("])[0])")
END
ELSE
IF type = ret THEN
out.WriteSString("CtlC.Var"); WriteShortType(t, tinfo, out);
out.WriteChar("("); out.WriteString(retName); out.WriteChar(")")
ELSIF type = get THEN
out.WriteSString("CtlC.Get"); WriteShortType(t, tinfo, out);
out.WriteSString("(this, "); out.WriteInt(n); out.WriteChar(")")
ELSIF type = par THEN
out.WriteSString("CtlC.Var"); WriteShortType(t, tinfo, out);
out.WriteSString("(par["); out.WriteInt(n); out.WriteSString("])")
ELSE (* type = refpar *)
out.WriteSString("CtlC.VarRef"); WriteShortType(t, tinfo, out);
out.WriteSString("(par["); out.WriteInt(n); out.WriteSString("])[0]")
END
END
END WriteTypeConv;
PROCEDURE IsSpecial (IN type: WinOleAut.TYPEDESC; tinfo: WinOleAut.ITypeInfo): BOOLEAN;
(* special handling needed for bool, string, dispatch & variant passed by reference *)
VAR ti: WinOleAut.ITypeInfo; vt: INTEGER;
BEGIN
GetDescType(type, tinfo, vt, ti);
RETURN (vt = WinOle.VT_BOOL) OR (vt = WinOle.VT_BSTR)
OR (vt = WinOle.VT_DISPATCH) OR (vt = WinOle.VT_VARIANT)
END IsSpecial;
PROCEDURE GetParamType (IN param: WinOleAut.ELEMDESC; tinfo: WinOleAut.ITypeInfo; opts: SET;
OUT type: WinOleAut.TYPEDESC; OUT kind: SHORTINT);
VAR flags: SHORTINT; vt: INTEGER; ti: WinOleAut.ITypeInfo;
BEGIN
type := param.tdesc; kind := value;
GetDescType(param.tdesc, tinfo, vt, ti);
IF (type.vt = WinOle.VT_PTR) & (vt = WinOle.VT_PTR) THEN
flags := param.u.paramdesc.wParamFlags;
type := type.u.lptdesc^;
IF ODD(flags DIV WinOleAut.PARAMFLAG_FIN) THEN
IF ~ODD(flags DIV WinOleAut.PARAMFLAG_FOUT) THEN kind := varin;
(* correction for wrong IN attributes *)
GetDescType(type, tinfo, vt, ti);
IF (vt # record) & (vt # union) & (vt # WinOle.VT_CARRAY) THEN kind := var END
ELSE kind := var
END
ELSIF ODD(flags DIV WinOleAut.PARAMFLAG_FOUT) THEN kind := varout
ELSE kind := var
END
END
END GetParamType;
PROCEDURE ShowVar (VAR var: WinOleAut.PtrVARDESC; tinfo: WinOleAut.ITypeInfo;
opts: SET; VAR out: TextMappers.Formatter);
VAR n: INTEGER; name, s, t: WinOle.BSTR; res: COM.RESULT; e: SHORTINT;
BEGIN
res := tinfo.GetNames(var.memid, name, 1, n);
out.WriteTab; out.WriteTab; out.WriteTab; WriteBSTR(name, out);
WinOleAut.SysFreeString(name);
IF var.varkind = WinOleAut.VAR_CONST THEN
out.WriteSString("* = "); WriteVariant(var.u.lpvarValue^, out)
ELSE
IF ODD(var.wVarFlags DIV WinOleAut.VARFLAG_FREADONLY) THEN out.WriteChar("-")
ELSE out.WriteChar("*")
END;
IF var.varkind = WinOleAut.VAR_STATIC THEN
res := tinfo.GetDllEntry(var.memid, 0, s, t, e);
IF res >= 0 THEN
out.WriteSString(" [");
IF s # NIL THEN
out.WriteChar('"'); WriteBSTR(s, out); out.WriteSString('", '); WinOleAut.SysFreeString(s)
END;
IF t # NIL THEN out.WriteChar('"'); WriteBSTR(s, out); out.WriteChar('"'); WinOleAut.SysFreeString(t)
ELSE out.WriteChar('"'); out.WriteInt(e); out.WriteChar('"')
END;
out.WriteChar("]")
END
END;
out.WriteSString(": "); WriteType(var.elemdescVar.tdesc, tinfo, opts + {browse}, out)
END;
out.WriteChar(";");
res := tinfo.GetDocumentation(var.memid, NIL, s, NIL, NIL);
IF (s # NIL) OR (browse IN opts) THEN
out.WriteSString(" (* ");
IF s # NIL THEN
WriteBSTR(s, out);
IF browse IN opts THEN out.WriteSString(", ") END;
WinOleAut.SysFreeString(s)
END;
IF browse IN opts THEN
out.WriteSString("id: "); out.WriteIntForm(var.memid, TextMappers.hexadecimal, 8, "0", FALSE);
IF var.varkind = WinOleAut.VAR_DISPATCH THEN out.WriteSString(", property") END;
IF ODD(var.wVarFlags DIV WinOleAut.VARFLAG_FREADONLY) THEN out.WriteSString(", readonly")
END;
IF ODD(var.wVarFlags DIV WinOleAut.VARFLAG_FSOURCE) THEN out.WriteSString(", source") END;
IF ODD(var.wVarFlags DIV WinOleAut.VARFLAG_FBINDABLE) THEN out.WriteSString(", bindable")
END;
IF ODD(var.wVarFlags DIV WinOleAut.VARFLAG_FDISPLAYBIND) THEN out.WriteSString(", display")
END;
IF ODD(var.wVarFlags DIV WinOleAut.VARFLAG_FDEFAULTBIND) THEN out.WriteSString(", default")
END;
IF ODD(var.wVarFlags DIV WinOleAut.VARFLAG_FHIDDEN) THEN out.WriteSString(", hidden") END;
IF var.varkind = WinOleAut.VAR_PERINSTANCE THEN
out.WriteSString(", offset: "); out.WriteInt(var.u.oInst)
END
END;
out.WriteSString(" *)")
END;
out.WriteLn
END ShowVar;
PROCEDURE ShowParam (VAR param: WinOleAut.ELEMDESC; name: WinOle.BSTR;
tinfo: WinOleAut.ITypeInfo; opts: SET; VAR out: TextMappers.Formatter);
VAR type: WinOleAut.TYPEDESC; flags, kind: SHORTINT; ti: WinOleAut.ITypeInfo; s: WinOle.BSTR; res: COM.RESULT;
BEGIN
GetParamType(param, tinfo, opts, type, kind);
IF kind = var THENout.WriteSString("VAR ")
ELSIF kind = varin THEN out.WriteSString("IN ")
ELSIF kind = varout THEN out.WriteSString("OUT ")
END;
flags := param.u.paramdesc.wParamFlags;
IF ODD(flags DIV WinOleAut.PARAMFLAG_FLCID) THEN out.WriteSString("(* lcid *) ") END;
IF ODD(flags DIV WinOleAut.PARAMFLAG_FRETVAL) THEN out.WriteSString("(* retval *) ") END;
(*
(* correct parameter name *)
IF (type.vt = WinOle.VT_PTR) & (type.u.lptdesc.vt = WinOle.VT_USERDEFINED) THEN
res := tinfo.GetRefTypeInfo(type.u.lptdesc.u.hreftype, ti);
IF res >= 0 THEN
res := ti.GetDocumentation(-1, s, NIL, NIL, NIL);
IF s # NIL THEN
IF name^ = s^ THEN
IF name[0] < "a" THEN name[0] := CHR(ORD(name[0]) + 32)
ELSE name[0] := CHR(ORD(name[0]) - 32)
END
END;
WinOleAut.SysFreeString(s)
END
END
END;
*)
WriteBSTR(name, out); out.WriteSString(": ");
IF (wrapper IN opts) & (type.vt = WinOle.VT_BSTR) & (kind = value) THEN out.WriteSString("ARRAY OF CHAR")
ELSE WriteType(type, tinfo, opts, out)
END;
(*
IF ODD(param.u.paramdesc.wParamFlags DIV WinOleAut.PARAMFLAG_FHASDEFAULT) THEN
out.WriteSString(" (* := ");
WriteVariant(param.u.paramdesc.pparamdescex.varDefaultValue, out);
out.WriteSString(" *)")
END;
*)
END ShowParam;
PROCEDURE ShowWrapper (VAR [nil] param: ARRAY [untagged] OF WinOleAut.ELEMDESC;
VAR retTyp: WinOleAut.TYPEDESC;
VAR names: ARRAY OF WinOle.BSTR;
par, id, invoke: INTEGER; hasRet: BOOLEAN; opts: SET;
tinfo: WinOleAut.ITypeInfo; VAR out: TextMappers.Formatter);
VAR i: INTEGER; type: WinOleAut.TYPEDESC; kind: SHORTINT; hasVar: BOOLEAN;
BEGIN
IF (invoke = WinOleAut.INVOKE_PROPERTYPUT) & ~hasRet & (par = 1) THEN
out.WriteTab; out.WriteSString("BEGIN"); out.WriteLn;
out.WriteTab; out.WriteTab; out.WriteSString("CtlC.Put");
WriteShortType(param[0].tdesc, tinfo, out); out.WriteSString("(this, ");
out.WriteInt(id); out.WriteSString(", ");
WriteBSTR(names[1], out); out.WriteChar(")"); out.WriteLn
ELSIF (invoke = WinOleAut.INVOKE_PROPERTYGET) & hasRet & (par = 0) THEN
out.WriteTab; out.WriteSString("BEGIN"); out.WriteLn;
out.WriteTab; out.WriteTab; out.WriteSString("RETURN ");
WriteTypeConv(retTyp, tinfo, get, id, out); out.WriteLn
ELSE
hasVar := FALSE;
IF par > 0 THEN
IF ~hasVar THEN out.WriteTab; out.WriteTab; out.WriteSString("VAR"); hasVar := TRUE END;
out.WriteString(" arg: ARRAY "); out.WriteInt(par);
out.WriteString(" OF CtlT.Variant;")
END;
IF hasRet THEN
IF ~hasVar THEN out.WriteTab; out.WriteTab; out.WriteSString("VAR"); hasVar := TRUE END;
out.WriteString(" ret: CtlT.Variant;")
END;
i := 0;
WHILE i < par DO
GetParamType(param[i], tinfo, opts, type, kind);
IF (kind # value) & IsSpecial(type, tinfo) THEN
IF ~hasVar THEN out.WriteTab; out.WriteTab; out.WriteSString("VAR"); hasVar := TRUE END;
out.WriteChar(" "); WriteBSTR(names[i + 1], out); out.WriteString("_TEMP: CtlT.Variant;")
END;
INC(i)
END;
IF hasVar THEN out.WriteLn END;
out.WriteTab; out.WriteSString("BEGIN"); out.WriteLn;
i := 0;
WHILE i < par DO
GetParamType(param[i], tinfo, opts, type, kind);
IF (kind IN {var, varin}) & IsSpecial(type, tinfo) THEN
out.WriteTab; out.WriteTab; out.WriteSString("CtlC.");
WriteShortType(type, tinfo, out);
out.WriteString("Var("); WriteBSTR(names[i + 1], out);
out.WriteString(", "); WriteBSTR(names[i + 1], out);
out.WriteString("_TEMP);"); out.WriteLn
END;
out.WriteTab; out.WriteTab; out.WriteSString("CtlC.");
IF kind # value THEN out.WriteSString("Ref") END;
WriteShortType(type, tinfo, out);
out.WriteSString("Var("); WriteBSTR(names[i + 1], out);
IF (kind # value) & IsSpecial(type, tinfo) THEN out.WriteString("_TEMP") END;
out.WriteSString(", arg["); out.WriteInt(par - i - 1);
out.WriteSString("]);"); out.WriteLn;
INC(i)
END;
out.WriteTab; out.WriteTab;
IF par = 0 THEN out.WriteSString("CtlC.CallMethod(this, ")
ELSIF ODD(invoke DIV WinOleAut.INVOKE_PROPERTYGET) THEN
out.WriteSString("CtlC.CallGetMethod(this, ")
ELSIF ODD(invoke DIV WinOleAut.INVOKE_PROPERTYPUT) THEN
out.WriteSString("CtlC.CallPutMethod(this, ")
ELSIF ODD(invoke DIV WinOleAut.INVOKE_PROPERTYPUTREF) THEN
out.WriteSString("CtlC.CallPutRefMethod(this, ")
ELSE out.WriteSString("CtlC.CallParMethod(this, ")
END;
out.WriteInt(id);
IF par > 0 THEN out.WriteSString(", arg") END;
IF hasRet THEN out.WriteSString(", ret") ELSE out.WriteSString(", NIL") END;
out.WriteSString(");"); out.WriteLn;
i := 0;
WHILE i < par DO
GetParamType(param[i], tinfo, opts, type, kind);
IF (kind IN {var, varout}) & IsSpecial(type, tinfo) THEN
out.WriteTab; out.WriteTab; WriteBSTR(names[i + 1], out);
out.WriteSString(" := "); retName := names[i + 1]$ + "_TEMP";
WriteTypeConv(type, tinfo, ret, 0, out);
out.WriteChar(";"); out.WriteLn
END;
INC(i)
END;
IF hasRet THEN
out.WriteTab; out.WriteTab; out.WriteSString("RETURN ");
retName := "ret";
WriteTypeConv(retTyp, tinfo, ret, 0, out); out.WriteLn
END
END
END ShowWrapper;
PROCEDURE ShowGenerator (tinfo: WinOleAut.ITypeInfo; opts: SET; VAR out: TextMappers.Formatter);
VAR res: COM.RESULT; attr: WinOleAut.PtrTYPEATTR; name: WinOle.BSTR;
BEGIN
res := tinfo.GetTypeAttr(attr);
res := tinfo.GetDocumentation(-1, name, NIL, NIL, NIL);
(* !!! *)
out.WriteTab; out.WriteSString("PROCEDURE This"); WriteBSTR(name, out);
out.WriteSString("* (v: CtlT.Any): ");WriteBSTR(name, out);
out.WriteChar(";"); out.WriteLn;
out.WriteTab; out.WriteTab; out.WriteSString("VAR new: ");
WriteBSTR(name, out); out.WriteChar(";"); out.WriteLn;
out.WriteTab; out.WriteSString("BEGIN"); out.WriteLn;
out.WriteTab; out.WriteTab; out.WriteSString("IF v # NIL THEN"); out.WriteLn;
out.WriteTab; out.WriteTab; out.WriteTab;
out.WriteSString('NEW(new); CtlC.InitObj(new, v, "');
WriteGuid(attr.guid, out);
out.WriteSString('"); RETURN new'); out.WriteLn;
out.WriteTab; out.WriteTab; out.WriteSString("ELSE RETURN NIL"); out.WriteLn;
out.WriteTab; out.WriteTab; out.WriteSString("END"); out.WriteLn;
out.WriteTab; out.WriteSString("END This");
WriteBSTR(name, out); out.WriteChar(";"); out.WriteLn; out.WriteLn;
out.WriteTab; out.WriteSString("PROCEDURE Is"); WriteBSTR(name, out);
out.WriteSString("* (v: CtlT.Any): BOOLEAN;"); out.WriteLn;
out.WriteTab; out.WriteSString("BEGIN"); out.WriteLn;
out.WriteTab; out.WriteTab;
out.WriteSString('RETURN CtlC.IsObj(v, "');
WriteGuid(attr.guid, out); out.WriteSString('")');
out.WriteLn; out.WriteTab; out.WriteSString("END Is");
WriteBSTR(name, out); out.WriteChar(";"); out.WriteLn; out.WriteLn;
WinOleAut.SysFreeString(name)
END ShowGenerator;
PROCEDURE ShowClassGenerator (tinfo: WinOleAut.ITypeInfo; opts: SET; VAR out: TextMappers.Formatter);
VAR res: COM.RESULT; attr, iattr: WinOleAut.PtrTYPEATTR; sc, si: WinOle.BSTR; i: INTEGER;
t: WinOleAut.HREFTYPE; iinfo: WinOleAut.ITypeInfo; flags: SET;
BEGIN
IF (inAll IN opts) OR (inAuto IN opts) THEN
res := tinfo.GetTypeAttr(attr); ASSERT(res >= 0, 100); i := 0;
WHILE i < attr.cImplTypes DO
res := tinfo.GetImplTypeFlags(i, flags);
IF WinOleAut.IMPLTYPEFLAG_FSOURCE * flags = {} THEN
res := tinfo.GetRefTypeOfImplType(i, t); ASSERT(res >= 0, 101);
res := tinfo.GetRefTypeInfo(t, iinfo); ASSERT(res >= 0, 102);
res := iinfo.GetTypeAttr(iattr); ASSERT(res >= 0, 103);
IF iattr.typekind = WinOleAut.TKIND_DISPATCH THEN
res := tinfo.GetDocumentation(-1, sc, NIL, NIL, NIL); ASSERT(res >= 0, 104);
res := iinfo.GetDocumentation(-1, si, NIL, NIL, NIL); ASSERT(res >= 0, 105);
(* !!! *)
IF si # NIL THEN
out.WriteTab; out.WriteSString("PROCEDURE New"); WriteBSTR(sc, out);
IF WinOleAut.IMPLTYPEFLAG_FDEFAULT * flags = {}THEN
out.WriteChar("_"); WriteBSTR(si, out)
END;
out.WriteSString("* (): ");WriteBSTR(si, out); out.WriteChar(";"); out.WriteLn;
out.WriteTab; out.WriteSString("BEGIN"); out.WriteLn;
out.WriteTab; out.WriteTab;
out.WriteSString("RETURN This"); WriteBSTR(si, out);
out.WriteSString('(CtlC.NewObj("'); WriteGuid(attr.guid, out);
out.WriteSString('"))'); out.WriteLn;
out.WriteTab; out.WriteSString("END New"); WriteBSTR(sc, out);
IF WinOleAut.IMPLTYPEFLAG_FDEFAULT * flags = {}THEN
out.WriteChar("_"); WriteBSTR(si, out)
END;
out.WriteChar(";"); out.WriteLn; out.WriteLn;
WinOleAut.SysFreeString(sc); WinOleAut.SysFreeString(si)
END
END;
iinfo.ReleaseTypeAttr(iattr)
END;
INC(i)
END;
tinfo.ReleaseTypeAttr(attr)
END
END ShowClassGenerator;
PROCEDURE ShowProperty (VAR var: WinOleAut.PtrVARDESC; tinfo: WinOleAut.ITypeInfo; opts: SET;
VAR attr: WinOleAut.PtrTYPEATTR; tn: WinOle.BSTR; VAR out: TextMappers.Formatter);
VAR n, i: INTEGER; s, t: WinOle.BSTR; res: COM.RESULT; e: SHORTINT;
names: ARRAY 2 OF WinOle.BSTR; elem: ARRAY 1 OF WinOleAut.ELEMDESC;
BEGIN
res := tinfo.GetNames(var.memid, names[0], 1, n);
out.WriteTab; out.WriteSString("PROCEDURE ");
out.WriteSString("(this: "); WriteBSTR(tn, out); out.WriteSString(") ");
WriteBSTR(names[0], out);
out.WriteSString("* (): "); WriteType(var.elemdescVar.tdesc, tinfo, opts, out);
out.WriteString(", NEW");
IF (inAll IN opts) OR (inAuto IN opts) & ~(source IN opts) THEN
(* Something's wrong here, should choose ABSTRACT. *)
IF (outAll IN opts) OR (outAuto IN opts) & (source IN opts) THEN out.WriteString(", EXTENSIBLE") END;
out.WriteChar(";"); out.WriteLn;
ShowWrapper(elem, var.elemdescVar.tdesc, names, 0, var.memid,
WinOleAut.INVOKE_PROPERTYGET, TRUE, opts, tinfo, out);
out.WriteTab; out.WriteSString("END ");
WriteBSTR(names[0], out);
ELSE
out.WriteString(", ABSTRACT")
END;
out.WriteChar(";"); out.WriteLn; out.WriteLn;
IF ~ODD(var.wVarFlags DIV WinOleAut.VARFLAG_FREADONLY) THEN
out.WriteTab; out.WriteSString("PROCEDURE ");
out.WriteSString("(this: "); WriteBSTR(tn, out); out.WriteSString(") PUT");
WriteBSTR(names[0], out);
out.WriteSString("* (val: ");
IF var.elemdescVar.tdesc.vt = WinOle.VT_BSTR THEN out.WriteSString("ARRAY OF CHAR")
ELSE WriteType(var.elemdescVar.tdesc, tinfo, opts, out)
END;
out.WriteString("), NEW");
IF (inAll IN opts) OR (inAuto IN opts) & ~(source IN opts) THEN
IF (outAll IN opts) OR (outAuto IN opts) & (source IN opts) THEN out.WriteString(", EXTENSIBLE") END;
out.WriteChar(";"); out.WriteLn;
elem[0] := var.elemdescVar;
names[1] := WinOleAut.SysAllocString("val");
ShowWrapper(elem, var.elemdescVar.tdesc, names, 1, var.memid,
WinOleAut.INVOKE_PROPERTYPUT, FALSE, opts, tinfo, out);
WinOleAut.SysFreeString(names[1]);
out.WriteTab; out.WriteSString("END PUT");
WriteBSTR(names[0], out);
ELSE
out.WriteString(", ABSTRACT")
END;
out.WriteChar(";"); out.WriteLn; out.WriteLn;
END;
WinOleAut.SysFreeString(names[0]);
END ShowProperty;
PROCEDURE ShowFunc (VAR func: WinOleAut.PtrFUNCDESC; tinfo: WinOleAut.ITypeInfo; VAR attr: WinOleAut.PtrTYPEATTR;
tn: WinOle.BSTR; opts: SET; VAR out: TextMappers.Formatter);
VAR n, i: INTEGER; names: ARRAY 64 OF WinOle.BSTR; s, t: WinOle.BSTR; res: COM.RESULT; e: SHORTINT;
retTyp: WinOleAut.TYPEDESC; ti: WinOleAut.ITypeInfo;
BEGIN
res := tinfo.GetNames(func.memid, names[0], LEN(names), n);
IF (wrapper IN opts) & ((func.memid = WinOleAut.DISPID_NEWENUM)
OR (names[0]^ = "_NewEnum") & (func.cParams = 0)
& ((func.elemdescFunc.tdesc.vt = WinOle.VT_UNKNOWN)
OR (func.elemdescFunc.tdesc.vt = WinOle.VT_VARIANT))) THEN
(*
IF names[0]^ = "_NewEnum" THEN names[0]^ := "NewEnum" END;
*)
retTyp.vt := enumerator
ELSE
retTyp := func.elemdescFunc.tdesc
END;
IF ~(wrapper IN opts) OR ~ODD(func.wFuncFlags DIV WinOleAut.FUNCFLAG_FRESTRICTED)
OR (retTyp.vt = enumerator) THEN
(*
IF ~(wrapper IN opts) OR (names[0]^ # "QueryInterface") & (names[0]^ # "AddRef") & (names[0]^ # "Release")
& (names[0]^ # "GetTypeInfoCount") & (names[0]^ # "GetTypeInfo")
& (names[0]^ # "GetIDsOfNames") & (names[0]^ # "Invoke") THEN
*)
out.WriteTab; out.WriteSString("PROCEDURE ");
IF ~(wrapper IN opts) & (func.callconv # WinOleAut.CC_STDCALL) THEN
out.WriteChar("[");
IF func.callconv = WinOleAut.CC_CDECL THEN out.WriteSString("ccall")
ELSIF func.callconv = WinOleAut.CC_PASCAL THEN out.WriteSString("pascal")
ELSIF func.callconv = WinOleAut.CC_MACPASCAL THEN out.WriteSString("macpascal")
ELSIF func.callconv = WinOleAut.CC_SYSCALL THEN out.WriteSString("syscall")
ELSIF func.callconv = WinOleAut.CC_MPWCDECL THEN out.WriteSString("mpwccall")
ELSIF func.callconv = WinOleAut.CC_MPWPASCAL THEN out.WriteSString("mpwpascal")
ELSE HALT(100)
END;
out.WriteSString("] ")
END;
IF (func.funckind = WinOleAut.FUNC_VIRTUAL)
OR (func.funckind = WinOleAut.FUNC_PUREVIRTUAL)
OR (func.funckind = WinOleAut.FUNC_DISPATCH) THEN
out.WriteSString("(this: ");
WriteBSTR(tn, out); out.WriteSString(") ")
END;
IF func.invkind = WinOleAut.INVOKE_PROPERTYPUT THEN out.WriteSString("PUT")
ELSIF func.invkind = WinOleAut.INVOKE_PROPERTYPUTREF THEN out.WriteSString("PUTREF")
END;
WriteBSTR(names[0], out); out.WriteChar("*");
IF func.funckind = WinOleAut.FUNC_STATIC THEN
res := tinfo.GetDllEntry(func.memid, func.invkind, s, t, e);
IF res >= 0 THEN
out.WriteSString(" [");
IF s # NIL THEN
out.WriteChar('"'); WriteBSTR(s, out); out.WriteSString('", '); WinOleAut.SysFreeString(s)
END;
IF t # NIL THEN out.WriteChar('"'); WriteBSTR(t, out); out.WriteChar('"'); WinOleAut.SysFreeString(t)
ELSE out.WriteChar('"'); out.WriteInt(e); out.WriteChar('"')
END;
out.WriteChar("]")
END
END;
out.WriteSString(" (");
WHILE n <= func.cParams DO
IF n <= 9 THEN
names[n] := WinOleAut.SysAllocString("p0");
names[n][1] := SHORT(CHR(n + ORD("0")))
ELSE
names[n] := WinOleAut.SysAllocString("p00");
names[n][1] := SHORT(CHR(n DIV 10 + ORD("0")));
names[n][2] := SHORT(CHR(n MOD 10 + ORD("0")))
END;
INC(n)
END;
(*
(* correct parameter name - return type conflict *)
IF (n > 1) & (retTyp.vt = WinOle.VT_PTR) & (retTyp.u.lptdesc.vt = WinOle.VT_USERDEFINED) THEN
res := tinfo.GetRefTypeInfo(retTyp.u.lptdesc.u.hreftype, ti);
IF res >= 0 THEN
res := ti.GetDocumentation(-1, s, NIL, NIL, NIL);
IF s # NIL THEN
IF names[1]^ = s^ THEN
IF names[1, 0] < "a" THEN names[1, 0] := CHR(ORD(names[1, 0]) + 32)
ELSE names[1, 0] := CHR(ORD(names[1, 0]) - 32)
END
END;
WinOleAut.SysFreeString(s)
END
END
END;
*)
i := 0;
WHILE i < func.cParams DO
IF i > 0 THEN out.WriteSString("; ") END;
IF i = func.cParams - ABS(func.cParamsOpt) THEN out.WriteSString("(* optional *) ") END;
ShowParam(func.lprgelemdescParam[i], names[i + 1], tinfo, opts, out);
INC(i)
END;
out.WriteChar(")");
IF retTyp.vt # WinOle.VT_VOID THEN
out.WriteSString(": "); WriteType(retTyp, tinfo, opts, out)
END;
IF (names[0]^ # "Date") & (names[0]^ # "Cy") & (names[0]^ # "Int") THEN
out.WriteString(", NEW")
END;
IF (inAll IN opts) OR (inAuto IN opts) & ~(source IN opts) THEN
IF (outAll IN opts) OR (outAuto IN opts) & (source IN opts) THEN out.WriteString(", EXTENSIBLE") END
ELSE
out.WriteString(", ABSTRACT")
END;
out.WriteChar(";"); out.WriteLn;
res := tinfo.GetDocumentation(func.memid, NIL, s, NIL, NIL);
IF (s # NIL) OR (browse IN opts) THEN
out.WriteTab; out.WriteTab; out.WriteSString("(* ");
IF s # NIL THEN
WriteBSTR(s, out);
IF browse IN opts THEN out.WriteSString(", ") END;
WinOleAut.SysFreeString(s)
END;
IF browse IN opts THEN
out.WriteSString("id: "); out.WriteIntForm(func.memid, TextMappers.hexadecimal, 8, "0", FALSE);
IF func.memid = attr.memidConstructor THEN out.WriteSString(", contructor") END;
IF func.memid = attr.memidDestructor THEN out.WriteSString(", destructor") END;
IF func.funckind = WinOleAut.FUNC_DISPATCH THEN out.WriteSString(", dispatch") END;
IF func.invkind = WinOleAut.INVOKE_PROPERTYGET THEN out.WriteSString(", get")
ELSIF func.invkind = WinOleAut.INVOKE_PROPERTYPUT THEN out.WriteSString(", put")
ELSIF func.invkind = WinOleAut.INVOKE_PROPERTYPUTREF THEN out.WriteSString(", putref")
END;
IF ODD(func.wFuncFlags DIV WinOleAut.FUNCFLAG_FRESTRICTED) THEN
out.WriteSString(", restricted")
END;
IF ODD(func.wFuncFlags DIV WinOleAut.FUNCFLAG_FSOURCE) THEN
out.WriteSString(", source")
END;
IF ODD(func.wFuncFlags DIV WinOleAut.FUNCFLAG_FBINDABLE) THEN
out.WriteSString(", bindable")
END;
IF ODD(func.wFuncFlags DIV WinOleAut.FUNCFLAG_FREQUESTEDIT) THEN
out.WriteSString(", request")
END;
IF ODD(func.wFuncFlags DIV WinOleAut.FUNCFLAG_FDISPLAYBIND) THEN
out.WriteSString(", display")
END;
IF ODD(func.wFuncFlags DIV WinOleAut.FUNCFLAG_FDEFAULTBIND) THEN
out.WriteSString(", default")
END;
IF ODD(func.wFuncFlags DIV WinOleAut.FUNCFLAG_FHIDDEN) THEN
out.WriteSString(", hidden")
END;
IF (func.funckind = WinOleAut.FUNC_PUREVIRTUAL)
OR (func.funckind = WinOleAut.FUNC_VIRTUAL)
THEN
out.WriteSString(", offset: "); out.WriteInt(func.oVft)
END
END;
out.WriteSString(" *)"); out.WriteLn
END;
res := tinfo.GetMops(func.memid, s);
IF s # NIL THEN
out.WriteTab; out.WriteTab; out.WriteSString("(* mops: "); WriteBSTR(s, out);
out.WriteSString(" *)"); out.WriteLn; WinOleAut.SysFreeString(s)
END;
IF func.cScodes > 0 THEN
out.WriteTab; out.WriteTab; out.WriteSString("(* scodes:"); i := 0;
WHILE i < func.cScodes DO
out.WriteChar(" "); out.WriteIntForm(func.lprgscode[i], TextMappers.hexadecimal, 9, "0", TRUE); INC(i)
END;
out.WriteSString(" *)"); out.WriteLn
END;
IF (inAll IN opts) OR (inAuto IN opts) & ~(source IN opts) THEN
IF wrapper IN opts THEN
ShowWrapper(func.lprgelemdescParam^, retTyp, names, func.cParams,
func.memid, func.invkind, retTyp.vt # WinOle.VT_VOID, opts, tinfo, out)
END;
out.WriteTab; out.WriteSString("END ");
IF func.invkind = WinOleAut.INVOKE_PROPERTYPUT THEN out.WriteSString("PUT")
ELSIF func.invkind = WinOleAut.INVOKE_PROPERTYPUTREF THEN out.WriteSString("PUTREF")
END;
WriteBSTR(names[0], out); out.WriteChar(";"); out.WriteLn
END;
out.WriteLn
END;
i := 0;
WHILE i < n DO WinOleAut.SysFreeString(names[i]); INC(i) END
END ShowFunc;
PROCEDURE ShowConst (tinfo: WinOleAut.ITypeInfo; opts: SET; VAR out: TextMappers.Formatter);
VAR res: COM.RESULT; attr: WinOleAut.PtrTYPEATTR; var: WinOleAut.PtrVARDESC;
i: INTEGER; s, t: WinOle.BSTR; used: BOOLEAN;
BEGIN
res := tinfo.GetTypeAttr(attr); ASSERT(res >= 0, 100);
i := 0; used := FALSE;
WHILE i < attr.cVars DO
res := tinfo.GetVarDesc(i, var); ASSERT(res >= 0, 101);
IF var.varkind = WinOleAut.VAR_CONST THEN
IF ~used THEN
out.WriteTab; out.WriteTab; out.WriteSString("(* ");
res := tinfo.GetDocumentation(-1, s, t, NIL, NIL);
IF s # NIL THEN WriteBSTR(s, out); WinOleAut.SysFreeString(s) END;
IF t # NIL THEN out.WriteSString(": "); WriteBSTR(t, out); WinOleAut.SysFreeString(t) END;
WriteTypeFlags(attr.wTypeFlags, out);
out.WriteSString(" *)"); out.WriteLn; used := TRUE
END;
ShowVar(var, tinfo, opts, out)
END;
tinfo.ReleaseVarDesc(var);
INC(i)
END;
tinfo.ReleaseTypeAttr(attr)
END ShowConst;
PROCEDURE ShowStatic (tinfo: WinOleAut.ITypeInfo; opts: SET; VAR out: TextMappers.Formatter);
VAR res: COM.RESULT; attr: WinOleAut.PtrTYPEATTR; var: WinOleAut.PtrVARDESC;
i: INTEGER; s, t: WinOle.BSTR; used: BOOLEAN;
BEGIN
res := tinfo.GetTypeAttr(attr); ASSERT(res >= 0, 100);
i := 0; used := FALSE;
WHILE i < attr.cVars DO
res := tinfo.GetVarDesc(i, var); ASSERT(res >= 0, 101);
IF var.varkind # WinOleAut.VAR_CONST THEN
IF ~used THEN
out.WriteTab; out.WriteTab; out.WriteSString("(* ");
res := tinfo.GetDocumentation(-1, s, t, NIL, NIL);
IF s # NIL THEN WriteBSTR(s, out); WinOleAut.SysFreeString(s) END;
IF t # NIL THEN out.WriteSString(": "); WriteBSTR(t, out); WinOleAut.SysFreeString(t) END;
WriteTypeFlags(attr.wTypeFlags, out);
out.WriteSString(" *)"); out.WriteLn; used := TRUE
END;
ShowVar(var, tinfo, opts, out)
END;
tinfo.ReleaseVarDesc(var);
INC(i)
END;
tinfo.ReleaseTypeAttr(attr)
END ShowStatic;
PROCEDURE ShowType (tinfo: WinOleAut.ITypeInfo; opts: SET; VAR out: TextMappers.Formatter);
VAR res: COM.RESULT; attr: WinOleAut.PtrTYPEATTR; var: WinOleAut.PtrVARDESC; flags: SET;
i, vt: INTEGER; func: WinOleAut.PtrFUNCDESC; s, s1: WinOle.BSTR; iinfo: WinOleAut.ITypeInfo;
t: WinOleAut.HREFTYPE;
BEGIN
res := tinfo.GetDocumentation(-1, s, s1, NIL, NIL);
(* !!! *)
IF s1 # NIL THEN
out.WriteTab; out.WriteTab; out.WriteSString("(* "); WriteBSTR(s1, out);
out.WriteSString(" *)"); out.WriteLn; WinOleAut.SysFreeString(s1)
END;
res := tinfo.GetMops(-1, s1);
IF s1 # NIL THEN
out.WriteTab; out.WriteTab; out.WriteSString("(* Mops: "); WriteBSTR(s1, out);
out.WriteSString(" *)"); out.WriteLn; WinOleAut.SysFreeString(s1)
END;
res := tinfo.GetTypeAttr(attr); ASSERT(res >= 0, 100);
IF attr.typekind = WinOleAut.TKIND_COCLASS THEN (* !!! *)
IF wrapper IN opts THEN
GetInfoType(tinfo, vt, iinfo);
IF vt = WinOle.VT_DISPATCH THEN
res := iinfo.GetDocumentation(-1, s1, NIL, NIL, NIL); ASSERT(res >= 0, 104);
IF s1 # NIL THEN
out.WriteTab; out.WriteTab;
WriteBSTR(s, out); out.WriteSString("* = "); WriteBSTR(s1, out);
out.WriteChar(";"); out.WriteLn;
WinOleAut.SysFreeString(s1)
END
END
END
ELSE
out.WriteTab; out.WriteTab;
WriteBSTR(s, out); out.WriteSString("* = ");
IF attr.typekind = WinOleAut.TKIND_ALIAS THEN
WriteType(attr.tdescAlias, tinfo, opts, out)
ELSIF attr.typekind = WinOleAut.TKIND_ENUM THEN
out.WriteString("INTEGER");
ELSE
out.WriteSString("POINTER TO ");
IF wrapper IN opts THEN
IF (inAll IN opts) OR (inAuto IN opts) & ~(source IN opts) THEN
IF (outAll IN opts) OR (outAuto IN opts) & (source IN opts) THEN
out.WriteString("EXTENSIBLE ")
END
ELSE
out.WriteString("ABSTRACT ")
END;
out.WriteSString("RECORD ")
ELSE
out.WriteSString("RECORD ");
IF (attr.typekind = WinOleAut.TKIND_INTERFACE) OR (attr.typekind = WinOleAut.TKIND_DISPATCH)
THEN
out.WriteSString('["'); WriteGuid(attr.guid, out); out.WriteSString('"] ')
ELSIF attr.typekind = WinOleAut.TKIND_UNION THEN out.WriteSString("[union] ")
ELSIF attr.cbAlignment = 1 THEN out.WriteSString("[noalign] ")
ELSIF attr.cbAlignment = 2 THEN out.WriteSString("[align2] ")
ELSIF attr.cbAlignment = 8 THEN out.WriteSString("[align8] ")
ELSE out.WriteSString("[untagged] ")
END
END;
IF attr.cImplTypes > 0 THEN
ASSERT(attr.cImplTypes = 1, 101);
res := tinfo.GetRefTypeOfImplType(0, t); ASSERT(res >= 0, 102);
out.WriteChar("(");
IF (wrapper IN opts) & ((outAll IN opts) OR (outAuto IN opts) & (source IN opts)) THEN
out.WriteString("CtlT.OutObject")
ELSE
WriteHandleName(t, tinfo, opts, out)
END;
out.WriteSString(") ")
END;
IF ~(wrapper IN opts) THEN
IF attr.typekind = WinOleAut.TKIND_DISPATCH THEN
out.WriteSString("(* dispatch")
ELSE
out.WriteSString("(* size: "); out.WriteInt(attr.cbSizeInstance);
out.WriteSString(", vtbl size: "); out.WriteInt(attr.cbSizeVft)
END;
WriteTypeFlags(attr.wTypeFlags, out);
out.WriteSString(" *)"); out.WriteLn;
i := 0;
WHILE i < attr.cVars DO
res := tinfo.GetVarDesc(i, var); ASSERT(res >= 0, 103);
IF var.varkind # WinOleAut.VAR_CONST THEN
ShowVar(var, tinfo, opts, out)
END;
tinfo.ReleaseVarDesc(var);
INC(i)
END;
out.WriteTab; out.WriteTab
END;
out.WriteSString("END")
END;
out.WriteChar(";"); out.WriteLn
END;
WinOleAut.SysFreeString(s);
tinfo.ReleaseTypeAttr(attr)
END ShowType;
PROCEDURE ShowInvokeCall (func: WinOleAut.PtrFUNCDESC; tinfo: WinOleAut.ITypeInfo;
opts: SET; VAR out: TextMappers.Formatter);
VAR p, n: INTEGER; res: COM.RESULT; name: WinOle.BSTR; type: WinOleAut.TYPEDESC; kind: SHORTINT;
BEGIN
res := tinfo.GetNames(func.memid, name, 1, n);
IF func.elemdescFunc.tdesc.vt # WinOle.VT_VOID THEN (* function *)
out.WriteSString("CtlC.");
IF (wrapper IN opts) & ((func.memid = WinOleAut.DISPID_NEWENUM)
OR (name^ = "_NewEnum") & (func.cParams = 0)
& ((func.elemdescFunc.tdesc.vt = WinOle.VT_UNKNOWN)
OR (func.elemdescFunc.tdesc.vt = WinOle.VT_VARIANT))) THEN out.WriteString("Enum")
ELSE WriteShortType(func.elemdescFunc.tdesc, tinfo, out)
END;
out.WriteSString("Var(")
END;
out.WriteSString("this.");
IF ODD(func.invkind DIV WinOleAut.INVOKE_PROPERTYPUT) THEN out.WriteSString("PUT")
ELSIF ODD(func.invkind DIV WinOleAut.INVOKE_PROPERTYPUTREF) THEN out.WriteSString("PUTREF")
END;
WriteBSTR(name, out); out.WriteChar("(");
WinOleAut.SysFreeString(name);
p := 0;
WHILE p < func.cParams DO
IF p > 0 THEN out.WriteSString(", ") END;
GetParamType(func.lprgelemdescParam[p], tinfo, opts, type, kind);
IF kind = value THEN WriteTypeConv(type, tinfo, par, func.cParams - 1 - p, out)
ELSE WriteTypeConv(type, tinfo, refpar, func.cParams - 1 - p, out)
END;
INC(p)
END;
out.WriteChar(")");
IF func.elemdescFunc.tdesc.vt # WinOle.VT_VOID THEN out.WriteSString(", ret)") END;
p := 0;
WHILE p < func.cParams DO
GetParamType(func.lprgelemdescParam[p], tinfo, opts, type, kind);
IF (kind # value) & IsSpecial(type, tinfo) THEN
out.WriteSString("; CtlC.Ret");
WriteShortType(type, tinfo, out);
out.WriteString("(par["); out.WriteInt(func.cParams - 1 - p); out.WriteString("])")
END;
INC(p)
END;
END ShowInvokeCall;
PROCEDURE ShowInvoke (tinfo: WinOleAut.ITypeInfo; attr: WinOleAut.PtrTYPEATTR;
tn: WinOle.BSTR; opts: SET; VAR out: TextMappers.Formatter);
VAR func, pfunc: WinOleAut.PtrFUNCDESC; res: COM.RESULT; i, j, n: INTEGER;
name: WinOle.BSTR; var: WinOleAut.PtrVARDESC; ifUsed: BOOLEAN;
BEGIN
out.WriteTab; out.WriteSString("PROCEDURE (this: "); WriteBSTR(tn, out);
out.WriteSString(") Invoke* (id, n: INTEGER; VAR par: CtlT.ParList; VAR ret: CtlT.Variant);");
out.WriteLn; out.WriteTab; out.WriteSString("BEGIN"); out.WriteLn;
out.WriteTab; out.WriteTab; out.WriteSString("CASE id OF"); out.WriteLn;
i := 0;
WHILE i < attr.cVars DO (* property access *)
res := tinfo.GetVarDesc(i, var); ASSERT(res >= 0, 101);
IF var.varkind # WinOleAut.VAR_CONST THEN
res := tinfo.GetNames(var.memid, name, 1, n);
out.WriteTab; out.WriteTab; out.WriteSString("| "); out.WriteInt(var.memid);
out.WriteSString(": ");
IF ~ODD(var.wVarFlags DIV WinOleAut.VARFLAG_FREADONLY) THEN
out.WriteSString("IF n = -1 THEN this.PUT");
WriteBSTR(name, out); out.WriteChar("(");
WriteTypeConv(var.elemdescVar.tdesc, tinfo, par, 0, out);
out.WriteChar(")"); out.WriteLn;
out.WriteTab; out.WriteTab; out.WriteTab; out.WriteSString("ELSE ")
END;
out.WriteSString("ASSERT(n = 0, 11); ");
out.WriteSString("CtlC."); WriteShortType(var.elemdescVar.tdesc, tinfo, out);
out.WriteSString("Var(this."); WriteBSTR(name, out);
out.WriteSString("(), ret)"); out.WriteLn;
IF ~ODD(var.wVarFlags DIV WinOleAut.VARFLAG_FREADONLY) THEN
out.WriteTab; out.WriteTab; out.WriteTab; out.WriteSString("END"); out.WriteLn
END;
WinOleAut.SysFreeString(name)
END;
tinfo.ReleaseVarDesc(var);
INC(i)
END;
i := 0;
WHILE i < attr.cFuncs DO (* method access *)
res := tinfo.GetFuncDesc(i, func); ASSERT(res >= 0, 102);
IF ~ODD(func.wFuncFlags DIV WinOleAut.FUNCFLAG_FRESTRICTED)
& (func.invkind < WinOleAut.INVOKE_PROPERTYPUT) THEN
out.WriteTab; out.WriteTab; out.WriteSString("| "); out.WriteInt(func.memid);
out.WriteSString(": "); ifUsed := FALSE;
IF func.invkind = WinOleAut.INVOKE_PROPERTYGET THEN
j := 0;
WHILE j < attr.cFuncs DO
res := tinfo.GetFuncDesc(j, pfunc); ASSERT(res >= 0, 103);
IF (pfunc.memid = func.memid)
& ~ODD(pfunc.wFuncFlags DIV WinOleAut.FUNCFLAG_FRESTRICTED)
& (pfunc.invkind >= WinOleAut.INVOKE_PROPERTYPUT) THEN
IF ifUsed THEN out.WriteTab; out.WriteTab; out.WriteTab; out.WriteSString("ELS") END;
out.WriteSString("IF n = -");
IF ODD(pfunc.invkind DIV WinOleAut.INVOKE_PROPERTYPUT) THEN
out.WriteInt(pfunc.cParams)
ELSE out.WriteInt(pfunc.cParams + 100)
END;
out.WriteSString(" THEN ");
ShowInvokeCall(pfunc, tinfo, opts, out); out.WriteLn;
ifUsed := TRUE
END;
tinfo.ReleaseFuncDesc(pfunc);
INC(j)
END
END;
IF ifUsed THEN out.WriteTab; out.WriteTab; out.WriteTab; out.WriteSString("ELSE ") END;
out.WriteSString("ASSERT(n = "); out.WriteInt(func.cParams); out.WriteSString(", 11); ");
ShowInvokeCall(func, tinfo, opts, out); out.WriteLn;
IF ifUsed THEN out.WriteTab; out.WriteTab; out.WriteTab; out.WriteSString("END"); out.WriteLn END
END;
tinfo.ReleaseFuncDesc(func);
INC(i)
END;
out.WriteTab; out.WriteTab; out.WriteSString("END"); out.WriteLn;
out.WriteTab; out.WriteSString("END Invoke;"); out.WriteLn; out.WriteLn;
(* GetIID *)
out.WriteTab; out.WriteSString("PROCEDURE (this: "); WriteBSTR(tn, out);
out.WriteSString(") GetIID* (OUT iid: CtlT.GUID);"); out.WriteLn;
out.WriteTab; out.WriteSString("BEGIN"); out.WriteLn;
out.WriteTab; out.WriteTab; out.WriteSString('iid := "');
WriteGuid(attr.guid, out); out.WriteChar('"'); out.WriteLn;
out.WriteTab; out.WriteSString("END GetIID;"); out.WriteLn; out.WriteLn
END ShowInvoke;
PROCEDURE ShowProcs (tinfo: WinOleAut.ITypeInfo; opts: SET; VAR out: TextMappers.Formatter);
VAR res: COM.RESULT; attr: WinOleAut.PtrTYPEATTR; s, t: WinOle.BSTR;
i: INTEGER; func: WinOleAut.PtrFUNCDESC; var: WinOleAut.PtrVARDESC;
BEGIN
res := tinfo.GetTypeAttr(attr); ASSERT(res >= 0, 100);
IF (wrapper IN opts) OR (attr.cFuncs > 0) THEN
res := tinfo.GetDocumentation(-1, s, t, NIL, NIL);
(* !!! *)
out.WriteLn; out.WriteTab;
out.WriteSString("(* ---------- ");
IF s # NIL THEN WriteBSTR(s, out) END;
IF t # NIL THEN out.WriteSString(": "); WriteBSTR(t, out) END;
WriteTypeFlags(attr.wTypeFlags, out); out.WriteSString(" ---------- *)");
out.WriteLn; out.WriteLn;
IF wrapper IN opts THEN
i := 0;
WHILE i < attr.cVars DO
res := tinfo.GetVarDesc(i, var); ASSERT(res >= 0, 101);
IF var.varkind # WinOleAut.VAR_CONST THEN
ShowProperty(var, tinfo, opts, attr, s, out)
END;
tinfo.ReleaseVarDesc(var);
INC(i)
END
END;
i := 0;
WHILE i < attr.cFuncs DO
res := tinfo.GetFuncDesc(i, func); ASSERT(res >= 0, 102);
ShowFunc(func, tinfo, attr, s, opts, out);
tinfo.ReleaseFuncDesc(func);
INC(i)
END;
IF (wrapper IN opts) & ((outAll IN opts) OR (outAuto IN opts) & (source IN opts)) THEN
ShowInvoke(tinfo, attr, s, opts, out)
END;
WinOleAut.SysFreeString(s);
WinOleAut.SysFreeString(t)
END;
tinfo.ReleaseTypeAttr(attr)
END ShowProcs;
PROCEDURE ShowClass (tinfo: WinOleAut.ITypeInfo; VAR out: TextMappers.Formatter);
VAR res: COM.RESULT; attr: WinOleAut.PtrTYPEATTR; flags: SET;
i: INTEGER; s, s1: WinOle.BSTR; t: WinOleAut.HREFTYPE;
BEGIN
out.WriteTab; out.WriteSString("(* CLASS ");
res := tinfo.GetDocumentation(-1, s, s1, NIL, NIL);
IF s # NIL THEN WriteBSTR(s, out) END;
IF s1 # NIL THEN out.WriteSString(": "); WriteBSTR(s1, out); WinOleAut.SysFreeString(s1) END;
res := tinfo.GetTypeAttr(attr); ASSERT(res >= 0, 100);
out.WriteLn; out.WriteTab; out.WriteTab;
WriteGuid(attr.guid, out); WriteTypeFlags(attr.wTypeFlags, out);
out.WriteLn;
i := 0;
WHILE i < attr.cImplTypes DO
res := tinfo.GetImplTypeFlags(i, flags);
res := tinfo.GetRefTypeOfImplType(i, t); ASSERT(res >= 0, 103);
out.WriteTab; out.WriteTab; out.WriteSString("INTERFACE ");
WriteHandleName(t, tinfo, {}, out);
out.WriteTab; out.WriteSString("(* ");
IF WinOleAut.IMPLTYPEFLAG_FDEFAULT * flags # {} THEN out.WriteSString("default ") END;
IF WinOleAut.IMPLTYPEFLAG_FDEFAULTVTABLE * flags # {} THEN
out.WriteSString("defaultVtable ")
END;
IF WinOleAut.IMPLTYPEFLAG_FRESTRICTED * flags # {} THEN out.WriteSString("restricted ") END;
IF WinOleAut.IMPLTYPEFLAG_FSOURCE * flags # {} THEN out.WriteSString("source ") END;
out.WriteSString("*)"); out.WriteLn; INC(i)
END;
out.WriteTab; out.WriteSString("END *)"); out.WriteLn; out.WriteLn;
WinOleAut.SysFreeString(s);
tinfo.ReleaseTypeAttr(attr)
END ShowClass;
PROCEDURE IsSource (tlib: WinOleAut.ITypeLib; tinfo: WinOleAut.ITypeInfo): BOOLEAN;
VAR attr, ca, ta: WinOleAut.PtrTYPEATTR; ci, ti: WinOleAut.ITypeInfo; i, j, n: INTEGER;
res: COM.RESULT; kind: WinOleAut.TYPEKIND; t: WinOleAut.HREFTYPE; flags: SET;
BEGIN
res := tinfo.GetTypeAttr(attr); ASSERT(res >= 0, 100);
i := 0; n := tlib.GetTypeInfoCount();
WHILE i < n DO
res := tlib.GetTypeInfoType(i, kind); ASSERT(res >= 0, 101);
IF kind = WinOleAut.TKIND_COCLASS THEN
res := tlib.GetTypeInfo(i, ci); ASSERT(res >= 0, 102);
res := ci.GetTypeAttr(ca); ASSERT(res >= 0, 103);
j := 0;
WHILE j < ca.cImplTypes DO
res := ci.GetImplTypeFlags(j, flags); ASSERT(res >= 0, 104);
IF WinOleAut.IMPLTYPEFLAG_FSOURCE * flags # {} THEN
res := ci.GetRefTypeOfImplType(j, t); ASSERT(res >= 0, 105);
res := ci.GetRefTypeInfo(t, ti); ASSERT(res >= 0, 106);
res := ti.GetTypeAttr(ta); ASSERT(res >= 0, 107);
IF ta.guid = attr.guid THEN i := n; j := ca.cImplTypes END;
ti.ReleaseTypeAttr(ta)
END;
INC(j)
END;
ci.ReleaseTypeAttr(ca)
END;
INC(i)
END;
tinfo.ReleaseTypeAttr(attr);
RETURN i > n
END IsSource;
PROCEDURE ShowLibrary (
tlib: WinOleAut.ITypeLib; name: ARRAY OF CHAR; opts: SET; VAR out: TextMappers.Formatter
);
VAR s1, s2, s3: WinOle.BSTR; str: ARRAY 256 OF SHORTCHAR; i, n, impPos: INTEGER; res: COM.RESULT;
attr: WinOleAut.PtrTLIBATTR; tinfo, ti: WinOleAut.ITypeInfo; kind: WinOleAut.TYPEKIND;
t: WinOleAut.HREFTYPE;
BEGIN
res := tlib.GetDocumentation(-1, s1, s2, n, s3); ASSERT(res >= 0, 100);
modules[0] := s1$; WinOleAut.SysFreeString(s1);
modules[1] := "CtlT"; modules[2] := "CtlC"; noMod := 3;
IF wrapper IN opts THEN modules[0] := "Ctl" + modules[0] END;
out.WriteSString("MODULE ");
out.WriteString(name);
IF interface IN opts THEN out.WriteSString(' [""]') END;
out.WriteChar(";"); out.WriteLn; out.WriteTab; out.WriteSString("(* ");
IF s2 # NIL THEN WriteBSTR(s2, out); WinOleAut.SysFreeString(s2) END;
out.WriteSString(", help: ");
IF s3 # NIL THEN WriteBSTR(s3, out); WinOleAut.SysFreeString(s3) END;
out.WriteSString(", id: "); out.WriteInt(n); out.WriteSString(" *)"); out.WriteLn;
res := tlib.GetLibAttr(attr); ASSERT(res >= 0, 102);
out.WriteTab; out.WriteSString("(* guid: "); WriteGuid(attr.guid, out);
out.WriteSString(", lcid: "); out.WriteInt(attr.lcid);
out.WriteSString(", syskind: ");
IF attr.syskind = WinOleAut.SYS_WIN16 THEN out.WriteSString("win16")
ELSIF attr.syskind = WinOleAut.SYS_WIN32 THEN out.WriteSString("win32")
ELSIF attr.syskind = WinOleAut.SYS_MAC THEN out.WriteSString("mac")
ELSE out.WriteInt(attr.syskind)
END;
out.WriteSString(", version: ");
out.WriteInt(attr.wMajorVerNum);
out.WriteChar(".");
out.WriteInt(attr.wMinorVerNum);
IF ODD(attr.wLibFlags DIV WinOleAut.LIBFLAG_FRESTRICTED) THEN out.WriteSString(", restricted") END;
IF ODD(attr.wLibFlags DIV WinOleAut.LIBFLAG_FCONTROL) THEN out.WriteSString(", control") END;
IF ODD(attr.wLibFlags DIV WinOleAut.LIBFLAG_FHIDDEN) THEN out.WriteSString(", hidden") END;
out.WriteSString(" *)"); out.WriteLn; out.WriteLn;
impPos := out.Pos();
tlib.ReleaseTLibAttr(attr);
n := tlib.GetTypeInfoCount();
out.WriteTab; out.WriteSString("CONST"); out.WriteLn; i := 0;
WHILE i < n DO
res := tlib.GetTypeInfo(i, tinfo); ASSERT(res >= 0, 103);
ShowConst(tinfo, opts, out);
INC(i)
END;
out.WriteLn; out.WriteLn;
out.WriteTab; out.WriteSString("TYPE"); out.WriteLn; i := 0;
WHILE i < n DO
res := tlib.GetTypeInfoType(i, kind); ASSERT(res >= 0, 104);
IF (kind = WinOleAut.TKIND_ALIAS) OR (kind = WinOleAut.TKIND_ENUM)
OR ~(wrapper IN opts) & (kind IN {WinOleAut.TKIND_RECORD, WinOleAut.TKIND_INTERFACE,
WinOleAut.TKIND_ALIAS, WinOleAut.TKIND_UNION})
OR ~(interface IN opts) & (kind IN {WinOleAut.TKIND_DISPATCH, WinOleAut.TKIND_COCLASS})
THEN
res := tlib.GetTypeInfo(i, tinfo); ASSERT(res >= 0, 105);
IF (wrapper IN opts) & IsSource(tlib, tinfo) THEN
ShowType(tinfo, opts + {source}, out)
ELSE ShowType(tinfo, opts, out)
END
END;
IF (~(wrapper IN opts)) & (kind = WinOleAut.TKIND_DISPATCH) THEN
res := tlib.GetTypeInfo(i, tinfo); ASSERT(res >= 0, 105);
res := tinfo.GetRefTypeOfImplType(-1, t);
IF res >= 0 THEN (* dual interfaced *)
res := tinfo.GetRefTypeInfo(t, ti); ASSERT(res >= 0, 106);
ShowType(ti, opts, out)
END
END;
INC(i)
END;
out.WriteLn; out.WriteLn;
IF ~(wrapper IN opts) THEN
out.WriteTab; out.WriteSString("VAR"); out.WriteLn;
i := 0;
WHILE i < n DO
res := tlib.GetTypeInfoType(i, kind); ASSERT(res >= 0, 107);
IF kind = WinOleAut.TKIND_MODULE THEN
res := tlib.GetTypeInfo(i, tinfo); ASSERT(res >= 0, 108);
ShowStatic(tinfo, opts, out)
END;
INC(i)
END;
out.WriteLn; out.WriteLn
ELSE
i := 0;
WHILE i < n DO
res := tlib.GetTypeInfoType(i, kind); ASSERT(res >= 0, 109);
IF (wrapper IN opts) & (kind = WinOleAut.TKIND_DISPATCH) THEN
res := tlib.GetTypeInfo(i, tinfo); ASSERT(res >= 0, 110);
IF (inAll IN opts) OR (inAuto IN opts) & ~IsSource(tlib, tinfo) THEN
ShowGenerator(tinfo, opts, out)
END
END;
INC(i)
END;
out.WriteLn
END;
i := 0;
WHILE i < n DO
res := tlib.GetTypeInfoType(i, kind); ASSERT(res >= 0, 109);
IF ~(wrapper IN opts) & (kind IN {WinOleAut.TKIND_MODULE, WinOleAut.TKIND_INTERFACE})
OR ~(interface IN opts) & (kind = WinOleAut.TKIND_DISPATCH) THEN
res := tlib.GetTypeInfo(i, tinfo); ASSERT(res >= 0, 110);
IF (wrapper IN opts) & IsSource(tlib, tinfo) THEN
ShowProcs(tinfo, opts + {source}, out)
ELSE ShowProcs(tinfo, opts, out)
END
END;
IF ~(wrapper IN opts) & (kind = WinOleAut.TKIND_DISPATCH) THEN
res := tlib.GetTypeInfo(i, tinfo); ASSERT(res >= 0, 110);
res := tinfo.GetRefTypeOfImplType(-1, t);
IF res >= 0 THEN (* dual interfaced *)
res := tinfo.GetRefTypeInfo(t, ti); ASSERT(res >= 0, 111);
ShowProcs(ti, opts, out)
END
END;
INC(i)
END;
out.WriteLn; i := 0;
WHILE i < n DO
res := tlib.GetTypeInfoType(i, kind); ASSERT(res >= 0, 112);
IF kind = WinOleAut.TKIND_COCLASS THEN
res := tlib.GetTypeInfo(i, tinfo); ASSERT(res >= 0, 113);
IF wrapper IN opts THEN ShowClassGenerator(tinfo, opts, out)
ELSE ShowClass(tinfo, out)
END
END;
INC(i)
END;
out.WriteSString("END ");
out.WriteString(name); out.WriteChar("."); out.WriteLn;
IF (wrapper IN opts) & (noMod > 1) THEN
out.SetPos(impPos);
out.WriteTab; out.WriteSString("IMPORT "); i := 1;
WHILE i < noMod DO
IF i > 1 THEN out.WriteSString(", ") END;
out.WriteString(modules[i]); INC(i)
END;
out.WriteChar(";"); out.WriteLn; out.WriteLn
END;
END ShowLibrary;
PROCEDURE AutomationInterface* (
fileName: ARRAY 256 OF CHAR; modName: ARRAY 64 OF CHAR
): TextModels.Model;
VAR t: TextModels.Model; out: TextMappers.Formatter; res: COM.RESULT; tlib: WinOleAut.ITypeLib;
BEGIN
t := TextModels.dir.New();
out.ConnectTo(t);
res := WinOleAut.LoadTypeLib(fileName, tlib);
IF res >= 0 THEN
ShowLibrary(tlib, modName, {wrapper, inAuto, outAuto}, out)
END;
out.ConnectTo(NIL);
RETURN t
END AutomationInterface;
PROCEDURE CustomInterface* (
fileName: ARRAY 256 OF CHAR; modName: ARRAY 64 OF CHAR
): TextModels.Model;
(* not yet tested *)
VAR t: TextModels.Model; out: TextMappers.Formatter; res: COM.RESULT; tlib: WinOleAut.ITypeLib;
BEGIN
t := TextModels.dir.New();
out.ConnectTo(t);
res := WinOleAut.LoadTypeLib(fileName, tlib);
IF res >= 0 THEN
ShowLibrary(tlib, modName, {interface}, out)
END;
out.ConnectTo(NIL);
RETURN t
END CustomInterface;
PROCEDURE Browse* (fileName: ARRAY 256 OF CHAR; modName: ARRAY 64 OF CHAR): TextModels.Model;
(* not yet tested *)
VAR t: TextModels.Model; out: TextMappers.Formatter; res: COM.RESULT; tlib: WinOleAut.ITypeLib;
BEGIN
t := TextModels.dir.New();
out.ConnectTo(t);
res := WinOleAut.LoadTypeLib(fileName, tlib);
IF res >= 0 THEN
ShowLibrary(tlib, modName, {browse}, out)
END;
out.ConnectTo(NIL);
RETURN t
END Browse;
END DevTypeLibs.
DevComInterfaceGen
DevTypeLibs