{**************************************************************************************************}
{                                                                                                  }
{ Project JEDI Code Library (JCL)                                                                  }
{                                                                                                  }
{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); }
{ you may not use this file except in compliance with the License. You may obtain a copy of the    }
{ License at http://www.mozilla.org/MPL/                                                           }
{                                                                                                  }
{ Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF   }
{ ANY KIND, either express or implied. See the License for the specific language governing rights  }
{ and limitations under the License.                                                               }
{                                                                                                  }
{ The Original Code is JclCOM.pas.                                                                 }
{                                                                                                  }
{ The Initial Developer of the Original Code is documented in the accompanying                     }
{ help file JCL.chm. Portions created by these individuals are Copyright (C) of these individuals. }
{                                                                                                  }
{**************************************************************************************************}
{                                                                                                  }
{ This unit contains Various COM (Component Object Model) utility routines.                        }
{                                                                                                  }
{ Unit owner: Marcel van Brakel                                                                    }
{ Last modified: February 27, 2002                                                                 }
{                                                                                                  }
{**************************************************************************************************}

unit JclCOM;

{$I jcl.inc}

{$WEAKPACKAGEUNIT ON}

interface

uses
  ActiveX, Classes,
  JclBase;

//--------------------------------------------------------------------------------------------------
// Various definitions
//--------------------------------------------------------------------------------------------------

const
  { Class ID's that may be reused }
  CLSID_StdComponentCategoriesMgr: TGUID = '{0002E005-0000-0000-C000-000000000046}';

  CATID_SafeForInitializing: TGUID = '{7DD95802-9882-11CF-9FA9-00AA006C42C4}';
  CATID_SafeForScripting: TGUID = '{7DD95801-9882-11CF-9FA9-00AA006C42C4}';

  icMAX_CATEGORY_DESC_LEN = 128;

type
  { For use with the Internet Explorer Component Categories Routines.  May be Reused. }
  TArrayCatID = array[0..0] of TGUID;

//--------------------------------------------------------------------------------------------------
// Exception classes
//--------------------------------------------------------------------------------------------------

type
  EInvalidParam = class (EJclError);

//--------------------------------------------------------------------------------------------------
// DCOM and MDAC Related Tests and Utility Routines
//--------------------------------------------------------------------------------------------------

function IsDCOMInstalled: Boolean;
function IsDCOMEnabled: Boolean;
function GetDCOMVersion: string;
function GetMDACVersion: string;

//--------------------------------------------------------------------------------------------------
// Other Marshalling Routines to complement "CoMarshalInterThreadInterfaceInStream"
//--------------------------------------------------------------------------------------------------

  { These routines will provide the ability to Marshal an Interface for a Seperate
    Process or even for access by a Seperate Machine.  However, to make things
    familiar to users of the existing CoMarshal... routine, I have kept the required
    Parameters the same, apart from the "stm" type now being a Var rather than just
    an Out - to allow a little flexibility if the developer wants the destination
    to be a specific stream, otherwise it creates one into the passed variable! }
function MarshalInterThreadInterfaceInVarArray(const iid: TIID;
  unk: IUnknown; var VarArray: OleVariant): HResult;
function MarshalInterProcessInterfaceInStream(const iid: TIID;
  unk: IUnknown; var stm: IStream): HResult;
function MarshalInterProcessInterfaceInVarArray(const iid: TIID;
  unk: IUnknown; var VarArray: OleVariant): HResult;
function MarshalInterMachineInterfaceInStream(const iid: TIID;
  unk: IUnknown; var stm: IStream): HResult;
function MarshalInterMachineInterfaceInVarArray(const iid: TIID;
  unk: IUnknown; var VarArray: OleVariant): HResult;

//--------------------------------------------------------------------------------------------------
// Internet Explorer Component Categories Routines
//--------------------------------------------------------------------------------------------------

  { These routines help with the registration of:
      - Safe-Initialization &
      - Safe-for-Scripting
    of ActiveX controls or COM Automation Servers intended to be used in
    HTML pages displayed in Internet Explorer }
  { Conversion of an examples found in Microsoft Development Network document:
    MSDN Home >  MSDN Library >  ActiveX Controls >  Overviews/Tutorials
    Safe Initialization and Scripting for ActiveX Controls }

function CreateComponentCategory(const CatID: TGUID; const sDescription: string): HResult;
function RegisterCLSIDInCategory(const ClassID: TGUID; const CatID: TGUID): HResult;
function UnRegisterCLSIDInCategory(const ClassID: TGUID; const CatID: TGUID): HResult;


//--------------------------------------------------------------------------------------------------
// Stream Related Routines
//--------------------------------------------------------------------------------------------------
  { IDE ISSUE:  These need to be at the bottom of the interface definition as otherwise
                the CTRL+SHIFT+ Up/Down arrows feature no-longer operates }

function ResetIStreamToStart(Stream: IStream): Boolean;
function SizeOfIStreamContents(Stream: IStream): Largeint;

{ Use VarIsEmpty to determine the result of the following XStreamToVariantArray routines!
  VarIsEmptry will return True if VarClear was called - indicating major problem! }
function StreamToVariantArray(Stream: TStream): OleVariant; overload;
function StreamToVariantArray(Stream: IStream): OleVariant; overload;

procedure VariantArrayToStream(VarArray: OleVariant; var Stream: TStream); overload;
procedure VariantArrayToStream(VarArray: OleVariant; var Stream: IStream); overload;

implementation

uses
  Windows, SysUtils,
  {$IFDEF COMPILER6_UP}
  Variants,
  {$ENDIF COMPILER6_UP}
  JclFileUtils, JclRegistry, JclResources, JclSysInfo, JclSysUtils, JclWin32;

{ Implementation Constants - may be reused by more than one routine }

const
  pcOLE32 = 'OLE32.dll';

  { TODO:  Utility routine here might need to be re-vamped with the
           use of JclUnicode unit in mind. }

//--------------------------------------------------------------------------------------------------

function StringToWideString(const Str: string): WideString;
var
  iLen: Integer;
begin
  iLen:= Length(Str) + 1;
  SetLength(Result, (iLen - 1));
  StringToWideChar(Str, PWideChar(Result), iLen);
end;

//==================================================================================================
// DCOM and MDAC Related Tests and Utility Routines
//==================================================================================================

function IsDCOMInstalled: Boolean;
var
  OLE32: HModule;
begin
  { DCOM is installed by default on all but Windows 95 }
  Result := not (GetWindowsVersion in [wvUnknown, wvWin95, wvWin95OSR2]);
  if not Result then
  begin
    OLE32 := LoadLibrary(pcOLE32);
    if OLE32 > 0 then
    try
      Result := GetProcAddress(OLE32, PChar('CoCreateInstanceEx')) <> nil;
    finally
      FreeLibrary(OLE32);
    end;
  end;
end;

//--------------------------------------------------------------------------------------------------

function IsDCOMEnabled: Boolean;
var
  RegValue: string;
begin
  RegValue := RegReadString(HKEY_LOCAL_MACHINE, 'Software\Microsoft\OLE', 'EnableDCOM');
  Result := (RegValue = 'y') or (RegValue = 'Y');
end;

//--------------------------------------------------------------------------------------------------

function GetDCOMVersion: string;
const
  DCOMVersionKey: PChar = 'CLSID\{bdc67890-4fc0-11d0-a805-00aa006d2ea4}\InstalledVersion';
begin
  { NOTE:  This does not work on Windows NT/2000! For a list of DCOM versions:
      http://support.microsoft.com/support/kb/articles/Q235/6/38.ASP }
  Result := '';
  if (Win32Platform = VER_PLATFORM_WIN32_WINDOWS) AND IsDCOMEnabled then
    Result := RegReadString(HKEY_CLASSES_ROOT, DCOMVersionKey, '')
  else
    { Possibly from DComExt.dll ‘Product Version’ }
    Result := 'DCOM Version Unknown';
end;

//--------------------------------------------------------------------------------------------------

{ NOTE:  Checking whether MDAC is installed at all can be done by querying the
         Software\Microsoft\DataAccess key for the FullInstallVer or
         Fill32InstallVer values. Windows 2000 always installs MDAC 2.5 }

function GetMDACVersion: string;
var
  Key: string;
  DLL: string;
  Version: TJclFileVersionInfo;
begin
  Result := '' ;
  Key := RegReadString(HKEY_CLASSES_ROOT, 'ADODB.Connection\CLSID', '');
  DLL := RegReadString(HKEY_CLASSES_ROOT, 'CLSID\' + Key + '\InprocServer32', '');
  if VersionResourceAvailable(DLL) then
  begin
    Version := TJclFileVersionInfo.Create(DLL);
    try
      Result := Version.ProductVersion;
    finally
      FreeAndNil(Version);
    end;
  end;
end;

//==================================================================================================
// Other Marshalling Routines to complement "CoMarshalInterThreadInterfaceInStream"
//==================================================================================================

function MarshalInterThreadInterfaceInVarArray(const iid: TIID; unk: IUnknown;
  var VarArray: OleVariant): HResult;
var
  msData: TMemoryStream;
  itfStream: IStream;
begin
  { TODO:  Test this routine.
    TOTEST:  D4, D5, D6 (CBx ??) }
  try
    { Will need a stream to obtain the data initially before creating the Variant Array }
    msData := TMemoryStream.Create;

    itfStream := (TStreamAdapter.Create(msData, soOwned) as IStream);

    { Probably would never get here in such a condition, but just in case }
    if itfStream = Nil then
    begin
      Result := E_OUTOFMEMORY;
      Exit;
    end;

    if itfStream <> Nil then
    begin
      { Different Machine }
      Result := CoMarshalInterThreadInterfaceInStream(iid, unk, itfStream);

      if Result <> S_OK then
        Exit;

      VarArray := StreamToVariantArray(itfStream);

      if VarIsNull(VarArray) or VarIsEmpty(VarArray) then
        Result := E_FAIL;
    end else
      { TODO:  Most likely out of memory, though should not reach here }
      Result := E_POINTER;
  except
    Result := E_UNEXPECTED;
  end;
end;

//--------------------------------------------------------------------------------------------------

function MarshalInterProcessInterfaceInStream(const iid: TIID; unk: IUnknown;
  var stm: IStream): HResult;
var
  msData: TMemoryStream;
begin
  { TODO:  Test this routine.
    TOTEST:  D4 (CBx ??) }
  try
    { If passed a variable which doesn't contain a valid stream, create and return }
    if stm = Nil then
    begin
      msData := TMemoryStream.Create;

      stm := (TStreamAdapter.Create(msData, soOwned) as IStream);

      { Probably would never get here in such a condition, but just in case }
      if stm = Nil then
      begin
        Result := E_OUTOFMEMORY;
        Exit;
      end;
    end else
      ResetIStreamToStart(stm);

    if stm <> Nil then
      { Same Machine, Different Process}
      Result := CoMarshalInterface(stm, iid, unk, MSHCTX_LOCAL, Nil, MSHLFLAGS_NORMAL)
    else
      { TODO:  Most likely out of memory, though should not reach here }
      Result := E_POINTER;
  except
    Result := E_UNEXPECTED;
  end;
end;

//--------------------------------------------------------------------------------------------------

function MarshalInterProcessInterfaceInVarArray(const iid: TIID;
  unk: IUnknown; var VarArray: OleVariant): HResult;
var
  itfStream: IStream;
begin
  { TODO:  Test this routine.
    TOTEST:  D4 (CBx ??) }
  Result := MarshalInterProcessInterfaceInStream(iid, unk, itfStream);

  if Result <> S_OK then
    Exit;

  { TODO:  Add compiler support for using a VCL Stream instead of an IStream here }
  { Otherwise convert from IStream into Variant Array }
  VarArray := StreamToVariantArray(itfStream);

  if VarIsNull(VarArray) or VarIsEmpty(VarArray) then
    Result := E_FAIL;
end;

//--------------------------------------------------------------------------------------------------

function MarshalInterMachineInterfaceInStream(const iid: TIID; unk: IUnknown;
  var stm: IStream): HResult;
var
  msData: TMemoryStream;
begin
  { TODO:  Test this routine.  Have no need for it myself at present.
    TOTEST:  D4 (CBx ??) }
  try
    { If passed a variable which doesn't contain a valid stream, create and return }
    if stm = Nil then
    begin
      msData := TMemoryStream.Create;

      stm := (TStreamAdapter.Create(msData, soOwned) as IStream);

      { Probably would never get here in such a condition, but just in case }
      if stm = Nil then
      begin
        Result := E_OUTOFMEMORY;
        Exit;
      end;
    end else
      ResetIStreamToStart(stm);

    if stm <> Nil then
      { Different Machine }
      Result := CoMarshalInterface(stm, iid, unk, MSHCTX_DIFFERENTMACHINE, Nil, MSHLFLAGS_NORMAL)
    else
      { TODO:  Most likely out of memory, though should not reach here }
      Result := E_POINTER;
  except
    Result := E_UNEXPECTED;
  end;
end;

//--------------------------------------------------------------------------------------------------

function MarshalInterMachineInterfaceInVarArray(const iid: TIID; unk: IUnknown;
  var VarArray: OleVariant): HResult;
var
  itfStream: IStream;
begin
  { TODO:  Test this routine.
    TOTEST:  D4 (CBx ??) }
  Result := MarshalInterMachineInterfaceInStream(iid, unk, itfStream);

  if Result <> S_OK then
    Exit;

  { TODO:  Add compiler support for using a VCL Stream instead of an IStream here }
  { Otherwise convert from IStream into Variant Array }
  VarArray := StreamToVariantArray(itfStream);

  if VarIsNull(VarArray) or VarIsEmpty(VarArray) then
    Result := E_FAIL;
end;

//==================================================================================================
// Internet Explorer Component Categories Routines
//==================================================================================================

function CreateComponentCategory(const CatID: TGUID; const sDescription: string): HResult;
var
  CatRegister: ICatRegister;
  hr: HResult;
  CatInfo: TCATEGORYINFO;
  iLen: Integer;
  sTemp: string;
  wsTemp: WideString;
begin
  { TODO:  Test this routine.
    TOTEST:  D4 (CBx ??) }
  CatRegister := Nil;

  hr := CoCreateInstance(CLSID_StdComponentCategoriesMgr,
          Nil, CLSCTX_INPROC_SERVER, ICatRegister, CatRegister);

  if Succeeded(hr) then
    try
      (* Make sure the:
           HKCR\Component Categories\{..catid...}
         key is registered *)
      CatInfo.catid := CatID;
      CatInfo.lcid := MAKELANGID(LANG_ENGLISH, SUBLANG_ENGLISH_US); // english

      { Make sure the provided description is not too long.
        Only copy the first 127 characters if it is. }
      iLen := Length(sDescription);
      if iLen > icMAX_CATEGORY_DESC_LEN then
         iLen := icMAX_CATEGORY_DESC_LEN;

      sTemp := Copy(sDescription, 1, iLen);
      wsTemp := StringToWideString(sTemp); 

      Move(Pointer(wsTemp)^, CatInfo.szDescription, (iLen * SizeOf(WideChar)));

      hr := CatRegister.RegisterCategories(1, @CatInfo);
    finally
      CatRegister := Nil;
    end;

  { Return the Appropriate Result }
  Result := hr;
end;

//--------------------------------------------------------------------------------------------------

function RegisterCLSIDInCategory(const ClassID: TGUID; const CatID: TGUID): HResult;
var
  CatRegister: ICatRegister;
  hr: HRESULT;
  arCatID: TArrayCatID;
begin
  { TODO:  Test this routine.
    TOTEST:  D4 (CBx ??) }
  { Register your component categories information }
  CatRegister := Nil;
  hr := CoCreateInstance(CLSID_StdComponentCategoriesMgr,
          Nil, CLSCTX_INPROC_SERVER, ICatRegister, CatRegister);

  if Succeeded(hr) then
    try
      { Register this category as being "implemented" by the class }
      arCatID[0] := CatID;
      hr := CatRegister.RegisterClassImplCategories(ClassID, 1, @arCatID);
    finally
      CatRegister := Nil;
    end;

  { Return the Appropriate Result }
  Result := hr;
end;

//--------------------------------------------------------------------------------------------------

function UnRegisterCLSIDInCategory(const ClassID: TGUID; const CatID: TGUID): HResult;
var
  CatRegister: ICatRegister;
  hr: HRESULT;
  arCatID: TArrayCatID;
begin
  { TODO:  Test this routine.
    TOTEST:  D4 (CBx ??) }
  CatRegister := Nil;

  hr := CoCreateInstance(CLSID_StdComponentCategoriesMgr,
          Nil, CLSCTX_INPROC_SERVER, ICatRegister, CatRegister);

  if Succeeded(hr) then
    try
      { Unregister this category as being "implemented" by the class }
      arCatID[0] := CatID;
      hr := CatRegister.UnRegisterClassImplCategories(ClassID, 1, @arCatID);
    finally
      CatRegister := Nil;
    end;

  { Return the Appropriate Result }
  Result := hr;
end;

//==================================================================================================
// Stream Related Routines
//==================================================================================================

function ResetIStreamToStart(Stream: IStream): Boolean;
var
  i64Pos: Largeint;
  hrSeek: HResult;
begin
  { TODO:  Test this routine.
    TOTEST:  D4 (CBx ??) }
  { Try to get the current stream position, and reset to start if not already there }
  if Succeeded(Stream.Seek(0, STREAM_SEEK_CUR, i64Pos)) then
  begin
    if i64Pos = 0 then
      hrSeek := S_OK
    else
      hrSeek := Stream.Seek(0, STREAM_SEEK_SET, i64Pos);
      { Another possible option was seen as:
        - Stream.Seek(0, STREAM_SEEK_SET, NULL); }

    Result := (hrSeek = S_OK);
  end else
    Result := False;
end;

//--------------------------------------------------------------------------------------------------

function SizeOfIStreamContents(Stream: IStream): Largeint;
var
  stat: TStatStg;
begin
  { TODO:  Test this routine.
    TOTEST:  D4 (CBx ??) }
  { If we can't determine the size of the Stream, then return -1 for Unattainable }
  if Succeeded(Stream.Stat(stat, STATFLAG_NONAME)) then
    Result := stat.cbSize
  else Result := -1;
end;

//--------------------------------------------------------------------------------------------------

function StreamToVariantArray(Stream: TStream): OleVariant;
var
  pLocked: Pointer;
begin
  { Use VarIsEmpty to determine the result of this method!
    VarIsEmptry will return True if VarClear was called - indicating major problem! }

  { TODO:  Test this routine.
    TOTEST:  D4 (CBx ??) }
  { Obviously, we must have a valid stream to perform this on }
  if NOT Assigned(Stream) then
    raise EInvalidParam.CreateResRec(@RsComInvalidParam);

  if Stream.Size > 0 then
  begin
    Result := VarArrayCreate([0, Stream.Size - 1], varByte);
    try
      pLocked := VarArrayLock(Result);
      try
        Stream.Position := 0;
        Stream.Read(pLocked^, Stream.Size);
      finally
        VarArrayUnlock(Result);
      end;
    except
      { If we get an exception, clean up the Variant so as not to return incomplete data! }
      VarClear(Result);

      { Alternative:  Re-Raise this Exception
      raise; }
    end;
  end else
    { Stream has no data! }
    Result := Null;
end;

//--------------------------------------------------------------------------------------------------

function StreamToVariantArray(Stream: IStream): OleVariant;
var
  pLocked: Pointer;
  iSize: Largeint;
  iReadCount: LongInt;
begin
  { Use VarIsEmpty to determine the result of this method!
    VarIsEmptry will return True if VarClear was called - indicating major problem! }

  { TODO:  Test this routine.
    TOTEST:  D4 (CBx ??) }
  { Obviously, we must have a valid stream to perform this on }
  if NOT Assigned(Stream) then
    raise EInvalidParam.CreateResRec(@RsComInvalidParam);

  iSize := SizeOfIStreamContents(Stream);
  if iSize > 0 then
  begin
    if ResetIStreamToStart(Stream) then
    begin
      Result := VarArrayCreate([0, iSize - 1], varByte);
      try
        pLocked := VarArrayLock(Result);
        try
          Stream.Read(pLocked, iSize, @iReadCount);

          if iReadCount <> iSize then
            { Error!  Didn't read all content! }
            raise EInOutError.Create(RsComFailedStreamRead);
        finally
          VarArrayUnlock(Result);
        end;
      except
        { If we get an exception, clean up the Variant so as not to return incomplete data! }
        VarClear(Result);

        { Alternative:  Re-Raise this Exception
        raise; }
      end;
    end else
      { Unable to Reset the Stream to Start!  Return Null Variant }
      Result := Null;
  end else
    { Stream has no data! }
    Result := Null;
end;

//--------------------------------------------------------------------------------------------------

procedure VariantArrayToStream(VarArray: OleVariant; var Stream: TStream);
var
  pLocked: Pointer;
begin
  { TODO:  Test this routine.
    TOTEST:  D4 (CBx ??) }
  { Check if the Variant is Empty or Null }
  if VarIsEmpty(VarArray) or VarIsNull(VarArray) then
    raise EInvalidParam.CreateResRec(@RsComInvalidParam);

  { TODO:  Should we allow them to write to the Stream, not matter what position it is at? }
  if Assigned(Stream) then
    Stream.Position := 0
  else
    Stream := TMemoryStream.Create;

  Stream.Size := VarArrayHighBound(VarArray, 1) - VarArrayLowBound(VarArray, 1) + 1;
  pLocked := VarArrayLock(VarArray);
  try
    Stream.Write(pLocked^, Stream.Size);
  finally
    VarArrayUnlock(VarArray);
    Stream.Position := 0;
  end;
end;

//--------------------------------------------------------------------------------------------------

procedure VariantArrayToStream(VarArray: OleVariant; var Stream: IStream);
var
  pLocked: Pointer;
  bCreated: Boolean;
  iSize: Largeint;
  iWriteCount: LongInt;
begin
  { TODO:  Test this routine.
    TOTEST:  D4 (CBx ??) }
  { Check if the Variant is Empty or Null }
  if VarIsEmpty(VarArray) or VarIsNull(VarArray) then
    raise EInvalidParam.CreateResRec(@RsComInvalidParam);

  bCreated := False;

  { TODO:  Should we allow them to write to the Stream, not matter what position it is at? }
  if Assigned(Stream) then
    ResetIStreamToStart(Stream)
  else
  begin
    Stream := (TStreamAdapter.Create(TMemoryStream.Create, soOwned) as IStream);
    bCreated := True;
  end;

  { Check to ensure creation went well, otherwise we might have run out of memory }
  if Stream <> Nil then
  begin
    iSize := VarArrayHighBound(VarArray, 1) - VarArrayLowBound(VarArray, 1) + 1;
    try
      Stream.SetSize(iSize);
      pLocked := VarArrayLock(VarArray);
      try
        Stream.Write(pLocked, iSize, @iWriteCount);

        if iWriteCount <> iSize then
          raise EInOutError.Create(RsComFailedStreamWrite);
      finally
        VarArrayUnlock(VarArray);
        ResetIStreamToStart(Stream);
      end;
    except
      if bCreated then
        Stream := Nil;

      raise; { Re-Raise this Exception }
    end;
  end;
end;

//--------------------------------------------------------------------------------------------------

end.
