console application --> events --> clientsocket prob :(

[Beckman]

so. kann das wer in windows bitte kompilieren und testen?

mit 'nc.exe -lp 6667' koennt ihr auf verbingund warten.
http://xchannel.org/temp/nc.exe

Code:

program client;

{$APPTYPE CONSOLE}

uses
  Sockets, SysUtils, Classes;

type
  TEvent = class
  private
    FClient: TTCPClient;
    FDisconnectOnError: boolean;
  protected
    procedure ClientConnect(Sender: TObject);
    procedure ClientCreateHandle(Sender: TObject);
    procedure ClientDestroyHandle(Sender: TObject);
    procedure ClientDisconnect(Sender: TObject);
    procedure ClientError(Sender: TObject; SocketError: Integer);
    procedure ClientReceive(Sender: TObject; Buf: PAnsiChar; var DataLen: Integer);
    procedure ClientSend(Sender: TObject; Buf: PAnsiChar; var DataLen: Integer);
    procedure SetDisconnectOnError(Value: boolean);
  public
    constructor Create;
    destructor Destroy; override;
    procedure Connect;
    procedure Disconnect;
    procedure Send(Msg: string; const Prefix: string = #13#10);
    procedure UnwireMethods;
    procedure WireMethods;

    property Client: TTcpClient read FClient;
    property DisconnectOnError: boolean read FDisconnectOnError write SetDisconnectOnError;
  end;

  TReadLnThread = class(TThread)
  public
    procedure Execute; override;
  end;

var
  gEvent: TEvent;
  gCommand: string;
  gInput: string;
  gParameter: array of string;
  gThread: TReadLnThread;
  //targetlist: TStringlist;
  //runvar: Integer;

// errorcodetostring
//
function ErrorCodeToString(ErrorCode: integer): string;
begin
  case ErrorCode of
    10004: Result := 'interrupted function call';
    10013: Result := 'permission denied';
    10014: Result := 'bad address';
    10022: Result := 'invalid argument';
    10024: Result := 'too many open files';
    10035: Result := 'resource temporarily unavailable';
    10036: Result := 'operation now in progress';
    10037: Result := 'operation already in progress';
    10038: Result := 'socket operation on non-socket';
    10039: Result := 'destination address required';
    10040: Result := 'message too long';
    10041: Result := 'protocol wrong type for socket';
    10042: Result := 'bad protocol option';
    10043: Result := 'protocol not supported';
    10044: Result := 'socket type not supported';
    10045: Result := 'operation not supported';
    10046: Result := 'protocol family not supported';
    10047: Result := 'address family not supported by protocol family';
    10048: Result := 'address already in use';
    10049: Result := 'cannot assign requested address';
    10050: Result := 'network is down';
    10051: Result := 'network is unreachable';
    10052: Result := 'network dropped connection on reset';
    10053: Result := 'software caused connection abort';
    10054: Result := 'connection reset by peer';
    10055: Result := 'no buffer space available';
    10056: Result := 'socket is already connected';
    10057: Result := 'socket is not connected';
    10058: Result := 'cannot send after socket shutdown';
    10060: Result := 'connection timed out';
    10061: Result := 'connection refused';
    10064: Result := 'host is down';
    10065: Result := 'no route to host';
    10067: Result := 'too many processes';
    10091: Result := 'network subsystem is unavailable';
    10092: Result := 'winsock.dll version out of range';
    10093: Result := 'successful wsastartup not yet performed';
    10094: Result := 'graceful shutdown in progress';
    11001: Result := 'host not found';
    11002: Result := 'non-authoritative host not found';
    11003: Result := 'this is a non-recoverable error';
    11004: Result := 'valid name, no data record of requested type';
  end;
end;


// gettoken
//
function GetToken(Src: string; Index: integer; Delimiter: char): string; 
var 
  I: integer; 
  J: integer; 
  Count: integer; 
  S: string; 
begin 
Result := ''; 
if Index = 0 then 
        begin 
        Result := Src; 
        Exit; 
        end 

        else 
        if Index < 0 then 
                begin 
                Index := -Index; 
                J := 1; 
                for I := 1 to Length(Src) do 
                        begin 
                        if Src[I] = Delimiter then 
                                Inc(J); 
                                if J >= Index then 
                                        Break; 
                        end; 
                if J = 1 then 
                        begin 
                        Result := Src; 
                        Exit; 
                        end; 
                Result := Copy(Src, I + 1, Length(Src)); // MaxInt 
                Exit; 
                end; 
        S := Src; 
        I := 0; 
        Count := 1; 
        while (I <= (Index - 2)) do 
                begin 
                J := Pos(Delimiter, S); 
                if J = 0 then 
                        Break; 
                Delete(S, 1, J); 
                Inc(I); 
                end; 
        for I := 1 to Length(Src) do 
        if Src[I] = Delimiter then 
                Inc(Count); 
        if Index > Count then 
                Exit; 
        J := Pos(Delimiter, S); 
        if J = 0 then 
                begin 
                J := Length(S); 
                Result := Copy(S, 1, J); 
                end 
                        else 
                        Result := Copy(S, 1, J - 1); 
end;

{ TEvent }

// clientconnect
//
procedure TEvent.ClientConnect(Sender: TObject);
begin
  WriteLn('client connected');
end;

// clientcreatehandle
//
procedure TEvent.ClientCreateHandle(Sender: TObject);
begin
  WriteLn('client handle created');
end;

// clientdestroyhandle
//
procedure TEvent.ClientDestroyHandle(Sender: TObject);
begin
  WriteLn('client handle destroyed');
end;

// clientdisconnect
//
procedure TEvent.ClientDisconnect(Sender: TObject);
begin
  WriteLn('client disconnected');
end;

// clienterror
//
procedure TEvent.ClientError(Sender: TObject; SocketError: Integer);
begin
  WriteLn('client error: ' + ErrorCodeToString(SocketError));
  if FDisconnectOnError then
    Disconnect;
end;

// clientreceive
//
procedure TEvent.ClientReceive(Sender: TObject; Buf: PAnsiChar; var DataLen: Integer);
var
  lBuffer: string;

begin
  SetLength(lBuffer, DataLen);
  lBuffer := StrPas(Buf);
  WriteLn('> ' + lBuffer);
end;

// clientsend
//
procedure TEvent.ClientSend(Sender: TObject; Buf: PAnsiChar; var DataLen: Integer);
var
  lBuffer: string;

begin
  SetLength(lBuffer, DataLen);
  lBuffer := StrPas(Buf);
 // WriteLn('< ' + lBuffer);
end;

// connect
//
procedure TEvent.Connect;
begin
  WriteLn('client connecting...');
  if FClient.RemoteHost = '' then
    FClient.RemoteHost := '127.0.0.1';
  if FClient.RemotePort = '' then
    FClient.RemotePort := '6667';
  FClient.Connect;
end;

// create
//
constructor TEvent.Create;
begin
  inherited Create;
  WriteLn('creating client...');
  FClient := TTcpClient.Create(nil);
  FClient.BlockMode := bmBlocking;
  FDisconnectOnError := True;
  WireMethods;
  WriteLn('client created');
end;

// disconnect
//
procedure TEvent.Disconnect;
begin
  WriteLn('client disconnecting...');
  FClient.Disconnect;
end;

// destroy
//
destructor TEvent.Destroy;
begin
  WriteLn('destroying client...');
  if FClient.Connected then
    FClient.Disconnect;
  UnwireMethods;
  FClient.Free;
  FClient := nil;
  WriteLn('client destroyed');
  inherited Destroy;
end;

// send
//
procedure TEvent.Send(Msg: string; const Prefix: string = #13#10);
begin
  if FClient.Connected then
    FClient.Sendln(Msg, Prefix);
end;

// setdisconnectonerror
//
procedure TEvent.SetDisconnectOnError(Value: boolean);
begin
  if FDisconnectOnError <> Value then
    FDisconnectOnError := Value;
end;

// unwiremethods
//
procedure TEvent.UnwireMethods;
begin
  WriteLn('unwiring client methods...');
  FClient.OnCreateHandle := nil;
  FClient.OnDestroyHandle := nil;
  FClient.OnConnect := nil;
  FClient.OnDisconnect := nil;
  FClient.OnReceive := nil;
  FClient.OnSend := nil;
  FClient.OnError := nil;
  WriteLn('unwiring done');
end;

// wiremethods
//
procedure TEvent.WireMethods;
begin
  WriteLn('wiring client methods...');
  FClient.OnCreateHandle := ClientCreateHandle;
  FClient.OnDestroyHandle := ClientDestroyHandle;
  FClient.OnConnect := ClientConnect;
  FClient.OnDisconnect := ClientDisconnect;
  FClient.OnReceive := ClientReceive;
  FClient.OnSend := ClientSend;
  FClient.OnError := ClientError;
  WriteLn('wiring done');
end;

{ TReadLnThread }

// execute
//
procedure TReadLnThread.Execute;
begin
  if not Assigned(gEvent) then begin
    Terminate;
    Exit;
  end;
  while not Terminated do begin
    if gEvent.Client.Connected then
      WriteLn(gEvent.Client.ReceiveLn);
  end;
end;

//var
  //cputmp: TStringlist;
  //i: Integer;

begin
  gEvent := TEvent.Create;
  gThread := TReadLnThread.Create(False);
  repeat
    ReadLn(gInput);
    gCommand := GetToken(gInput, 1, ' ');
    if gCommand = 'blockmode' then begin
      SetLength(gParameter, 1);
      gParameter[0] := GetToken(gInput, 2, ' ');
      if gParameter[0] = 'blocking' then begin
        gEvent.Client.BlockMode := bmBlocking;
        WriteLn('client blockmode = blocking');
      end
      else if gParameter[0] = 'nonblocking' then begin
        gEvent.Client.BlockMode := bmNonBlocking;
        WriteLn('client blockmode = nonblocking');
      end
      else begin
        case gEvent.Client.BlockMode of
          bmBlocking: WriteLn('client blockmode = blocking');
          bmNonBlocking: WriteLn('client blockmode = nonblocking');
        end;
      end;
    end
    else if gCommand = 'connect' then begin
      SetLength(gParameter, 2);
      gParameter[0] := GetToken(gInput, 2, ' ');
      gParameter[1] := GetToken(gInput, 3, ' ');
      if gParameter[0] <> '' then
        gEvent.Client.RemoteHost := gParameter[0];
      if gParameter[1] <> '' then
        gEvent.Client.RemotePort := gParameter[1];
      gEvent.Connect;
    end
    else if gCommand = 'disconnect' then
      gEvent.Disconnect
    else if gCommand = 'help' then begin
      WriteLn(':: available commands are:');
      WriteLn('- blockmode [blocking | nonblocking] - sets client blockmode');
      WriteLn('- connect - connects to a server');
      WriteLn('- disconnect - disconnect the client from a server');
      WriteLn('- quit - terminate this program');
      WriteLn('- help - displays this commands');
      WriteLn('- send - sends the text to the server');
    end
    else
      gEvent.Send(gInput);
  until gCommand = 'quit';
  FreeAndNil(gThread);
  FreeAndNil(gEvent);
end.