{ -----------------------------------------------------------------------
Tcl Scripting Language Components (Tslc)
Copyright (C) 1996-2002 William Byrne

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

WilliamB@ByrneLitho.com
------------------------------------------------------------------------}
unit uTslcSox;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  TclTk, Tslc, TslcServ, StdCtrls, WinSock;

type
  TSocketsMod = class(TTclThreadServer)
    TclSockets: TTcl;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    TclCmd_socket: TTclCommand;
    TclCmd_select: TTclCommand;
    TclCmd_send: TTclCommand;
    TclCmd_recv: TTclCommand;
    TclCmd_ioctl: TTclCommand;
    TclCmd_setsockopt: TTclCommand;
    TclCmd_close: TTclCommand;
    TclCmd_accept: TTclCommand;
    TclCmd_listen: TTclCommand;
    TclCmd_gethostbyaddr: TTclCommand;
    TclCmd_gethostbyname: TTclCommand;
    TclCmd_inet_addr: TTclCommand;
    TclCmd_inet_ntoa: TTclCommand;
    TclCmd_ntohl: TTclCommand;
    TclCmd_ntohs: TTclCommand;
    TclCmd_htonl: TTclCommand;
    TclCmd_htons: TTclCommand;
    TclCmd_startup: TTclCommand;
    TclCmd_errno: TTclCommand;
    TclCmd_errno_string: TTclCmdSwitch;
    TclCmd_cleanup: TTclCommand;
    TclCmd_recv_buffer: TTclCmdSwitch;
    TclCmd_send_buffer: TTclCmdSwitch;
    TclCmd_getsockopt: TTclCommand;
    TclCmd_bind: TTclCommand;
    TclCmd_connect: TTclCommand;
    TclCmd_send__: TTclCmdSwitch;
    TclCmd_recv_translate: TTclCmdSwitch;
    TclCmd_send_translate: TTclCmdSwitch;
    procedure TclCmd_socketCommand(Sender: TTclCommand; var result: string;
      var success: Boolean);
    procedure TclCmd_acceptCommand(Sender: TTclCommand; var result: string;
      var success: Boolean);
    procedure TclCmd_closeCommand(Sender: TTclCommand; var result: string;
      var success: Boolean);
    procedure TclCmd_recvCommand(Sender: TTclCommand; var result: string;
      var success: Boolean);
    procedure TclCmd_listenCommand(Sender: TTclCommand; var result: string;
      var success: Boolean);
    procedure TclCmd_selectCommand(Sender: TTclCommand; var result: string;
      var success: Boolean);
    procedure TclCmd_sendCommand(Sender: TTclCommand; var result: string;
      var success: Boolean);
    procedure TclCmd_setsockoptCommand(Sender: TTclCommand;
      var result: string; var success: Boolean);
    procedure TclCmd_gethostbyaddrCommand(Sender: TTclCommand;
      var result: string; var success: Boolean);
    procedure TclCmd_gethostbynameCommand(Sender: TTclCommand;
      var result: string; var success: Boolean);
    procedure TclCmd_htonsCommand(Sender: TTclCommand; var result: string;
      var success: Boolean);
    procedure TclCmd_htonlCommand(Sender: TTclCommand; var result: string;
      var success: Boolean);
    procedure TclCmd_inet_addrCommand(Sender: TTclCommand;
      var result: string; var success: Boolean);
    procedure TclCmd_inet_ntoaCommand(Sender: TTclCommand;
      var result: string; var success: Boolean);
    procedure TclCmd_ntohlCommand(Sender: TTclCommand; var result: string;
      var success: Boolean);
    procedure TclCmd_ntohsCommand(Sender: TTclCommand; var result: string;
      var success: Boolean);
    procedure TclCmd_startupCommand(Sender: TTclCommand;
      var result: string; var success: Boolean);
    procedure TclCmd_errnoCommand(Sender: TTclCommand; var result: string;
      var success: Boolean);
    procedure TclCmd_cleanupCommand(Sender: TTclCommand;
      var result: string; var success: Boolean);
    procedure FormCreate(Sender: TObject);
    procedure TclCmd_getsockoptCommand(Sender: TTclCommand;
      var result: string; var success: Boolean);
    procedure TclCmd_ioctlCommand(Sender: TTclCommand; var result: string;
      var success: Boolean);
    procedure TclCmd_bindCommand(Sender: TTclCommand; var result: string;
      var success: Boolean);
    procedure TclCmd_connectCommand(Sender: TTclCommand;
      var result: string; var success: Boolean);
  private
    { Private declarations }
	FErrno: integer;
	function FmtHostEnt(phe: PHostEnt): string;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent; AThreadId: integer); override;
	class function GetThreadServer(AThreadId: integer): TSocketsMod;
    procedure Serve(AClient: TTcl); override;
    procedure ServeInterp(AInterp: pTcl_Interp); override;
    procedure Unserve(AClient: TTcl);

  end;

const
	TSLC_SOCKETS_VERSION_MAJOR = 1;
	TSLC_SOCKETS_VERSION_MINOR = 0;
	TSLC_SOCKETS_VERSION_ISSUE = 'a';
	TSLC_SOCKETS_NAME = 'TslcSockets';

procedure SocketsServeThread(AThreadId: integer; AClient: TTcl);
procedure SocketsServeThreadInterp(AThreadId: integer; AInterp: pTcl_Interp);

