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

git-svn-id: trunk@26427 -

packages/winunits-base/src/comobj.pp

@@ -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}