--- Merging r13945 into '.':

D    packages/fcl-extra/units
--- Merging r13957 into '.':
U    packages/winunits-base/src/comobj.pp
U    packages/winunits-base/src/comserv.pp
--- Merging r13984 into '.':
U    rtl/objpas/classes/streams.inc
U    rtl/objpas/classes/classesh.inc
G    packages/winunits-base/src/comobj.pp
--- Merging r13988 into '.':
U    rtl/objpas/types.pp
G    rtl/objpas/classes/streams.inc
--- Merging r13991 into '.':
G    rtl/objpas/types.pp
U    packages/winunits-base/src/activex.pp
G    packages/winunits-base/src/comobj.pp
G    packages/winunits-base/src/comserv.pp
--- Merging r14078 into '.':
G    rtl/objpas/classes/streams.inc
G    rtl/objpas/classes/classesh.inc

# revisions: 13945,13957,13984,13988,13991,14078
------------------------------------------------------------------------
r13945 | marco | 2009-10-24 19:10:06 +0200 (Sat, 24 Oct 2009) | 2 lines
Changed paths:
   D /trunk/packages/fcl-extra/units

 * unitdir shouldn't be in SVN

------------------------------------------------------------------------
------------------------------------------------------------------------
r13957 | marco | 2009-10-26 12:02:00 +0100 (Mon, 26 Oct 2009) | 6 lines
Changed paths:
   M /trunk/packages/winunits-base/src/comobj.pp
   M /trunk/packages/winunits-base/src/comserv.pp

 * second patch from mantis 14822
    - registration of tlb
    - registry registration
    - implemented functions needed for comserv register/unregister 
    - registry function
    - finished TTypedComObject (but not really tested)
------------------------------------------------------------------------
------------------------------------------------------------------------
r13984 | marco | 2009-10-30 19:27:26 +0100 (Fri, 30 Oct 2009) | 2 lines
Changed paths:
   M /trunk/packages/winunits-base/src/comobj.pp
   M /trunk/rtl/objpas/classes/classesh.inc
   M /trunk/rtl/objpas/classes/streams.inc

 * TOleStream + TProxystream (Mantis 8376)

------------------------------------------------------------------------
------------------------------------------------------------------------
r13988 | marco | 2009-10-31 21:13:41 +0100 (Sat, 31 Oct 2009) | 2 lines
Changed paths:
   M /trunk/rtl/objpas/classes/streams.inc
   M /trunk/rtl/objpas/types.pp

 * TStreamAdapter + relevant constants. From 10608

------------------------------------------------------------------------
------------------------------------------------------------------------
r13991 | marco | 2009-10-31 23:31:26 +0100 (Sat, 31 Oct 2009) | 3 lines
Changed paths:
   M /trunk/packages/winunits-base/src/activex.pp
   M /trunk/packages/winunits-base/src/comobj.pp
   M /trunk/packages/winunits-base/src/comserv.pp
   M /trunk/rtl/objpas/types.pp

 * fixed compilation win32/win64 after (my) last commit. 
     due to wince <-> win32/win64 headerwise. wince has some identifiers in Windows that win32/win64 has in activex
 * patches for comobj/comserv from 0014822 and 0014939	as well as one minor fix to activex.
------------------------------------------------------------------------
------------------------------------------------------------------------
r14078 | marco | 2009-11-06 11:52:23 +0100 (Fri, 06 Nov 2009) | 2 lines
Changed paths:
   M /trunk/rtl/objpas/classes/classesh.inc
   M /trunk/rtl/objpas/classes/streams.inc

 * patch from 15003 from M spiller, reverting now implemented. 

------------------------------------------------------------------------

git-svn-id: branches/fixes_2_4@14669 -

packages/winunits-base/src/activex.pp

@@ -2846,9 +2846,10 @@ TYPE
      Function  LocalInvoke ():HResult;StdCall;
      {$endif}
      {$ifndef Call_as}
-     Function  GetDocumentation(memid: MEMBERID; OUT pBstrName: WideString; OUT pBstrDocString: WideString; OUT pdwHelpContext: DWORD; OUT pBstrHelpFile: WideString):HResult;StdCall;
+     //Function  GetDocumentation(memid: MEMBERID; OUT pBstrName: WideString; OUT pBstrDocString: WideString; OUT pdwHelpContext: DWORD; OUT pBstrHelpFile: WideString):HResult;StdCall;
+	 Function  GetDocumentation(memid: MEMBERID; pBstrName: PWideString; pBstrDocString: PWideString; pdwHelpContext: PDWORD; pBstrHelpFile: PWideString):HResult;StdCall;
      {$else}
-     Function  GetDocumentation(memid: MEMBERID; refPtrFlags: DWORD; OUT pBstrName: WideString; OUT pBstrDocString: WideString; OUT pdwHelpContext: DWORD; OUT pBstrHelpFile: WideString):HResult;StdCall;
+	 Function  GetDocumentation(memid: MEMBERID; refPtrFlags: DWORD; OUT pBstrName: WideString; OUT pBstrDocString: WideString; OUT pdwHelpContext: DWORD; OUT pBstrHelpFile: WideString):HResult;StdCall;
      {$endif}
 
      {$ifndef Call_as}

packages/winunits-base/src/comobj.pp

@@ -18,8 +18,8 @@ unit comobj;
 
   interface
 
-{define DEBUG_COM}
-
+{ $define DEBUG_COM}
+{ $define DUMMY_REG}
     uses
       Windows,Types,Variants,Sysutils,ActiveX,classes;
 
@@ -46,6 +46,10 @@ unit comobj;
 
       EOleRegistrationError = class(EOleError);
 