function GetErrorStr(error: integer): string;

implementation
uses TslcPlat, TslcUtil, uTslcUti;
{$R *.DFM}


procedure SocketsServeThread(AThreadId: integer; AClient: TTcl);
begin
	if AClient = nil then
    	exit;
	with TSocketsMod.GetThreadServer(AThreadId) do
    	Serve(AClient);
end;

procedure SocketsServeThreadInterp(AThreadId: integer; AInterp: pTcl_Interp);
begin
	if AInterp = nil then
    	exit;
	with TSocketsMod.GetThreadServer(AThreadId) do
    	ServeInterp(AInterp);
end;

class function TSocketsMod.GetThreadServer(AThreadId: integer): TSocketsMod;
begin
	result := TTclThreadServer.GetThreadServer(TSocketsMod, AThreadId) as TSocketsMod;
end;

procedure TSocketsMod.Serve(AClient: TTcl);
var
	x: integer;
begin
	if AClient = nil then // ??? should also check for redundancy
    	exit;

	for x:= 0 to ComponentCount - 1 do
    	if (Components[x] is TTclBridge) and (TTclBridge(Components[x]).Client = AClient) then
			exit;


    with TTclBridge.Create(Self) do
    begin
        Options := Options + [boFreeOnClientFree];
    	Server := TclSockets;
        Client := AClient;
    end;
end;

procedure TSocketsMod.Unserve(AClient: TTcl);
var
    x: integer;
begin

	for x:= 0 to ComponentCount - 1 do
    	if (Components[x] is TTclBridge) and (TTclBridge(Components[x]).Client = AClient) then
        begin
        	Components[x].Free;
            break;
        end;
end;



procedure TSocketsMod.ServeInterp(AInterp: pTcl_Interp);
begin
	if AInterp = nil then
    	exit;
	TclSockets.ServiceInterp(AInterp);
end;

constructor TSocketsMod.Create(AOwner: TComponent; AThreadId: integer);
begin
	InitTcl(''); // make sure Tcl procedure pointers get bound. Returns immediately if already initialized.
	inherited Create(AOwner, AThreadId);
    TclSockets.AutoActivate := False;
end;

