Salut Steve Batson !
unit Tnsrv1;
{
Author:     François PIETTE
Email:      2:293/2202@fidonet.org, fpiette@msn.com or BBS +32-41-651395
            (+32-4-365.13.95 starting from sept 14, 1996)
Creation:   April 1996
Object:     TnSrv implement a (very basic) Telnet server (daemon)
}
interface
uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, WSocket, WinSock, StdCtrls, Tnsrv2;
type
  TClient = class(TObject)
    Form      : TClientForm;
    Peer      : String;
    constructor Create(AOwner : TComponent);
    destructor  Destroy;
  end;
  TForm1 = class(TForm)
    Memo: TMemo;
    QuitButton: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Display(Msg : String);
    procedure QuitButtonClick(Sender: TObject);
    procedure FormActivate(Sender: TObject);
  protected
    procedure WMDisconnect(var msg: TMessage); message WM_DISCONNECT;
  private
    { Private declarations }
  public
    SrvSocket: TWSocket;
    Clients  : TList;
    procedure SrvSocketSessionAvailable(Sender: TObject; Error : word);
    procedure SrvSocketSessionClosed(Sender: TObject; Error : word);
  end;
var
  Form1: TForm1;
implementation
{$R *.DFM}
{$DEFINE Debug}      { Add or remove minus sign before dollar sign to }
                     { generate code for debug message output         }
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure DebugString(Msg : String);
const
    Cnt : Integer = 0;
var
    Buf : String[20];
begin
{$IFDEF Debug}
    Cnt := Cnt + 1;
    Buf := IntToHex(Cnt, 4) + ' ' + #0;
    OutputDebugString(@Buf[1]);
{$IFDEF WIN32}
    OutputDebugString(PChar(Msg));
{$ELSE}
    if Length(Msg) < High(Msg) then
        Msg[Length(Msg) + 1] := #0;
    OutputDebugString(@Msg[1]);
{$ENDIF}
{$ENDIF}
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
constructor TClient.Create(AOwner : TComponent);
begin
     Application.CreateForm(TClientForm, Form);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
destructor TClient.Destroy;
begin
    Form.Release;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TForm1.FormCreate(Sender: TObject);
begin
    Memo.Clear;
    Clients := TList.Create;
    SrvSocket                    := TWSocket.Create(Self);
    SrvSocket.Parent             := Self;
    SrvSocket.Top                := Memo.Top + Memo.Height + 2;
    SrvSocket.OnSessionAvailable := SrvSocketSessionAvailable;
    SrvSocket.OnSessionClosed    := SrvSocketSessionClosed;
    Display('Telnet Server Ready' + #13 + #10);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TForm1.FormDestroy(Sender: TObject);
begin
    SrvSocket.Free;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TForm1.FormActivate(Sender: TObject);
const
    FirstTime : Boolean = TRUE;
begin
    if not FirstTime then
        Exit;
    FirstTime := FALSE;
    SrvSocket.Proto := 'tcp';
    SrvSocket.Port  := 'telnet';
    SrvSocket.Addr  := '0.0.0.0';
    SrvSocket.Listen;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TForm1.Display(Msg : String);
var
    Start, Stop : Integer;
begin
    if Memo.Lines.Count = 0 then
        Memo.Lines.Add('');
    Start := 1;
    Stop  := Pos(#13, Msg);
    if Stop = 0 then
        Stop := Length(Msg) + 1;
    while Start <= Length(Msg) do begin
        Memo.Lines.Strings[Memo.Lines.Count - 1] := 
Memo.Lines.Strings[Memo.Lin
es.Count - 1] + Copy(Msg, Start, Stop - Start);
        if Msg[Stop] = #13 then begin
            Memo.Lines.Add('');
            SendMessage(Memo.Handle, WM_KEYDOWN, VK_UP, 1);
        end;
        Start := Stop + 1;
        if Start > Length(Msg) then
            Break;
        if Msg[Start] = #10 then
           Start := Start + 1;
        Stop := Start;
        while (Msg[Stop]  #13) and (Stop <= Length(Msg)) do
            Stop := Stop + 1;
    end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TForm1.SrvSocketSessionAvailable(Sender: TObject; Error : word);
var
    NewHSocket : TSocket;
    PeerName   : TSockAddrIn;
    Client     : TClient;
begin
    NewHSocket := SrvSocket.Accept;
    Client := TClient.Create(Self);
    Client.Form.Reference  := Client;
    Client.Form.AcceptForm := Self;
    Client.Form.Socket.Dup(NewHSocket);
    Client.Form.Socket.GetPeerName(PeerName, Sizeof(PeerName));
    Client.Peer := IntToStr(ord(PeerName.sin_addr.S_un_b.s_b1)) + '.' +
                   IntToStr(ord(PeerName.sin_addr.S_un_b.s_b2)) + '.' +
                   IntToStr(ord(PeerName.sin_addr.S_un_b.s_b3)) + '.' +
                   IntToStr(ord(PeerName.sin_addr.S_un_b.s_b4));
    Display('Remote ' + Client.Peer + ' connected' + #13 + #10);
    Client.Form.Caption := Client.Peer;
    Client.Form.Show;
{    Client.Form.SetFocus; }
    Clients.Add(Client);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TForm1.WMDisconnect(var msg: TMessage);
var
    Client : TClient;
    Why    : String;
begin
    case msg.wParam of
    DISCONNECT_SELF   : Why := 'has been disconnected';
    DISCONNECT_REMOTE : Why := 'has closed the connection';
    else                Why := 'disconnected';
    end;
    Client := TCLient(msg.lParam);
    Display('Remote ' + Client.Peer + ' ' + Why + #13 + #10);
    Client.Form.Socket.Shutdown(2);
    Client.Form.Socket.Close;
    Client.Form.Visible := FALSE;
    Client.Form.Release;
    Clients.Remove(Client);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TForm1.SrvSocketSessionClosed(Sender: TObject; Error : word);
begin
    Display(#13 + #10 + '*** Remote has closed ***' + #13 + #10);
    if SrvSocket.State = Opened then
        SrvSocket.Close;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TForm1.QuitButtonClick(Sender: TObject);
begin
    SrvSocket.Close;
    Close;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
end.
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
Amiti‚s,
{-Francois Piette-}
--- SvFido 1.32
---------------