+      TOleStream = Class(TProxyStream)
+                  procedure Check(err:integer);override;
+		end;
+
       TComServerObject = class(TObject)
       protected
         function CountObject(Created: Boolean): Integer; virtual; abstract;
@@ -132,6 +136,8 @@ unit comobj;
       TClassInstancing = (ciInternal, ciSingleInstance, ciMultiInstance);
       TThreadingModel = (tmSingle, tmApartment, tmFree, tmBoth, tmNeutral);
 
+      { TComObjectFactory }
+
       TComObjectFactory = class(TObject, IUnknown, IClassFactory, IClassFactory2)
       private
         FRefCount : Integer;
@@ -140,6 +146,7 @@ unit comobj;
         FComClass: TClass;
         FClassID: TGUID;
         FClassName: string;
+        FClassVersion : String;
         FDescription: string;
         FErrorIID: TGUID;
         FInstancing: TClassInstancing;
@@ -167,12 +174,16 @@ unit comobj;
         constructor Create(ComServer: TComServerObject; ComClass: TComClass;
           const ClassID: TGUID; const Name, Description: string;
           Instancing: TClassInstancing; ThreadingModel: TThreadingModel = tmSingle);
+        constructor Create(ComServer: TComServerObject; ComClass: TComClass;
+          const ClassID: TGUID; const Name, Version, Description: string;
+          Instancing: TClassInstancing; ThreadingModel: TThreadingModel = tmSingle);
         destructor Destroy; override;
         function CreateComObject(const Controller: IUnknown): TComObject; virtual;
         procedure RegisterClassObject;
         procedure UpdateRegistry(Register: Boolean); virtual;
         property ClassID: TGUID read FClassID;
         property ClassName: string read FClassName;
+        property ClassVersion: string read FClassVersion;
         property ComClass: TClass read FComClass;
         property ComServer: TComServerObject read FComServer;
         property Description: string read FDescription;
@@ -206,6 +217,48 @@ unit comobj;
         property ClassInfo : ITypeInfo read FClassInfo;
       end;
 
+      { TAutoObject }
+
+      TAutoObject = class(TTypedComObject, IDispatch)
+      protected
+        { IDispatch }
+        function GetTypeInfoCount(out count : longint) : HResult;stdcall;
+        function GetTypeInfo(Index,LocaleID : longint; out TypeInfo): HResult;stdcall;
+        function GetIDsOfNames(const iid: TGUID; names: Pointer; NameCount, LocaleID: LongInt; DispIDs: Pointer) : HResult;stdcall;
+        function Invoke(DispID: LongInt;const iid : TGUID; LocaleID : longint; Flags: Word;var params; VarResult,ExcepInfo,ArgErr : pointer) : HResult;stdcall;
+      public
+
+      end;
+
+      TAutoClass = class of TAutoObject;
+
+      { TAutoObjectFactory }
+      TAutoObjectFactory = class(TTypedComObjectFactory)
+      public
+        constructor Create(AComServer: TComServerObject; AutoClass: TAutoClass; const AClassID: TGUID;
+          AInstancing: TClassInstancing; AThreadingModel: TThreadingModel = tmSingle);
+      end;
+
+      { TAutoIntfObject }
+
+      //example of how to implement IDispatch: http://www.opensource.apple.com/source/vim/vim-34/vim/src/if_ole.cpp
+      TAutoIntfObject = class(TInterfacedObject, IDispatch, ISupportErrorInfo)
+      private
+        fTypeInfo: ITypeInfo;
+        fInterfacePointer: Pointer;
+      protected
+        { IDispatch }
+        function GetTypeInfoCount(out count : longint) : HResult;stdcall;
+        function GetTypeInfo(Index,LocaleID : longint; out TypeInfo): HResult;stdcall;
+        function GetIDsOfNames(const iid: TGUID; names: Pointer; NameCount, LocaleID: LongInt; DispIDs: Pointer) : HResult;stdcall;
+        function Invoke(DispID: LongInt;const iid : TGUID; LocaleID : longint; Flags: Word;var params; VarResult,ExcepInfo,ArgErr : pointer) : HResult;stdcall;
+
+        { ISupportErrorInfo }
+        function  InterfaceSupportsErrorInfo(CONST riid: TIID):HResult;StdCall;
+      public
+        function SafeCallException(ExceptObject: TObject; ExceptAddr: Pointer): HResult; override;
+        constructor Create(TypeLib: ITypeLib; const Guid: TGuid);
+      end;
 
     function CreateClassID : ansistring;
 
@@ -252,7 +305,7 @@ unit comobj;
 implementation
 
     uses
-      ComConst,Ole2, Registry;
+      ComConst, Ole2, Registry, RtlConsts;
 
     var
       Uninitializing : boolean;
@@ -370,7 +423,6 @@ implementation
         OleCheck(CoCreateInstance(id,nil,CLSCTX_INPROC_SERVER or CLSCTX_LOCAL_SERVER,IDispatch,result));
      end;
 
-
    function GetActiveOleObject(const ClassName : string) : IDispatch;
 {$ifndef wince}
      var
@@ -387,6 +439,79 @@ implementation
      end;
 {$endif wince}
 