const
	SIOCSHIWAT	= IOC_IN or
    	((longint(sizeof(longint)) and IOCPARM_MASK) shl 16) or
        (longint(Byte('s')) shl 8) or 0;
	SIOCGHIWAT	= IOC_OUT or
    	((longint(sizeof(longint)) and IOCPARM_MASK) shl 16) or
        (longint(Byte('s')) shl 8) or 1;
	SIOCSLOWAT	= IOC_IN or
    	((longint(sizeof(longint)) and IOCPARM_MASK) shl 16) or
        (longint(Byte('s')) shl 8) or 2;
	SIOCGLOWAT	= IOC_OUT or
    	((longint(sizeof(longint)) and IOCPARM_MASK) shl 16) or
        (longint(Byte('s')) shl 8) or 3;
	SIOCATMARK	= IOC_OUT or
    	((longint(sizeof(longint)) and IOCPARM_MASK) shl 16) or
        (longint(Byte('s')) shl 8) or 7;

    cNum = 0;
    cStr = 1;

    cTypes = 5;
    cTypeStr: array[0..cTypes - 1,0..1] of pChar = (
    	(pChar(SOCK_STREAM),	'SOCK_STREAM'),
        (pChar(SOCK_DGRAM),		'SOCK_DGRAM'),
        (pChar(SOCK_RAW),		'SOCK_RAW'),
        (pChar(SOCK_RDM),		'SOCK_RDM'),
        (pChar(SOCK_SEQPACKET),	'SOCK_SEQPACKET'));


	cProtos = 10;
	cProtoStr: array[0..cProtos - 1,0..1] of pChar = (
    	(pChar(IPPROTO_IP),		'IP'),
        (pChar(IPPROTO_ICMP),	'ICMP'),
        (pChar(IPPROTO_GGP),	'GCP'),
        (pChar(IPPROTO_TCP),	'TCP'),
        (pChar(IPPROTO_PUP),	'PUP'),
        (pChar(IPPROTO_UDP),	'UDP'),
        (pChar(IPPROTO_IDP),	'IDP'),
        (pChar(IPPROTO_ND),		'ND'),
        (pChar(IPPROTO_RAW),	'RAW'),
        (pChar(IPPROTO_MAX),	'MAX'));

	cPorts = 25;
	cPortStr: array[0..cPorts - 1,0..1] of pChar = (
    	(pChar(IPPORT_ECHO),	 	'ECHO'),
        (pChar(IPPORT_DISCARD),  	'DISCARD'),
        (pChar(IPPORT_SYSTAT),		'SYSTAT'),
        (pChar(IPPORT_DAYTIME),		'DAYTIME'),
        (pChar(IPPORT_NETSTAT),		'NETSTAT'),
        (pChar(IPPORT_FTP),			'FTP'),
        (pChar(IPPORT_TELNET),		'TELNET'),
        (pChar(IPPORT_SMTP),	 	'SMTP'),
        (pChar(IPPORT_TIMESERVER),	'TIMESERVER'),
        (pChar(IPPORT_NAMESERVER),	'NAMESERVER'),
        (pChar(IPPORT_WHOIS),	 	'WHOIS'),
        (pChar(IPPORT_MTP),			'MTP'),
        { Port/socket numbers: host specific functions }
        (pChar(IPPORT_TFTP), 	 	'TFTP'),
        (pChar(IPPORT_RJE),			'RJE'),
        (pChar(IPPORT_FINGER),		'FINGER'),
        (pChar(IPPORT_TTYLINK),		'TTYLINK'),
        (pChar(IPPORT_SUPDUP),		'SUPDUP'),
        { UNIX TCP sockets }
        (pChar(IPPORT_EXECSERVER),	'EXECSERVER'),
        (pChar(IPPORT_LOGINSERVER),	'LOGINSERVER'),
        (pChar(IPPORT_CMDSERVER),	'CMDSERVER'),
        (pChar(IPPORT_EFSSERVER),	'EFSSERVER'),
		{ UNIX UDP sockets }
		(pChar(IPPORT_BIFFUDP),		'BIFFUDP'),
        (pChar(IPPORT_WHOSERVER),	'WHOSERVER'),
		(pChar(IPPORT_ROUTESERVER),	'ROUTESERVER'),
		{ Ports < IPPORT_RESERVED are reserved for privileged processes (e.g. root). }
		(pChar(IPPORT_RESERVED), 	'RESERVED'));

	cOpts = 18;
    cOptStr: array[0..cOpts - 1,0..1] of pChar = (
		(pChar(SO_DEBUG),		'SO_DEBUG'),
		(pChar(SO_ACCEPTCONN),	'SO_ACCEPTCONN'),
		(pChar(SO_REUSEADDR),	'SO_REUSEADDR'),
		(pChar(SO_KEEPALIVE),	'SO_KEEPALIVE'),
		(pChar(SO_DONTROUTE),	'SO_DONTROUTE'),
		(pChar(SO_BROADCAST),	'SO_BROADCAST'),
		(pChar(SO_USELOOPBACK),	'SO_USELOOPBACK'),
		(pChar(SO_LINGER),		'SO_LINGER'),
		(pChar(SO_OOBINLINE),	'SO_OOBINLINE'),
		(pChar(SO_DONTLINGER),	'SO_DONTLINGER'),
		(pChar(SO_SNDBUF),		'SO_SNDBUF'),
		(pChar(SO_RCVBUF),		'SO_RCVBUF'),
		(pChar(SO_SNDLOWAT),	'SO_SNDLOWAT'),
		(pChar(SO_RCVLOWAT),	'SO_RCVLOWAT'),
		(pChar(SO_SNDTIMEO),	'SO_SNDTIMEO'),
		(pChar(SO_RCVTIMEO),	'SO_RCVTIMEO'),
		(pChar(SO_ERROR),		'SO_ERROR'),
		(pChar(SO_TYPE),		'SO_TYPE'));


	cLevels = 2;
    cLevelStr: array[0..cLevels - 1,0..1] of pChar = (
    	(pChar(SOL_SOCKET),		'SOL_SOCKET'),
        (pChar(IPPROTO_TCP),	'IPPROTO_TCP'));

	cIOCtls = 8;
    cIOCtlStr: array[0..cIOCtls - 1, 0..1] of pChar = (
    	(pChar(FIONBIO),		'FIONBIO'),
        (pChar(FIONREAD),		'FIONREAD'),
        (pChar(FIOASYNC),		'FIOASYNC'),
        (pChar(SIOCSHIWAT),		'SIOCSHIWAT'),
        (pChar(SIOCGHIWAT),		'SIOCGHIWAT'),
        (pChar(SIOCSLOWAT),		'SIOCSLOWAT'),
        (pChar(SIOCGLOWAT),		'SIOCGLOWAT'),
        (pChar(SIOCATMARK),		'SIOCATMARK'));

function StrToType(value: string): integer;
var
	e: integer;
begin
	Val(value, result, e);
    if e = 0 then
    	exit;

    for e := 0 to cTypes - 1 do
    	if TslcTextEqual(cTypeStr[e][cStr], value) then
        begin
        	result := integer(cTypeStr[e][cNum]);
            exit;
        end;

    TclErrorFmt('Unknown socket type: %s', [value]);
end;

function StrToProto(value: string): integer;
var
	e: integer;
begin
	Val(value, result, e);
    if e = 0 then
    	exit;

    for e := 0 to cProtos - 1 do
    	if TslcTextEqual(cProtoStr[e][cStr], value) then
        begin
        	result := integer(cProtoStr[e][cNum]);
            exit;
        end;

    TclErrorFmt('Unknown protocal: %s', [value]);
end;

function StrToPort(value: string): integer;
var
	e: integer;
begin
	Val(value, result, e);
    if e = 0 then
    	exit;

    for e := 0 to cPorts - 1 do
    	if TslcTextEqual(cPortStr[e][cStr], value) then
        begin
        	result := integer(cPortStr[e][cNum]);
            exit;
        end;

    TclErrorFmt('Unknown port: %s', [value]);
end;

function StrToOpt(value: string): integer;
var
	e: integer;
begin
	Val(value, result, e);
    if e = 0 then
    	exit;

    for e := 0 to cOpts - 1 do
    	if TslcTextEqual(cOptStr[e][cStr], value) then
        begin
        	result := integer(cOptStr[e][cNum]);
            exit;
        end;

    TclErrorFmt('Unknown option: %s', [value]);
end;

