unit DXPlay;

interface

{$INCLUDE DelphiXcfg.inc}

uses
  Windows, SysUtils, Classes, Forms, DXClass, ActiveX, DirectX, DXETable;
                                                                        
type

  {  TDXPlayPlayer  }

  TDXPlayPlayer = class(TCollectionItem)
  private
    FData: Pointer;
    FID: TDPID;
    FName: string;
    FRemotePlayer: Boolean;
  public
    property Data: Pointer read FData write FData;
    property ID: TDPID read FID;
    property Name: string read FName;
    property RemotePlayer: Boolean read FRemotePlayer;
  end;

  {  TDXPlayPlayers  }

  TDXPlayPlayers = class(TCollection)
  private
    function GetPlayer(Index: Integer): TDXPlayPlayer;
  public
    constructor Create;
    function Find(ID: TDPID): TDXPlayPlayer;
    function IndexOf(ID: TDPID): Integer;
    property Players[Index: Integer]: TDXPlayPlayer read GetPlayer; default;
  end;

  {  TDXPlayModemSetting  }

  TDXPlayModemSetting = class(TPersistent)
  private
    FEnabled: Boolean;
    FPhoneNumber: string;
    FModemName: string;
    FModemNames: TStrings;
    function GetModemNames: TStrings;
  public
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    property ModemName: string read FModemName write FModemName;
    property ModemNames: TStrings read GetModemNames;
  published
    property Enabled: Boolean read FEnabled write FEnabled;
    property PhoneNumber: string read FPhoneNumber write FPhoneNumber;
  end;

  {  TDXPlayTCPIPSetting  }

  TDXPlayTCPIPSetting = class(TPersistent)
  private
    FEnabled: Boolean;
    FHostName: string;
    FPort: Word;
  public
    procedure Assign(Source: TPersistent); override;
  published
    property Enabled: Boolean read FEnabled write FEnabled;
    property HostName: string read FHostName write FHostName;
    property Port: Word read FPort write FPort;
  end;

  {  EDXPlayError  }

  EDXPlayError = class(Exception);

  {  TCustomDXPlay  }

  TDXPlayEvent = procedure(Sender: TObject; Player: TDXPlayPlayer) of object;

  TDXPlayMessageEvent = procedure(Sender: TObject; From: TDXPlayPlayer;
    Data: Pointer; DataSize: Integer) of object;

  TDXPlaySendCompleteResult = (crOk, crAbort, crGeneric);

  TDXPlaySendCompleteEvent = procedure(Sender: TObject; MessageID: DWORD;
    Result: TDXPlaySendCompleteResult; SendTime: Integer) of object;

  TCustomDXPlay = class(TComponent)
  private
    FDPlay: IDirectPlay4A;
    FGUID: string;
    FIsHost: Boolean;
    FLocalPlayer: TDXPlayPlayer;
    FMaxPlayers: Integer;
    FPlayers: TDXPlayPlayers;
    FCalledDoOpen: Boolean;
    FOnAddPlayer: TDXPlayEvent;
    FOnClose: TNotifyEvent;
    FOnDeletePlayer: TDXPlayEvent;
    FOnMessage: TDXPlayMessageEvent;
    FOnOpen: TNotifyEvent;
    FOnSendComplete: TDXPlaySendCompleteEvent;
    FOnSessionLost: TNotifyEvent;
    FOpened: Boolean;
    FRecvEvent: array[0..1] of THandle;
    FRecvThread: TThread;
    FInThread: Boolean;
    FProviderName: string;
    FProviders: TStrings;
    FSessionName: string;
    FSessions: TStrings;
    FReadSessioned: Boolean;
    FModemSetting: TDXPlayModemSetting;
    FTCPIPSetting: TDXPlayTCPIPSetting;
    FAsync: Boolean;
    FAsyncSupported: Boolean;
    procedure ChangeDPlay;
    procedure CreateDPlayWithoutDialog(out DPlay: IDirectPlay4A; const ProviderName: string);
    function OpenDPlayWithLobby(out Name: string): Boolean;
    function OpenDPlayWithoutLobby(out Name: string): Boolean;
    function OpenDPlayWithoutLobby2(const NewSession: Boolean; const ProviderName, SessionName, PlayerName: string): Boolean;
    procedure Open_(NameS: string);
    procedure ReceiveMessage;
    function GetProviders: TStrings;
    function GetSessionsPty: TStrings;
    procedure ClearSessionList;
    procedure SetGUID(const Value: string);
    procedure SetModemSetting(Value: TDXPlayModemSetting);
    procedure SetProviderName(const Value: string);
    procedure SetTCPIPSetting(Value: TDXPlayTCPIPSetting);
  protected
    procedure DoAddPlayer(Player: TDXPlayPlayer); virtual;
    procedure DoClose; virtual;
    procedure DoDeletePlayer(Player: TDXPlayPlayer); virtual;
    procedure DoMessage(From: TDXPlayPlayer; Data: Pointer; DataSize: Integer); virtual;
    procedure DoOpen; virtual;
    procedure DoSessionLost; virtual;
    procedure DoSendComplete(MessageID: DWORD; Result: TDXPlaySendCompleteResult;
      SendTime: Integer); virtual;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Close;
    procedure Open;
    procedure Open2(NewSession: Boolean; const SessionName, PlayerName: string);
    function GetProviderNameFromGUID(const ProviderGUID: TGUID): string;
    procedure GetSessions;
    procedure SendMessage(ToID: TDPID; Data: Pointer; DataSize: Integer);
    function SendMessageEx(ToID: TDPID; Data: Pointer; DataSize: Integer;
      dwFlags: DWORD): DWORD;
    property GUID: string read FGUID write SetGUID;
    property IsHost: Boolean read FIsHost;
    property LocalPlayer: TDXPlayPlayer read FLocalPlayer;
    property MaxPlayers: Integer read FMaxPlayers write FMaxPlayers;
    property OnAddPlayer: TDXPlayEvent read FOnAddPlayer write FOnAddPlayer;
    property OnClose: TNotifyEvent read FOnClose write FOnClose;
    property OnDeletePlayer: TDXPlayEvent read FOnDeletePlayer write FOnDeletePlayer;
    property OnMessage: TDXPlayMessageEvent read FOnMessage write FOnMessage;
    property OnOpen: TNotifyEvent read FOnOpen write FOnOpen;
    property OnSendComplete: TDXPlaySendCompleteEvent read FOnSendComplete write FOnSendComplete;
    property OnSessionLost: TNotifyEvent read FOnSessionLost write FOnSessionLost;
    property Opened: Boolean read FOpened;
    property Players: TDXPlayPlayers read FPlayers;
    property ProviderName: string read FProviderName write SetProviderName;
    property Providers: TStrings read GetProviders;
    property SessionName: string read FSessionName;
    property Sessions: TStrings read GetSessionsPty;
    property ModemSetting: TDXPlayModemSetting read FModemSetting write SetModemSetting;
    property TCPIPSetting: TDXPlayTCPIPSetting read FTCPIPSetting write SetTCPIPSetting;
    property Async: Boolean read FAsync write FAsync;
    property AsyncSupported: Boolean read FAsyncSupported;
  end;

  TDXPlay = class(TCustomDXPlay)
  published
    property Async;
    property GUID;
    property MaxPlayers;
    property ModemSetting;
    property TCPIPSetting;
    property OnAddPlayer;
    property OnClose;
    property OnDeletePlayer;
    property OnMessage;
    property OnOpen;
    property OnSendComplete;
    property OnSessionLost;
  end;