+    procedure CreateRegKey(const Key, ValueName, Value: string);
+{$ifndef DUMMY_REG}
+      var
+        Reg: TRegistry;
+{$endif}
+      begin
+{$ifdef DEBUG_COM}
+        WriteLn('CreateRegKey: ', Key, ': ', ValueName, ': ', Value );
+{$endif}
+{$ifndef DUMMY_REG}
+        Reg := TRegistry.Create;
+        try
+          Reg.RootKey := HKEY_CLASSES_ROOT;
+          if Reg.OpenKey(Key, True) then
+          begin
+            try
+              Reg.WriteString(ValueName, Value);
+            finally
+              Reg.CloseKey;
+            end;
+          end
+          else
+            raise ERegistryException.CreateResFmt(@SRegCreateFailed, [Key]);
+        finally
+          Reg.Free;
+        end;
+{$endif}
+{$ifdef DEBUG_COM}
+        WriteLn('CreateRegKey exit: ', Key, ': ', ValueName, ': ', Value );
+{$endif}
+      end;
+
+    procedure DeleteRegKey(const Key: string);
+{$ifndef DUMMY_REG}
+      var
+        Reg: TRegistry;
+{$endif}
+      begin
+{$ifdef DEBUG_COM}
+        WriteLn('DeleteRegKey: ', Key);
+{$endif}
+{$ifndef DUMMY_REG}
+        Reg := TRegistry.Create;
+        try
+          Reg.RootKey := HKEY_CLASSES_ROOT;
+          Reg.DeleteKey(Key);
+        finally
+          Reg.Free;
+        end;
+{$endif}
+      end;
+
+    function GetRegStringValue(const Key, ValueName: string): string;
+      var
+        Reg: TRegistry;
+      begin
+        Reg := TRegistry.Create();
+        try
+          Reg.RootKey := HKEY_CLASSES_ROOT;
+          if Reg.OpenKeyReadOnly(Key) then
+          begin
+            try
+              Result := Reg.ReadString(ValueName)
+            finally
+              Reg.CloseKey;
+            end;
+          end
+          else
+            Result := '';
+        finally
+          Reg.Free;
+        end;
+      end;
 
    procedure OleError(Code: HResult);
      begin
@@ -681,7 +806,7 @@ implementation
 
     function TComObjectFactory.GetProgID: string;
       begin
-        RunError(217);
+        Result := FComServer.GetServerName + '.' + FClassName;
       end;
 
 
@@ -767,6 +892,13 @@ implementation
       Description: string; Instancing: TClassInstancing;
       ThreadingModel: TThreadingModel);
       begin
+        Create(ComServer, ComClass, ClassID, Name, '', Description, Instancing, ThreadingModel);
+      end;
+
+    constructor TComObjectFactory.Create(ComServer: TComServerObject;
+      ComClass: TComClass; const ClassID: TGUID; const Name, Version, Description: string; Instancing: TClassInstancing;
+      ThreadingModel: TThreadingModel);
+    begin
 {$ifdef DEBUG_COM}
         WriteLn('TComObjectFactory.Create');
 {$endif}
@@ -775,6 +907,7 @@ implementation
         FThreadingModel := ThreadingModel;
         FDescription := Description;
         FClassName := Name;
+        FClassVersion := Version;
         FComServer := ComServer;
         FComClass := ComClass;
         FInstancing := Instancing;;
@@ -801,6 +934,9 @@ implementation
 
     procedure TComObjectFactory.RegisterClassObject;
       begin
+      {$ifdef DEBUG_COM}
+        WriteLn('TComObjectFactory.RegisterClassObject');
+      {$endif}
         RunError(217);
       end;
 
@@ -837,38 +973,69 @@ HKCR
     procedure TComObjectFactory.UpdateRegistry(Register: Boolean);
       var
         reg: TRegistry;
+        classidguid: String;
+
+        function ThreadModelToString(model: TThreadingModel): String;
+        begin
+          case model of
+            tmSingle: Result := '';
+            tmApartment: Result := 'Apartment';
+            tmFree: Result := 'Free';
+            tmBoth: Result := 'Both';
+            tmNeutral: Result := 'Neutral';
+          end;
+        end;
+
       begin
-        RunError(217);
+{$ifdef DEBUG_COM}
+        WriteLn('UpdateRegistry begin');
+{$endif}
+        if Instancing = ciInternal then Exit;
 
-        //todo: finish this
         if Register then
         begin