function StrToIOCtl(value: string): integer;
var
	e: integer;
begin
	Val(value, result, e);
    if e = 0 then
    	exit;

    for e := 0 to cIOCtls - 1 do
    	if TslcTextEqual(cIOCtlStr[e][cStr], value) then
        begin
        	result := integer(cIOCtlStr[e][cNum]);
            exit;
        end;

    TclErrorFmt('Unknown ioctl command: %s', [value]);
end;

function StrToLevel(value: string): integer;
var
	e: integer;
begin
	Val(value, result, e);
    if e = 0 then
    	exit;

    for e := 0 to cLevels - 1 do
    	if TslcTextEqual(cLevelStr[e][cStr], value) then
        begin
        	result := integer(cLevelStr[e][cNum]);
            exit;
        end;
    TclErrorFmt('Unknown level: %s', [value]);
end;

procedure TSocketsMod.TclCmd_acceptCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
var
	addr: string;
	sock, e, len: integer;
	sin: TSockAddrIn;
begin
	with Sender do
    begin
    	sock := TslcStrToInt(ParamValues[0]);
        if not GetVar(Interp, ParamValues[1], '', addr, []) then
        	TclErrorFmt('unable to read variable: %s', [ParamValues[1]]);
        sin.sin_family := AF_INET;
        sin.sin_addr.s_addr := htonl(inet_addr(pChar(addr)));
        sin.sin_port := htons(StrToPort(ParamValues[2]));
        len := sizeof(sin);
{$IFDEF VER90}
        e := accept(sock, TSockAddr(sin), len);
{$ELSE}
        e := accept(sock, PSockAddr(@sin), @len);
{$ENDIF}
        result := inttostr(e);
        if e <> INVALID_SOCKET then
        begin
        	if not SetVar(Interp, ParamValues[1], '', inet_ntoa(sin.sin_addr), []) then
            	TclErrorFmt('unable to set variable: %s', [ParamValues[1]]);
        	FErrno := 0
        end else
        	FErrno := WSAGetLastError;
    end;
end;

procedure TSocketsMod.TclCmd_bindCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
var
	sock, e, len: integer;
	sin: TSockAddrIn;
begin
	with Sender do
    begin
    	sock := TslcStrToInt(ParamValues[0]);
        sin.sin_family := AF_INET;
        sin.sin_addr.s_addr := htonl(inet_addr(pChar(ParamValues[1])));
        sin.sin_port := htons(StrToPort(ParamValues[2]));
        len := sizeof(sin);
        e := bind(sock, TSockAddr(sin), len);
        result := inttostr(e);
        if e = 0 then
        	FErrno := 0
        else
        	FErrno := WSAGetLastError;
    end;
end;

procedure TSocketsMod.TclCmd_closeCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
begin
	if closesocket(TslcStrToInt(Sender.ParamValues[0])) <> 0 then
    begin
    	result := '-1';
        FErrno := WSAGetLastError;
    end else
    begin
    	result := '0';
        FErrno := 0;
    end;
end;

procedure TSocketsMod.TclCmd_connectCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
var
	sock, e, len: integer;
	sin: TSockAddrIn;
begin
	with Sender do
    begin
    	sock := TslcStrToInt(ParamValues[0]);
        sin.sin_family := AF_INET;
        sin.sin_addr.s_addr := inet_addr(pChar(ParamValues[1]));
        sin.sin_port := htons(StrToPort(ParamValues[2]));
        len := sizeof(sin);
        e := connect(sock, TSockAddr(sin), len);
        result := inttostr(e);
        if e = 0 then
        	FErrno := 0
        else
        	FErrno := WSAGetLastError;
    end;
end;

function TSocketsMod.FmtHostEnt(phe: PHostEnt): string;
var
    host, aliases, addr_list: string;
    list: TStrings;
    x: integer;
    pp: ppChar;
begin
	if phe <> nil then
	begin
		list := TStringList.Create;
        try
        	pp := ppChar(phe^.h_aliases);
            if pp <> nil then
			while pp^ <> nil do
        	begin
            	list.add(pp^);
                inc(pp);
            end;
			aliases := MergeList(list);
            list.clear;
            pp := ppChar(phe^.h_addr_list);
            if pp <> nil then
        	while pp^ <> nil do
            begin
            	list.add(inet_ntoa((PInAddr(pp^))^));
                inc(pp);
            end;
            addr_list := MergeList(list);
            result := MergeArray([phe^.h_name, aliases, addr_list]);
        finally
        	list.free;
        end;
        FErrno := 0;
    end else
    begin
    	FErrno := WSAGetLastError;
        result := '';
    end;
end;

procedure TSocketsMod.TclCmd_gethostbyaddrCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
begin
	result := FmtHostEnt(gethostbyaddr(pChar(Sender.ParamValues[0]), 4, AF_INET));
end;


procedure TSocketsMod.TclCmd_gethostbynameCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
begin
	result := FmtHostEnt(gethostbyname(pChar(Sender.ParamValues[0])));
end;

procedure TSocketsMod.TclCmd_htonsCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
begin
	result := inttostr(htons(TslcStrToInt(Sender.ParamValues[0])));
end;

procedure TSocketsMod.TclCmd_htonlCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
begin
	result := inttostr(htonl(TslcStrToInt(Sender.ParamValues[0])));
end;

