{ 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 IntfScanner.pas                                 }
{                                                                      }
{ The Initial Developer of the Original Code is Ashley Godfrey, all    }
{ Portions created by these individuals are Copyright (C) of Ashley    }
{ Godfrey.                                                             }
{                                                                      }
{**********************************************************************}
{                                                                      }
{ This unit contains code that helps to identify what interfaces and   }
{ services any given interface supports by scanning against a list of  }
{ known interfaces, and the list of interfaces registered in the       }
{ system registry.                                                     }
{                                                                      }
{ Unit owner: Ashley Godfrey.                                          }
{ Last modified: April 13, 2004.                                       }
{ Updates available from http://www.evocorp.com                        }
{                                                                      }
{**********************************************************************}

{$WRITEABLECONST ON}

unit IntfScanner;

interface
uses
  SysUtils, Classes, ActiveX;

type
  // TInterfaceScanSource is used to identify where the information
  // used to interrogate an interface comes from.
  //   ssKnown means that we're going to load a list of known
  //           interfaces from the file IridiumXKnownIntfs.dat
  //   ssRegistry means that we'll use information obtained from
  //              the system registry to use for scanning
  TInterfaceScanSource = (ssKnown, ssRegistry);
  TInterfaceScanSources = set of TInterfaceScanSource;

  TInterfaceItem = record
    IID: TGUID;              // Actual IID of the interface scanned
    pInterface: IInterface;  // Interface returned for this IID
    sIID: string;            // Friendly name of this IID, if known,
                             // otherwise contains a string
                             // representation of the IID field.
  end;
  pInterfaceItem = ^TInterfaceItem;

  TInterfaceItems = class
  private
    FItems: TList;
    procedure Add(const InterfaceItem: TInterfaceItem);
    function GetCount: Integer;
    function GetItem(Index: Integer): TInterfaceItem;
  public
    procedure Clear;
    procedure CopyToStrings(Strings: TStrings;
      const ClearStrings: Boolean = True);
    procedure Delete(Index: Integer);
    constructor Create;
    destructor Destroy; override;
    function Exists(const IID: TGUID): Boolean; overload;
    function Exists(const pInterface: IInterface): Boolean; overload;
    function IndexOf(const IID: TGUID): Integer; overload;
    function IndexOf(const pInterface: IInterface): Integer; overload;

    property Count: Integer read GetCount;
    property Items[Index: Integer]: TInterfaceItem read GetItem; default;
  end;

// Both InterrogateInterfaces and InterrogateServices return the
// total number of interfaces discovered.
function InterrogateInterfaces(const pIntfToScan: IInterface;
  ScanSources: TInterfaceScanSources; InterfacesFound: TInterfaceItems): Integer;
function InterrogateServices(const pIntfToScan: IInterface;
  ScanSources: TInterfaceScanSources; InterfacesFound: TInterfaceItems): Integer;

implementation
uses
  Windows, SyncObjs, Registry;

const
  sKnownIntfsFilename = 'IridiumXKnownIntfs.dat';
  _InterfaceLoadSection: TCriticalSection = nil;
  _KnownInterfaces: TInterfaceItems = nil;
  _RegistryInterfaces: TInterfaceItems = nil;

procedure LoadKnownInterfaces;
var Strings: TStringList;
    IntfItem: TInterfaceItem;
    i, iPos: Integer;
    FileNameArray: array [0..MAX_PATH + 1] of char;
    FileName: string;
begin
  IntfItem.pInterface := nil;
  
  // Load the list of known interfaces from our file.
  FillChar(FileNameArray, SizeOf(FileNameArray), 0);
  GetModuleFileName(hInstance, @FileNameArray, MAX_PATH);
  FileName := ExtractFilePath(FileNameArray) + sKnownIntfsFilename;
  if not FileExists(FileName) then
    raise Exception.Create('The file "' + sKnownIntfsFilename + '" was not ' +
                           'found in folder ' + ExtractFilePath(FileNameArray))
  else begin
    Strings := TStringList.Create;
    try
      Strings.LoadFromFile(FileName);
      if Strings.Count > 0 then
        for i := 0 to Strings.Count - 1 do
        begin
          // Extract the friendly name
          IntfItem.sIID := Strings.Names[i];
          // Extract the IID
          iPos := Pos('=', Strings[i]);
          IntfItem.IID := StringToGUID(Copy(Strings[i], iPos + 1, MaxInt));
          // Add this item to the list.
          _KnownInterfaces.Add(IntfItem);
        end;
    finally
      Strings.Free;
    end;
  end;
end;

function KnownInterfaces: TInterfaceItems;
begin
  if _KnownInterfaces = nil then
  begin
    // Make sure that we only do this once.
    _InterfaceLoadSection.Enter;
    try
      _KnownInterfaces := TInterfaceItems.Create;
      LoadKnownInterfaces;
    finally
      _InterfaceLoadSection.Leave;
    end;
  end;
  Result := _KnownInterfaces;
end;

procedure LoadRegistryInterfaces;
var Reg: TRegistry;
    IntfKeys: TStringList;
    IntfItem: TInterfaceItem;
    i: Integer;
begin
  IntfItem.pInterface := nil;
  Reg := TRegistry.Create;
  with Reg do
  try
    RootKey := HKEY_CLASSES_ROOT;
    if OpenKeyReadOnly('\Interface') then
    begin
      IntfKeys := TStringList.Create;
      try
        GetKeyNames(IntfKeys);
        if IntfKeys.Count > 0 then
          for i := 0 to IntfKeys.Count - 1 do
            if OpenKeyReadOnly('\Interface\' + IntfKeys[i]) then
            try
              IntfItem.IID := StringToGUID(IntfKeys[i]);
              // The default value should identify the interface name...
              IntfItem.sIID := ReadString('');
              // ...but if not, then the friendly name will be the GUID.
              if IntfItem.sIID = '' then
                IntfItem.sIID := IntfKeys[i];
              _RegistryInterfaces.Add(IntfItem);
            except
              // Continue
            end;
      finally
        IntfKeys.Free;
      end;
    end;
  finally
    Reg.Free;
  end;
end;

function RegistryInterfaces: TInterfaceItems;
begin
  // Because loading interface information from the registry can take
  // a particularly long time, we'll only load that information when
  // necessary.
  if _RegistryInterfaces = nil then
  begin
    // Make sure that we only do this once.
    _InterfaceLoadSection.Enter;
    try
      _RegistryInterfaces := TInterfaceItems.Create;
      LoadRegistryInterfaces;
    finally
      _InterfaceLoadSection.Leave;
    end;
  end;
  Result := _RegistryInterfaces;
end;

type
  TInterrogateType = (itQueryInterface, itQueryService);

procedure Interrogate(
  const pIntfToScan: IInterface; InterrogateType: TInterrogateType;
  SourceInterfaces, InterfacesFound: TInterfaceItems);
var i: Integer;
    pInterface: IInterface;
    pServiceProvider: IServiceProvider;
    IntfItem: TInterfaceItem;
    ItemFound: Boolean;
begin
  pointer(pServiceProvider) := nil;
  if InterrogateType = itQueryService then
    if pIntfToScan.QueryInterface(IServiceProvider, pServiceProvider) <> S_OK then
      Exit;
  try
    if SourceInterfaces.Count > 0 then
      for i := 0 to SourceInterfaces.Count - 1 do
        // Don't bother querying for the same IID multiple times
        // (which can happen if the interface we're querying for
        // exists in both the known interfaces list and the system
        // registry).
        if not InterfacesFound.Exists(SourceInterfaces[i].IID) then
        try
          case InterrogateType of
            itQueryInterface: ItemFound := pIntfToScan.QueryInterface(
              SourceInterfaces[i].IID, pInterface) = S_OK;
            itQueryService: ItemFound := pServiceProvider.QueryService(
              SourceInterfaces[i].IID, IUnknown, pInterface) = S_OK;
          else
            ItemFound := False;
          end;

          if ItemFound then
          begin
            IntfItem := SourceInterfaces[i];
            IntfItem.pInterface := pInterface;
            InterfacesFound.Add(IntfItem);
          end;
        finally
          pInterface := nil;
        end;
  finally
    pServiceProvider := nil;
  end;
end;

function InterrogateInterfaces(const pIntfToScan: IInterface;
  ScanSources: TInterfaceScanSources; InterfacesFound: TInterfaceItems): Integer;
begin
  Result := 0;
  if (pIntfToScan <> nil) and
     (ScanSources <> []) and
     Assigned(InterfacesFound) then
  begin
    InterfacesFound.Clear;
    if ssKnown in ScanSources then
      Interrogate(pIntfToScan, itQueryInterface, KnownInterfaces, InterfacesFound);
    if ssRegistry in ScanSources then
      Interrogate(pIntfToScan, itQueryInterface, RegistryInterfaces, InterfacesFound);
    Result := InterfacesFound.Count;
  end;
end;

function InterrogateServices(const pIntfToScan: IInterface;
  ScanSources: TInterfaceScanSources; InterfacesFound: TInterfaceItems): Integer;
begin
  Result := 0;
  if (pIntfToScan <> nil) and
     Supports(pIntfToScan, IServiceProvider) and
     (ScanSources <> []) and
     Assigned(InterfacesFound) then
  begin
    InterfacesFound.Clear;
    if ssKnown in ScanSources then
      Interrogate(pIntfToScan, itQueryService, KnownInterfaces, InterfacesFound);
    if ssRegistry in ScanSources then
      Interrogate(pIntfToScan, itQueryService, RegistryInterfaces, InterfacesFound);
  end;
end;

{ TInterfaceItems }

procedure TInterfaceItems.Add(const InterfaceItem: TInterfaceItem);
var Item: pInterfaceItem;
begin
  New(Item);
  Item^ := InterfaceItem;
  FItems.Add(Item);
end;

procedure TInterfaceItems.Clear;
var i: Integer;
begin
  if Assigned(FItems) and (FItems.Count > 0) then
    for i := FItems.Count - 1 downto 0 do
      Delete(i);
end;

procedure TInterfaceItems.CopyToStrings(Strings: TStrings;
  const ClearStrings: Boolean = True);
var i: Integer;
begin
  if ClearStrings then
    Strings.Clear;
    
  if Assigned(FItems) and (FItems.Count > 0) then
    for i := 0 to FItems.Count - 1 do
      Strings.Add(pInterfaceItem(FItems[i])^.sIID);
end;

constructor TInterfaceItems.Create;
begin
  FItems := TList.Create;
end;

procedure TInterfaceItems.Delete(Index: Integer);
var Item: pInterfaceItem;
begin
  Item := pInterfaceItem(FItems[Index]);
  FItems.Delete(Index);
  Dispose(Item);
end;

destructor TInterfaceItems.Destroy;
begin
  if Assigned(FItems) then
  try
    Clear;
  finally
    FreeAndNil(FItems);
  end;

  inherited;
end;

function TInterfaceItems.Exists(const IID: TGUID): Boolean;
begin
  Result := IndexOf(IID) <> -1;
end;

function TInterfaceItems.Exists(const pInterface: IInterface): Boolean;
begin
  Result := IndexOf(pInterface) <> -1;
end;

function TInterfaceItems.GetCount: Integer;
begin
  Result := FItems.Count;
end;

function TInterfaceItems.GetItem(Index: Integer): TInterfaceItem;
begin
  Result := pInterfaceItem(FItems[Index])^;
end;

function TInterfaceItems.IndexOf(const IID: TGUID): Integer;
begin
  if FItems.Count > 0 then
    for Result := 0 to FItems.Count - 1 do
      if IsEqualGUID(pInterfaceItem(FItems[Result])^.IID, IID) then
        Exit;
  Result := -1;
end;

function TInterfaceItems.IndexOf(const pInterface: IInterface): Integer;
begin
  if FItems.Count > 0 then
    for Result := 0 to FItems.Count - 1 do
      if pInterfaceItem(FItems[Result])^.pInterface = pInterface then
        Exit;
  Result := -1;
end;

initialization
  _InterfaceLoadSection := TCriticalSection.Create;

finalization
  if Assigned(_KnownInterfaces) then
    FreeAndNil(_KnownInterfaces);
  if Assigned(_RegistryInterfaces) then
    FreeAndNil(_RegistryInterfaces);
  if Assigned(_InterfaceLoadSection) then
    FreeAndNil(_InterfaceLoadSection);

end.