thrdsrv1.pas

搜索百度MP3并下载源码.批量下载.百度TOP100等

{*_* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *

Author:       Fran鏾is Piette
Creation:     Sep 02, 2001
Version:      1.02
Description:  Basic TCP server showing how to use TWSocketServer and
              TWSocketClient components with threads.
              This demo is mostly the same as TcpSrv demo but use a thread to
              run client code. This is needed if client operation is lengthy
              and blocking (such as a long database query) but otherwise will
              consume more CPU cycles in task switching and makes thing much
              more complexe because multithreading requires synchronization.
EMail:        [e-mail]  http://www.overbyte.be
              [e-mail]      http://www.rtfm.be/fpiette
                                           [e-mail]
Support:      Use the mailing list [e-mail]
              Follow "support" link at http://www.overbyte.be for subscription.
Legal issues: Copyright (C) 2001-2005 by Fran鏾is PIETTE
              Rue de Grady 24, 4053 Embourg, Belgium. Fax: [phone]
              <[e-mail]><[e-mail]>

              This software is provided 'as-is', without any express or
              implied warranty.  In no event will the author be held liable
              for any  damages arising from the use of this software.

              Permission is granted to anyone to use this software for any
              purpose, including commercial applications, and to alter it
              and redistribute it freely, 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.

              4. You must register this software by sending a picture postcard
                 to the author. Use a nice stamp and mention your name, street
                 address, EMail address and any comment you like to say.
History:
Feb 24, 2002 V1.01 Wilfried Mestdagh <[e-mail]> added ThreadDetach
Jun 20, 2004 V1.02 Fixed BannerToBusy error (BannerTooBusy).


 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
unit ThrdSrv1;

interface

{$IFDEF VER80}
  'This sample program use threads and hence is not compatible with Delphi 1';
{$ENDIF}

uses
  WinTypes, WinProcs, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, IniFiles, StdCtrls, ExtCtrls, WSocket, WSocketS;

const
  ThrdSrvVersion = 102;
  CopyRight      = ' ThrdSrv (c) 2001-2005 by Fran鏾is PIETTE. V1.02';
  WM_APPSTARTUP  = WM_USER + 1;

type
  TDisplayProc  = procedure (const Msg : String) of object;

  { TClientThread is our worker thread class. Each time a client connect, a }
  { new TClientThread is instanciated and client socket attached to it so   }
  { events are processed in the thread's context.                           }
  { Remember that multithreading requires synchronization, specially when   }
  { updating GUI or accessing shared data.                                  }
  { TClientThread uses OnDisplay event to display data on the application   }
  { main form. Synchronization is automatically done.                       }
  TClientThread = class(TThread)
  private
      FWSocket        : TWSocket;             { Reference to client socket  }
      FMsg            : String;               { Message to be displayed     }
      FOnDisplay      : TDisplayProc;         { Event variable              }
      FThreadAttached : Boolean;              { TRUE once socket attached   }
      procedure DisplayMsg;                   { Synchronized procedure      }
  public
      procedure Execute; override;            { Main method                 }
      procedure Display(const Msg : String);  { Takes care of synchroniz.   }
  published
      property WSocket   :      TWSocket     read  FWSocket
                                             write FWSocket;
      property ThreadAttached : Boolean      read  FThreadAttached
                                             write FThreadAttached;
      property OnDisplay :      TDisplayProc read  FOnDisplay
                                             write FOnDisplay;
  end;

  { TThrdSrvClient is the class which will be instanciated by server        }
  { component for each new client. N simultaneous clients means N           }
  { TThrdSrvClient will be instanciated. Each being used to handle only a   }
  { single client.                                                          }
  { We can add any data that has to be private for each client, such as     }
  { receive buffer or any other data needed for processing.                 }
  TThrdSrvClient = class(TWSocketClient)
  public
    ClientThread : TClientThread;
    RcvdLine     : String;
    ConnectTime  : TDateTime;
  end;

  { Application main from                                                   }
  TTcpSrvForm = class(TForm)
    ToolPanel: TPanel;
    DisplayMemo: TMemo;
    WSocketServer1: TWSocketServer;
    procedure FormShow(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormCreate(Sender: TObject);
    procedure WSocketServer1ClientConnect(Sender: TObject;
      Client: TWSocketClient; Error: Word);
    procedure WSocketServer1ClientDisconnect(Sender: TObject;
      Client: TWSocketClient; Error: Word);
    procedure WSocketServer1BgException(Sender: TObject; E: Exception;
      var CanClose: Boolean);
    procedure WSocketServer1ClientCreate(Sender: TObject;
      Client: TWSocketClient);
  private
    FIniFileName  : String;
    FInitialized  : Boolean;
    procedure Display(const Msg : String);
    procedure WMAppStartup(var Msg: TMessage); message WM_APPSTARTUP;
    procedure ClientDataAvailable(Sender: TObject; Error: Word);
    procedure ProcessData(Client : TThrdSrvClient);
    procedure ClientBgException(Sender       : TObject;
                                E            : Exception;
                                var CanClose : Boolean);
    procedure ClientLineLimitExceeded(Sender        : TObject;
                                      Cnt           : LongInt;
                                      var ClearData : Boolean);
{$IFDEF VER140}
    { Delphi 6 changed the rules about synchronization... }
    procedure WakeMainThread(Sender: TObject);
{$ENDIF}
  public
    property IniFileName : String read FIniFileName write FIniFileName;
  end;

var
  TcpSrvForm: TTcpSrvForm;

implementation

{$R *.DFM}

const
    SectionWindow      = 'WindowTcpSrv';
    KeyTop             = 'Top';
    KeyLeft            = 'Left';
    KeyWidth           = 'Width';
    KeyHeight          = 'Height';


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TTcpSrvForm.FormCreate(Sender: TObject);
begin
    { Compute INI file name based on exe file name. Remove path to make it  }
    { go to windows directory.                                              }
    FIniFileName := LowerCase(ExtractFileName(Application.ExeName));
    FIniFileName := Copy(FIniFileName, 1, Length(FIniFileName) - 3) + 'ini';

{$IFDEF VER140}
    { With Delphi 6, we need to waken mainthread ourself !                  }
    Classes.WakeMainThread := Self.WakeMainThread;
{$ENDIF}
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TTcpSrvForm.FormShow(Sender: TObject);
var
    IniFile : TIniFile;
begin
    if not FInitialized then begin
        FInitialized := TRUE;

        { Fetch persistent parameters from INI file }
        IniFile      := TIniFile.Create(FIniFileName);
        Width        := IniFile.ReadInteger(SectionWindow, KeyWidth,  Width);
        Height       := IniFile.ReadInteger(SectionWindow, KeyHeight, Height);
        Top          := IniFile.ReadInteger(SectionWindow, KeyTop,
                                            (Screen.Height - Height) div 2);
        Left         := IniFile.ReadInteger(SectionWindow, KeyLeft,
                                            (Screen.Width  - Width)  div 2);
        IniFile.Destroy;
        DisplayMemo.Clear;
        { Delay startup code until our UI is ready and visible }
        PostMessage(Handle, WM_APPSTARTUP, 0, 0);
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TTcpSrvForm.FormClose(Sender: TObject; var Action: TCloseAction);
var
    IniFile : TIniFile;
begin
    { Save persistent data to INI file }
    IniFile := TIniFile.Create(FIniFileName);
    IniFile.WriteInteger(SectionWindow, KeyTop,         Top);
    IniFile.WriteInteger(SectionWindow, KeyLeft,        Left);
    IniFile.WriteInteger(SectionWindow, KeyWidth,       Width);
    IniFile.WriteInteger(SectionWindow, KeyHeight,      Height);
    IniFile.Destroy;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ Display a message in our display memo. Delete lines to be sure to not     }
{ overflow the memo which may have a limited capacity.                      }
procedure TTcpSrvForm.Display(const Msg : String);
var
    I : Integer;
begin
    DisplayMemo.Lines.BeginUpdate;
    try
        if DisplayMemo.Lines.Count > 200 then begin
            for I := 1 to 50 do
                DisplayMemo.Lines.Delete(0);
        end;
        DisplayMemo.Lines.Add(Msg);
    finally
        DisplayMemo.Lines.EndUpdate;
        {$IFNDEF VER80}
        { Scroll to makes caret visible }
        SendMessage(DisplayMemo.Handle, EM_SCROLLCARET, 0, 0);
        {$ENDIF}
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ This is our custom message handler. We posted a WM_APPSTARTUP message     }
{ from FormShow event handler. Now UI is ready and visible.                 }
procedure TTcpSrvForm.WMAppStartup(var Msg: TMessage);
begin
    Display(Trim(CopyRight));                     { This demo version       }
    Display(Trim(wsocket.Copyright));             { TWSocket version        }
    Display(Trim(wsockets.CopyRight));            { TWSocketServer version  }
    Display('');
    Display('MainThreadID : $' + IntToHex(GetCurrentThreadID, 8));
    WSocketServer1.Proto       := 'tcp';          { Use TCP protocol        }
    WSocketServer1.Port        := 'telnet';       { Use telnet port         }
    WSocketServer1.Addr        := '0.0.0.0';      { Use any interface       }
    WSocketServer1.ClientClass := TThrdSrvClient; { Use our component       }
    WSocketServer1.Listen;                        { Start litening          }
    Display('Waiting for clients on port ''' + WSocketServer1.Port + '''...');
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{$IFDEF VER140}
{ Delphi 6 requires a little help in order for TThread.Synchronize to work. }
{ We just post a do-nothing message to the form which will waken up the     }