paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-19 13:59:29 +02:00
Code Issues Packages Projects Releases Wiki Activity

* change registry functions in comobj to "HKEY" because of win64 reasons. (Mantis #25515)

Browse Source 
git-svn-id: trunk@26427 -
This commit is contained in:
marco 2014-01-11 20:53:59 +00:00
parent f09374a197
commit 4804a5528b
1 changed files with 63 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

74
packages/winunits-base/src/comobj.pp
View File

@ -18,7 +18,8 @@ unit comobj;
interface
{ $define DEBUG_COM}
{$define DEBUG_COM}
{$define DEBUG_COMDISPATCH}
{$ifdef wince}
{$define DUMMY_REG}
@ -296,9 +297,9 @@ unit comobj;
function ComClassManager : TComClassManager;
procedure CreateRegKey(const Key, ValueName, Value: string; RootKey: DWord = HKEY_CLASSES_ROOT);
procedure DeleteRegKey(const Key: string; RootKey: DWord = HKEY_CLASSES_ROOT);
function GetRegStringValue(const Key, ValueName: string; RootKey: DWord = HKEY_CLASSES_ROOT): string;
procedure CreateRegKey(const Key, ValueName, Value: string; RootKey: HKey= HKEY_CLASSES_ROOT);
procedure DeleteRegKey(const Key: string; RootKey: HKey = HKEY_CLASSES_ROOT);
function GetRegStringValue(const Key, ValueName: string; RootKey: HKey = HKEY_CLASSES_ROOT): string;
type
TCoCreateInstanceExProc = function(const clsid: TCLSID; unkOuter: IUnknown; dwClsCtx: DWORD; ServerInfo: PCoServerInfo;
@ -319,6 +320,9 @@ unit comobj;
CoSuspendClassObjects : TCoSuspendClassObjectsProc = nil;
CoInitFlags : Longint = -1;
{$ifdef DEBUG_COM}
var printcom : boolean=true;
{$endif}
implementation
uses
@ -456,13 +460,14 @@ implementation
end;
{$endif wince}
procedure CreateRegKey(const Key, ValueName, Value: string; RootKey: DWord = HKEY_CLASSES_ROOT);
procedure CreateRegKey(const Key, ValueName, Value: string; RootKey: HKEY = HKEY_CLASSES_ROOT);
{$ifndef DUMMY_REG}
var
Reg: TRegistry;
{$endif}
begin
{$ifdef DEBUG_COM}
if printcom then
WriteLn('CreateRegKey: ', Key, ': ', ValueName, ': ', Value );
{$endif}
{$ifndef DUMMY_REG}
@ -484,18 +489,20 @@ implementation
end;
{$endif}
{$ifdef DEBUG_COM}
if printcom then
WriteLn('CreateRegKey exit: ', Key, ': ', ValueName, ': ', Value );
{$endif}
end;
procedure DeleteRegKey(const Key: string; RootKey: DWord = HKEY_CLASSES_ROOT);
procedure DeleteRegKey(const Key: string; RootKey: HKEY = HKEY_CLASSES_ROOT);
{$ifndef DUMMY_REG}
var
Reg: TRegistry;
{$endif}
begin
{$ifdef DEBUG_COM}
if printcom then
WriteLn('DeleteRegKey: ', Key);
{$endif}
{$ifndef DUMMY_REG}
@ -510,7 +517,7 @@ implementation
end;
function GetRegStringValue(const Key, ValueName: string; RootKey: DWord = HKEY_CLASSES_ROOT): string;
function GetRegStringValue(const Key, ValueName: string; RootKey: HKEY = HKEY_CLASSES_ROOT): string;
{$ifndef DUMMY_REG}
var
Reg: TRegistry;
@ -629,6 +636,7 @@ implementation
procedure TComClassManager.AddObjectFactory(factory: TComObjectFactory);
begin
{$ifdef DEBUG_COM}
if printcom then
WriteLn('AddObjectFactory: ', GUIDToString(factory.FClassID), ' ', factory.FClassName);
{$endif}
fClassFactoryList.Add(factory);
@ -647,6 +655,7 @@ implementation
obj: TComObjectFactory;
begin
{$ifdef DEBUG_COM}
if printcom then
WriteLn('ForEachFactory');
{$endif}
for i := 0 to fClassFactoryList.Count - 1 do
@ -664,6 +673,7 @@ implementation
i: Integer;
begin
{$ifdef DEBUG_COM}
if printcom then
WriteLn('GetFactoryFromClass: ', ComClass.ClassName);
{$endif}
for i := 0 to fClassFactoryList.Count - 1 do
@ -682,6 +692,7 @@ implementation
i: Integer;
begin
{$ifdef DEBUG_COM}
if printcom then
WriteLn('GetFactoryFromClassID: ', GUIDToString(ClassId));
{$endif}
for i := 0 to fClassFactoryList.Count - 1 do
@ -691,6 +702,7 @@ implementation
Exit();
end;
{$ifdef DEBUG_COM}
if printcom then
WriteLn('GetFactoryFromClassID not found: ', GUIDToString(ClassId));
{$endif}
Result := nil;
@ -863,6 +875,7 @@ implementation
comObject: TComObject;
begin
{$ifdef DEBUG_COM}
if printcom then
WriteLn('CreateInstance: ', GUIDToString(IID));
{$endif}
comObject := CreateComObject(UnkOuter);
@ -876,6 +889,7 @@ implementation
function TComObjectFactory.LockServer(fLock: BOOL): HResult; stdcall;
begin
{$ifdef DEBUG_COM}
if printcom then
WriteLn('LockServer: ', fLock);
{$endif}
RunError(217);
@ -886,6 +900,7 @@ implementation
function TComObjectFactory.GetLicInfo(var licInfo: TLicInfo): HResult; stdcall;
begin
{$ifdef DEBUG_COM}
if printcom then
WriteLn('GetLicInfo');
{$endif}
RunError(217);
@ -896,6 +911,7 @@ implementation
function TComObjectFactory.RequestLicKey(dwResrved: DWORD; out bstrKey: WideString): HResult; stdcall;
begin
{$ifdef DEBUG_COM}
if printcom then
WriteLn('RequestLicKey');
{$endif}
RunError(217);
@ -908,6 +924,7 @@ implementation
vObject): HResult; stdcall;
begin
{$ifdef DEBUG_COM}
if printcom then
WriteLn('CreateInstanceLic');
{$endif}
RunError(217);
@ -928,6 +945,7 @@ implementation
ThreadingModel: TThreadingModel);
begin
{$ifdef DEBUG_COM}
if printcom then
WriteLn('TComObjectFactory.Create');
{$endif}
FRefCount := 1;
@ -954,6 +972,7 @@ implementation
): TComObject;
begin
{$ifdef DEBUG_COM}
if printcom then
WriteLn('TComObjectFactory.CreateComObject');
{$endif}
Result := TComClass(FComClass).Create();
@ -963,6 +982,7 @@ implementation
procedure TComObjectFactory.RegisterClassObject;
begin
{$ifdef DEBUG_COM}
if printcom then
WriteLn('TComObjectFactory.RegisterClassObject');
{$endif}
RunError(217);
@ -1016,6 +1036,7 @@ HKCR
begin
{$ifndef DUMMY_REG}
{$ifdef DEBUG_COM}
if printcom then
WriteLn('UpdateRegistry begin');
{$endif}
if Instancing = ciInternal then Exit;
@ -1066,13 +1087,14 @@ HKCR
DeleteRegKey('CLSID\' + classidguid);
end;
{$ifdef DEBUG_COM}
if printcom then
WriteLn('UpdateRegistry end');
{$endif}
{$endif DUMMY_REG}
end;
{ $define DEBUG_COMDISPATCH}
procedure DispatchInvoke(const Dispatch: IDispatch; CallDesc: PCallDesc;
DispIDs: PDispIDList; Params: Pointer; Result: PVariant);
@ -1095,12 +1117,14 @@ HKCR
fillchar(dispparams,sizeof(dispparams),0);
try
{$ifdef DEBUG_COMDISPATCH}
if printcom then
writeln('DispatchInvoke: Got ',CallDesc^.ArgCount,' arguments NamedArgs = ',CallDesc^.NamedArgCount);
{$endif DEBUG_COMDISPATCH}
{ copy and prepare arguments }
for i:=0 to CallDesc^.ArgCount-1 do
begin
{$ifdef DEBUG_COMDISPATCH}
if printcom then
writeln('DispatchInvoke: Params = ',hexstr(Params));
{$endif DEBUG_COMDISPATCH}
{ get plain type }
@ -1119,6 +1143,7 @@ HKCR
varStrArg:
begin
{$ifdef DEBUG_COMDISPATCH}
if printcom then
writeln('Translating var ansistring argument ',PString(Params^)^);
{$endif DEBUG_COMDISPATCH}
StringMap[NextString].ComStr:=StringToOleStr(PString(Params^)^);
@ -1131,11 +1156,13 @@ HKCR
varVariant:
begin
{$ifdef DEBUG_COMDISPATCH}
if printcom then
writeln('Got ref. variant containing type: ',PVarData(PPointer(Params)^)^.VType);
{$endif DEBUG_COMDISPATCH}
if PVarData(PPointer(Params)^)^.VType=varString then
begin
{$ifdef DEBUG_COMDISPATCH}
if printcom then
writeln(' Casting nested varString: ',Ansistring(PVarData(Params^)^.vString));
{$endif DEBUG_COMDISPATCH}
VarCast(PVariant(Params^)^,PVariant(Params^)^,varOleStr);
@ -1148,11 +1175,13 @@ HKCR
else
begin
{$ifdef DEBUG_COMDISPATCH}
if printcom then
write('DispatchInvoke: Got ref argument with type = ',CurrType);
case CurrType of
varOleStr:
varOleStr: if printcom then
write(' Value = ',pwidestring(PPointer(Params)^)^);
end;
if printcom then
writeln;
{$endif DEBUG_COMDISPATCH}
Arguments[i].VType:=CurrType or VarByRef;
@ -1166,6 +1195,7 @@ HKCR
varStrArg:
begin
{$ifdef DEBUG_COMDISPATCH}
if printcom then
writeln('Translating ansistring argument ',PString(Params)^);
{$endif DEBUG_COMDISPATCH}
StringMap[NextString].ComStr:=StringToOleStr(PString(Params)^);
@ -1179,6 +1209,7 @@ HKCR
varVariant:
begin
{$ifdef DEBUG_COMDISPATCH}
if printcom then
writeln('By-value Variant, making a copy');
{$endif DEBUG_COMDISPATCH}
{ Codegen always passes a pointer to variant,
@ -1193,6 +1224,7 @@ HKCR
varDate:
begin
{$ifdef DEBUG_COMDISPATCH}
if printcom then
writeln('Got 8 byte argument');
{$endif DEBUG_COMDISPATCH}
Arguments[i].VType:=CurrType;
@ -1202,11 +1234,13 @@ HKCR
else
begin
{$ifdef DEBUG_COMDISPATCH}
if printcom then
write('DispatchInvoke: Got argument with type ',CurrType);
case CurrType of
varOleStr:
varOleStr: if printcom then
write(' Value = ',pwidestring(Params)^);
else
if printcom then
write(' Value = ',hexstr(PtrInt(PPointer(Params)^),SizeOf(Pointer)*2));
end;
writeln;
@ -1246,6 +1280,7 @@ HKCR
InvokeKind:=DISPATCH_METHOD or DISPATCH_PROPERTYGET;
end;
{$ifdef DEBUG_COMDISPATCH}
if printcom then
writeln('DispatchInvoke: MethodID: ',MethodID,' InvokeKind: ',InvokeKind);
{$endif DEBUG_COMDISPATCH}
{ do the call and check the result }
@ -1284,13 +1319,15 @@ HKCR
getmem(NamesData,CurrentNameDataSize);
NameCount:=0;
OrigNames:=Names;
{$ifdef DEBUG_COMDISPATCH}
{$ifdef DEBUG_COMDISPATCH}
if printcom then
writeln('SearchIDs: Searching ',Count,' IDs');
{$endif DEBUG_COMDISPATCH}
for i:=1 to Count do
begin
NameLen:=strlen(Names);
{$ifdef DEBUG_COMDISPATCH}
if printcom then
writeln('SearchIDs: Original name: ',Names,' Len: ',NameLen);
{$endif DEBUG_COMDISPATCH}
NewNameLen:=MultiByteToWideChar(0,0,Names,NameLen,nil,0)+1;
@ -1303,6 +1340,7 @@ HKCR
MultiByteToWideChar(0,0,Names,NameLen,@NamesData[CurrentNameDataUsed],NewNameLen);
NamesData[CurrentNameDataUsed+NewNameLen-1]:=#0;
{$ifdef DEBUG_COMDISPATCH}
if printcom then
writeln('SearchIDs: Translated name: ',WideString(PWideChar(@NamesData[CurrentNameDataUsed])));
{$endif DEBUG_COMDISPATCH}
inc(CurrentNameDataUsed,NewNameLen);
@ -1317,6 +1355,7 @@ HKCR
{$endif wince}
,IDs);
{$ifdef DEBUG_COMDISPATCH}
if printcom then
writeln('SearchIDs: GetIDsOfNames result = ',hexstr(res,SizeOf(HRESULT)*2));
for i:=0 to Count-1 do
writeln('SearchIDs: ID[',i,'] = ',ids^[i]);
@ -1338,7 +1377,9 @@ HKCR
begin
fillchar(ids,sizeof(ids),0);
{$ifdef DEBUG_COMDISPATCH}
if printcom then
writeln('ComObjDispatchInvoke called');
if printcom then
writeln('ComObjDispatchInvoke: @CallDesc = $',hexstr(PtrInt(CallDesc),SizeOf(Pointer)*2),' CallDesc^.ArgCount = ',CallDesc^.ArgCount);
{$endif DEBUG_COMDISPATCH}
if tvardata(source).vtype=VarDispatch then
@ -1559,6 +1600,7 @@ HKCR
function TAutoIntfObject.GetTypeInfoCount(out count: longint): HResult; stdcall;
begin
{$ifdef DEBUG_COM}
if printcom then
WriteLn('TAutoIntfObject.GetTypeInfoCount');
{$endif}
count := 1;
@ -1569,6 +1611,7 @@ HKCR
): HResult; stdcall;
begin
{$ifdef DEBUG_COM}
if printcom then
WriteLn('TAutoIntfObject.GetTypeInfo: ', Index);
{$endif}
if Index <> 0 then
@ -1584,6 +1627,7 @@ HKCR
NameCount, LocaleID: LongInt; DispIDs: Pointer): HResult; stdcall;
begin
{$ifdef DEBUG_COM}
if printcom then
WriteLn('TAutoIntfObject.GetIDsOfNames: ', GUIDToString(iid));
{$endif}
//return typeinfo->GetIDsOfNames(names, n, dispids);
@ -1595,6 +1639,7 @@ HKCR
ArgErr: pointer): HResult; stdcall;
begin
{$ifdef DEBUG_COM}
if printcom then
WriteLn('TAutoIntfObject.Invoke: ', DispID, ': ', Flags, ': ', TDispParams(params).cArgs, ': ', GUIDToString(iid));
//WriteLn('TAutoIntfObject.Invoke: ', DispID, ': ', Flags, ': ', TDispParams(params).cArgs, ': ', TDispParams(params).rgvarg^, ': ', GUIDToString(iid));
{$endif}
@ -1610,6 +1655,7 @@ HKCR
StdCall;
begin
{$ifdef DEBUG_COM}
if printcom then
WriteLn('TAutoIntfObject.InterfaceSupportsErrorInfo: ', GUIDToString(riid));
{$endif}
if assigned(GetInterfaceEntry(riid)) then
@ -1625,6 +1671,7 @@ HKCR
Handled: Integer;
begin
{$ifdef DEBUG_COM}
if printcom then
WriteLn('TAutoIntfObject.SafeCallException');
{$endif}
Handled:=0;
@ -1647,6 +1694,7 @@ HKCR
constructor TAutoIntfObject.Create(TypeLib: ITypeLib; const Guid: TGuid);
begin
{$ifdef DEBUG_COM}
if printcom then
WriteLn('TAutoIntfObject.Create: ', GUIDToString(Guid));
{$endif}
OleCheck(TypeLib.GetTypeInfoOfGuid(Guid, fTypeInfo));
@ -1658,6 +1706,7 @@ HKCR
function TAutoObject.GetTypeInfoCount(out count: longint): HResult; stdcall;
begin
{$ifdef DEBUG_COM}
if printcom then
WriteLn('TAutoObject.GetTypeInfoCount');
{$endif}
count := 1;
@ -1668,6 +1717,7 @@ HKCR
): HResult; stdcall;
begin
{$ifdef DEBUG_COM}
if printcom then
WriteLn('TAutoIntfObject.GetTypeInfo: ', Index);
{$endif}
if Index <> 0 then
@ -1683,6 +1733,7 @@ HKCR
LocaleID: LongInt; DispIDs: Pointer): HResult; stdcall;
begin
{$ifdef DEBUG_COM}
if printcom then
WriteLn('TAutoIntfObject.GetIDsOfNames: ', GUIDToString(iid));
{$endif}
//return typeinfo->GetIDsOfNames(names, n, dispids);
@ -1694,6 +1745,7 @@ HKCR
ArgErr: pointer): HResult; stdcall;
begin
{$ifdef DEBUG_COM}
if printcom then
WriteLn('TAutoIntfObject.Invoke: ', DispID, ': ', Flags, ': ', TDispParams(params).cArgs, ': ', GUIDToString(iid));
//WriteLn('TAutoIntfObject.Invoke: ', DispID, ': ', Flags, ': ', TDispParams(params).cArgs, ': ', TDispParams(params).rgvarg^, ': ', GUIDToString(iid));
{$endif}