{ Pascal unit for registering COM servers without administrative privileges.

(C) 2009-2014 Jan Holst Jensen, jan@biochemfusion.com.

This pascal source code unit (BCF_ComSrvReg.pas) is released under a BSD-style
license:

* Copyright (C) 2009-2014, Biochemfusion ApS (http://www.biochemfusion.com)
* All rights reserved.
*
* Redistribution and use for any purpose in source and binary forms, with or
* without modification, are permitted, subject to the following restrictions:
*
* 1. The origin of this software must not be misrepresented; you must not
*    claim that you wrote the original software. If you use this software
*    in a product, an acknowledgment in the product documentation would be
*    appreciated but is not required.
* 2. Altered source versions must be plainly marked as such, and must not be
*    misrepresented as being the original software.
* 3. This notice may not be removed or altered from any source distribution.
*
* THIS SOFTWARE IS PROVIDED BY Biochemfusion ``AS IS'' AND ANY
* EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
* DISCLAIMED. IN NO EVENT SHALL Biochemfusion BE LIABLE FOR ANY
* DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
* (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

}

unit BCF_ComSrvReg;

interface

uses
  Registry;

{ Registers and unregisters a COM server. If IsSystemWide is set to false
  registration will be done in HKEY_CURRENT_USER only, and so limited user
  accounts can register a user-local COM server and registration will not
  affect system settings at all.

  If you are on a 64-bit system and need to access the registry without
  being redirected (if you run this from a 32-bit process running on a
  64-bit OS) then set the Wow64Redirect flag to false. }

// If ExeName has the extension .EXE then a LocalServer32 entry is created,
// otherwise (e.g. a .DLL file) an InprocServer32 entry is produced with a
// ThreadingModel of 'Apartment'.
procedure RegisterCoClass(
  IsSystemWide: Boolean;
  const ProgID: String; MajorVersion, MinorVersion: Integer;
  const CoClassGuid, TypeLibGuid: TGUID;
  const ExeName, ServerDescription, CoClassDescription: String;
  Wow64Redirect: Boolean
);
procedure RegisterTypeLib(
  IsSystemWide: Boolean;
  const TypeLibGuid: TGUID; MajorVersion, MinorVersion: Integer;
  const ExeName, LibraryDescription: String;
  Wow64Redirect: Boolean
);
procedure RegisterInterface(
  IsSystemWide: Boolean;
  const InterfaceGuid, TypeLibGuid: TGUID; MajorVersion, MinorVersion: Integer;
  const InterfaceName: String;
  Wow64Redirect: Boolean
);

procedure UnregisterCoClass(IsSystemWide: Boolean; const CoClassGuid: TGUID; Wow64Redirect: Boolean);
procedure UnregisterTypeLib(IsSystemWide: Boolean; const TypeLibGuid: TGUID; Wow64Redirect: Boolean);
procedure UnregisterInterface(IsSystemWide: Boolean; const InterfaceGuid: TGUID; Wow64Redirect: Boolean);

procedure InitializeRegistry(Reg: TRegistry; ReadOnlyAccess, SystemWideAccess, ClearRedirect64: Boolean);

implementation

uses
  Windows, SysUtils;

const
  KEY_WOW64_64KEY = $0100;

procedure InitializeRegistry(Reg: TRegistry; ReadOnlyAccess, SystemWideAccess, ClearRedirect64: Boolean);
begin
  if ClearRedirect64 then begin
    if ReadOnlyAccess then
      Reg.Access := KEY_READ or KEY_WOW64_64KEY
    else
      Reg.Access := KEY_READ or KEY_WRITE or KEY_WOW64_64KEY;
  end
  else begin
    if ReadOnlyAccess then
      Reg.Access := KEY_READ
    else
      Reg.Access := KEY_READ or KEY_WRITE;
  end;

  if SystemWideAccess then
    Reg.RootKey := HKEY_LOCAL_MACHINE
  else
    Reg.RootKey := HKEY_CURRENT_USER;
end;

procedure TryToCreateKey(Reg: TRegistry; const AKeyName: String; const ADefaultKeyValue: String = '');
begin
  if not Reg.OpenKey(AKeyName, true) then
    raise Exception.CreateFmt('Unable to create or open registry key "%s".', [AKeyName]);
  if ADefaultKeyValue <> '' then
    Reg.WriteString('', ADefaultKeyValue);
end;

procedure TryToOpenKey(Reg: TRegistry; const APath: String);
begin
  if not Reg.OpenKey(APath, false) then
    raise Exception.CreateFmt('Unable to open registry key "%s".', [APath]);
end;

{ == Public functions == }

procedure RegisterCoClass(
  IsSystemWide: Boolean;
  const ProgID: String; MajorVersion, MinorVersion: Integer;
  const CoClassGuid, TypeLibGuid: TGUID;
  const ExeName, ServerDescription, CoClassDescription: String;
  Wow64Redirect: Boolean
);
var
  Reg: TRegistry;
  Version: String;
  ParentKey: String;
begin
  Reg := TRegistry.Create;
  try
    InitializeRegistry(Reg, false, IsSystemWide, not Wow64Redirect);
    Version := Format('%d.%d', [MajorVersion, MinorVersion]);
    { Register CoClass. }
    TryToOpenKey(Reg, '\Software\Classes\');
    TryToCreateKey(Reg, ProgID, ServerDescription);
    //
    TryToCreateKey(Reg, 'Clsid', GUIDToString(CoClassGuid));
    { Register CoClass implementation. }
    ParentKey := '\Software\Classes\CLSID\' + GUIDToString(CoClassGuid);
    TryToCreateKey(Reg, '\Software\Classes\CLSID\');
    TryToCreateKey(Reg, GUIDToString(CoClassGuid), CoClassDescription);
    TryToOpenKey(Reg, ParentKey); TryToCreateKey(Reg, 'LocalServer32', ExeName);
	// Local server executable or in-process library ?
    if LowerCase(ExtractFileExt(ExeName)) = '.exe' then
      TryToCreateKey(Reg, 'LocalServer32', ExeName)
    else begin
      TryToCreateKey(Reg, 'InprocServer32', ExeName);
      Reg.WriteString('ThreadingModel', 'Apartment');
    end;
    TryToOpenKey(Reg, ParentKey); TryToCreateKey(Reg, 'ProgID', ProgID);
    TryToOpenKey(Reg, ParentKey); TryToCreateKey(Reg, 'Programmable');
    TryToOpenKey(Reg, ParentKey); TryToCreateKey(Reg, 'TypeLib', GUIDToString(TypeLibGuid));
    TryToOpenKey(Reg, ParentKey); TryToCreateKey(Reg, 'Version', Version);
  finally
    Reg.Free;
  end;
end;

procedure RegisterTypeLib(
  IsSystemWide: Boolean;
  const TypeLibGuid: TGUID; MajorVersion, MinorVersion: Integer;
  const ExeName, LibraryDescription: String;
  Wow64Redirect: Boolean
);
var
  Reg: TRegistry;
  Version: String;
  ParentKey: String;
begin
  Reg := TRegistry.Create;
  try
    InitializeRegistry(Reg, false, IsSystemWide, not Wow64Redirect);
    Version := Format('%d.%d', [MajorVersion, MinorVersion]);
    { Register TypeLib. }
    ParentKey := '\Software\Classes\TypeLib\' + GUIDToString(TypeLibGuid) + '\' + Version;
    TryToCreateKey(Reg, '\Software\Classes\TypeLib\');
    TryToCreateKey(Reg, GUIDToString(TypeLibGuid));
    TryToCreateKey(Reg, Version, LibraryDescription);
    TryToCreateKey(Reg, '0');
    TryToCreateKey(Reg, 'win32', ExeName);
    TryToOpenKey(Reg, ParentKey); TryToCreateKey(Reg, 'Flags', '0');
    TryToOpenKey(Reg, ParentKey); TryToCreateKey(Reg, 'HELPDIR', ExtractFilePath(ExeName));
  finally
    Reg.Free;
  end;
end;

procedure RegisterInterface(
  IsSystemWide: Boolean;
  const InterfaceGuid, TypeLibGuid: TGUID; MajorVersion, MinorVersion: Integer;
  const InterfaceName: String;
  Wow64Redirect: Boolean
);
var
  Reg: TRegistry;
  Version: String;
  ParentKey: String;
begin
  Reg := TRegistry.Create;
  try
    InitializeRegistry(Reg, false, IsSystemWide, not Wow64Redirect);
    Version := Format('%d.%d', [MajorVersion, MinorVersion]);
    { Register interface. }
    ParentKey := '\Software\Classes\Interface\' + GUIDToString(InterfaceGuid);
    TryToCreateKey(Reg, '\Software\Classes\Interface\');
    TryToCreateKey(Reg, GUIDToString(InterfaceGuid), InterfaceName);
    TryToOpenKey(Reg, ParentKey); TryToCreateKey(Reg, 'ProxyStubClsId', '{00020424-0000-0000-C000-000000000046}');
    TryToOpenKey(Reg, ParentKey); TryToCreateKey(Reg, 'ProxyStubClsId32', '{00020424-0000-0000-C000-000000000046}');
    TryToOpenKey(Reg, ParentKey); TryToCreateKey(Reg, 'TypeLib', GUIDToString(TypeLibGuid));
    Reg.WriteString('Version', Version);
  finally
    Reg.Free;
  end;
end;

procedure UnregisterCoClass(IsSystemWide: Boolean; const CoClassGuid: TGUID; Wow64Redirect: Boolean);
var
  Reg: TRegistry;
  ProgID: String;
begin
  Reg := TRegistry.Create;
  try
    InitializeRegistry(Reg, false, IsSystemWide, not Wow64Redirect);
    { Remove CoClass. }
    TryToOpenKey(Reg, '\Software\Classes\CLSID\' + GUIDToString(CoClassGuid) + '\ProgID\');
    ProgID := Reg.ReadString('');
    if ProgID = '' then
      raise Exception.CreateFmt('CoClass %s has no associated ProgID.', [GUIDToString(CoClassGuid)]);
    TryToOpenKey(Reg, '\Software\Classes\CLSID\');
    Reg.DeleteKey(GUIDToString(CoClassGuid));

    TryToOpenKey(Reg, '\Software\Classes\');
    Reg.DeleteKey(ProgID);
  finally
    Reg.Free;
  end;
end;

procedure UnregisterTypeLib(IsSystemWide: Boolean; const TypeLibGuid: TGUID; Wow64Redirect: Boolean);
var
  Reg: TRegistry;
begin
  Reg := TRegistry.Create;
  try
    InitializeRegistry(Reg, false, IsSystemWide, not Wow64Redirect);
    { Remove TypeLib. }
    TryToOpenKey(Reg, '\Software\Classes\TypeLib\');
    Reg.DeleteKey(GUIDToString(TypeLibGuid));
  finally
    Reg.Free;
  end;
end;

procedure UnregisterInterface(IsSystemWide: Boolean; const InterfaceGuid: TGUID; Wow64Redirect: Boolean);
var
  Reg: TRegistry;
begin
  Reg := TRegistry.Create;
  try
    InitializeRegistry(Reg, false, IsSystemWide, not Wow64Redirect);
    { Remove interface. }
    TryToOpenKey(Reg, '\Software\Classes\Interface\');
    Reg.DeleteKey(GUIDToString(InterfaceGuid));
  finally
    Reg.Free;
  end;
end;

end.