procedure TSocketsMod.TclCmd_ioctlCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
var
	sock, cmd, e: integer;
    val: u_long;
    str: string;
begin
	with Sender do
    begin
    	sock := TslcStrToInt(ParamValues[0]);
    	cmd := StrToIOCtl(ParamValues[1]);
        if not GetVar(Interp, ParamValues[2], '', str, []) then
        	TclErrorFmt('unable to read variable: %s', [ParamValues[2]]);
        if str = '' then
        	val := 0
        else
	        val := TslcStrToInt(str);
    	e := ioctlsocket(sock, cmd, val);
		result := inttostr(e);
        if e = 0 then
        begin
			FErrno := 0;
            if not SetVar(Interp, ParamValues[2], '', inttostr(val), []) then
            	TclErrorFmt('unable to set variable: %s', [ParamValues[2]]);
        end else
        	FErrno := WSAGetLastError;
	end;
end;

procedure TSocketsMod.TclCmd_inet_addrCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
begin
	result := inttostr(inet_addr(pChar(Sender.ParamValues[0])));
end;

procedure TSocketsMod.TclCmd_inet_ntoaCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
var
	ia: TInAddr;
begin
	ia.S_addr := TslcStrToInt(Sender.ParamValues[0]);
	result := inet_ntoa(ia);
end;

procedure TSocketsMod.TclCmd_listenCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
var
	e: integer;
begin
	with Sender do
    begin
    	e := listen(TslcStrToInt(ParamValues[0]), TslcStrToInt(ParamValues[1]));
        result := inttostr(e);
        if e = 0 then
        	FErrno := 0
        else
        	FErrno := WSAGetLastError;
    end;
end;

procedure TSocketsMod.TclCmd_ntohlCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
begin
	result := inttostr(ntohl(TslcStrToInt(Sender.ParamValues[0])));
end;

procedure TSocketsMod.TclCmd_ntohsCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
begin
	result := inttostr(ntohs(TslcStrToInt(Sender.ParamValues[0])));
end;

type
	TBufType = (btTclVar, btTslcBuffer);
const
    btError = TBufType(-1);
	BufTypeStr: array[btTclVar..btTslcBuffer] of pChar = ('TclVar', 'TslcBuffer');


function StrToBufType(value: string): TBufType;
begin
	for result := Low(TBufType) to High(TBufType) do
    	if TslcTextEqual(BufTypeStr[result], value) then
			exit;
    result := btError;
end;

procedure TSocketsMod.TclCmd_recvCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
var
	cmd: TTclCommand;
    buftype: TBufType;
    buf: array[0..1023] of char;
    p: pChar;
    c: char;
    cnt, len, rlen, smode, socket: integer;
begin
	cnt := Sender.ParamValuesCount;
   	socket := TslcStrToInt(Sender.ParamValues[0]);
    if cnt = 1 then
    begin
		len := recv(socket, c, 1, 0);
       	FErrno := 0;
        if len = 1 then
        begin
			if TclCmd_recv_translate.Hits > 0 then
	        	result := inttostr(integer(c))
            else
            	result := c;
        end else if len = 0 then
        	result := ''
        else
        begin
        	result := '-1';
           	FErrno := WSAGetLastError;
        end;
        exit;
    end;

	if TclCmd_recv_buffer.Hijacked then
    begin
		buftype := StrToBufType(TclCmd_recv_buffer.SwitchValue);
        if buftype = btError then
        	TclError('Invalid buffer type. Must be "TclVar" or "TslcBuffer"');
	end else
    	buftype := btTclVar;

	with Sender do
    begin
    	len := TslcStrToInt(ParamValues[2]);
        if cnt < 4 then
           smode := 0
        else
        	smode := 0; // ???
        if len > sizeof(buf) + 1 then
        	GetMem(p, len + 1)
        else
        	p := buf;
        try
			rlen := recv(socket, p^, len, smode);
            if rlen < 0 then
            	FErrno := WSAGetLastError
            else
            	FErrno := 0;
        	result := inttostr(rlen);
           	p[rlen] := #0;
   			if (len = 1) and (rlen = 1) and (TclCmd_recv_translate.Hits > 0) then
            begin
              	strpcopy(p, inttostr(integer(p[0])));
                rlen := strlen(p);
            end;
	    	if buftype = btTclVar then
            begin
				if not SetVar(Interp, ParamValues[1], '', p, []) then
                	TclErrorFmt('Could not write %d byte(s) to Tcl var: %s', [rlen, ParamValues[1]]);
	        end else
	        begin
				cmd := TslcFindCommand(Interp, ParamValues[1]);
				if (cmd = nil) or not (cmd is TTclCommandBuffer) then
            		TclErrorFmt('%s is not a TslcBuffer type', [ParamValues[1]]);
            	if rlen <> TTclCommandBuffer(cmd).Write(p, rlen) then
                	TclErrorFmt('Could not write %d byte(s) to Tslc buffer %s', [rlen, ParamValues[1]]);
            end;
		finally
        	if len > sizeof(buf) + 1 then
            	FreeMem(p);
        end;
    end;
end;

