类TListenSocket(我写的类似Borland Socket Service的类)

原创 2001年01月30日 14:04:00

{这是我根据Borland Socket Service改写的类:TListenSocket, 它的功能是相当于:"X:/Program Files/Borland/Delphi5/Bin/scktsrvr.exe"。也是说它可以将你的分布式服务端程序变成一个有侦听功能的程序,有侦听,还有你的Remote DataModule可以照样运行。写出来不久,如果有什么BUG,请指出,谢谢。}

{本想把它做成控件方式的,现在不想去改动了。有需要再说,}

{

用法:

uses Listensocket;

var Socket:TListenSocket;

const ListenPort=8888;

Socket:=TListenSocket.Create(Self);

Socket.ListenPort:=ListPort;

Socket.Open;

//OK

}

unit ListenSocket;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  SConnect,ScktComp,SvcMgr, ActiveX,MidConst,winsock,MyConst;

var 
    FClientThreads:TList;
type
  TSocketDispatcherThread = class(TServerClientThread, ISendDataBlock)
  private
    FRefCount: Integer;
    FInterpreter: TDataBlockInterpreter;
    FTransport: ITransport;
    FLastActivity: TDateTime;
    FTimeout: TDateTime;
    FRegisteredOnly: Boolean;
    procedure AddClient;
    procedure RemoveClient;
  protected
    function CreateServerTransport: ITransport; virtual;
   { procedure AddClient;
    procedure RemoveClient; }
    { IUnknown }
    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
    { ISendDataBlock }
    function Send(const Data: IDataBlock; WaitForResult: Boolean): IDataBlock; stdcall;
  public
    constructor Create(CreateSuspended: Boolean; ASocket: TServerClientWinSocket;
      const InterceptGUID: string; Timeout: Integer; RegisteredOnly: Boolean);
    procedure ClientExecute; override;
  end;

type MyServerSocket=Class(TServerSocket)
  private
    procedure GetThread(Sender: TObject; ClientSocket: TServerClientWinSocket;var SocketThread: TServerClientThread);
  public
    constructor Create(AOwner: TComponent); override;
end;

type
  TListenSocket = class(TObject)
  private
    FActive:Boolean;
    FListPort :integer;
    FCacheSize :integer;
    SH:MyServerSocket;
    FItemIndex :integer;
    procedure SetActiveState(Value:boolean);
    function GetClientCount :integer;
    { Private declarations }
  public
    property CacheSize :integer read FCacheSize write FCacheSize;
    property ListPort:integer read FListPort write FListPort;
    property Active :boolean read FActive write SetActiveState;
    property ClientCount:integer read GetClientCount;
  public
    constructor Create(AOwner :TComponent);
    destructor Destroy;override;
    class procedure AddClientThread(Thread :TSocketDispatcherThread);
    class procedure RemoveClientThread(Thread:TSocketDispatcherThread);
    procedure Open;
    procedure Close;
  end;

implementation

function TListenSocket.GetClientCount :integer;
begin
  Result:=FClientThreads.Count;
end;

constructor TListenSocket.Create(AOwner :TComponent);
begin
  LoadWinSock2;
  FActive:=False;
  FClientCount:=0;
  FCacheSize :=10;
  FClientThreads:=TList.Create;
  SH:=MyServerSocket.Create(nil);
  inherited Create;
end;

destructor TListenSocket.Destroy;
begin
  SetActiveState(False);
  FreeAndNil(FClientThreahs);
  inherited Destroy;
end;

procedure TListenSocket.Open;
begin
  SetActiveState(True);
end;

procedure TListenSocket.Close;
begin
  SetActiveState(False);
end;

class procedure TListenSocket.AddClientThread(Thread :TSocketDispatcherThread);
begin
  FClientThreads.Add(Thread);
end;