function DXPlayMessageType(P: Pointer): DWORD;

function DXPlayStringToGUID(const S: string): TGUID;
function DXDirectPlayCreate(const lpGUID: TGUID; out lplpDP: IDirectPlay;
  pUnk: IUnknown): HRESULT;

implementation

uses DXPlayFm, DXConsts;

function DXPlayMessageType(P: Pointer): DWORD;
begin
  Result := PDPMSG_GENERIC(P)^.dwType;
end;

function DXPlayStringToGUID(const S: string): TGUID;
var
  ErrorCode: Integer;
begin
  ErrorCode := CLSIDFromString(PWideChar(WideString(S)), Result);
  if ErrorCode<0 then
    raise EDXPlayError.Create(WindowsErrorMsg(ErrorCode));
end;

function GUIDToString(const ClassID: TGUID): string;
var
  ErrorCode: Integer;
  P: PWideChar;
begin
  ErrorCode := StringFromCLSID(ClassID, P);
  if ErrorCode<0 then
    raise EDXPlayError.Create(WindowsErrorMsg(ErrorCode));
  Result := P;
  CoTaskMemFree(P);
end;

function DXDirectPlayCreate(const lpGUID: TGUID; out lplpDP: IDirectPlay;
  pUnk: IUnknown): HRESULT;
type
  TDirectPlayCreate= function(const lpGUID: TGUID; out lplpDP: IDirectPlay; pUnk: IUnknown): HRESULT; stdcall;
begin
  Result := TDirectPlayCreate(DXLoadLibrary('DPlayX.dll', 'DirectPlayCreate'))
    (lpGUID, lplpDP, pUnk);
end;

function DXDirectPlayEnumerateA(lpEnumDPCallback: TDPEnumDPCallbackA; lpContext: Pointer): HRESULT;
type
  TDirectPlayEnumerateA= function(lpEnumDPCallback: TDPEnumDPCallbackA; lpContext: Pointer): HRESULT; stdcall;
begin
  Result := TDirectPlayEnumerateA(DXLoadLibrary('DPlayX.dll', 'DirectPlayEnumerateA'))
    (lpEnumDPCallback, lpContext);
end;

function DXDirectPlayLobbyCreateA(const lpguidSP: TGUID; out lplpDPL: IDirectPlayLobbyA;
  lpUnk: IUnknown; lpData: Pointer; dwDataSize: DWORD): HRESULT;
