Chip 2002 September/Chip_2002-09_cd1.bin/zkuste/vbasic/Data/Utils/XZipComp.exe/XceedWinsock.Cab/F112667_unChat.pas

Pascal/Delphi Source File | 2000-05-16 | 29.5 KB | 731 lines

unit unChat;

{
 Xceed Winsock Library Sample: Chat
 Copyright (c) 2000 Xceed Software Inc.

 This is a traditional chat application that uses a connection-oriented
 protocol (TCP/IP) to connect another user running the same application.
 Multiple users can connect to the same destination chat application.

 It specifically demonstrates how to:
   - Use a listening socket to listen for incoming connections
   - Manage multiple connection-oriented sockets
   - Receive event notifications through dispatch calls using the
     unXceedWinsockEvents.pas distributed with the library.
   - Tranfer strings
   - Use the TCP/IP protocol

 This file is part of the Xceed Winsock Library Samples.
 The source code in this file is only intended as a supplement
 to Xceed Winsock Library's documentation, and is provided "as is",
 without warranty of any kind, either expressed or implied.
}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  XCEEDWINSOCKlib_TLB, StdCtrls, ActiveX, ComObj,
  { These files are distributed with the Xceed Winsock Library to help you
    receive events from the the different event objects. }
  xwlIncomingConnectionEvents,
  xwlConnectionEvents,
  xwlStringTransferEvents;

type
  TfrmChat = class( TForm,
                    { These interfaces contain the events that the different
                      helper classes can trigger when handling Invoke requests }
                    IIncomingConnectionEvents,
                    IConnectionEvents,
                    IStringTransferEvents )
    { Controls on the form }
    lblChatThread: TLabel;
    lblEnterMessage: TLabel;
    lblNickname: TLabel;
    edtNickname: TEdit;
    btnClearScreen: TButton;
    btnConnect: TButton;
    btnDisconnect: TButton;
    btnSend: TButton;
    btnClose: TButton;
    memoChatThread: TMemo;
    memoMessage: TMemo;

    { Standard event procedures }
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure btnConnectClick(Sender: TObject);
    procedure btnDisconnectClick(Sender: TObject);
    procedure btnClearScreenClick(Sender: TObject);
    procedure btnCloseClick(Sender: TObject);
    procedure btnSendClick(Sender: TObject);
    procedure memoMessageKeyPress(Sender: TObject; var Key: Char);

    { IIncomingConnectionEvents methods }
    procedure OnConnection( const xListeningSocket : IDispatch;
                            const xRemoteAddress : IDispatch;
                            vaCallerData : OleVariant;
                            lExpectedCalleeDataSize : Integer;
                            var vaCalleeData : OleVariant;
                            var xQualityOfService : IdXWQualityOfServiceInfo;
                            var lUserParam : Integer;
                            var bReject : WordBool );
    procedure OnConnectionProcessed( const xListeningSocket : IDispatch;
                                     const xIncomingSocket : IDispatch;
                                     lUserParam : Integer );
    procedure OnListeningError( const xListeningSocket : IDispatch;
                                lUserParam: Integer;
                                lResultCode: Integer );

    { IConnectionEvents }
    procedure OnDisconnected( const xSocket: IDispatch;
                              vaCallerData: OleVariant;
                              var vaCalleeData: OleVariant );

    { IStringTransferEvents }
    procedure OnStringSent( const xSocket: IDispatch;
                            lUserParam: Integer;
                            lResultCode: Integer );
    procedure OnStringReceived( const xSocket: IDispatch;
                                const sString: WideString;
                                lUserParam: Integer;
                                lResultCode: Integer );
    procedure OnStringAvailable( const xSocket: IDispatch;
                                 lCharsReceived: Integer;
                                 lCharsAvailable: Integer );
    procedure OnOutOfBandStringReceived( const xSocket: IDispatch;
                                         const sString: WideString;
                                         lResultCode: Integer );

  private
    { These objects wil receive dispatch events from the library for us. }
    { They will then call one of the methods above }

    m_xIncomingConnectionEvents : TIncomingConnectionEvents;
    m_xConnectionEvents : TConnectionEvents;
    m_xStringTransferEvents : TStringTransferEvents;

    { These members are created once and reused throughout the application
      to avoid recreating them each time they are required. }

    m_xTCPprotocol : Protocol;  { The TCP protocol to use (see Create) }

    m_xListeningSocket : ListeningSocket; { The socket that monitors incoming
                                            connections (see
                                            StartListeningForChatConnections) }

    { This list will hold all active connections throughout the chat
      application's execution. Each item in the list is kept as a
      ConnectionOrientedSocket. Each time an item is added or removed
      from this list, we must call _AddRef or _Release on the item. }
    m_xConnections : TList;

    { Private procedures }

    procedure StartListeningForChatConnections;
    procedure SendToConnections( sDataToSend : String; bWait : Boolean );
    procedure StopListeningForChatConnections;
    procedure DisconnectFromChatSessions( sNickname : String );
    procedure ConnectToChatSession( sNickname : String );
    procedure RemoveConnection( xSocket : ConnectionOrientedSocket );
    procedure DisplayMessage( sMsg : String );
    procedure SetInterfaceState( bEnabled : Boolean );
  public
  end;