class procedure TListenSocket.RemoveClientThread(Thread :TSocketDispatcherThread);
var i:integer;
begin
  for i:=0 to FClientThreads.Count -1 do
  begin

    i:=FClientThreahs.IndexOf(Thread);
    if i<>-1then
      FClientThreads.Delete(i);
  end;
end;

procedure TListenSocket.SetActiveState(Value:boolean);
var i:integer;
begin
  if Value then
  begin
    SH.Close;
    SH.Port :=ListPort;
    SH.ThreadCacheSize :=CacheSize;
    SH.Open;
  end else
  if not Value then//if FClientCount>0 then Error('还有客户在连接状态,中止。')
    SH.Close;
  FActive:=Value;
end;

//下面的东西都是在Delphi中Copy过来的,为我所用了。呵呵

{MyServerSocket Class}
procedure MyServerSocket.GetThread(Sender: TObject; ClientSocket: TServerClientWinSocket;
  var SocketThread: TServerClientThread);
begin
  SocketThread:=TSocketDispatcherThread.Create(false,ClientSocket,'',0,false);
end;

constructor MyServerSocket.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ServerType := stThreadBlocking;
  OnGetThread := GetThread;
end;
{MyServerSocket Class over}

{TSocketDispatcherThread class}
function TSocketDispatcherThread.CreateServerTransport: ITransport;
var
  SocketTransport: TSocketTransport;
begin
  SocketTransport := TSocketTransport.Create;
  SocketTransport.Socket := ClientSocket;
  Result := SocketTransport as ITransport;
end;

constructor TSocketDispatcherThread.Create(CreateSuspended: Boolean; ASocket: TServerClientWinSocket;
      const InterceptGUID: string; Timeout: Integer; RegisteredOnly: Boolean);
begin
  FTimeout:=EncodeTime(Timeout div 60, Timeout mod 60, 0, 0);
  FRegisteredOnly:=RegisteredOnly;
  FLastActivity:=Now;
  inherited Create(CreateSuspended, ASocket);
end;

function TSocketDispatcherThread.Send(const Data:IDataBlock; WaitForResult:Boolean):IDataBlock;
begin
  FTransport.Send(Data);
  if WaitForResult then
    while True do
    begin
      Result := FTransport.Receive(True, 0);
      if Result = nil then break;
      if (Result.Signature and ResultSig) = ResultSig then
        break else
        FInterpreter.InterpretData(Result);
    end;
end;

procedure TSocketDispatcherThread.AddClient;
begin
  TListenSocket.AddClientThread(Self);
end;

procedure TSocketDispatcherThread.RemoveClient;
begin
  TListenSocket.RemoveClientThread(Self);
end;

procedure TSocketDispatcherThread.ClientExecute;
var
  Data: IDataBlock;
  msg: TMsg;
  Obj: ISendDataBlock;
  Event: THandle;
  WaitTime: DWord;
begin
  CoInitialize(nil);
  try
    Synchronize(AddClient);
    FTransport := CreateServerTransport;
    try
      Event := FTransport.GetWaitEvent;
      PeekMessage(msg, 0, WM_USER, WM_USER, PM_NOREMOVE);
      GetInterface(ISendDataBlock, Obj);
      if FRegisteredOnly then
        FInterpreter := TDataBlockInterpreter.Create(Obj, SSockets) else
        FInterpreter := TDataBlockInterpreter.Create(Obj, '');
      try
        Obj := nil;
        if FTimeout = 0 then
          WaitTime := INFINITE else
          WaitTime := 60000; //MAXIMUM_WAIT_OBJECTS
        while not Terminated and FTransport.Connected do
        try
          case MsgWaitForMultipleObjects(1, Event, False, WaitTime, QS_ALLEVENTS) of
            WAIT_OBJECT_0:
            begin
              WSAResetEvent(Event);
              Data := FTransport.Receive(False, 0);
              if Assigned(Data) then
              begin
                FLastActivity := Now;
                FInterpreter.InterpretData(Data);
                Data := nil;
                FLastActivity := Now;
              end;
            end;
            WAIT_OBJECT_0 + 1:
              while PeekMessage(msg, 0, 0, 0, PM_REMOVE) do
                DispatchMessage(msg);
            WAIT_TIMEOUT:
              if (FTimeout > 0) and ((Now - FLastActivity) > FTimeout) then
                FTransport.Connected := False;
          end;
        except
          FTransport.Connected := False;
        end;
      finally
        FInterpreter.Free;
        FInterpreter := nil;
      end;
    finally
      FTransport := nil;
    end;
  finally
    CoUninitialize;
    Synchronize(RemoveClient);
  end;