type
  TDirectPlayLobbyCreateA = function(const lpguidSP: TGUID; out lplpDPL: IDirectPlayLobbyA;
    lpUnk: IUnknown; lpData: Pointer; dwDataSize: DWORD): HRESULT; stdcall;
begin
  Result := TDirectPlayLobbyCreateA(DXLoadLibrary('DPlayX.dll', 'DirectPlayLobbyCreateA'))
    (lpguidSP, lplpDPL, lpUnk, lpData, dwDataSize);
end;

{  TDXPlayPlayers  }

constructor TDXPlayPlayers.Create;
begin
  inherited Create(TDXPlayPlayer);
end;

function TDXPlayPlayers.Find(ID: TDPID): TDXPlayPlayer;
var
  i: Integer;
begin
  i := IndexOf(ID);
  if i=-1 then
    raise EDXPlayError.Create(SDXPlayPlayerNotFound);
  Result := Players[i];
end;

function TDXPlayPlayers.IndexOf(ID: TDPID): Integer;
var
  i: Integer;
begin
  for i:=0 to Count-1 do
    if Players[i].FID=ID then
    begin
      Result := i;
      Exit;
    end;
  Result := -1;
end;

function TDXPlayPlayers.GetPlayer(Index: Integer): TDXPlayPlayer;
begin
  Result := TDXPlayPlayer(Items[Index]);
end;

{  TDXPlayModemSetting  }

destructor TDXPlayModemSetting.Destroy;
begin
  FModemNames.Free;
  inherited Destroy;
end;

procedure TDXPlayModemSetting.Assign(Source: TPersistent);
begin
  if Source is TDXPlayModemSetting then
  begin
    FEnabled := TDXPlayModemSetting(Source).FEnabled;
    FPhoneNumber := TDXPlayModemSetting(Source).FPhoneNumber;
    FModemName := TDXPlayModemSetting(Source).FModemName;
  end else
    inherited Assign(Source);
end;

function TDXPlayModemSetting.GetModemNames: TStrings;

  function EnumModemAddress(const guidDataType: TGUID;
    dwDataSize: DWORD; lpData: Pointer; lpContext: Pointer): BOOL; stdcall;
  begin
    if CompareMem(@guidDataType, @DPAID_Modem, SizeOf(TGUID)) then
      TStrings(lpContext).Add( PChar(lpData));
    Result := True;
  end;

var
  Lobby1: IDirectPlayLobbyA;
  Lobby: IDirectPlayLobby2A;
  DPlay1: IDirectPlay;
  DPlay: IDirectPlay4A;
  lpAddress: Pointer;
  dwAddressSize: DWORD;
begin
  if FModemNames=nil then
  begin
    FModemNames := TStringList.Create;
    try
      if DXDirectPlayLobbyCreateA(PGUID(nil)^, Lobby1, nil, nil, 0)<>0 then
        raise EDXPlayError.CreateFmt(SCannotInitialized, [SDirectPlay]);
      Lobby := Lobby1 as IDirectPlayLobby2A;

      if DXDirectPlayCreate(DPSPGUID_MODEM, DPlay1, nil)<>0 then
        raise EDXPlayError.CreateFmt(SCannotInitialized, [SDirectPlay]);
      DPlay := DPlay1 as IDirectPlay4A;

      {  get size of player address for all players  }
      if DPlay.GetPlayerAddress(DPID_ALLPLAYERS, nil^, dwAddressSize)<>DPERR_BUFFERTOOSMALL then
        raise EDXPlayError.Create(SDXPlayModemListCannotBeAcquired);

      GetMem(lpAddress, dwAddressSize);
      try
        FillChar(lpAddress^, dwAddressSize, 0);

        {  get the address  }
        if DPlay.GetPlayerAddress(DPID_ALLPLAYERS, lpAddress^, dwAddressSize)<>0 then
          raise EDXPlayError.Create(SDXPlayModemListCannotBeAcquired);

        {  get modem strings from address and put them in the combo box  }
        if Lobby.EnumAddress(@EnumModemAddress, lpAddress^, dwAddressSize, FModemNames)<>0 then
          raise EDXPlayError.Create(SDXPlayModemListCannotBeAcquired);
      finally
        FreeMem(lpAddress);
      end;
    except
      FModemNames.Free; FModemNames := nil;
      raise;
    end;
  end;

  Result := FModemNames;
end;

{  TDXPlayTCPIPSetting  }

procedure TDXPlayTCPIPSetting.Assign(Source: TPersistent);
begin
  if Source is TDXPlayTCPIPSetting then
  begin
    FEnabled := TDXPlayTCPIPSetting(Source).FEnabled;
    FHostName := TDXPlayTCPIPSetting(Source).FHostName;
  end else
    inherited Assign(Source);
end;

{  TCustomDXPlay  }

constructor TCustomDXPlay.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FPlayers := TDXPlayPlayers.Create;
  FModemSetting := TDXPlayModemSetting.Create;