var
  frmChat: TfrmChat; { Our main form }

implementation

{$R *.DFM}

{------------------------------------------------------------------------------}
{                                SYSTEM EVENTS                                 }
{------------------------------------------------------------------------------}

{ FormCreate: Triggered by Delphi when a form instance is being created.
              Here, we initialize all global variables that we need
              throughout the application. }

procedure TfrmChat.FormCreate(Sender: TObject);
var
  xProtocols : Protocols; { This object will provide all available protocols }
begin
  { Create our event objects that will receive events from the Library }

  m_xIncomingConnectionEvents := TIncomingConnectionEvents.Create( Self );
  m_xConnectionEvents := TConnectionEvents.Create( Self );
  m_xStringTransferEvents := TStringTransferEvents.Create( Self );

  { To avoid creating a TCP protocol object again and again, we get one
    once and for all! }

  xProtocols := CoProtocols.Create;

  { The GetProtocol method helps isolate a specific protocol of interest.
    Our sample uses the TCP/IP protocol, which is connection-oriented. }

  m_xTCPprotocol := xProtocols.GetProtocol( wafUnspecified, wstUnspecified, wptIP_TCP );

  { Instantiate our global list of active connections that will actually
    contain ConnectionOrientedSocket instances }

  m_xConnections := TList.Create;

  { Start listening for incoming connections now that the form is loaded }

  StartListeningForChatConnections;
end;

{------------------------------------------------------------------------------}
{ FormDestroy: Called by Delphi when the form instance is being released.
               We make sure to release all our instances too! }

procedure TfrmChat.FormDestroy(Sender: TObject);
begin
  { Stop listening for incoming connections. }

  StopListeningForChatConnections;

  { Disconnect everyone that we are connected to }

  DisconnectFromChatSessions( edtNickname.Text );

  { Free each instance }

  m_xTCPprotocol := Nil;
  m_xConnections.Free;

  m_xIncomingConnectionEvents.Free;
  m_xConnectionEvents.Free;
  m_xStringTransferEvents.Free;
end;

{------------------------------------------------------------------------------}
{ btnConnectClick: Called when a user clicks the Connect button. }

procedure TfrmChat.btnConnectClick(Sender: TObject);
begin
  ConnectToChatSession( edtNickname.Text );
end;

{------------------------------------------------------------------------------}
{ btnDisconnectClick: Called when a user clicks the Disconnect button. }

procedure TfrmChat.btnDisconnectClick(Sender: TObject);
begin
  DisconnectFromChatSessions( edtNickname.Text );
end;

{------------------------------------------------------------------------------}
{ btnClearScreenClick: Called when a user clicks the Clear Screen button. }

procedure TfrmChat.btnClearScreenClick(Sender: TObject);
begin
  memoChatThread.Text := '';
end;

{------------------------------------------------------------------------------}
{ btnCloseClick: Called when a user clicks the Close button. }

procedure TfrmChat.btnCloseClick(Sender: TObject);
begin
  { Close the form. The FormDestroy event will be triggered, which will
    cause all connections to be closed and all objects to be freed. }

  Close;
end;

{------------------------------------------------------------------------------}
{ btnSendClick: Called when the user clicks on the Send button. We send the
                text, reset the text field contents and set the focus back
                to the text field. }