procedure TSocketsMod.TclCmd_selectCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);

	procedure FR(vari: string; var fds: TFDSet; timeval: boolean);
    var
    	buf: array[0..255] of char;
        p, q: pChar;
        descs: string;
    begin
    	fds.fd_count := 0;
		if vari = '' then
        	exit;
        if timeval then
        	descs := vari
        else if not GetVar(Sender.Interp, vari, '', descs, []) then
        	TclErrorFmt('unable to read variable: %s', [vari]);
		strlcopy(buf, pChar(descs), sizeof(buf) - 1)[sizeof(buf) -1] := #0;
        q := buf;
       	while q^ in [' ','{','}'] do
           	inc(q);
        while q^ <> #0 do
        begin
        	while q^ in [' ','{','}'] do
            	inc(q);
			p := q;
			while not (q^ in [' ','{','}',#0]) do
            	inc(q);
            if q^ <> #0 then
            begin
            	q^ := #0;
                inc(q);
            end;
            if fds.fd_count >= FD_SETSIZE then
            	TclErrorFmt('too many descriptors in fd_set', [descs]);
            fds.fd_array[fds.fd_count] := TslcStrToInt(p);
            inc(fds.fd_count);
        end;
	end;

    procedure FW(vari: string; var fds: TFDSet);
    var
    	x: integer;
        descs: string;
    begin
		if vari = '' then
        	exit;
		descs := '';
    	for x:= 0 to fds.fd_count - 1 do
        	if x = 0 then
        		descs := inttostr(fds.fd_array[x])
            else
            	descs := descs + ' ' + inttostr(fds.fd_array[x]);
        if not SetVar(Sender.Interp, vari, '', descs, []) then
        	TclErrorFmt('unable to set variable: %s', [descs]);
    end;

var
	cnt: integer;
	rbits, wbits, xbits, tbits: TFDSet;
    tv: TTimeVal;
    ptv: PTimeVal;
    str: string;
begin
	with Sender do
    begin
    	FR(ParamValues[0], rbits, False);
        FR(ParamValues[1], wbits, False);
        FR(ParamValues[2], xbits, False);
        FR(ParamValues[3], tbits, True);
        if tbits.fd_count = 0 then
        	ptv := nil
        else if tbits.fd_count = 1 then
        begin
        	tv.tv_sec := tbits.fd_array[0];
            tv.tv_usec := 0;
            ptv := @tv;
        end else if tbits.fd_count = 2 then
        begin
        	tv.tv_sec := tbits.fd_array[0];
            tv.tv_usec := tbits.fd_array[1];
            ptv := @tv;
        end else
        	TclErrorFmt('invalid timeval: %s', [ParamValues[3]]);

		cnt := select(0, @rbits, @wbits, @xbits, ptv);
        result := inttostr(cnt);
        if cnt >= 0 then
			FErrno := 0
        else
        	FErrno := WSAGetLastError;
    	FW(ParamValues[0], rbits);
        FW(ParamValues[1], wbits);
        FW(ParamValues[2], xbits);
    end;
end;

procedure TSocketsMod.TclCmd_sendCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
var
	cmd: TTclCommand;
    buftype: TBufType;
    buf: string;
    len, smode, socket: integer;
    p: pChar;
begin
	if TclCmd_send_buffer.Hijacked then
    begin
		buftype := StrToBufType(TclCmd_send_buffer.SwitchValue);
        if buftype = btError then
        	TclError('Invalid buffer type. Must be "TclVar" or "TslcBuffer"');
	end else
    	buftype := btError; // implies raw data ( hard string )

	with Sender do
    begin
    	socket := TslcStrToInt(ParamValues[0]);
        p := pChar(ParamValues[1]);
    	len := TslcStrToInt(ParamValues[2]);
        if ParamValuesCount < 4 then
        	smode := 0
        else
        	smode := 0; // ???

		if buftype = btError then
        begin
        	if (len = 1) and (strlen(p) = 3) and (TclCmd_send_translate.Hits > 0) and
            	(p^ = '{') and ((p + 2)^ = '}') then
				inc(p);
            len := send(socket, p^, len, smode);
            result := inttostr(len);
            if len < 0 then
            	FErrno := WSAGetLastError
            else
            	FErrno := 0;
            exit;
        end;
    	if buftype = btTclVar then
        begin
	        if not GetVar(Interp, ParamValues[1], '', buf, []) then
    	    	TclErrorFmt('Could not read Tcl var: %s', [ParamValues[1]]);
            p := pChar(buf);
        end else
        begin
        	cmd := TslcFindCommand(Interp, ParamValues[1]);
            if (cmd = nil) or not (cmd is TTclCommandBuffer) then
            	TclErrorFmt('%s is not a TslcBuffer type', [ParamValues[1]]);
            SetString(buf, nil, len);
            if len <> TTclCommandBuffer(cmd).Read(pChar(buf), len) then
            	TclErrorFmt('Could not read %d byte(s) from Tslc buffer %s', [len, ParamValues[1]]);
			p := pChar(buf);
        end;
       	if (len = 1) and (strlen(p) = 3) and (TclCmd_send_translate.Hits > 0) and
           	(p^ = '{') and ((p + 2)^ = '}') then
			inc(p);

		len := send(socket, p^, len, smode);
        if len < 0 then
        	FErrno := WSAGetLastError
        else
        	FErrno := 0;
        result := inttostr(len);
    end;
end;

procedure TSocketsMod.TclCmd_getsockoptCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
var
	sock, level, opt, value, sz, ret: integer;
    linger: TLinger;
    s: string;
begin
	with Sender do
    begin
    	sock := TslcStrToInt(ParamValues[0]);
        level := StrToLevel(ParamValues[1]);
		opt := StrToOpt(ParamValues[2]);
		if opt = SO_LINGER then
        begin
        	sz := sizeof(linger);
	        ret := getsockopt(sock, level, opt, pChar(@linger), sz);
            if ret = 0 then
            	s := MergeArray([inttostr(linger.l_onoff), inttostr(linger.l_linger)]);
        end else
        begin
        	sz := sizeof(value);
	        ret := getsockopt(sock, level, opt, pChar(@value), sz);
			if ret = 0 then
            	s := inttostr(value);
        end;
        if ret <> 0 then
        	FErrno := WSAGetLastError
        else
        begin
        	FErrno := 0;
			if not SetVar(Interp, ParamValues[3], '', s, []) then
				TclErrorFmt('Unable to set Tcl variable: %s', [ParamValues[3]]);
		end;

        result := inttostr(value);
    end;
end;

procedure TSocketsMod.TclCmd_setsockoptCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
var
	sock, level, opt, value, sz: integer;
    p: pChar;
    linger: TLinger;
    list: TStrings;
begin
	with Sender do
    begin
    	sock := TslcStrToInt(ParamValues[0]);
        level := StrToLevel(ParamValues[1]);
		opt := StrToOpt(ParamValues[2]);
		if opt = SO_LINGER then
        begin
			list := TStringList.Create;
            try
                if not SplitList(Interp, ParamValues[3], list) or (list.Count <> 2) then
                	TclErrorFmt('malformed list for SO_LINGER: %s', [ParamValues[3]]);
            	linger.l_onoff := TslcStrToInt(list.strings[0]);
                linger.l_linger := TslcStrToInt(list.strings[1]);
            finally
            	list.free;
            end;
            p := pChar(@linger);
            sz := sizeof(linger);
        end else
        begin
        	value := TslcStrToInt(ParamValues[3]);
            p := pChar(@value);
            sz := sizeof(value);
        end;
        value := setsockopt(sock, level, opt, p, sz);
        if value <> 0 then
        	FErrno := WSAGetLastError
        else
        	FErrno := 0;
        result := inttostr(value);
    end;
end;


procedure TSocketsMod.TclCmd_socketCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
var
	sock: integer;
begin
	with Sender do
    begin
		sock := socket(AF_INET, StrToType(ParamValues[0]), StrToProto(ParamValues[1]));
		if sock < 0 then
        	FErrno := WSAGetLastError
        else
        	FErrno := 0;
        result := inttostr(sock);
    end;
end;

var
	ErrorStr: array[0..114] of pChar;

function GetErrorStr(error: integer): string;
begin
	if error = 0 then
    begin
    	result := '0';
        exit;
    end;
	dec(error, WSABASEERR);
	if error < 0 then
    begin
    	result := 'UNKNOWN';
        exit;
    end;
    if error > 1000 then
    	inc(error, -890); // simply elimanates undocumented error codes between 101 and 1000

    if error > 114 then
    	result := 'UNKNOWN'
    else if ErrorStr[error] = nil then
    	result := 'UNKNOWN'
    else
    	result := ErrorStr[error];
end;


procedure Init;
begin
	ErrorStr[0]		:= nil;
	ErrorStr[1]		:= nil;
	ErrorStr[2]		:= nil;
	ErrorStr[3]		:= nil;
	ErrorStr[4]		:= 'EINTR';
	ErrorStr[5]		:= nil;
	ErrorStr[6]		:= nil;
	ErrorStr[7]		:= nil;
	ErrorStr[8]		:= nil;
	ErrorStr[9]		:= 'EBADF';
	ErrorStr[10]	:= nil;
	ErrorStr[11]	:= nil;
	ErrorStr[12]	:= nil;
	ErrorStr[13]	:= 'EACCES';
	ErrorStr[14]	:= 'EFAULT';
	ErrorStr[15]	:= nil;
	ErrorStr[16]	:= nil;
	ErrorStr[17]	:= nil;
	ErrorStr[18]	:= nil;
	ErrorStr[19]	:= nil;
	ErrorStr[20]	:= nil;
	ErrorStr[21]	:= nil;
	ErrorStr[22]	:= 'EINVAL';
	ErrorStr[23]	:= nil;
	ErrorStr[24]	:= 'EMFILE';
	ErrorStr[25]	:= nil;
	ErrorStr[26]	:= nil;
	ErrorStr[27]	:= nil;
	ErrorStr[28]	:= nil;
	ErrorStr[29]	:= nil;
	ErrorStr[30]	:= nil;
	ErrorStr[31]	:= nil;
	ErrorStr[32]	:= nil;
	ErrorStr[33]	:= nil;
	ErrorStr[34]	:= nil;
	ErrorStr[35]	:= 'EWOULDBLOCK';
	ErrorStr[36]	:= 'EINPROGRESS';
	ErrorStr[37]	:= 'EALREADY';
	ErrorStr[38]	:= 'ENOTSOCK';
	ErrorStr[39]	:= 'EDESTADDRREQ';
	ErrorStr[40]	:= 'EMSGSIZE';
	ErrorStr[41]	:= 'EPROTOTYPE';
	ErrorStr[42]	:= 'ENOPROTOOPT';
	ErrorStr[43]	:= 'EPROTONOSUPPORT';
	ErrorStr[44]	:= 'ESOCKTNOSUPPORT';
	ErrorStr[45]	:= 'EOPNOTSUPP';
	ErrorStr[46]	:= 'EPFNOSUPPORT';
	ErrorStr[47]	:= 'EAFNOSUPPORT';
	ErrorStr[48]	:= 'EADDRINUSE';
	ErrorStr[49]	:= 'EADDRNOTAVAIL';
	ErrorStr[50]	:= 'ENETDOWN';
	ErrorStr[51]	:= 'ENETUNREACH';
	ErrorStr[52]	:= 'ENETRESET';
	ErrorStr[53]	:= 'ECONNABORTED';
	ErrorStr[54]	:= 'ECONNRESET';
	ErrorStr[55]	:= 'ENOBUFS';
	ErrorStr[56]	:= 'EISCONN';
	ErrorStr[57]	:= 'ENOTCONN';
	ErrorStr[58]	:= 'ESHUTDOWN';
	ErrorStr[59]	:= 'ETOOMANYREFS';
	ErrorStr[60]	:= 'ETIMEDOUT';
	ErrorStr[61]	:= 'ECONNREFUSED';
	ErrorStr[62]	:= 'ELOOP';
	ErrorStr[63]	:= 'ENAMETOOLONG';
	ErrorStr[64]	:= 'EHOSTDOWN';
	ErrorStr[65]	:= 'EHOSTUNREACH';
	ErrorStr[66]	:= 'ENOTEMPTY';
	ErrorStr[67]	:= 'EPROCLIM';
	ErrorStr[68]	:= 'EUSERS';
	ErrorStr[69]	:= 'EDQUOT';
	ErrorStr[70]	:= 'ESTALE';
	ErrorStr[71]	:= 'EREMOTE';
	ErrorStr[72]	:= nil;
	ErrorStr[73]	:= nil;
	ErrorStr[74]	:= nil;
	ErrorStr[75]	:= nil;
	ErrorStr[76]	:= nil;
	ErrorStr[77]	:= nil;
	ErrorStr[78]	:= nil;
	ErrorStr[79]	:= nil;
	ErrorStr[80]	:= nil;
	ErrorStr[81]	:= nil;
	ErrorStr[82]	:= nil;
	ErrorStr[83]	:= nil;
	ErrorStr[84]	:= nil;
	ErrorStr[85]	:= nil;
	ErrorStr[86]	:= nil;
	ErrorStr[87]	:= nil;
	ErrorStr[88]	:= nil;
	ErrorStr[89]	:= nil;
	ErrorStr[90]	:= nil;
	ErrorStr[91]	:= nil;
	ErrorStr[92]	:= nil;
	ErrorStr[93]	:= nil;
	ErrorStr[94]	:= nil;
	ErrorStr[95]	:= nil;
	ErrorStr[96]	:= nil;
	ErrorStr[97]	:= nil;
	ErrorStr[98]	:= nil;
	ErrorStr[99]	:= nil;
	ErrorStr[100]	:= nil;
	ErrorStr[101]	:= 'EDISCON';
	ErrorStr[91]	:= 'SYSNOTREADY';
	ErrorStr[92]	:= 'VERNOTSUPPORTED';
	ErrorStr[93]	:= 'NOTINITIALISED';
	ErrorStr[105]	:= nil;
	ErrorStr[106]	:= nil;
	ErrorStr[107]	:= nil;
	ErrorStr[108]	:= nil;
	ErrorStr[109]	:= nil;
	ErrorStr[110]	:= nil;
	ErrorStr[111]	:= 'HOST_NOT_FOUND';
	ErrorStr[112]	:= 'TRY_AGAIN';
	ErrorStr[113]	:= 'NO_RECOVERY';
	ErrorStr[114]	:= 'NO_DATA';

end;

procedure TSocketsMod.TclCmd_startupCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
var
	data: TWSADATA;
	major, minor: integer;
    ver: array[0..9] of char;
    p: pChar;
begin
	with Sender do
    begin
    	if ParamValuesCount > 0 then
        	strlcopy(ver, pChar(ParamValues[0]), 9)[9] := #0
        else
        	strcopy(ver, '1.1');
		p := ver;
        while p^ <> #0 do
        	if p^ = '.' then
            begin
            	p^ := #0;
                inc(p);
                break;
            end else
            	inc(p);
    	major := TslcStrToInt(ver);
        if p^ <> #0 then
        	minor := TslcStrToInt(p)
        else
        	minor := 0;
        FErrno := WSAStartup(MAKEWORD(major, minor), data);
		result := inttostr(FErrno);
	end;
end;

procedure TSocketsMod.TclCmd_errnoCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
begin
	if TclCmd_errno_string.Hits > 0 then
    begin
		if TclCmd_errno_string.Hijacked then
            result := GetErrorStr(TslcStrToInt(TclCmd_errno_string.SwitchValue))
        else
        	result := GetErrorStr(FErrno);
    end else
    	result := inttostr(FErrno);
    FErrno := 0;
end;

procedure TSocketsMod.TclCmd_cleanupCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
begin
	result := inttostr(WSACleanup);
end;

procedure TSocketsMod.FormCreate(Sender: TObject);
begin
	FErrno := 0;
end;



initialization;
	Init;
	RegisterTclServer(TSocketsMod);
	TslcPrepareCritical;

finalization
	TslcDoneCritical;


end.