-          reg := TRegistry.Create;
-          reg.RootKey := HKEY_CLASSES_ROOT;
-          reg.OpenKey(FClassName + '.1', True);
-          reg.WriteString('', Description);
-          reg.WriteString('CLSID', GUIDToString(ClassID));
-          reg.CloseKey;
-
-          reg.OpenKey(FClassName, True);
-          reg.WriteString('', Description);
-          reg.WriteString('CLSID', GUIDToString(ClassID));
-          reg.WriteString('CurVer', FClassName + '.1');
-          reg.CloseKey;
-
-          reg.OpenKey('CLSID\' + GUIDToString(ClassID), True);
-          reg.WriteString('', Description);
-          reg.WriteString('ProgID', FClassName);
-          reg.WriteString('VersionIndependentProgID', FClassName);
-          reg.WriteString('InprocServer32', 'MODULENAME');
-          reg.CloseKey;
-
-          reg.Free;
+          classidguid := GUIDToString(ClassID);
+          CreateRegKey('CLSID\' + classidguid, '', Description);
+          if ClassVersion <> '' then
+          begin
+            CreateRegKey('CLSID\' + classidguid + '\ProgID', '', ProgID + '.' + ClassVersion);
+            CreateRegKey('CLSID\' + classidguid + '\VersionIndependentProgID', '', ProgID + '.' + ClassVersion);
+          end
+          else
+            CreateRegKey('CLSID\' + classidguid + '\ProgID', '', ProgID);
 
-        end;
-        //This should be in typedcomobject
-        //reg.WriteString('TypeLib', FClassName);
+          CreateRegKey('CLSID\' + classidguid + '\InprocServer32', '', FComServer.ServerFileName);
+
+          //tmSingle, tmApartment, tmFree, tmBoth, tmNeutral
+          CreateRegKey('CLSID\' + classidguid + '\InprocServer32', 'ThreadingModel', ThreadModelToString(ThreadingModel));
+
+          CreateRegKey(ProgID, '', Description);
+          CreateRegKey(ProgID + '\CLSID', '', GUIDToString(ClassID));
+          if ClassVersion <> '' then
+          begin
+            CreateRegKey(ProgID + '\CurVer', '', ProgID + '.' + ClassVersion);
+            CreateRegKey(ProgID + '.' + ClassVersion, '', Description);
+            CreateRegKey(ProgID + '.' + ClassVersion + '\CLSID', '', GUIDToString(ClassID));
+          end;
 
+        end else
+        begin
+          classidguid := GUIDToString(ClassID);
+          DeleteRegKey('CLSID\' + classidguid + '\InprocServer32');
+          DeleteRegKey('CLSID\' + classidguid + '\VersionIndependentProgID');
+          DeleteRegKey('CLSID\' + classidguid + '\ProgID');
+          DeleteRegKey('CLSID\' + classidguid);
+          DeleteRegKey(ProgID + '\CLSID');
+          DeleteRegKey(ProgID);
+          if ClassVersion <> '' then
+          begin
+            DeleteRegKey(ProgID + '.' + ClassVersion + '\CLSID');
+            DeleteRegKey(ProgID + '.' + ClassVersion);
+          end;
+        end;
+{$ifdef DEBUG_COM}
+        WriteLn('UpdateRegistry end');
+{$endif}
       end;
 
 
@@ -1255,13 +1422,28 @@ HKCR
     constructor TTypedComObjectFactory.Create(AComServer: TComServerObject; TypedComClass: TTypedComClass; const AClassID: TGUID;
       AInstancing: TClassInstancing; AThreadingModel: TThreadingModel = tmSingle);
       var
-        TypedName, TypedDescription: WideString;
+        TypedName, TypedDescription, TypedVersion: WideString;
+        ppTypeAttr: lpTYPEATTR;
       begin
         //TDB get name and description from typelib (check if this is a valid guid)
         OleCheck(AComServer.GetTypeLib.GetTypeInfoOfGuid(AClassID, FClassInfo));
+
         //bug FPC 0010569 - http://msdn2.microsoft.com/en-us/library/ms221396(VS.85).aspx
-        OleCheck(FClassInfo.GetDocumentation(-1, TypedName, TypedDescription, PLongWord(nil)^, PWideString(nil)^));
-        inherited Create(AComServer, TypedComClass, AClassID, TypedName, TypedDescription, AInstancing, AThreadingModel);
+        OleCheck(FClassInfo.GetDocumentation(-1, @TypedName, @TypedDescription, nil, nil));
+        FClassInfo.GetTypeAttr(ppTypeAttr);
+        try
+          TypedVersion := '';
+          if (ppTypeAttr^.wMajorVerNum <> 0) or (ppTypeAttr^.wMinorVerNum <> 0) then
+          begin
+            TypedVersion := IntToStr(ppTypeAttr^.wMajorVerNum);
+            if ppTypeAttr^.wMinorVerNum <> 0 then
+              TypedVersion := TypedVersion + '.' + IntToStr(ppTypeAttr^.wMinorVerNum)
+          end;
+        finally
+          FClassInfo.ReleaseTypeAttr(ppTypeAttr);
+        end;
+
+        inherited Create(AComServer, TypedComClass, AClassID, TypedName, TypedVersion, TypedDescription, AInstancing, AThreadingModel);
       end;
 
 
@@ -1272,13 +1454,205 @@ HKCR
 
 
     procedure TTypedComObjectFactory.UpdateRegistry(Register: Boolean);
+         var
+        ptla: PTLibAttr;
       begin
-        inherited UpdateRegistry(Register);
-        // 'TypeLib' = s '%LIBID%' missing ??? or does TComServer register it ?
-        //un/register typed library
-        RunError(217);
+        if Instancing = ciInternal then
+          Exit;
+
+        if Register then
+        begin
+          inherited UpdateRegistry(Register);
+
+          //http://www.experts-exchange.com/Programming/Misc/Q_20634807.html
+          //There seems to also be Version according to Process Monitor
+          //http://technet.microsoft.com/en-us/sysinternals/bb896645.aspx
+          if FComServer.TypeLib = nil then
+            raise Exception.Create('TypeLib is not set!');
+
+          OleCheck(FComServer.TypeLib.GetLibAttr(ptla));
+          try
+            CreateRegKey('CLSID\' + GUIDToString(ClassID) + '\TypeLib', '', GUIDToString(ptla^.GUID));
+          finally
+            FComServer.TypeLib.ReleaseTLibAttr(ptla);
+          end;
+        end else
+        begin
+          DeleteRegKey('CLSID\' + GUIDToString(ClassID) + '\TypeLib');
+          inherited UpdateRegistry(Register);
+        end;
+      end;
+
+   { TAutoIntfObject }
+
+    function TAutoIntfObject.GetTypeInfoCount(out count: longint): HResult; stdcall;
+      begin
+{$ifdef DEBUG_COM}
+        WriteLn('TAutoIntfObject.GetTypeInfoCount');
+{$endif}
+        count := 1;
+        Result := S_OK;
+      end;
+
+    function TAutoIntfObject.GetTypeInfo(Index, LocaleID: longint; out TypeInfo
+      ): HResult; stdcall;
+      begin
+{$ifdef DEBUG_COM}
+        WriteLn('TAutoIntfObject.GetTypeInfo: ', Index);
+{$endif}
+        if Index <> 0 then
+          Result := DISP_E_BADINDEX
+        else
+        begin
+          ITypeInfo(TypeInfo) := fTypeInfo;
+          Result := S_OK;
+        end;
+      end;
+
+    function TAutoIntfObject.GetIDsOfNames(const iid: TGUID; names: Pointer;
+      NameCount, LocaleID: LongInt; DispIDs: Pointer): HResult; stdcall;
+      begin
+{$ifdef DEBUG_COM}
+        WriteLn('TAutoIntfObject.GetIDsOfNames: ', GUIDToString(iid));
+{$endif}
+        //return typeinfo->GetIDsOfNames(names, n, dispids);
+        Result := fTypeInfo.GetIDsOfNames(names, NameCount, lpDISPID(DispIDs)^);
+      end;
+
+    function TAutoIntfObject.Invoke(DispID: LongInt; const iid: TGUID;
+      LocaleID: longint; Flags: Word; var params; VarResult, ExcepInfo,
+      ArgErr: pointer): HResult; stdcall;
+      begin
+{$ifdef DEBUG_COM}
+        WriteLn('TAutoIntfObject.Invoke: ', DispID, ': ', Flags, ': ', TDispParams(params).cArgs, ': ', GUIDToString(iid));
+        //WriteLn('TAutoIntfObject.Invoke: ', DispID, ': ', Flags, ': ', TDispParams(params).cArgs, ': ', TDispParams(params).rgvarg^, ': ', GUIDToString(iid));
+{$endif}
+        if not IsEqualGUID(iid, GUID_NULL) then
+          Result := DISP_E_UNKNOWNINTERFACE
+        else
+      //  Function  Invoke(pvInstance: Pointer; memid: MEMBERID; wFlags: WORD; VAR pDispParams: DISPPARAMS; OUT pVarResult: VARIANT; OUT pExcepInfo: EXCEPINFO; OUT puArgErr: UINT):HResult;StdCall;
+      //  Result := fTypeInfo.Invoke(IDispatch(Self), DispID, Flags, TDispParams(params), PVariant(VarResult)^, PExcepInfo(ExcepInfo)^, PUINT(ArgErr)^);
+          Result := fTypeInfo.Invoke(fInterfacePointer, DispID, Flags, TDispParams(params), PVariant(VarResult)^, PExcepInfo(ExcepInfo)^, PUINT(ArgErr)^);
+      end;
+
+    function TAutoIntfObject.InterfaceSupportsErrorInfo(const riid: TIID): HResult;
+      StdCall;
+      begin
+{$ifdef DEBUG_COM}
+        WriteLn('TAutoIntfObject.InterfaceSupportsErrorInfo: ', GUIDToString(riid));
+{$endif}
+        if assigned(GetInterfaceEntry(riid)) then
+          Result:=S_OK
+        else
+          Result:=S_FALSE;
+      end;
+
+    function TAutoIntfObject.SafeCallException(ExceptObject: TObject;
+      ExceptAddr: Pointer): HResult;
+      var
+        //Message: string;
+        Handled: Integer;
+      begin
+{$ifdef DEBUG_COM}
+        WriteLn('TAutoIntfObject.SafeCallException');
+{$endif}
+        Handled:=0;
+        Result:=0;
+        //TODO: DO WE NEED THIS ?
+        //if assigned(ServerExceptionHandler) then
+        //  begin
+        //    if ExceptObject is Exception then
+        //      Message:=Exception(ExceptObject).Message;
+        //
+        //    ServerExceptionHandler.OnException(ClassName,ExceptObject.ClassName,
+        //      Message,PtrInt(ExceptAddr),WideString(GUIDToString(FFactory.ErrorIID)),
+        //      FFactory.ProgID,Handled,Result);
+        //  end;
+        if Handled=0 then
+          Result:=HandleSafeCallException(ExceptObject,ExceptAddr,StringToGuid('{7C538328-8A75-4EC4-A02E-FB3B27FAA411}'),
+            '','');
+      end;
+
+    constructor TAutoIntfObject.Create(TypeLib: ITypeLib; const Guid: TGuid);
+      begin
+{$ifdef DEBUG_COM}
+        WriteLn('TAutoIntfObject.Create: ', GUIDToString(Guid));
+{$endif}
+        OleCheck(TypeLib.GetTypeInfoOfGuid(Guid, fTypeInfo));
+        OleCheck(QueryInterface(Guid, fInterfacePointer));
       end;
 
+    { TAutoObject }
+
+    function TAutoObject.GetTypeInfoCount(out count: longint): HResult; stdcall;
+      begin
+{$ifdef DEBUG_COM}
+        WriteLn('TAutoObject.GetTypeInfoCount');
+{$endif}
+        count := 1;
+        Result := S_OK;
+      end;
+
+    function TAutoObject.GetTypeInfo(Index, LocaleID: longint; out TypeInfo
+      ): HResult; stdcall;
+      begin
+{$ifdef DEBUG_COM}
+        WriteLn('TAutoIntfObject.GetTypeInfo: ', Index);
+{$endif}
+        if Index <> 0 then
+          Result := DISP_E_BADINDEX
+        else
+        begin
+          ITypeInfo(TypeInfo) := TAutoObjectFactory(Factory).ClassInfo;
+          Result := S_OK;
+        end;
+      end;
+
+    function TAutoObject.GetIDsOfNames(const iid: TGUID; names: Pointer; NameCount,
+      LocaleID: LongInt; DispIDs: Pointer): HResult; stdcall;
+      begin
+{$ifdef DEBUG_COM}
+        WriteLn('TAutoIntfObject.GetIDsOfNames: ', GUIDToString(iid));
+{$endif}
+        //return typeinfo->GetIDsOfNames(names, n, dispids);
+        Result := TAutoObjectFactory(Factory).ClassInfo.GetIDsOfNames(names, NameCount, lpDISPID(DispIDs)^);
+      end;
+
+    function TAutoObject.Invoke(DispID: LongInt; const iid: TGUID;
+      LocaleID: longint; Flags: Word; var params; VarResult, ExcepInfo,
+      ArgErr: pointer): HResult; stdcall;
+      var
+        fInterfacePointer: Pointer;
+      begin
+{$ifdef DEBUG_COM}
+        WriteLn('TAutoIntfObject.Invoke: ', DispID, ': ', Flags, ': ', TDispParams(params).cArgs, ': ', GUIDToString(iid));
+        //WriteLn('TAutoIntfObject.Invoke: ', DispID, ': ', Flags, ': ', TDispParams(params).cArgs, ': ', TDispParams(params).rgvarg^, ': ', GUIDToString(iid));
+{$endif}
+        if not IsEqualGUID(iid, GUID_NULL) then
+          Result := DISP_E_UNKNOWNINTERFACE
+        else
+        begin
+      //  Function  Invoke(pvInstance: Pointer; memid: MEMBERID; wFlags: WORD; VAR pDispParams: DISPPARAMS; OUT pVarResult: VARIANT; OUT pExcepInfo: EXCEPINFO; OUT puArgErr: UINT):HResult;StdCall;
+      //  Result := fTypeInfo.Invoke(IDispatch(Self), DispID, Flags, TDispParams(params), PVariant(VarResult)^, PExcepInfo(ExcepInfo)^, PUINT(ArgErr)^);
+          OleCheck(QueryInterface(TAutoObjectFactory(Factory).ClassID, fInterfacePointer));
+          Result := TAutoObjectFactory(Factory).ClassInfo.Invoke(fInterfacePointer, DispID, Flags, TDispParams(params), PVariant(VarResult)^, PExcepInfo(ExcepInfo)^, PUINT(ArgErr)^);
+        end;
+      end;
+
+    { TAutoObjectFactory }
+
+    constructor TAutoObjectFactory.Create(AComServer: TComServerObject;
+      AutoClass: TAutoClass; const AClassID: TGUID; AInstancing: TClassInstancing;
+      AThreadingModel: TThreadingModel);
+      begin
+        inherited Create(AComServer, AutoClass, AClassID, AInstancing, AThreadingModel);
+      end;
+
+procedure TOleStream.Check(err:integer);
+begin
+  OleCheck(err);
+end;
+
 
 const
   Initialized : boolean = false;

packages/winunits-base/src/comserv.pp

@@ -21,7 +21,7 @@ interface
 uses
   Classes, SysUtils, comobj, ActiveX;
 
-{define DEBUG_COM}
+{ $define DEBUG_COM}
 
 //according to doc
 // * ComServer Variable
@@ -44,6 +44,9 @@ type
   private
     fCountObject: Integer;
     fCountFactory: Integer;
+    fTypeLib: ITypeLib;
+    fServerName,
+    fServerFileName: String;
   protected
     function CountObject(Created: Boolean): Integer; override;
     function CountFactory(Created: Boolean): Integer; override;
@@ -60,6 +63,7 @@ type
     procedure UnregisterServerFactory(Factory: TComObjectFactory);
   public
     constructor Create;
+    destructor Destroy; override;
     function CanUnloadNow: Boolean;
     procedure RegisterServer;
     procedure UnRegisterServer;
@@ -90,6 +94,9 @@ function DllUnregisterServer: HResult; stdcall;
 
 implementation
 
+uses
+  Windows;
+
 function DllCanUnloadNow: HResult; stdcall;
 begin
 {$ifdef DEBUG_COM}
@@ -168,6 +175,43 @@ begin
   end;
 end;
 
+function GetModuleFileName: String;
+const
+  MAX_PATH_SIZE = 2048;
+begin
+  SetLength(Result, MAX_PATH_SIZE);
+  SetLength(Result, Windows.GetModuleFileName(HInstance, @Result[1], MAX_PATH_SIZE));
+end;
+
+function GetModuleName: String;
+begin
+  Result := ExtractFileName(GetModuleFileName);
+  Result := Copy(Result, 1,LastDelimiter('.', Result)-1);
+end;
+
+procedure RegisterTypeLib(TypeLib: ITypeLib; const ModuleName: string);
+var
+  FullPath: WideString;
+begin
+  FullPath := ModuleName;
+  //according to MSDN helpdir can be null
+  OleCheck(ActiveX.RegisterTypeLib(TypeLib, @FullPath[1], nil));
+end;
+
+procedure UnRegisterTypeLib(TypeLib: ITypeLib);
+var
+  ptla: PTLibAttr;
+begin
+  //http://www.experts-exchange.com/Programming/Misc/Q_20634807.html
+  OleCheck(TypeLib.GetLibAttr(ptla));
+  try
+    OleCheck(ActiveX.UnRegisterTypeLib(ptla^.guid, ptla^.wMajorVerNum, ptla^.wMinorVerNum, ptla^.lcid, ptla^.syskind));
+  finally
+    TypeLib.ReleaseTLibAttr(ptla);
+  end;
+end;
+
+
 { TComServer }
 
 function TComServer.CountObject(Created: Boolean): Integer;
@@ -193,7 +237,7 @@ end;
 
 function TComServer.GetServerFileName: string;
 begin
-  RunError(217);
+  Result := fServerFileName;
 end;
 
 function TComServer.GetServerKey: string;
@@ -203,7 +247,7 @@ end;
 
 function TComServer.GetServerName: string;
 begin
-  RunError(217);
+  Result := fServerName;
 end;
 
 function TComServer.GetStartSuspended: Boolean;
@@ -213,7 +257,7 @@ end;
 
 function TComServer.GetTypeLib: ITypeLib;
 begin
-  RunError(217);
+  Result := fTypeLib;
 end;
 
 procedure TComServer.SetHelpFileName(const Value: string);
@@ -228,13 +272,41 @@ end;
 
 procedure TComServer.UnregisterServerFactory(Factory: TComObjectFactory);
 begin
-  Factory.UpdateRegistry(false);
+  Factory.UpdateRegistry(False);
 end;
 
 constructor TComServer.Create;
+var
+  name: WideString;
 begin
+  inherited Create;
+{$ifdef DEBUG_COM}
+  WriteLn('TComServer.Create');
+{$endif}
   fCountFactory := 0;
   fCountObject := 0;
+
+  fServerFileName := GetModuleFileName();
+
+  name := fServerFileName;
+  if not(Succeeded(LoadTypeLib(@name[1], fTypeLib))) then
+    fTypeLib := nil;
+
+  if FTypeLib <> nil then
+  begin
+    fTypeLib.GetDocumentation(-1, @name, nil, nil, nil);
+    fServerName := name;
+  end
+  else
+    fServerName := GetModuleName;
+end;
+
+destructor TComServer.Destroy;
+begin
+  inherited Destroy;
+{$ifdef DEBUG_COM}
+  WriteLn('TComServer.Destroy');
+{$endif}
 end;
 
 function TComServer.CanUnloadNow: Boolean;
@@ -244,11 +316,17 @@ end;
 
 procedure TComServer.RegisterServer;
 begin
+  if fTypeLib <> nil then
+    RegisterTypeLib(fTypeLib, fServerFileName);
+
   ComClassManager.ForEachFactory(self, @RegisterServerFactory);
 end;
 
 procedure TComServer.UnRegisterServer;
 begin
+  if fTypeLib <> nil then
+    UnRegisterTypeLib(fTypeLib);
+
   ComClassManager.ForEachFactory(self, @UnregisterServerFactory);
 end;
 

rtl/objpas/classes/classesh.inc

@@ -703,6 +703,7 @@ type
   end;
 
 {$endif}
+  
 
 { TStream abstract class }
 
@@ -745,6 +746,19 @@ type
     property Size: Int64 read GetSize write SetSize64;
   end;
 
+  TProxyStream = class(TStream)
+  private
+    FStream: IStream;
+  protected
+    function GetIStream: IStream;
+  public
+    constructor Create(const Stream: IStream);
+    function Read(var Buffer; Count: Longint): Longint; override;
+    function Write(const Buffer; Count: Longint): Longint; override;
+    function Seek(Offset: Longint; Origin: Word): Longint; override;
+    procedure Check(err:longint); virtual;
+  end;
+
   { TOwnerStream }
   TOwnerStream = Class(TStream)
   Protected
@@ -877,8 +891,9 @@ type
 { Implements OLE IStream on TStream }
   TStreamAdapter = class(TInterfacedObject, IStream)
   private
-    FStream: TStream;
-    FOwnership: TStreamOwnership;
+    FStream    : TStream;
+    FOwnership : TStreamOwnership;
+    m_bReverted: Boolean;
   public
     constructor Create(Stream: TStream; Ownership: TStreamOwnership = soReference);
     destructor Destroy; override;

rtl/objpas/classes/streams.inc

@@ -821,6 +821,9 @@ begin
   inherited Create;
   FStream:=Stream;
   FOwnership:=Ownership;
+  m_bReverted:=false;   // mantis 15003
+			// http://www.tech-archive.net/Archive/German/microsoft.public.de.vc/2005-08/msg00791.html
+			// http://code.google.com/p/ddab-lib/wiki/TPJIStreamWrapper
 end;
 
 
@@ -833,67 +836,184 @@ end;
   
 {$warnings off}
 function TStreamAdapter.Read(pv: Pointer; cb: DWORD; pcbRead: PDWORD): HResult; stdcall;
+var
+  readcount: Longint;
 begin
-  runerror(217);
-end;
+  if m_bReverted then
+      begin
+        Result := STG_E_REVERTED;
+        Exit;
+      end;
+  if pv = nil then
+  begin
+    Result := E_INVALIDARG;
+    Exit;
+  end;
 
+  readcount := FStream.Read(pv^, cb);
+  if pcbRead <> nil then pcbRead^ := readcount;
+  Result := S_OK;
+end;
 
 function TStreamAdapter.Write(pv: Pointer; cb: DWORD; pcbWritten: PDWORD): HResult; stdcall;
+var
+  writecount: Longint;
 begin
-  runerror(217);
-end;
+  if m_bReverted then
+      begin
+        Result := STG_E_REVERTED;
+        Exit;
+      end;
+  if pv = nil then
+  begin
+    Result := E_INVALIDARG;
+    Exit;
+  end;
 
+  writecount := FStream.Write(pv^, cb);
+  if pcbWritten <> nil then pcbWritten^ := writecount;
+  Result := S_OK;
+end;
 
 function TStreamAdapter.Seek(dlibMove: Largeint; dwOrigin: Longint; out libNewPosition: Largeint): HResult; stdcall;
+var
+  newpos: Int64;
 begin
-  runerror(217);
+  if m_bReverted then
+      begin
+        Result := STG_E_REVERTED;
+        Exit;
+      end;
+  case dwOrigin of
+    STREAM_SEEK_SET: newpos := FStream.Seek(dlibMove, soBeginning);
+    STREAM_SEEK_CUR: newpos := FStream.Seek(dlibMove, soCurrent);
+    STREAM_SEEK_END: newpos := FStream.Seek(dlibMove, soEnd);
+    else begin Result := E_INVALIDARG; exit; end;
+  end;
+  if @libNewPosition <> nil then
+    libNewPosition := newpos;
+  Result := S_OK;
 end;
 
-
 function TStreamAdapter.SetSize(libNewSize: Largeint): HResult; stdcall;
 begin
+  if m_bReverted then
+      begin
+        Result := STG_E_REVERTED;
+        Exit;
+      end;
   runerror(217);
 end;
 
 
 function TStreamAdapter.CopyTo(stm: IStream; cb: Largeint; out cbRead: Largeint; out cbWritten: Largeint): HResult; stdcall;
 begin
+  if m_bReverted then
+      begin
+        Result := STG_E_REVERTED;
+        Exit;
+      end;
   runerror(217);
 end;
 
-
 function TStreamAdapter.Commit(grfCommitFlags: Longint): HResult; stdcall;
 begin
-  runerror(217);
+  if m_bReverted then
+    Result := STG_E_REVERTED
+  else
+    Result := S_OK;
 end;
 
-
 function TStreamAdapter.Revert: HResult; stdcall;
 begin
-  runerror(217);
+  m_bReverted := True;
+  Result := S_OK;
 end;
 
 
 function TStreamAdapter.LockRegion(libOffset: Largeint; cb: Largeint; dwLockType: Longint): HResult; stdcall;
 begin
-  runerror(217);
+  Result := STG_E_INVALIDFUNCTION;
 end;
 
 
 function TStreamAdapter.UnlockRegion(libOffset: Largeint; cb: Largeint; dwLockType: Longint): HResult; stdcall;
 begin
-  runerror(217);
+  Result := STG_E_INVALIDFUNCTION;
 end;
 
 
 function TStreamAdapter.Stat(out statstg: TStatStg; grfStatFlag: Longint): HResult; stdcall;
 begin
+  if m_bReverted then
+      begin
+        Result := STG_E_REVERTED;
+        Exit;
+      end;
+  if grfStatFlag in [STATFLAG_DEFAULT,STATFLAG_NOOPEN,STATFLAG_NONAME] then
+  begin
+    if @statstg <> nil then
+    begin
+      fillchar(statstg, sizeof(TStatStg),#0);
+      
+      { //TODO handle pwcsName
+        if grfStatFlag = STATFLAG_DEFAULT then
+          runerror(217) //Result :={$ifdef windows} STG_E_INVALIDFLAG{$else}E_INVALID_FLAG{$endif}
+      }
+
+      statstg.dwType := STGTY_STREAM;
+      statstg.cbSize := FStream.Size;
+      statstg.grfLocksSupported := LOCK_WRITE;
+    end;
+    Result := S_OK;
+  end else
+    Result := STG_E_INVALIDFLAG
+end; 
+
+function TStreamAdapter.Clone(out stm: IStream): HResult; stdcall;
+begin
+  if m_bReverted then
+      begin
+        Result := STG_E_REVERTED;
+        Exit;
+      end;
   runerror(217);
 end;
 
+constructor TProxyStream.Create(const Stream: IStream);
+begin
+  FStream := Stream;
+end;
 
-function TStreamAdapter.Clone(out stm: IStream): HResult; stdcall;
+function TProxyStream.Read(var Buffer; Count: Longint): Longint;
 begin
-  runerror(217);
+  Check(FStream.Read(@Buffer, Count, @Result));
+end;
+
+function TProxyStream.Seek(Offset: Longint; Origin: Word): Longint;
+var
+  Pos: Int64;
+begin
+  Check(FStream.Seek(Offset, Origin, Pos));
+  Result := Pos;
+end;
+
+function TProxyStream.Write(const Buffer; Count: Longint): Longint;
+begin
+  Check(FStream.Write(@Buffer, Count, @Result));
+end;
+
+function TProxyStream.GetIStream: IStream;
+begin
+  Result := FStream;
+end; 
+
+procedure TProxyStream.Check(err:integer);
+var e : EInOutError;
+begin 
+  e:= EInOutError.Create('Proxystream.Check');
+  e.Errorcode:=err;
+  raise e;
 end;
+
 {$warnings on}

rtl/objpas/types.pp

@@ -134,7 +134,9 @@ type
 const
   GUID_NULL: TGUID  = '{00000000-0000-0000-0000-000000000000}';
 
-{$ifndef Windows}
+{$ifndef Wince}
+  // in Wince these are in unit windows. Under 32/64 in ActiveX.
+  // for now duplicate them. Not that bad for untyped constants.
   STGTY_STORAGE   = 1;
   STGTY_STREAM    = 2;
   STGTY_LOCKBYTES = 3;
@@ -148,7 +150,8 @@ const
   LOCK_EXCLUSIVE = 2;
   LOCK_ONLYONCE  = 4;
 
-  E_FAIL = HRESULT($80004005);
+  E_FAIL 		      = HRESULT($80004005);
+  E_INVALIDARG                = HRESULT($80070057);
 
   STG_E_INVALIDFUNCTION       = HRESULT($80030001);
   STG_E_FILENOTFOUND          = HRESULT($80030002);
@@ -193,6 +196,11 @@ const
   STG_S_RETRYNOW              = $00030202;
   STG_S_MONITORING            = $00030203;
 
+  STATFLAG_DEFAULT   	      = 0;
+  STATFLAG_NONAME    	      = 1;
+  STATFLAG_NOOPEN    	      = 2; 
+{$endif}
+{$ifndef Windows}
 type
   PCLSID = PGUID;
   TCLSID = TGUID;