procedure TfrmChat.btnSendClick(Sender: TObject);
var
  sMessage : String;
begin
  { Format the output text to include our nickname }

  sMessage := edtNickname.Text + ' > ' + memoMessage.Text + #13#10;

  { Send the text to all active connections so they can display it }

  SendToConnections( sMessage, False );

  { Display the message in our own output window }

  DisplayMessage( sMessage );

  { Clear the edit field so its ready for user to enter a new message }

  memoMessage.Text := '';
  memoMessage.SetFocus;
end;

{-------------------------------------------------}
{ memoMessageKeyPress: Called everytime a user presses a key while the memo
                       field has the focus. If the pressed key is "Enter", we
                       perform a virtual click on the "Send" button. }

procedure TfrmChat.memoMessageKeyPress(Sender: TObject; var Key: Char);
begin
  if ( Key = Chr(13) ) or ( Key = Chr(10) ) then
  begin
    btnSend.Click;  { Fake this system event }
    Key := Chr(0);  { Cancel this pressed key }
  end;
end;

{------------------------------------------------------------------------------}
{                             XCEED WINSOCK EVENTS                             }
{------------------------------------------------------------------------------}

{ OnConnection: Triggered when a connection is about to be made with a client
                application. The "bReject" is false by default, so since we
                accept any connections in this sample, we can just ignore this
                event. }

procedure TfrmChat.OnConnection( const xListeningSocket : IDispatch;
                                 const xRemoteAddress : IDispatch;
                                 vaCallerData : OleVariant;
                                 lExpectedCalleeDataSize : Integer;
                                 var vaCalleeData : OleVariant;
                                 var xQualityOfService : IdXWQualityOfServiceInfo;
                                 var lUserParam : Integer;
                                 var bReject : WordBool );
begin
  { Nothing special to do }
end;

{------------------------------------------------------------------------------}
{ OnConnectionProcessed: Triggered when a connection was established with a
                         client application. This event provides a brand new
                         ConnectionOrientedSocket instance representing the
                         new connection. We'll add this new socket to our list
                         of active connections. }

procedure TfrmChat.OnConnectionProcessed( const xListeningSocket: IDispatch;
                                          const xIncomingSocket: IDispatch;
                                          lUserParam: Integer );
var
  xConnectionOrientedSocket : ConnectionOrientedSocket; { The new socket object }
  xRemoteAddress : Address;