end;

function TSocketDispatcherThread.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
  if GetInterface(IID, Obj) then Result := 0 else Result := E_NOINTERFACE;
end;

function TSocketDispatcherThread._AddRef: Integer;
begin
  Inc(FRefCount);
  Result := FRefCount;
end;

function TSocketDispatcherThread._Release: Integer;
begin
  Dec(FRefCount);
  Result := FRefCount;
end;
{TSocketDispatcherThread class over}

end.

 

JAVA中service实现类中的@Service(demoService)是什么意思? 求哪位大神指点

JAVA中service实现类中的@Service(demoService)是什么意思? 求哪位大神指点  分享| 2012-12-28 16:47328510453 | 浏览 21077 次 ...
  • evilcry2012
  • evilcry2012
  • 2016年08月10日 11:20
  • 2707

关于iOS中类似于Android的Toast短暂提示框

类似于Android的短暂提示框Toast
  • haoxindasoft
  • haoxindasoft
  • 2016年03月26日 00:10
  • 3016

iOS开发之类似安卓的Toast短暂提示框

向凡神致敬~ 在Android中具有确认提示框与短暂提示框Toast,但在iOS中只有确认提示框Alert并无类似于Android的短暂提示框Toast。 注:使用此组件控制器...
  • WJP19930121
  • WJP19930121
  • 2016年05月26日 14:58
  • 1178

使用c++的成员指针实现类似Borland VCL组件的事件回调

相信用过Borland delphi或者C++ builder的朋友都应该对VCL组件中的事件回调机制有深刻印象,VCL组件大量的使用了事件属性来简化类之间的交互,提高了VCL组件开发程序的效率。同时...
  • ilvu999
  • ilvu999
  • 2011年12月24日 22:10
  • 265

使用c++的成员指针实现类似Borland VCL组件的事件回调

相信用过Borland delphi或者C++ builder的朋友都应该对VCL组件中的事件回调机制有深刻印象,VCL组件大量的使用了事件属性来简化类之间的交互,提高了VCL组件开发程序的效率。同时...
  • ilvu999
  • ilvu999
  • 2012年10月19日 09:18
  • 237

Socket 服务器端程序,VC写的,很适合学习,类似QQ界面

  • 2018年01月03日 07:54
  • 19.69MB
  • 下载

Borland Socket Server程序 包含D6和D7源码

  • 2014年01月12日 18:38
  • 1.77MB
  • 下载

Borland Socket Server 补丁 For D5,7

  • 2006年01月13日 09:51
  • 76KB
  • 下载

Borland Socket server fix

  • 2009年12月25日 01:05
  • 272KB
  • 下载

自己写的类似UITextView的类,实现UIKeyInput协议

这是别人的一个app作品,我仿着做的,之前对keyboard用的不多,一般都是UITextField用到的,从来没想过可以写个类似功能的 看到这个画面的时候,我在想这是有个隐藏的textField把...
  • lqzitongyezu
  • lqzitongyezu
  • 2015年07月17日 15:07
  • 493
内容举报
返回顶部
收藏助手
不良信息举报
您举报文章:类TListenSocket(我写的类似Borland Socket Service的类)
举报原因:
原因补充:

(最多只允许输入30个字)