begin
  { This event is ready to handle many types of connections. We'll need to
    "typecast" the xIncomingSocket to the proper type, using the "As" operator. }

  xConnectionOrientedSocket := xIncomingSocket As ConnectionOrientedSocket;

  { Add this new socket to our global list of active connections, making sure
    to add a reference on the object, since the TList object won't do this
    automatically, and all COM objects must have their ref count incremented
    everytime another object holds a pointer to them. }

  xConnectionOrientedSocket._AddRef;
  m_xConnections.Add( Pointer( xConnectionOrientedSocket ) );
  btnDisconnect.Enabled := True;

  { Display a message that a new connection has been established. }

  xRemoteAddress := xConnectionOrientedSocket.RemoteAddress As Address;
  DisplayMessage( 'New user has connected from ' + xRemoteAddress.GetAddressString + #13#10 );

  { Inform the other chat application of who we are. }

  xConnectionOrientedSocket.AsyncSendString( 'You are now in session with ' +
                                             frmChat.edtNickname.Text + #13#10,
                                             wnfAnsiStrings, 0, wsoNone );
end;

{------------------------------------------------------------------------------}
{ OnListeningError: Triggered when an error occurs while listening for
                    incoming connections. We ignore this event in this sample. }

procedure TfrmChat.OnListeningError( const xListeningSocket : IDispatch;
                                     lUserParam: Integer;
                                     lResultCode: Integer );
begin
  { Ignored }
end;

{------------------------------------------------------------------------------}
{ OnDisconnected: Triggered when a connection-oriented socket becomes
                  disconnected for any reason. Some protocols support
                  "disconnection data", which is data exchanged at the
                  disconnection phase. In this sample, it is irrelevent
                  and we ignore this data. }

procedure TfrmChat.OnDisconnected( const xSocket: IDispatch;
                                   vaCallerData: OleVariant;
                                   var vaCalleeData: OleVariant );
begin
  { Display a message informing that someone has disconnected }

  DisplayMessage( 'A user has disconnected!' + #13#10 );

  { Remove the socket that just disconnected from our list of active
    connections. }

  RemoveConnection( xSocket As ConnectionOrientedSocket );
end;

{------------------------------------------------------------------------------}
{ OnStringSent: Triggered when a call to "AsyncSendString" completed. }

procedure TfrmChat.OnStringSent( const xSocket: IDispatch;
                                 lUserParam: Integer;
                                 lResultCode: Integer );
begin
  { We ignore this event }
end;

{------------------------------------------------------------------------------}
{ OnStringReceived: When advising for one of the "always" flags, this event is
                    triggered everytime a new string is received from a
                    connection-oriented socket. This is useful when you don't
                    want to call "ReceiveString" or "AsyncReceiveString"
                    at particular moments, but rather react to incoming
                    strings.
                    When advising for one of the "OnDemand" flags, this event is
                    triggered for every "AsyncReceiveString" or
                    "AsyncReceiveLine" that completes. }

procedure TfrmChat.OnStringReceived( const xSocket: IDispatch;
                                     const sString: WideString;
                                     lUserParam: Integer;
                                     lResultCode: Integer );
begin
  { We simply display the incoming data in our text box }

  DisplayMessage( sString );
end;

{------------------------------------------------------------------------------}
{ OnStringAvailable: Triggered when new data has arrived and was buffered by
                     the library. You then should call "ReceiveString" or
                     "AsyncReceiveString" to retrieve just the amount of bytes
                     you're interested in. In this sample, we prefer handling
                     the OnStringReceived event everytime data arrives. }

procedure TfrmChat.OnStringAvailable( const xSocket: IDispatch;
                                      lCharsReceived: Integer;
                                      lCharsAvailable: Integer );
begin
  { We ignore this event }
end;

{------------------------------------------------------------------------------}
{ OnOutOfBandStringReceived: Triggered when out-of-band data is received while
                             you advised to receive OOB data with the
                             wsaAdviseOutOfBandReceivedAlways flag. }

procedure TfrmChat.OnOutOfBandStringReceived( const xSocket: IDispatch;
                                              const sString: WideString;
                                              lResultCode: Integer );
begin
  { We ignore this event }
end;

{------------------------------------------------------------------------------}
{                              PRIVATE PROCEDURES                              }
{------------------------------------------------------------------------------}

{ StartListeningForChatConnections: This procedure creates a ListeningSocket
                                    and makes it start listening for incoming
                                    connections. }

procedure TfrmChat.StartListeningForChatConnections;
var
  xLocal   : InetAddress;   { Will represent our local IP address }
  xFactory : SocketFactory; { Allows creation of various types of sockets }
begin
  { The SocketFactory class is used to create all kinds of sockets. }

  xFactory := CoSocketFactory.Create;

  { Create our listening socket. As a parameter, we provide the global
    m_xTCPprotocol variable which defines the protocol we want the listening
    socket to use }

  { The listening socket that we are about to create will be handling all
    incoming connection requests from other chat samples that are trying to
    establish a connection with us. }

  m_xListeningSocket := xFactory.CreateListeningSocket( m_xTCPprotocol, 0 );

  { Later, we will call our listening socket's StartListening method.
    This will cause the library to trigger the OnConnectionProcessed
    event whenever a connection is established. Whenever the
    OnConnectionProcess event is triggered, the library provides (as
    a parameter of the event) a reference to a newly created
    ConnectionOrientedSocket object that you can use in order to
    communicate with the new connection.

    The ConnectionOrientedSocket object offers various Advise methods.
    An Advise method allows you to tell the library that you wish to
    receive certain events. So you can, for example, make the
    socket trigger string transfer events whenever a string is received
    from its connection. Each time a new socket is provided by the
    OnConnectionProcessed event metionned above, it must be Advised.

    When using a listening socket, there's a better way to proceed.
    An interesting feature of a listening socket is that it lets you
    call the same Advise methods offered by the ConnectionOrientedSocket
    object. For the listening socket itself, these Advise calls have
    no meaning. But all newly created ConnectionOrientedSocket instances
    provided by the OnConnectionProcessed event will inherit the listening
    socket's Advises. You won't need to individually Advise each newly
    created socket as described in the previous paragraph. That's why,
    in the next two lines of code below, we Advise the listening socket
    about some events we want future ConnectionOrientedSockets to trigger. }

  m_xListeningSocket.ConnectionAdvise( m_xConnectionEvents.m_xEventObject,
                                       wcaAdviseDisconnected );
  m_xListeningSocket.StringTransferAdvise( m_xStringTransferEvents.m_xEventObject,
                                           wsaAdviseReceivedAlways,
                                           wnfAnsiStrings );

  { "Listening" means to check for connections on a specific local address. Our
    sample uses IP addresses, so we create an InetAddress object. Any newly
    instantiated InetAddress, Inet6Address or IpxAddress is always initialized
    by the library to a value representing the default local address for the
    current machine. }

  xLocal := CoInetAddress.Create;

  { Now we specify the IP port we will be listening on. Our sample uses
    port 1555, which is not used by any other known services. }

  xLocal.Port := 1555;

  try
    { Now we are ready to start listening on this default local address for
      any incoming connections. We tell the library that we want to receive
      all incoming connection events throught the m_xIncomingConnectionEvents
      object. }

    m_xListeningSocket.StartListening( xLocal,
                                       m_xIncomingConnectionEvents.m_xEventObject,
                                       wifAdviseConnectionProcessed );

    DisplayMessage( 'Waiting for incoming connections...' + #13#10 );
  except
    on E:EOleException do
    begin
      DisplayMessage( 'Error: ' + E.Message + #13#10 );
    end;
  end;
end;

{------------------------------------------------------------------------------}
{ SendToConnections: Send a string message to all current connections. If the
                     bWait parameter is True, it uses a blocking call in order
                     to ensure that the string has really been sent. This is
                     used only when sending a "disconnection" message to the
                     other users before closing all sockets. If bWait is False,
                     it sends the string asynchronously (non-blocking). }

procedure TfrmChat.SendToConnections( sDataToSend : String; bWait : Boolean );
var
  xSocket : ConnectionOrientedSocket;
  nIterator : Integer;
begin
  nIterator := 0;

  { For each ConnectionOrientedSocket in our list... }
  While nIterator < m_xConnections.Count do
  begin
    { A TList keeps objects as a pointer. We must typecast each item to what
      these items really are: ConnectionOrientedSocket instances. }

    xSocket := ConnectionOrientedSocket( m_xConnections[ nIterator ] );

    if bWait then
      xSocket.SendString( sDataToSend, wnfAnsiStrings, wsoNone )
    else
      xSocket.AsyncSendString( sDataToSend, wnfAnsiStrings, 0, wsoNone );

    nIterator := nIterator + 1;
  end;
end;

{------------------------------------------------------------------------------}
{ StopListeningForChatConnections: This procedure makes our listening socket
                                   stop listening for incoming connections, and
                                   also releases this listening socket. }

procedure TfrmChat.StopListeningForChatConnections;
begin
  { We always create our listening socket right before we tell it to
    start listening. So now, right after we stop listening, we release our
    instance by assigning Nil to our member variable. }

  m_xListeningSocket.StopListening;
  m_xListeningSocket := Nil;
end;

{------------------------------------------------------------------------------}
{ DisconnectFromChatSessions: Sends a "disconnecting" message to all active
                              connections and then disconnects them all. }

procedure TfrmChat.DisconnectFromChatSessions(sNickname : String);
var
  xSocket : ConnectionOrientedSocket;
begin
  { Inform each remote user that we are leaving }

  SendToConnections( sNickname + ' is disconnecting.', True );

  { Close each connection. We could just release each reference we have in our
    list, but this is a cleaner way to end a conversation. }

  while m_xConnections.Count > 0 do
  begin
    xSocket := ConnectionOrientedSocket( m_xConnections[0] );
    xSocket.Disconnect;

    { Remove it from our list of active connections. }
    RemoveConnection( xSocket );
  end;
end;

{------------------------------------------------------------------------------}
{ ConnectToChatSession: Creates a new connection-oriented socket and uses it
                        to connect to a remote host running the chat
                        application. }

procedure TfrmChat.ConnectToChatSession;
var
  xFactory     : SocketFactory;            { Allows creation of various types of sockets }
  xSocket      : ConnectionOrientedSocket; { This will be the socket we will use }
  sHostAddress : String;                   { The remote address entered by the user }
  xRemote      : InetAddress;              { This object will contain the remote address }
begin
  { Disable the interface }

  SetInterfaceState( False );

  try
    { Instanciate the socket factory }

    xFactory := CoSocketFactory.Create;

    { Create the connection-oriented socket. Use the global m_xTCPprotocol
      object which represents the protocol that the socket should use. }

    xSocket := xFactory.CreateConnectionOrientedSocket( m_xTCPprotocol, 0 );

    { Now we advise the library that we wish to receive certain events. Keep
      in mind that this ConnectionOrientedSocket is not generated by our
      listening socket, and therefore does not inherit the Advises we performed
      on our listening socket. That's why we need to Advise it. }

    xSocket.ConnectionAdvise( m_xConnectionEvents.m_xEventObject,
                              wcaAdviseDisconnected);
    xSocket.StringTransferAdvise( m_xStringTransferEvents.m_xEventObject,
                                  wsaAdviseReceivedAlways, wnfAnsiStrings);

    { Now, it's time to connect somewhere! Lets display a dialog box to ask
      for the remote address where to connect to. }

    sHostAddress := InputBox( 'Xceed Winsock Library Sample - Chat',
                              'Enter the IP address of the machine you wish to connect to:',
                              '');

    if Length(sHostAddress) > 6 Then
    begin
      { Create an InetAddress object that will represent the address. }

      xRemote := CoInetAddress.Create;

      { Call the InetAddress's SetAddressString to set the InetAddress' object's
        address directly from the string version entered by the user. }

      xRemote.SetAddressString( sHostAddress );

      { We now set the port number we'll be connecting to. }

      xRemote.Port := 1555;

      { Display that we are trying to connect... }

      DisplayMessage( 'Connecting to <' + sHostAddress + '>...' + #13#10 );

      { Now attempt to establish a connection to the remote host. }

      xSocket.Connect( xRemote );

      { If we get here, no error has occured and we can assume we
        are connected. So now we add this socket to our list of active
        connections. When we do this, we need to notify COM that we are
        keeping a reference on this object, so that the object is not
        deleted because COM thinks nobody needs it anymore. }

      xSocket._Addref;
      m_xConnections.Add( Pointer( xSocket ) );

      { Let's inform the remote host of who we are. }

      xSocket.AsyncSendString( sNickname + ' has joined the session!' + #13#10,
                               wnfAnsiStrings, 0, wsoNone );

    end;
  except
     on E:EOleException do
     begin
       DisplayMessage( 'Error: ' + E.Message + #13#10 );
     end;
  end;

  { re-enable the interface }

  SetInterfaceState( True );
end;

{------------------------------------------------------------------------------}
{ RemoveConnection: Removes a ConnectionOrientedSocket from the list of active
                    connections. The reference count on the socket must be
                    decreased using the "_Release" function because it was
                    incremented (with "_Addref") when the socket was added to
                    the list. }

procedure TfrmChat.RemoveConnection(xSocket : ConnectionOrientedSocket);
begin
  m_xConnections.Remove( Pointer( xSocket ) );
  xSocket._Release;
end;

{------------------------------------------------------------------------------}
{ DisplayMessage: This procedure displays a message in the output window }

procedure TfrmChat.DisplayMessage(sMsg : String);
begin
  memoChatThread.Text := memoChatThread.Text + sMsg;
  Application.ProcessMessages; { Give Windows a chance to display it }
end;

{------------------------------------------------------------------------------}
{ SetInterfaceState: Change the state of the interface, enabling and disabling
                     buttons on the screen, changing the mouse pointer. }

procedure TfrmChat.SetInterfaceState(bEnabled : Boolean);
begin
  btnConnect.Enabled := bEnabled;
  btnSend.Enabled := bEnabled;
  btnClearScreen.Enabled := bEnabled;
  btnDisconnect.Enabled := bEnabled And ( m_xConnections.Count > 0 );
  btnClose.Enabled := bEnabled;

  if bEnabled then
    Screen.Cursor := crDefault
  else
    Screen.Cursor := crHourglass;
end;

end.