Delphi控件源码

开发平台：

WINDOWS

WSOCKET.PAS：源码内容

{*_* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
Author: Fran鏾is PIETTE
Description: TWSocket class encapsulate the Windows Socket paradigm
EMail: francois.piette@pophost.eunet.be francois.piette@rtfm.be
http://www.rtfm.be/fpiette
Creation: April 1996
Version: 4.07
Support: Use the mailing list twsocket@rtfm.be See website for details.
Rue de Grady 24, 4053 Embourg, Belgium. Fax: +32-4-365.74.56
<francois.piette@pophost.eunet.be>
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:
Jul 18, 1996 Move all low level socket to winsock to be Delphi 2.x compatible
Sep 18, 1996 Use structured exception for handling errors
Sep 19, 1996 Check csDestroying before invoking event handler
Nov 04, 1996 Better error handling
Jan 31, 1997 Changed property assignation for Addr, Port and Proto
Added notification handler
Feb 14, 1997 Corrected bug in property assignation for Addr, Port and Proto
Mar 26, 1997 Make UDP protocol work correctly
Enable UDP broadcasting by using addr 255.255.255.255
Apr 1, 1997 Added class function when independent of any open socket
Moved InitData as global
Added ReceivedFrom function
Added ResolveHost function
Jul 22, 1997 Adapted to Delphi 3 which has a modified winsock.accept
Aug 13, 1997 'sin' member made public
Aug 24, 1997 Create the only help
Makes writing HSocket the same as calling Dup.
Sep 5, 1997 Version 2.01, added WinsockInfo function
Sep 21, 1997 Version 2.02, make it really thread safe
created global WSocketVersion
Sep 25, 1997 Version 2.04, port to C++Builder
Sep 27, 1997 Version 2.05. All class methods converted to global
procedure or function because C++Builder do not like
class method very much.
Old class method New global function
---------------- -------------------
WinsockInfo WinsockInfo
SocketErrorDesc WSocketErrorDesc
GetHostByAddr WSocketGetHostByAddr
GetHostByName WSocketGetHostByName
ResolveHost WSocketResolveHost
HostName LocalHostName
Oct 02, 1997 V2.06 Added a check in destructor to avoid calling WSACleanup at
design time which crashes the excellent Eagle Software CDK.
Oct 16, 1997 V2.07 Added PortNum property with numeric value for Port.
Added RcvdCount property to return the number of
characters received in the buffer but not read yet. Do not
confuse with ReadCount which returns the number of chars
already received.
Added a check for FWait assignation in front of ReadLine
Prefixed each TSocketState value by 'ws' to avoid name conflict.
Moved FHSocket member to private section because the property
HSocket does the right job.
Added a check for state closed when changing Port, Proto and Addr.
Oct 22, 1997 V2.08 Added Flush method (asked by john@nexnix.co.uk) and
FlushTimeout property (default to 60 seconds).
Oct 22, 1997 V2.09 Added SendFlags property to enable sending in or out of
band data (normal or urgent, see RFC-1122)
Oct 28, 1997 V2.10 Added an OnLineTooLong event and code to handle the case
where ReadLine has been called and the buffer overflowed (line
long)
Oct 29, 1997 V2.11 Added DnsLookup functionnality (DnsLookup method, DnsResult
property and DnsLookupDone event).
Calling the connect method with a hostname work well except that
it could block for a long period (ie: 2 minutes) if DNS do not
respond. Calling the connect method with a numeric IP address will
never block. So you can call DnsLookup to start hostname
resolution in the background, after some time you evenutually
receive the OnDnsLookupDone event. The copy the DnsResult property
to the Addr property and call connect.
Oct 30, 1997 V2.12 added a check in DnsLookup to handel numeric IP which do
not require any lookup. The numeric IP is treated immediately
and immediately trigger the DnsLookupDone event.
I modified the code to be compatible with Delphi 1.
Oct 31, 1997 V2.13 added CancelDnsLookup procedure.
Nov 09, 1997 V2.14 add LocalIPList function to get the list of local IP
addresses (you have two IP addresses when connected to a LAN
and an ISP).
Nov 11, 1997 V2.15 Made TCustomWSocket with virtual functions. This will
allow to easily descend a new component from TCustomWSocket.
Make ReadLine stop when the connection is broken.
Nov 12, 1997 V2.16 Corrected bug (Justin Yunke <yunke@productivity.org>)
in LocalIPList: phe should be checked for nil.
Nov 18, 1997 Added ReceiveStr function (Suggested by FLDKNHA@danisco.com)
Nov 30, 1997 V2.18 Added a call to OnDnsLookupDone when canceling.
Dec 04, 1997 V2.19 Added LocalPort property and SessionConnected event
for UDP socket.
V2.20 Modified MessageLoop and ProcessMessages to process not
only the socket messages, but all messages (necessary if the
thread has several TWSocket for example).
Dec 09, 1997 V2.21 Corrected a minor bug in ReceiveStr. Detected by
david@e.co.za (David Butler).
Dec 10, 1997 V2.22 Corrected a minor bug in Send which now correctly
returns the number of bytes sent. Detected by
james.huggins@blockbuster.com
Dec 16, 1997 V2.23 Corrected a bug which prevented the receiving of datagram
from a UDP socket.
Thank to Mark Melvin (melvin@misrg.ml.org) for pointing it.
Dec 20, 1997 V2.24 Added the PeekData function as suggested by Matt Rose
mcrose@avproinc.com
Dec 26, 1997 V2.25 Added the Text property as suggested by Daniel P. Stasinski
<dse@pacific.net>. Made GetXPort work even when listening as
suggested by is81024@cis.nctu.edu.tw.
Jan 10, 1998 V2.26 Check for null hostname in DNSLookup
Added DnsResultList with all IP addresses returned form DNS
Jan 13, 1998 V2.27 a Added MultiThreaaded property to tell the component that
it is working in a thread and should take care of it (call
internal ProcessMessages in place of Application.ProcessMessages,
and do not use the WaitCtrl object).
Jan 15, 1998 V2.28 WMAsyncSelect revisited to work properly with NT winsock 2.
Feb 10, 1998 V2.29 Added an OnError event. If not assigned, then the component
raise an exception when the error occurs.
Feb 14, 1998 V2.30 Published Text property
Feb 16, 1998 V2.31 Added virtual methods to trigger events
Renamed all event handler variable to begin with FOn
Feb 26, 1998 V2.32 Added procedure PutDataInSendBuffer and PutStringInSendBuffer
Using PutDataInSendBuffer you can place data in the send buffer
without actualy trying to send it. This allows to place several
(probably small) data chunk before the component attempt to send
it. This prevent small packet to be sent. You can call
Send(nil, 0) to force the component to begin to send data.
If the buffer was not empty, PutDataInSendBuffer will just queue
data to the buffer. This data will be sent in sequence.
Mar 02, 1998 V2.33 Changed the error check with WSAstartup as pointed out by
Donald Strenczewilk (dstrenz@servtech.com)
Mar 06, 1998 V2.34 Added a runtime property to change the buffer size.
Mar 27, 1998 V2.35 Adapted for C++Builder 3
Apr 08, 1998 V2.36 Made SetDefaultValue virtual
Apr 13, 1998 V2.37 Reset FDnsLookupHandle to 0 after a failed call to
WSACancelAsyncRequest
Apr 22, 1998 V2.38 Published AllSent property to let outside know if our
buffer has some data unsent.
Apr 28, 1998 V2.39 Added LingerOnOff and LingerTimeout. Default values are
wsLingerOn and timeout = 0 to behave by default as before.
This value is setup just before Connect. Call SetLingerOption to
set the linger option on the fly (the connection must be
established to set the option). See winsock.closesocket on line
help (winsock.hlp or win32.hlp) for a dsicussion of this option
usage.
May 06, 1998 V2.40 Added a workaround for Trumpet winsock inet_addr bug.
Thanks to Andrej Cuckov <andrej@cuckov.com> for his code.
May 18, 1998 V2.41 Jan Tomasek <xtomasej@feld.cvut.cz> found that Trumpet
Winsock (Win 3.11) has some bugs and suggested a workaround in
TryToSend procedure. This workaround makes TWSocket blocking in
some cases. A new property enables the workaround. See code.
Jun 01, 1998 V2.42 In finalization section, check for not assigned IPList.
Jun 15, 1998 V2.43 Added code to finalization section to unload winsock if
still loaded at that point (this happend if no socket where
created but WinsockInfo called). Suggested by Daniel Fazekas
<fdsoft@dns.gyor-ph.hu>
Jun 27, 1998 V2.44 Added checks for valid arguments in SetPort, SetProto
and SetAddr. Deferred address resolution until Connect or Listen.
Jul 08, 1998 V2.45 Adadpted for Delphi 4
Jul 20, 1998 V2.46 Added SetWindowLong(FWindowHandle, 0, 0) in the destructor
and a check for TWSocket class in XSocketWindowProc.
Added virtual method RealSend.
Jul 23, 1998 V2.47 Added a TriggerSessionClosed from TryToSend in case of
send error. This was called before, but with a nul error argument.
Now it correctly gives the error number.
Added a trashcan to receive data if no OnDataAvailable event
handler is installed. Just receive the data and throw it away.
Added reverse dns lookup asynchronous code (IP -> HostName).
Thanks to Daniel Fazekas <fdsoft@dns.gyor-ph.hu> for his code.
Jul 30, 1998 V2.48 Changed local variable "error" by FLastError in SocketError
to make it available from the OnError handler. Thanks to
dana@medical-info.com for finding this bug.
In Abort procedure, deleted all buffered data because it was send
the next time the socket is opened !
Added CancelDnsLookup in Abort procedure.
Aug 28, 1998 V2.49 Made InternalClose and ReceiveStr virtual
Sep 01, 1998 V2.50 Ignore CancelDnsLookup exception during destroy
Sep 29, 1998 V2.51 In InternalClose, protect AssignDefaultValue with
try/except because SessionClosed event handler may have destroyed
the component.
Oct 11, 1998 V2.52 Changed Shutdown(2) to Shutdown(1) in Internal Close to
prevent data lost on send. You may have to call Shutdown(2) in
your own code before calling Close to have the same behaviour as
before.
Changed argument type for ASyncReceive and passed 0 from FD_CLOSE
message handler.
Oct 28, 1998 V2.53 Made WSocketLoadWinsock and WSocketUnloadWinsock public.
Nov 11, 1998 V2.54 Added OnDisplay event for debugging purpose
Nov 16, 1998 V2.55 Ignore WSANOTINITIALIZED error calling CloseSocket. This
occurs when using TWSocket from a DLL and the finalization
section is called before destroying TWSocket components (this is
a program logic error).
Made some properties and methods protected instead of private.
Made some methods virtual.
Added an Error argument to InternalClose.
Added DoRecv virtual function.
Added WSocketResolvePort
Added WSocketResolveProto
Deferred port and protocol resolution until really needed
Transformed Listen to procedure (in case of failure Listen
always calls SocketError which triggers an exception or the
OnError event).
Nov 22, 1998 V3.00 Skipped from V2.55 to V3.00. Socks support is major update!
Added SOCKS5 support for TCP connection and simple usercode
paswword authentication. Consider the socks code as beta !
New properties: SocksServer, SocksPort, SocksUsercode,
SocksPassword, FSocksAuthentication. New events: OnSocksError,
OnSocksConnected, OnSocksAuthState.
I used WinGate 2.1d to test my code. Unfortunately WinGate do
not correctly handle user authentication, so the code here is
just untested...
Dec 05, 1998 V3.10 Removed ReadLine feature using TWait component.
Added new TCustomLineWSocket and TCustomSyncWSocket.
Those modifications implies that the ReadLine functionnality is
slightly changed. Notably, the end of line marker is now
configurable and remains in the received line unless a timeout
occurs or the buffer is too small.
Dec 10, 1998 V3.11 Added missing code to resolve port in the Listen method.
Dec 12, 1998 V3.12 Added write method for LocalPort property. Thanks to
Jan Tomasek <xtomasej@feld.cvut.cz> for his code.
Added background exception handling.
Fixed a bug in TCustomLineWSocket.TriggerDataAvailable which was
not calling the inherited function when it actually should.
Added a check on multithreaded in WaitForClose to call the
correct ProcessMessages procedure.
Added SOCKS4 support (only tcp connect is supported).
Dec 28, 1998 V3.13 Changed WSocketResolveHost to check for invalid numeric
IP addresses whitout trying to use them as hostnames.
Dec 30, 1998 V3.14 Changed SetPort to SetRemotePort to solve the SetPort
syndrome with BCB. Also chnaged GetPort to be consistant.
Jan 12, 1999 V3.15 Introduced DoRecvFrom virtual function. This correct a bug
introduced in V3.14 related to UDP and RecvFrom.
Jan 23, 1999 V3.16 Changed FRcvdFlag computation in DoRecv and DoRecvFrom
because it caused problems with HTTP component and large blocks.
Removed modification by Jan Tomasek in TriggerDataAvailable
Jan 30, 1999 V3.17 Added WSocketResolveIp function.
Checked for tcp protocol before setting linger off in abort.
Moved a lot of variables from private to protected sections.
Removed check for Assigned(FOnDataSent) in WMASyncSelect.
Feb 03, 1999 V3.18 Removed useless units in the uses clause.
Feb 14, 1999 V4.00 Jump to next major version number because lots of
fundamental changes have been done. See below.
Use runtime dynamic link with winsock. All winsock functions
used by TWSocket are linked at runtime instead of loadtime. This
allows programs to run without winsock installed, provided program
doesn't try to use TWSocket or winsock function without first
checking for winsock installation.
Removed WSocketLoadWinsock and all use to DllStarted because it
is no longer necessary because winsock is automatically loaded
and initialized with the first call to a winsock function.
Added MessagePump to centralize call to the message pump.
It is a virtual procedure so that you can override it to
cutomize your message pump. Also changed slightly ProcessMessages
to closely match what is done in the forms unit.
Removed old stuff related to WaitCtrl (was already excluded from
compilation using a conditional directive).
Added NOFORMS conditional compilation to exclude the Forms unit
from wsocket. This will reduce exe or dll size by 100 to 150KB.
To use this feature, you have to add NOFORMS in your project
options in the "defines" edit box in the "directory/conditional"
tab. Then you must add a message pump to your application and
call it from TWSocket.OnMessagePump event handler. TWSocket really
need a message pump in order to receive messages from winsock.
Depending on how your application is built, you can use either
TWSocket.MessageLoop or TWSocket.ProcessMessages to quickly build
a working message pump. Or you may build your own custom message
pump taylored to your needs. Your message pump must set
TWSocket.Terminated property to TRUE when your application
terminates or you may experience long delays when closing your
application.
You may use NOFORMS setting even if you use the forms unit (GUI
application). Simply call Application.ProcessMessages in the
OnMessagePump event handler.
OnMessagePump event is not visible in the object inspector. You
must assign it at run-time before using the component and after
having created it (in a GUI application you can do that in the
FormCreate event, in a console application, you can do it right
after TWSocket.Create call).
Feb 17, 1999 V4.01 Added LineEcho and LineEdit features.
Feb 27, 1999 V4.02 Added TCustomLineWSocket.GetRcvdCount to make RcvdCount
property and ReceiveStr work in line mode.
Mar 01, 1999 V4.03 Added conditional compile for BCB4. Thanks to James
Legg <jlegg@iname.com>.
Mar 14, 1999 V4.04 Corrected a bug: wsocket hangup when there was no
OnDataAvailable handler and line mode was on.
Apr 21, 1999 V4.05 Added H+ (long strings) and X+ (extended syntax)
compilation options
May 07, 1999 V4.06 Added WSAECONNABORTED to valid error codes in TryToSend.
Jul 21, 1999 V4.07 Added GetPeerPort method, PeerPort and PeerAddr propertied
as suggested by J. Punter <JPunter@login-bv.com>.
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
unit WSocket;
{$B-} { Enable partial boolean evaluation }
{$T-} { Untyped pointers }
{$X+} { Enable extended syntax }
{$IFNDEF VER80} { Not for Delphi 1 }
{$H+} { Use long strings }
{$J+} { Allow typed constant to be modified }
{$ENDIF}
{$IFDEF VER110} { C++ Builder V3.0 }
{$ObjExportAll On}
{$ENDIF}
interface
uses
WinTypes, WinProcs, Messages, Classes, SysUtils,
{$IFNDEF NOFORMS} { See comments in history at 14/02/99 }
Forms,
{$ENDIF}
WSockBuf, WinSock;
const
WSocketVersion = 407;
CopyRight : String = ' TWSocket (c) 96-99 F. Piette V4.07 ';
WM_ASYNCSELECT = WM_USER + 1;
WM_ASYNCGETHOSTBYNAME = WM_USER + 2;
WM_ASYNCGETHOSTBYADDR = WM_USER + 3;
WM_TRIGGER_DATA_AVAILABLE = WM_USER + 20;
WSA_WSOCKET_TIMEOUT = 12001;
{$IFDEF WIN32}
winsocket = 'wsock32.dll'; { 32 bits TCP/IP system DLL }
{$ELSE}
winsocket = 'winsock.dll'; { 16 bits TCP/IP system DLL }
{$ENDIF}
type
ESocketException = class(Exception);
TBgExceptionEvent = procedure (Sender : TObject;
E : Exception;
var CanClose : Boolean) of object;
TSocketState = (wsInvalidState,
wsOpened, wsBound,
wsConnecting, wsConnected,
wsAccepting, wsListening,
wsClosed);
TSocketSendFlags = (wsSendNormal, wsSendUrgent);
TSocketLingerOnOff = (wsLingerOff, wsLingerOn, wsLingerNoSet);
TDataAvailable = procedure (Sender: TObject; Error: word) of object;
TDataSent = procedure (Sender: TObject; Error: word) of object;
TSessionClosed = procedure (Sender: TObject; Error: word) of object;
TSessionAvailable = procedure (Sender: TObject; Error: word) of object;
TSessionConnected = procedure (Sender: TObject; Error: word) of object;
TDnsLookupDone = procedure (Sender: TObject; Error: Word) of object;
TChangeState = procedure (Sender: TObject;
OldState, NewState : TSocketState) of object;
TDebugDisplay = procedure (Sender: TObject; var Msg : String) of object;
TWSocketSyncNextProc = procedure of object;
{$IFDEF VER110} { C++Builder V3 }
TSocket = integer;
{$ENDIF}
{$IFDEF VER120} { C++Builder V4 }
TSocket = integer;
{$ENDIF}
TCustomWSocket = class(TComponent)
private
FDnsResult : String;
FDnsResultList : TStrings;
FASocket : TSocket; { Accepted socket }
FBufList : TList;
FBufSize : Integer;
FSendFlags : Integer;
FLastError : Integer;
FWindowHandle : HWND;
FDnsLookupBuffer : array [0..MAXGETHOSTSTRUCT] of char;
FDnsLookupHandle : THandle;
{$IFDEF VER80}
FTrumpetCompability : Boolean;
{$ENDIF}
protected
FHSocket : TSocket;
FAddrStr : String;
FAddrResolved : Boolean;
FAddrFormat : Integer;
FAddrAssigned : Boolean;
FProto : integer;
FProtoAssigned : Boolean;
FProtoResolved : Boolean;
FLocalPortResolved : Boolean;
FProtoStr : String;
FPortStr : String;
FPortAssigned : Boolean;
FPortResolved : Boolean;
FPortNum : Integer;
FLocalPortStr : String;
FLocalPortNum : Integer;
FType : integer;
FLingerOnOff : TSocketLingerOnOff;
FLingerTimeout : Integer; { In seconds, 0 = disabled }
ReadLineCount : Integer;
bWrite : Boolean;
nMoreCnt : Integer;
bMoreFlag : Boolean;
nMoreMax : Integer;
bAllSent : Boolean;
FReadCount : LongInt;
FPaused : Boolean;
FCloseInvoked : Boolean;
FFlushTimeout : Integer;
FMultiThreaded : Boolean;
FState : TSocketState;
FRcvdFlag : Boolean;
FTerminated : Boolean;
FOnSessionAvailable : TSessionAvailable;
FOnSessionConnected : TSessionConnected;
FOnSessionClosed : TSessionClosed;
FOnChangeState : TChangeState;
FOnDataAvailable : TDataAvailable;
FOnDataSent : TDataSent;
FOnLineTooLong : TNotifyEvent;
FOnDnsLookupDone : TDnsLookupDone;
FOnError : TNotifyEvent;
FOnBgException : TBgExceptionEvent;
FOnDisplay : TDebugDisplay;
FOnMessagePump : TNotifyEvent;
procedure WndProc(var MsgRec: TMessage); virtual;
procedure SocketError(sockfunc: string);
procedure WMASyncSelect(var msg: TMessage); message WM_ASYNCSELECT;
procedure WMAsyncGetHostByName(var msg: TMessage); message WM_ASYNCGETHOSTBYNAME;
procedure WMAsyncGetHostByAddr(var msg: TMessage); message WM_ASYNCGETHOSTBYADDR;
procedure ChangeState(NewState : TSocketState);
procedure TryToSend;
procedure ASyncReceive(Error : Word);
procedure AssignDefaultValue; virtual;
procedure InternalClose(bShut : Boolean; Error : Word); virtual;
procedure Notification(AComponent: TComponent; operation: TOperation); override;
procedure SetSendFlags(newValue : TSocketSendFlags);
function GetSendFlags : TSocketSendFlags;
procedure SetAddr(InAddr : String);
function GetAddr : String;
procedure SetRemotePort(sPort : String); virtual;
function GetRemotePort : String;
procedure SetLocalPort(sLocalPort : String);
procedure SetProto(sProto : String); virtual;
function GetProto : String;
function GetRcvdCount : LongInt; virtual;
procedure BindSocket; virtual;
procedure SendText(Str : String);
function RealSend(Data : Pointer; Len : Integer) : Integer; virtual;
procedure RaiseExceptionFmt(const Fmt : String; args : array of const); virtual;
procedure RaiseException(const Msg : String); virtual;
procedure HandleBackGroundException(E: Exception); virtual;
procedure TriggerDisplay(Msg : String);
function TriggerDataAvailable(Error : Word) : Boolean; virtual;
procedure TriggerSessionAvailable(Error : Word); virtual;
procedure TriggerSessionConnected(Error : Word); virtual;
procedure TriggerSessionClosed(Error : Word); virtual;
procedure TriggerDataSent(Error : Word); virtual;
procedure TriggerChangeState(OldState, NewState : TSocketState); virtual;
procedure TriggerDNSLookupDone(Error : Word); virtual;
procedure TriggerError; virtual;
function DoRecv(var Buffer;
BufferSize : Integer;
Flags : Integer) : Integer; virtual;
function DoRecvFrom(FHSocket : TSocket;
var Buffer;
BufferSize : Integer;
Flags : Integer;
var From : TSockAddr;
var FromLen : Integer) : Integer; virtual;
public
sin : TSockAddrIn;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Connect; virtual;
procedure Close; virtual;
procedure Abort; virtual;
procedure Flush; virtual;
procedure WaitForClose; virtual;
procedure Listen; virtual;
function Accept: TSocket; virtual;
function Receive(Buffer : Pointer; BufferSize: integer) : integer; virtual;
function ReceiveStr : string; virtual;
function ReceiveFrom(Buffer : Pointer;
BufferSize : Integer;
var From : TSockAddr;
var FromLen : Integer) : integer; virtual;
function PeekData(Buffer : Pointer; BufferSize: integer) : integer;
function Send(Data : Pointer; Len : Integer) : integer; virtual;
function SendTo(Dest : TSockAddr;
DestLen : Integer;
Data : Pointer;
Len : Integer) : integer; virtual;
function SendStr(Str : String) : Integer; virtual;
procedure DnsLookup(HostName : String); virtual;
procedure ReverseDnsLookup(HostAddr: String); virtual;
procedure CancelDnsLookup; virtual;
function GetPeerAddr: string; virtual;
function GetPeerPort: string; virtual;
function GetPeerName(var Name : TSockAddrIn; NameLen : Integer) : integer; virtual;
function GetXPort: string; virtual;
function TimerIsSet(var tvp : TTimeVal) : Boolean; virtual;
procedure TimerClear(var tvp : TTimeVal); virtual;
function TimerCmp(var tvp : TTimeVal; var uvp : TTimeVal; IsEqual : Boolean) : Boolean; virtual;
function GetSockName(var saddr : TSockAddrIn; var saddrlen : Integer) : integer; virtual;
procedure SetLingerOption;
procedure Dup(NewHSocket : TSocket); virtual;
procedure Shutdown(How : Integer); virtual;
procedure Pause; virtual;
procedure Resume; virtual;
procedure PutDataInSendBuffer(Data : Pointer; Len : Integer);
procedure PutStringInSendBuffer(Str : String);
procedure DeleteBufferedData;
procedure MessagePump; virtual;
{$IFNDEF VER80}
procedure MessageLoop;
function ProcessMessage : Boolean;
procedure ProcessMessages;
{$ENDIF}
{$IFDEF NOFORMS}
property Terminated : Boolean read FTerminated
write FTerminated;
property OnMessagePump : TNotifyEvent read FOnMessagePump
write FOnMessagePump;
{$ENDIF}
protected
property PortNum : Integer read FPortNum;
property Handle : HWND read FWindowHandle;
property HSocket : TSocket read FHSocket
write Dup;
property Addr : string read GetAddr
write SetAddr;
property Port : string read GetRemotePort
write SetRemotePort;
property LocalPort : string read FLocalPortStr
write SetLocalPort;
property Proto : String read GetProto
write SetProto;
property MultiThreaded : Boolean read FMultiThreaded
write FMultiThreaded;
property PeerAddr : String read GetPeerAddr;
property PeerPort : String read GetPeerPort;
property DnsResult : String read FDnsResult;
property DnsResultList : TStrings read FDnsResultList;
property State : TSocketState read FState;
property AllSent : Boolean read bAllSent;
property ReadCount : LongInt read FReadCount;
property RcvdCount : LongInt read GetRcvdCount;
property LastError : Integer read FLastError;
property BufSize : Integer read FBufSize
write FBufSize;
property OnDataAvailable : TDataAvailable read FOnDataAvailable
write FOnDataAvailable;
property OnDataSent : TDataSent read FOnDataSent
write FOnDataSent;
property OnSessionClosed : TSessionClosed read FOnSessionClosed
write FOnSessionClosed;
property OnSessionAvailable : TSessionAvailable read FOnSessionAvailable
write FOnSessionAvailable;
property OnSessionConnected : TSessionConnected read FOnSessionConnected
write FOnSessionConnected;
property OnChangeState : TChangeState read FOnChangeState
write FOnChangeState;
property OnLineTooLong : TNotifyEvent read FOnLineTooLong
write FOnLineTooLong;
property OnDnsLookupDone : TDnsLookupDone read FOnDnsLookupDone
write FOnDnsLookupDone;
property OnError : TNotifyEvent read FOnError
write FOnError;
property OnBgException : TBgExceptionEvent read FOnBgException
write FOnBgException;
property FlushTimeout : Integer read FFlushTimeOut
write FFlushTimeout;
property SendFlags : TSocketSendFlags read GetSendFlags
write SetSendFlags;
property Text: String read ReceiveStr
write SendText;
property LingerOnOff : TSocketLingerOnOff read FLingerOnOff
write FLingerOnOff;
property LingerTimeout : Integer read FLingerTimeout
write FLingerTimeout;
{$IFDEF VER80}
property TrumpetCompability : Boolean read FTrumpetCompability
write FTrumpetCompability;
{$ENDIF}
property OnDisplay : TDebugDisplay read FOnDisplay
write FOnDisplay;
end;
TSocksState = (socksData, socksNegociateMethods, socksAuthenticate, socksConnect);
TSocksAuthentication = (socksNoAuthentication, socksAuthenticateUsercode);
TSocksAuthState = (socksAuthStart, socksAuthSuccess, socksAuthFailure, socksAuthNotRequired);
TSocksAuthStateEvent = procedure(Sender : TObject; AuthState : TSocksAuthState) of object;
TSocksErrorEvent = procedure(Sender : TObject; Error : Integer; Msg : String) of Object;
TCustomSocksWSocket = class(TCustomWSocket)
protected
FSocksState : TSocksState;
FSocksServer : String;
FSocksLevel : String;
FSocksPort : String;
FSocksPortAssigned : Boolean;
FSocksServerAssigned : Boolean;
FSocksUsercode : String;
FSocksPassword : String;
FSocksAuthentication : TSocksAuthentication;
FSocksAuthNumber : char;
FBoundAddr : String;
FBoundPort : String;
FRcvBuf : array [0..127] of char;
FRcvCnt : Integer;
FRcvdCnt : Integer;
FRcvdPtr : PChar;
FOnSocksError : TSocksErrorEvent;
FOnSocksConnected : TSessionConnected;
FOnSocksAuthState : TSocksAuthStateEvent;
procedure AssignDefaultValue; override;
procedure TriggerSessionConnected(Error : Word); override;
procedure TriggerSocksConnected(Error : Word); virtual;
procedure TriggerSessionClosed(Error : Word); override;
function TriggerDataAvailable(Error : Word) : Boolean; override;
procedure SetSocksPort(sPort : String); virtual;
procedure SetSocksServer(sServer : String); virtual;
procedure TriggerSocksError(Error : Integer; Msg : String); virtual;
procedure TriggerSocksAuthState(AuthState : TSocksAuthState);
function GetRcvdCount : LongInt; override;
procedure SetSocksLevel(newValue : String);
function DoRecv(var Buffer;
BufferSize : Integer;
Flags : Integer) : Integer; override;
procedure SocksDoConnect;
procedure SocksDoAuthenticate;
procedure DataAvailableError(ErrCode : Integer; Msg : String);
public
procedure Connect; override;
procedure Listen; override;
protected
property SocksServer : String read FSocksServer
write SetSocksServer;
property SocksLevel : String read FSocksLevel
write SetSocksLevel;
property SocksPort : String read FSocksPort
write SetSocksPort;
property SocksUsercode : String read FSocksUsercode
write FSocksUsercode;
property SocksPassword : String read FSocksPassword
write FSocksPassword;
property SocksAuthentication : TSocksAuthentication
read FSocksAuthentication
write FSocksAuthentication;
property OnSocksError : TSocksErrorEvent read FOnSocksError
write FOnSocksError;
property OnSocksConnected : TSessionConnected read FOnSocksConnected
write FOnSocksConnected;
property OnSocksAuthState : TSocksAuthStateEvent
read FOnSocksAuthState
write FOnSocksAuthState;
end;
TCustomLineWSocket = class (TCustomSocksWSocket)
protected
FRcvdPtr : PChar;
FRcvBufSize : Integer;
FRcvdCnt : Integer;
FLineEnd : String;
FLineMode : Boolean;
FLineLength : Integer; { When a line is available }
FLineReceivedFlag : Boolean;
FLineEcho : Boolean; { Echo received data }
FLineEdit : Boolean; { Edit received data }
FTimeout : LongInt; { Given in milliseconds }
FTimeStop : LongInt; { Milliseconds }
procedure WndProc(var MsgRec: TMessage); override;
procedure WMTriggerDataAvailable(var msg: TMessage); message WM_TRIGGER_DATA_AVAILABLE;
function TriggerDataAvailable(Error : Word) : Boolean; override;
procedure TriggerSessionClosed(Error : Word); override;
procedure SetLineMode(newValue : Boolean); virtual;
procedure EditLine(var Len : Integer); virtual;
function GetRcvdCount : LongInt; override;
function DoRecv(var Buffer;
BufferSize : Integer;
Flags : Integer) : Integer; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property LineLength : Integer read FLineLength;
published
property LineMode : Boolean read FLineMode
write SetLineMode;
property LineEnd : String read FLineEnd
write FLineEnd;
property LineEcho : Boolean read FLineEcho
write FLineEcho;
property LineEdit : Boolean read FLineEdit
write FLineEdit;
end;
TCustomSyncWSocket = class(TCustomLineWSocket)
protected
FLinePointer : ^String;
function Synchronize(Proc : TWSocketSyncNextProc; var DoneFlag : Boolean) : Integer; virtual;
function WaitUntilReady(var DoneFlag : Boolean) : Integer; virtual;
procedure InternalDataAvailable(Sender: TObject; Error: Word);
public
procedure ReadLine(Timeout : integer; var Buffer : String);
end;
TWSocket = class(TCustomSyncWSocket)
public
property PortNum;
property Handle;
property HSocket;
property BufSize;
property Text;
property AllSent;
{$IFDEF VER80}
property TrumpetCompability;
{$ENDIF}
property OnDisplay;
published
property Addr;
property Port;
property Proto;
property LocalPort;
property PeerPort;
property PeerAddr;
property DnsResult;
property DnsResultList;
property State;
property ReadCount;
property RcvdCount;
property LastError;
property MultiThreaded;
property OnDataAvailable;
property OnDataSent;
property OnSessionClosed;
property OnSessionAvailable;
property OnSessionConnected;
property OnSocksConnected;
property OnChangeState;
property OnLineTooLong;
property OnDnsLookupDone;
property OnError;
property OnBgException;
property FlushTimeout;
property SendFlags;
property LingerOnOff;
property LingerTimeout;
property SocksLevel;
property SocksServer;
property SocksPort;
property SocksUsercode;
property SocksPassword;
property SocksAuthentication;
property OnSocksError;
property OnSocksAuthState;
end;
TSocksWSocket = class(TWSocket)
end;
procedure Register;
function WinsockInfo : TWSADATA;
function WSocketErrorDesc(error: integer) : string;
function WSocketGetHostByAddr(Addr : String) : PHostEnt;
function WSocketGetHostByName(Name : String) : PHostEnt;
function LocalHostName : String;
function LocalIPList : TStrings;
function WSocketResolveIp(IpAddr : String) : String;
function WSocketResolveHost(InAddr : String) : TInAddr;
function WSocketResolvePort(Port : String; Proto : String) : Word;
function WSocketResolveProto(sProto : String) : integer;
procedure WSocketUnloadWinsock;
{ function WSocketLoadWinsock : Boolean; 14/02/99 }
type
{$IFDEF VER80}
DWORD = LongInt;
TWSAStartup = function (wVersionRequired: word;
var WSData: TWSAData): Integer;
TWSACleanup = function : Integer;
TWSASetLastError = procedure (iError: Integer);
TWSAGetLastError = function : Integer;
TWSACancelAsyncRequest = function (hAsyncTaskHandle: THandle): Integer;
TWSAAsyncGetHostByName = function (HWindow: HWND;
wMsg: u_int;
name, buf: PChar;
buflen: Integer): THandle;
TWSAAsyncGetHostByAddr = function (HWindow: HWND;
wMsg: u_int; addr: PChar;
len, Struct: Integer;
buf: PChar;
buflen: Integer): THandle;
TWSAAsyncSelect = function (s: TSocket;
HWindow: HWND;
wMsg: u_int;
lEvent: Longint): Integer;
TGetServByName = function (name, proto: PChar): PServEnt;
TGetProtoByName = function (name: PChar): PProtoEnt;
TGetHostByName = function (name: PChar): PHostEnt;
TGetHostName = function (name: PChar; len: Integer): Integer;
TOpenSocket = function (af, Struct, protocol: Integer): TSocket;
TShutdown = function (s: TSocket; how: Integer): Integer;
TSetSockOpt = function (s: TSocket; level, optname: Integer;
optval: PChar;
optlen: Integer): Integer;
TGetSockOpt = function (s: TSocket; level, optname: Integer; optval: PChar; var optlen: Integer): Integer;
TSendTo = function (s: TSocket; var Buf;
len, flags: Integer;
var addrto: TSockAddr;
tolen: Integer): Integer;
TSend = function (s: TSocket; var Buf;
len, flags: Integer): Integer;
TRecv = function (s: TSocket;
var Buf;
len, flags: Integer): Integer;
TRecvFrom = function (s: TSocket;
var Buf; len, flags: Integer;
var from: TSockAddr;
var fromlen: Integer): Integer;
Tntohs = function (netshort: u_short): u_short;
Tntohl = function (netlong: u_long): u_long;
TListen = function (s: TSocket; backlog: Integer): Integer;
TIoctlSocket = function (s: TSocket; cmd: DWORD;
var arg: u_long): Integer;
TInet_ntoa = function (inaddr: TInAddr): PChar;
TInet_addr = function (cp: PChar): u_long;
Thtons = function (hostshort: u_short): u_short;
Thtonl = function (hostlong: u_long): u_long;
TGetSockName = function (s: TSocket; var name: TSockAddr;
var namelen: Integer): Integer;
TGetPeerName = function (s: TSocket; var name: TSockAddr;
var namelen: Integer): Integer;
TConnect = function (s: TSocket; var name: TSockAddr;
namelen: Integer): Integer;
TCloseSocket = function (s: TSocket): Integer;
TBind = function (s: TSocket; var addr: TSockAddr;
namelen: Integer): Integer;
TAccept = function (s: TSocket; var addr: TSockAddr;
var addrlen: Integer): TSocket;
{$ELSE}
TWSAStartup = function (wVersionRequired: word;
var WSData: TWSAData): Integer; stdcall;
TWSACleanup = function : Integer; stdcall;
TWSASetLastError = procedure (iError: Integer); stdcall;
TWSAGetLastError = function : Integer; stdcall;
TWSACancelAsyncRequest = function (hAsyncTaskHandle: THandle): Integer; stdcall;
TWSAAsyncGetHostByName = function (HWindow: HWND;
wMsg: u_int;
name, buf: PChar;
buflen: Integer): THandle; stdcall;
TWSAAsyncGetHostByAddr = function (HWindow: HWND;
wMsg: u_int; addr: PChar;
len, Struct: Integer;
buf: PChar;
buflen: Integer): THandle; stdcall;
TWSAAsyncSelect = function (s: TSocket;
HWindow: HWND;
wMsg: u_int;
lEvent: Longint): Integer; stdcall;
TGetServByName = function (name, proto: PChar): PServEnt; stdcall;
TGetProtoByName = function (name: PChar): PProtoEnt; stdcall;
TGetHostByName = function (name: PChar): PHostEnt; stdcall;
TGetHostName = function (name: PChar; len: Integer): Integer; stdcall;
TOpenSocket = function (af, Struct, protocol: Integer): TSocket; stdcall;
TShutdown = function (s: TSocket; how: Integer): Integer; stdcall;
TSetSockOpt = function (s: TSocket; level, optname: Integer;
optval: PChar;
optlen: Integer): Integer; stdcall;
TGetSockOpt = function (s: TSocket; level, optname: Integer;
optval: PChar;
var optlen: Integer): Integer; stdcall;
TSendTo = function (s: TSocket; var Buf;
len, flags: Integer;
var addrto: TSockAddr;
tolen: Integer): Integer; stdcall;
TSend = function (s: TSocket; var Buf;
len, flags: Integer): Integer; stdcall;
TRecv = function (s: TSocket;
var Buf;
len, flags: Integer): Integer; stdcall;
TRecvFrom = function (s: TSocket;
var Buf; len, flags: Integer;
var from: TSockAddr;
var fromlen: Integer): Integer; stdcall;
Tntohs = function (netshort: u_short): u_short; stdcall;
Tntohl = function (netlong: u_long): u_long; stdcall;
TListen = function (s: TSocket;
backlog: Integer): Integer; stdcall;
TIoctlSocket = function (s: TSocket; cmd: DWORD;
var arg: u_long): Integer; stdcall;
TInet_ntoa = function (inaddr: TInAddr): PChar; stdcall;
TInet_addr = function (cp: PChar): u_long; stdcall;
Thtons = function (hostshort: u_short): u_short; stdcall;
Thtonl = function (hostlong: u_long): u_long; stdcall;
TGetSockName = function (s: TSocket; var name: TSockAddr;
var namelen: Integer): Integer; stdcall;
TGetPeerName = function (s: TSocket; var name: TSockAddr;
var namelen: Integer): Integer; stdcall;
TConnect = function (s: TSocket; var name: TSockAddr;
namelen: Integer): Integer; stdcall;
TCloseSocket = function (s: TSocket): Integer; stdcall;
TBind = function (s: TSocket; var addr: TSockAddr;
namelen: Integer): Integer; stdcall;
{$IFDEF VER90} { Delphi 2 has a special definition}
TAccept = function (s: TSocket; var addr: TSockAddr;
var addrlen: Integer): TSocket; stdcall;
{$ELSE}
TAccept = function (s: TSocket; addr: PSockAddr;
addrlen: PInteger): TSocket; stdcall;
{$ENDIF}
{$ENDIF}
var
FWSAStartup : TWSAStartup;
FWSACleanup : TWSACleanup;
FWSASetLastError : TWSASetLastError;
FWSAGetLastError : TWSAGetLastError;
FWSACancelAsyncRequest : TWSACancelAsyncRequest;
FWSAAsyncGetHostByName : TWSAAsyncGetHostByName;
FWSAAsyncGetHostByAddr : TWSAAsyncGetHostByAddr;
FWSAAsyncSelect : TWSAAsyncSelect;
FGetServByName : TGetServByName;
FGetProtoByName : TGetProtoByName;
FGetHostByName : TGetHostByName;
FGetHostName : TGetHostName;
FOpenSocket : TOpenSocket;
FShutdown : TShutdown;
FSetSockOpt : TSetSockOpt;
FGetSockOpt : TGetSockOpt;
FSendTo : TSendTo;
FSend : TSend;
FRecv : TRecv;
FRecvFrom : TRecvFrom;
Fntohs : Tntohs;
Fntohl : Tntohl;
FListen : TListen;
FIoctlSocket : TIoctlSocket;
FInet_ntoa : TInet_ntoa;
FInet_addr : TInet_addr;
Fhtons : Thtons;
Fhtonl : Thtonl;
FGetSockName : TGetSockName;
FGetPeerName : TGetPeerName;
FConnect : TConnect;
FCloseSocket : TCloseSocket;
FBind : TBind;
FAccept : TAccept;
function WSocketGetProc(const ProcName : String) : Pointer;
function WSocket_WSAStartup(wVersionRequired: word;
var WSData: TWSAData): Integer;
function WSocket_WSACleanup : Integer;
procedure WSocket_WSASetLastError(iError: Integer);
function WSocket_WSAGetLastError: Integer;
function WSocket_WSACancelAsyncRequest(hAsyncTaskHandle: THandle): Integer;
function WSocket_WSAAsyncGetHostByName(HWindow: HWND; wMsg: u_int;
name, buf: PChar;
buflen: Integer): THandle;
function WSocket_WSAAsyncGetHostByAddr(HWindow: HWND;
wMsg: u_int; addr: PChar;
len, Struct: Integer;
buf: PChar;
buflen: Integer): THandle;
function WSocket_WSAAsyncSelect(s: TSocket; HWindow: HWND; wMsg: u_int; lEvent: Longint): Integer;
function WSocket_recv(s: TSocket;
var Buf; len, flags: Integer): Integer;
function WSocket_recvfrom(s: TSocket;
var Buf; len, flags: Integer;
var from: TSockAddr;
var fromlen: Integer): Integer;
function WSocket_getservbyname(name, proto: PChar): PServEnt;
function WSocket_getprotobyname(name: PChar): PProtoEnt;
function WSocket_gethostbyname(name: PChar): PHostEnt;
function WSocket_gethostname(name: PChar; len: Integer): Integer;
function WSocket_socket(af, Struct, protocol: Integer): TSocket;
function WSocket_shutdown(s: TSocket; how: Integer): Integer;
function WSocket_setsockopt(s: TSocket; level, optname: Integer; optval: PChar;
optlen: Integer): Integer;
function WSocket_getsockopt(s: TSocket; level, optname: Integer; optval: PChar;
var optlen: Integer): Integer;
function WSocket_sendto(s: TSocket; var Buf; len, flags: Integer;
var addrto: TSockAddr;
tolen: Integer): Integer;
function WSocket_send(s: TSocket; var Buf; len, flags: Integer): Integer;
function WSocket_ntohs(netshort: u_short): u_short;
function WSocket_ntohl(netlong: u_long): u_long;
function WSocket_listen(s: TSocket; backlog: Integer): Integer;
function WSocket_ioctlsocket(s: TSocket; cmd: DWORD; var arg: u_long): Integer;
function WSocket_inet_ntoa(inaddr: TInAddr): PChar;
function WSocket_inet_addr(cp: PChar): u_long;
function WSocket_htons(hostshort: u_short): u_short;
function WSocket_htonl(hostlong: u_long): u_long;
function WSocket_getsockname(s: TSocket; var name: TSockAddr;
var namelen: Integer): Integer;
function WSocket_getpeername(s: TSocket; var name: TSockAddr;
var namelen: Integer): Integer;
function WSocket_connect(s: TSocket; var name: TSockAddr;
namelen: Integer): Integer;
function WSocket_closesocket(s: TSocket): Integer;
function WSocket_bind(s: TSocket; var addr: TSockAddr; namelen: Integer): Integer;
{$IFDEF VER80}
function WSocket_accept(s: TSocket; var addr: TSockAddr; var addrlen: Integer): TSocket;
{$ELSE}
{$IFDEF VER90}
function WSocket_accept(s: TSocket; var addr: TSockAddr; var addrlen: Integer): TSocket;
{$ELSE}
function WSocket_accept(s: TSocket; addr: PSockAddr; addrlen: PInteger): TSocket;
{$ENDIF}
{$ENDIF}
implementation
const
GSocketCount : integer = 0;
{ DllStarted : Boolean = FALSE; 14/02/99}
FDllHandle : THandle = 0;
FDllName : String = winsocket;
socksNoError = 20000;
socksProtocolError = 20001;
socksVersionError = 20002;
socksAuthMethodError = 20003;
socksGeneralFailure = 20004;
socksConnectionNotAllowed = 20005;
socksNetworkUnreachable = 20006;
socksHostUnreachable = 20007;
socksConnectionRefused = 20008;
socksTtlExpired = 20009;
socksUnknownCommand = 20010;
socksUnknownAddressType = 20011;
socksUnassignedError = 20012;
socksInternalError = 20013;
socksDataReceiveError = 20014;
socksAuthenticationFailed = 20015;
socksRejectedOrFailed = 20016;
socksHostResolutionFailed = 20017;
var
GInitData : TWSADATA;
IPList : TStrings;
procedure Register;
begin
RegisterComponents('FPiette', [TWSocket]);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{$IFDEF VER80}
procedure SetLength(var S: string; NewLength: Integer);
begin
S[0] := chr(NewLength);
end;
{$ENDIF}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function atoi(value : string) : Integer;
var
i : Integer;
begin
Result := 0;
i := 1;
while (i <= Length(Value)) and (Value[i] = ' ') do
i := i + 1;
while (i <= Length(Value)) and (Value[i] >= '0') and (Value[i] <= '9')do begin
Result := Result * 10 + ord(Value[i]) - ord('0');
i := i + 1;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function IsDigit(Ch : Char) : Boolean;
begin
Result := (ch >= '0') and (ch <= '9');
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{$IFDEF VER80}
function TrimRight(Str : String) : String;
var
i : Integer;
begin
i := Length(Str);
while (i > 0) and (Str[i] = ' ') do
i := i - 1;
Result := Copy(Str, 1, i);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TrimLeft(Str : String) : String;
var
i : Integer;
begin
if Str[1] <> ' ' then
Result := Str
else begin
i := 1;
while (i <= Length(Str)) and (Str[i] = ' ') do
i := i + 1;
Result := Copy(Str, i, Length(Str) - i + 1);
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function Trim(Str : String) : String;
begin
Result := TrimLeft(TrimRight(Str));
end;
{$ENDIF}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.RaiseException(const Msg : String);
begin
if Assigned(FOnError) then
TriggerError
else
raise ESocketException.Create(Msg);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.RaiseExceptionFmt(const Fmt : String; args : array of const);
begin
if Assigned(FOnError) then
TriggerError
else
raise ESocketException.CreateFmt(Fmt, args);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{$IFDEF NEVER} { 14/02/99 }
function LoadWinsock(FileName : PChar) : Boolean;
var
LastError : LongInt;
begin
if not DllStarted then begin
LastError := WSocket_WSAStartup($101, GInitData);
if LastError <> 0 then begin
raise ESocketException.CreateFmt('%s: WSAStartup error #%d',
[FileName, LastError]);
end;
DllStarted := TRUE;
end;
Result := TRUE;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function WSocketLoadWinsock : Boolean;
begin
Result := LoadWinsock(winsocket);
end;
{$ENDIF}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure WSocketUnloadWinsock;
begin
{$IFDEF NEVER} { 14/02/99 }
if DllStarted then begin
DllStarted := FALSE;
WSocket_WSACleanup;
end;
{$ENDIF}
if FDllHandle <> 0 then begin
WSocket_WSACleanup;
FreeLibrary(FDllHandle);
FDllHandle := 0;
FWSAStartup := nil;
FWSACleanup := nil;
FWSASetLastError := nil;
FWSAGetLastError := nil;
FWSACancelAsyncRequest := nil;
FWSAAsyncGetHostByName := nil;
FWSAAsyncGetHostByAddr := nil;
FWSAAsyncSelect := nil;
FGetServByName := nil;
FGetProtoByName := nil;
FGetHostByName := nil;
FGetHostName := nil;
FOpenSocket := nil;
FShutdown := nil;
FSetSockOpt := nil;
FGetSockOpt := nil;
FSendTo := nil;
FSend := nil;
FRecv := nil;
FRecvFrom := nil;
Fntohs := nil;
Fntohl := nil;
FListen := nil;
FIoctlSocket := nil;
FInet_ntoa := nil;
FInet_addr := nil;
Fhtons := nil;
Fhtonl := nil;
FGetSockName := nil;
FGetPeerName := nil;
FConnect := nil;
FCloseSocket := nil;
FBind := nil;
FAccept := nil;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function WSocketGetProc(const ProcName : String) : Pointer;
{$IFDEF VER80}
var
Error : THandle;
Buf : String;
LastError : LongInt;
begin
if FDllHandle = 0 then begin
{ Delphi 1 strings are not nul terminated }
Buf := FDllName + #0;
FDllHandle := LoadLibrary(@Buf[1]);
if FDllHandle < HINSTANCE_ERROR then begin
Error := FDllHandle;
FDllHandle := 0;
raise ESocketException.Create('Unable to load ' + FDllName +
' Error #' + IntToStr(Error));
end;
LastError := WSocket_WSAStartup($101, GInitData);
if LastError <> 0 then begin
raise ESocketException.CreateFmt('%s: WSAStartup error #%d',
[FDllName, LastError]);
end;
end;
if Length(ProcName) = 0 then
Result := nil
else begin
{ Delphi 1 strings are not nul terminated }
Buf := ProcName + #0;
Result := GetProcAddress(FDllHandle, @Buf[1]);
if Result = nil then
raise ESocketException.Create('Procedure ' + ProcName +
' not found in ' + FDllName);
end;
end;
{$ELSE}
var
LastError : LongInt;
begin
if FDllHandle = 0 then begin
FDllHandle := LoadLibrary(@FDllName[1]);
if FDllHandle = 0 then
raise ESocketException.Create('Unable to load ' + FDllName +
' Error #' + IntToStr(GetLastError));
LastError := WSocket_WSAStartup($101, GInitData);
if LastError <> 0 then begin
raise ESocketException.CreateFmt('%s: WSAStartup error #%d',
[FDllName, LastError]);
end;
end;
if Length(ProcName) = 0 then
Result := nil
else begin
Result := GetProcAddress(FDllHandle, @ProcName[1]);
if Result = nil then
raise ESocketException.Create('Procedure ' + ProcName +
' not found in ' + winsocket +
' Error #' + IntToStr(GetLastError));
end;
end;
{$ENDIF}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function WSocket_WSAStartup(
wVersionRequired: word;
var WSData: TWSAData): Integer;
begin
if @FWSAStartup = nil then
@FWSAStartup := WSocketGetProc('WSAStartup');
Result := FWSAStartup(wVersionRequired, WSData);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function WSocket_WSACleanup : Integer;
begin
if @FWSACleanup = nil then
@FWSACleanup := WSocketGetProc('WSACleanup');
Result := FWSACleanup;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure WSocket_WSASetLastError(iError: Integer);
begin
if @FWSASetLastError = nil then
@FWSASetLastError := WSocketGetProc('WSASetLastError');
FWSASetLastError(iError);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function WSocket_WSAGetLastError: Integer;
begin
if @FWSAGetLastError = nil then
@FWSAGetLastError := WSocketGetProc('WSAGetLastError');
Result := FWSAGetLastError;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function WSocket_WSACancelAsyncRequest(hAsyncTaskHandle: THandle): Integer;
begin
if @FWSACancelAsyncRequest = nil then
@FWSACancelAsyncRequest := WSocketGetProc('WSACancelAsyncRequest');
Result := FWSACancelAsyncRequest(hAsyncTaskHandle);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function WSocket_WSAAsyncGetHostByName(
HWindow: HWND; wMsg: u_int;
name, buf: PChar;
buflen: Integer): THandle;
begin
if @FWSAAsyncGetHostByName = nil then
@FWSAAsyncGetHostByName := WSocketGetProc('WSAAsyncGetHostByName');
Result := FWSAAsyncGetHostByName(HWindow, wMsg, name, buf, buflen);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function WSocket_WSAAsyncGetHostByAddr(
HWindow: HWND;
wMsg: u_int; addr: PChar;
len, Struct: Integer;
buf: PChar;
buflen: Integer): THandle;
begin
if @FWSAAsyncGetHostByAddr = nil then
@FWSAAsyncGetHostByAddr := WSocketGetProc('WSAAsyncGetHostByAddr');
Result := FWSAAsyncGetHostByAddr(HWindow, wMsg, addr, len, struct, buf, buflen);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function WSocket_WSAAsyncSelect(
s: TSocket;
HWindow: HWND;
wMsg: u_int;
lEvent: Longint): Integer;
begin
if @FWSAAsyncSelect = nil then
@FWSAAsyncSelect := WSocketGetProc('WSAAsyncSelect');
Result := FWSAAsyncSelect(s, HWindow, wMsg, lEvent);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function WSocket_getservbyname(name, proto: PChar): PServEnt;
begin
if @Fgetservbyname = nil then
@Fgetservbyname := WSocketGetProc('getservbyname');
Result := Fgetservbyname(name, proto);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function WSocket_getprotobyname(name: PChar): PProtoEnt;
begin
if @Fgetprotobyname = nil then
@Fgetprotobyname := WSocketGetProc('getprotobyname');
Result := Fgetprotobyname(name);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function WSocket_gethostbyname(name: PChar): PHostEnt;
begin
if @Fgethostbyname = nil then
@Fgethostbyname := WSocketGetProc('gethostbyname');
Result := Fgethostbyname(name);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function WSocket_gethostname(name: PChar; len: Integer): Integer;
begin
if @Fgethostname = nil then
@Fgethostname := WSocketGetProc('gethostname');
Result := Fgethostname(name, len);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function WSocket_socket(af, Struct, protocol: Integer): TSocket;
begin
if @FOpenSocket= nil then
@FOpenSocket := WSocketGetProc('socket');
Result := FOpenSocket(af, Struct, protocol);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function WSocket_shutdown(s: TSocket; how: Integer): Integer;
begin
if @FShutdown = nil then
@FShutdown := WSocketGetProc('shutdown');
Result := FShutdown(s, how);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function WSocket_setsockopt(s: TSocket; level, optname: Integer; optval: PChar;
optlen: Integer): Integer;
begin
if @FSetSockOpt = nil then
@FSetSockOpt := WSocketGetProc('setsockopt');
Result := FSetSockOpt(s, level, optname, optval, optlen);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function WSocket_getsockopt(
s: TSocket; level, optname: Integer;
optval: PChar; var optlen: Integer): Integer;
begin
if @FGetSockOpt = nil then
@FGetSockOpt := WSocketGetProc('getsockopt');
Result := FGetSockOpt(s, level, optname, optval, optlen);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function WSocket_sendto(
s: TSocket;
var Buf;
len, flags: Integer;
var addrto: TSockAddr;
tolen: Integer): Integer;
begin
if @FSendTo = nil then
@FSendTo := WSocketGetProc('sendto');
Result := FSendTo(s, Buf, len, flags, addrto, tolen);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function WSocket_send(s: TSocket; var Buf; len, flags: Integer): Integer;
begin
if @FSend = nil then
@FSend := WSocketGetProc('send');
Result := FSend(s, Buf, len, flags);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function WSocket_ntohs(netshort: u_short): u_short;
begin
if @Fntohs = nil then
@Fntohs := WSocketGetProc('ntohs');
Result := Fntohs(netshort);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function WSocket_ntohl(netlong: u_long): u_long;
begin
if @Fntohl = nil then
@Fntohl := WSocketGetProc('ntohl');
Result := Fntohl(netlong);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function WSocket_listen(s: TSocket; backlog: Integer): Integer;
begin
if @FListen = nil then
@FListen := WSocketGetProc('listen');
Result := FListen(s, backlog);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function WSocket_ioctlsocket(s: TSocket; cmd: DWORD; var arg: u_long): Integer;
begin
if @FIoctlSocket = nil then
@FIoctlSocket := WSocketGetProc('ioctlsocket');
Result := FIoctlSocket(s, cmd, arg);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function WSocket_inet_ntoa(inaddr: TInAddr): PChar;
begin
if @FInet_ntoa = nil then
@FInet_ntoa := WSocketGetProc('inet_ntoa');
Result := FInet_ntoa(inaddr);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function WSocket_inet_addr(cp: PChar): u_long;
begin
if @FInet_addr = nil then
@FInet_addr := WSocketGetProc('inet_addr');
Result := FInet_addr(cp);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function WSocket_htons(hostshort: u_short): u_short;
begin
if @Fhtons = nil then
@Fhtons := WSocketGetProc('htons');
Result := Fhtons(hostshort);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function WSocket_htonl(hostlong: u_long): u_long;
begin
if @Fhtonl = nil then
@Fhtonl := WSocketGetProc('htonl');
Result := Fhtonl(hostlong);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function WSocket_getsockname(
s: TSocket;
var name: TSockAddr;
var namelen: Integer): Integer;
begin
if @FGetSockName = nil then
@FGetSockName := WSocketGetProc('getsockname');
Result := FGetSockName(s, name, namelen);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function WSocket_getpeername(
s: TSocket;
var name: TSockAddr;
var namelen: Integer): Integer;
begin
if @FGetPeerName = nil then
@FGetPeerName := WSocketGetProc('getpeername');
Result := FGetPeerName(s, name, namelen);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function WSocket_connect(
s: TSocket;
var name: TSockAddr;
namelen: Integer): Integer;
begin
if @FConnect= nil then
@FConnect := WSocketGetProc('connect');
Result := FConnect(s, name, namelen);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function WSocket_closesocket(s: TSocket): Integer;
begin
if @FCloseSocket = nil then
@FCloseSocket := WSocketGetProc('closesocket');
Result := FCloseSocket(s);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function WSocket_bind(
s: TSocket;
var addr: TSockAddr;
namelen: Integer): Integer;
begin
if @FBind = nil then
@FBind := WSocketGetProc('bind');
Result := FBind(s, addr, namelen);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function WSocket_accept(
s: TSocket;
{$IFDEF VER80} { Delphi 1 }
var addr: TSockAddr;
var addrlen: Integer): TSocket;
{$ELSE}
{$IFDEF VER90} { Delphi 2 }
var addr: TSockAddr;
var addrlen: Integer): TSocket;
{$ELSE}{ Delphi 3/4 }
addr: PSockAddr;
addrlen: PInteger): TSocket;
{$ENDIF}
{$ENDIF}
begin
if @FAccept = nil then
@FAccept := WSocketGetProc('accept');
Result := FAccept(s, addr, addrlen);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function WSocket_recv(s: TSocket; var Buf; len, flags: Integer): Integer;
begin
if @FRecv= nil then
@FRecv := WSocketGetProc('recv');
Result := FRecv(s, Buf, len, flags);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function WSocket_recvfrom(
s: TSocket;
var Buf; len, flags: Integer;
var from: TSockAddr;
var fromlen: Integer): Integer;
begin
if @FRecvFrom = nil then
@FRecvFrom := WSocketGetProc('recvfrom');
Result := FRecvFrom(s, Buf, len, flags, from, fromlen);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function WinsockInfo : TWSADATA;
begin
{ LoadWinsock(winsocket); 14/02/99 }
{ Load winsock and initialize it as needed }
WSocketGetProc('');
Result := GInitData;
{ If no socket created, then unload winsock immediately }
if GSocketCount <= 0 then
WSocketUnloadWinsock;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.Notification(AComponent: TComponent; operation: TOperation);
begin
inherited Notification(AComponent, operation);
if operation = opRemove then begin
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.AssignDefaultValue;
begin
FillChar(sin, 0, Sizeof(sin));
sin.sin_family := AF_INET;
FAddrFormat := PF_INET;
FPortAssigned := FALSE;
FAddrAssigned := FALSE;
FAddrResolved := FALSE;
FPortResolved := FALSE;
FProtoResolved := FALSE;
FLocalPortResolved := FALSE;
FProtoAssigned := TRUE;
FProto := IPPROTO_TCP;
FProtoStr := 'tcp';
FType := SOCK_STREAM;
FLocalPortStr := '0';
FLingerOnOff := wsLingerOn;
FLingerTimeout := 0;
FHSocket := INVALID_SOCKET;
FState := wsClosed;
bMoreFlag := FALSE;
nMoreCnt := 0;
nMoreMax := 24;
bWrite := FALSE;
bAllSent := TRUE;
FPaused := FALSE;
FReadCount := 0;
FCloseInvoked := FALSE;
FFlushTimeout := 60;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ All exceptions *MUST* be handled. If an exception is not handled, the }
{ application will be shut down ! }
procedure TCustomWSocket.HandleBackGroundException(E: Exception);
var
CanAbort : Boolean;
begin
CanAbort := TRUE;
{ First call the error event handler, if any }
if Assigned(FOnBgException) then begin
try
FOnBgException(Self, E, CanAbort);
except
end;
end;
{ Then abort the socket }
if CanAbort then begin
try
Abort;
except
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ This procedure handle all messages for TWSocket. All exceptions must be }
{ handled or the application will be shutted down ! }
{ If WndProc is overriden in descendent components, then the same exception }
{ handling *MUST* be setup because descendent component code is executed }
{ before the base class code. }
procedure TCustomWSocket.WndProc(var MsgRec: TMessage);
begin
try
with MsgRec do begin
if Msg = WM_ASYNCSELECT then
WMASyncSelect(MsgRec)
else if Msg = WM_ASYNCGETHOSTBYNAME then
WMAsyncGetHostByName(MsgRec)
else if Msg = WM_ASYNCGETHOSTBYADDR then
WMAsyncGetHostByAddr(MsgRec)
else
Result := DefWindowProc(Handle, Msg, wParam, lParam);
end;
except
on E:Exception do
HandleBackGroundException(E);
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{$IFNDEF VER80}
{ This function is a callback function. It means that it is called by }
{ windows. This is the very low level message handler procedure setup to }
{ handle the message sent by windows (winsock) to handle messages. }
function XSocketWindowProc(
ahWnd : HWND;
auMsg : Integer;
awParam : WPARAM;
alParam : LPARAM): Integer; stdcall;
var
Obj : TObject;
MsgRec : TMessage;
begin
{ At window creation asked windows to store a pointer to our object }
Obj := TObject(GetWindowLong(ahWnd, 0));
{ If the pointer doesn't represent a TWSocket, just call the default procedure}
if not (Obj is TCustomWSocket) then
Result := DefWindowProc(ahWnd, auMsg, awParam, alParam)
else begin
{ Delphi use a TMessage type to pass parameter to his own kind of }
{ windows procedure. So we are doing the same... }
MsgRec.Msg := auMsg;
MsgRec.wParam := awParam;
MsgRec.lParam := alParam;
{ May be a try/except around next line is needed. Not sure ! }
TWSocket(Obj).WndProc(MsgRec);
Result := MsgRec.Result;
end;
end;
{$ENDIF}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.MessagePump;
begin
{$IFDEF NOFORMS}
{ The Forms unit (TApplication object) has not been included. }
{ We used either an external message pump or our internal message pump. }
{ External message pump has to set Terminated property to TRUE when the }
{ application is terminated. }
if Assigned(FOnMessagePump) then
FOnMessagePump(Self)
else
Self.ProcessMessages;
{$ELSE}
{$IFNDEF VER80}
{ Delphi 1 doesn't support multithreading }
if FMultiThreaded then
Self.ProcessMessages
else
{$ENDIF}
Application.ProcessMessages;
{$ENDIF}
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ This function is very similar to TApplication.ProcessMessage }
{ You can also use it if your application has no TApplication object (Forms }
{ unit not referenced at all). }
{$IFNDEF VER80}
function TCustomWSocket.ProcessMessage : Boolean;
var
Msg : TMsg;
begin
Result := FALSE;
if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then begin
Result := TRUE;
if Msg.Message = WM_QUIT then
FTerminated := TRUE
else begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ Loop thru message processing until all messages are processed. }
{ This function is very similar to TApplication.ProcessMessage }
{ This is intended for multithreaded application using TWSocket. }
{ You can also use it if your application has no TApplication object (Forms }
{ unit not referenced at all). }
procedure TCustomWSocket.ProcessMessages;
begin
while Self.ProcessMessage do { loop };
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ Loop thru message processing until the WM_QUIT message is received }
{ This is intended for multithreaded application using TWSocket. }
{ MessageLoop is different from ProcessMessages because it actually block }
{ if no message is available. The loop is broken when WM_QUIT is retrieved. }
procedure TCustomWSocket.MessageLoop;
var
MsgRec : TMsg;
begin
{ If GetMessage retrieves the WM_QUIT, the return value is FALSE and }
{ the message loop is broken. }
while GetMessage(MsgRec, 0, 0, 0) do begin
TranslateMessage(MsgRec);
DispatchMessage(MsgRec)
end;
FTerminated := TRUE;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ This global variable is used to store the windows class characteristic }
{ and is needed to register the window class used by TWSocket }
var
XSocketWindowClass: TWndClass = (
style : 0;
lpfnWndProc : @XSocketWindowProc;
cbClsExtra : 0;
cbWndExtra : SizeOf(Pointer);
hInstance : 0;
hIcon : 0;
hCursor : 0;
hbrBackground : 0;
lpszMenuName : nil;
lpszClassName : 'XSocketWindowClass');
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ Allocate a window handle. This means registering a window class the first }
{ time we are called, and creating a new window each time we are called. }
function XSocketAllocateHWnd(Obj : TObject): HWND;
var
TempClass : TWndClass;
ClassRegistered : Boolean;
begin
{ Check if the window class is already registered }
XSocketWindowClass.hInstance := HInstance;
ClassRegistered := GetClassInfo(HInstance,
XSocketWindowClass.lpszClassName,
TempClass);
if not ClassRegistered then begin
{ Not yet registered, do it right now }
Result := WinProcs.RegisterClass(XSocketWindowClass);
if Result = 0 then
Exit;
end;
{ Now create a new window }
Result := CreateWindowEx(WS_EX_TOOLWINDOW,
XSocketWindowClass.lpszClassName,
'', { Window name }
WS_POPUP, { Window Style }
0, 0, { X, Y }
0, 0, { Width, Height }
0, { hWndParent }
0, { hMenu }
HInstance, { hInstance }
nil); { CreateParam }
{ if successfull, the ask windows to store the object reference }
{ into the reserved byte (see RegisterClass) }
if (Result <> 0) and Assigned(Obj) then
SetWindowLong(Result, 0, Integer(Obj));
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ Free the window handle }
procedure XSocketDeallocateHWnd(Wnd: HWND);
begin
DestroyWindow(Wnd);
end;
{$ENDIF}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
constructor TCustomWSocket.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
{$IFDEF VER80}
{ Delphi 16 bits has no thread, we can use the VCL }
FWindowHandle := AllocateHWnd(WndProc);
{$ELSE}
{ Delphi 32 bits has threads and VCL is not thread safe. }
{ We need to do our own way to be thread safe. }
FWindowHandle := XSocketAllocateHWnd(Self);
{$ENDIF}
FBufList := TList.Create;
FBufSize := 1514; { Default buffer size }
FDnsResultList := TStringList.Create;
AssignDefaultValue;
GSocketCount := GSocketCount + 1;
{ LoadWinsock(WINSOCKET);}
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
destructor TCustomWSocket.Destroy;
begin
try
CancelDnsLookup; { Cancel any pending dns lookup }
except
{ Ignore any exception here }
end;
if FState <> wsClosed then { Close the socket if not yet closed }
Close;
GSocketCount := GSocketCount - 1;
if {**(not (csDesigning in ComponentState)) and **}
{ (DllStarted) and 14/02/99 }
(GSocketCount <= 0) then begin
WSocketUnloadWinsock;
GSocketCount := 0;
end;
DeleteBufferedData;
FBufList.Free;
FDnsResultList.Free;
{ Remove the object reference from the window }
SetWindowLong(FWindowHandle, 0, 0);
{$IFDEF VER80}
DeallocateHWnd(FWindowHandle);
{$ELSE}
XSocketDeallocateHWnd(FWindowHandle);
{$ENDIF}
inherited Destroy;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.Dup(NewHSocket : TSocket);
var
iStatus : Integer;
begin
if (NewHSocket = 0) or (NewHSocket = INVALID_SOCKET) then begin
WSocket_WSASetLastError(WSAEINVAL);
SocketError('Dup');
Exit;
end;
if FState <> wsClosed then begin
iStatus := WSocket_closesocket(FHSocket);
FHSocket := INVALID_SOCKET;
if iStatus <> 0 then begin
SocketError('Dup (closesocket)');
Exit;
end;
ChangeState(wsClosed);
end;
FHsocket := NewHSocket;
SetLingerOption;
iStatus := WSocket_WSAASyncSelect(
FHSocket, Handle, WM_ASYNCSELECT,
FD_READ or FD_WRITE or FD_CLOSE or FD_CONNECT);
if iStatus <> 0 then begin
SocketError('WSAAsyncSelect');
Exit;
end;
ChangeState(wsConnected);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ Get the number of char received and waiting to be read }
function TCustomWSocket.GetRcvdCount : LongInt;
begin
if WSocket_ioctlsocket(FHSocket, FIONREAD, Result) = SOCKET_ERROR then begin
Result := -1;
SocketError('ioctlSocket');
Exit;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.ChangeState(NewState : TSocketState);
var
OldState : TSocketState;
begin
OldState := FState;
FState := NewState;
TriggerChangeState(OldState, NewState);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ DoRecv is a simple wrapper around winsock recv function to make it }
{ a virtual function. }
function TCustomWSocket.DoRecv(
var Buffer;
BufferSize : Integer;
Flags : Integer) : Integer;
begin
Result := WSocket_recv(FHSocket, Buffer, BufferSize, Flags);
{ FRcvdFlag := (Result > 0);}
{ If we received the requested size, we may need to receive more }
FRcvdFlag := (Result >= BufferSize);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ The socket is non-blocking, so this routine will only receive as much }
{ data as it is available. }
function TCustomWSocket.Receive(Buffer : Pointer; BufferSize: integer) : integer;
begin
Result := DoRecv(Buffer^, BufferSize, 0);
if Result < 0 then
FLastError := WSocket_WSAGetLastError
else
FReadCount := FReadCount + Result;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ Receive as much data as possible into a string }
{ You should avoid this function and use Receive. Using string will be }
{ much slower because data will be copied several times. }
{ ReceiveStr will *NOT* wait for a line to be received. It just read }
{ already received characters and return them as a string. }
function TCustomWSocket.ReceiveStr : string;
var
lCount : LongInt;
begin
SetLength(Result, 0);
lCount := GetRcvdCount;
{$IFDEF VER80}
{ Delphi 1 strings are limited }
if lCount > High(Result) then
lCount := High(Result);
{$ENDIF}
if lCount > 0 then begin
SetLength(Result, lCount);
lCount := DoRecv(Result[1], lCount, 0);
if lCount > 0 then
SetLength(Result, lCount)
else
SetLength(Result, 0);
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TCustomWSocket.DoRecvFrom(
FHSocket : TSocket;
var Buffer;
BufferSize : Integer;
Flags : Integer;
var From : TSockAddr;
var FromLen : Integer) : Integer;
begin
Result := WSocket_recvfrom(FHSocket, Buffer, BufferSize,
Flags, From, FromLen);
{ FRcvdFlag := (Result > 0); }
FRcvdFlag := (Result >= BufferSize);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TCustomWSocket.ReceiveFrom(
Buffer : Pointer;
BufferSize : Integer;
var From : TSockAddr;
var FromLen : Integer) : integer;
begin
Result := DoRecvFrom(FHSocket, Buffer^, BufferSize, 0, From, FromLen);
if Result < 0 then
FLastError := WSocket_WSAGetLastError
else
FReadCount := FReadCount + Result;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TCustomWSocket.PeekData(Buffer : Pointer; BufferSize: integer) : integer;
begin
Result := DoRecv(Buffer^, BufferSize, MSG_PEEK);
if Result < 0 then
FLastError := WSocket_WSAGetLastError;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function SearchChar(Data : PChar; Len : Integer; Ch : Char) : PChar;
begin
while Len > 0 do begin
Len := Len - 1;
if Data^ = Ch then begin
Result := Data;
exit;
end;
Data := Data + 1;
end;
Result := nil;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TCustomWSocket.SendTo(
Dest : TSockAddr;
DestLen : Integer;
Data : Pointer;
Len : Integer) : integer;
begin
Result := WSocket_SendTo(FHSocket, Data^, Len, FSendFlags,
TSockAddr(Dest), DestLen)
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TCustomWSocket.RealSend(Data : Pointer; Len : Integer) : Integer;
begin
if FType = SOCK_DGRAM then
Result := WSocket_SendTo(FHSocket, Data^, Len, FSendFlags,
TSockAddr(sin), SizeOf(sin))
else
Result := WSocket_Send(FHSocket, Data^, Len, FSendFlags);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.TryToSend;
var
oBuffer : TBuffer;
Len : Integer;
Count : Integer;
Data : Pointer;
LastError : Integer;
p : PChar;
bMore : Boolean;
begin
if (FHSocket = INVALID_SOCKET) or { No more socket }
(FBufList.Count = 0) or { Nothing to send }
(bMoreFlag and (nMoreCnt >= nMoreMax)) then { Waiting more signal }
exit;
bMore := TRUE;
while bMore do begin
oBuffer := FBufList.First;
Data := oBuffer.Peek(Len);
if Len <= 0 then begin
{ Buffer is empty }
if FBufList.Count <= 1 then begin
{ Every thing has been sent }
bAllSent := TRUE;
bMore := FALSE;
end
else begin
oBuffer.Free;
FBufList.Delete(0);
FBufList.Pack;
end;
end
else begin
if bMoreFlag then begin
p := SearchChar(Data, Len, #10);
if Assigned(p) then begin
len := p - PChar(Data) + 1;
nMoreCnt := nMoreCnt + 1;
if nMoreCnt >= nMoreMax then
bMore := FALSE;
end;
end;
Count := RealSend(Data, Len);
if Count = 0 then
bMore := FALSE { Closed by remote }
else if count = SOCKET_ERROR then begin
LastError := WSocket_WSAGetLastError;
if (LastError = WSAECONNRESET) or (LastError = WSAENOTSOCK) or
(LastError = WSAENOTCONN) or (LastError = WSAEINVAL) or
(LastError = WSAECONNABORTED) { 07/05/99 }
then begin
FCloseInvoked := TRUE; { 23/07/98 }
Close;
TriggerSessionClosed(LastError); { 23/07/98 }
end
else if LastError <> WSAEWOULDBLOCK then begin
SocketError('TryToSend failed');
Exit;
end;
bMore := FALSE;
end
else begin
oBuffer.Remove(Count);
if Count < Len then begin
{ Could not write as much as we wanted. Stop sending }
{$IFDEF VER80}
{ A bug in some Trumpet Winsock implementation break the }
{ background sending. Jan Tomasek <xtomasej@feld.cvut.cz> }
if not TrumpetCompability then begin
bWrite := FALSE;
bMore := FALSE;
end;
{$ELSE}
bWrite := FALSE;
bMore := FALSE;
{$ENDIF}
end;
end;
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.PutStringInSendBuffer(Str : String);
begin
PutDataInSendBuffer(@Str[1], Length(Str));
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.PutDataInSendBuffer(Data : Pointer; Len : Integer);
var
oBuffer : TBuffer;
cWritten : Integer;
bMore : Boolean;
begin
if Len <= 0 then
exit;
if FBufList.Count = 0 then begin
oBuffer := TBuffer.Create(FBufSize);
FBufList.Add(oBuffer);
end
else
oBuffer := FBufList.Last;
bMore := TRUE;
while bMore do begin
cWritten := oBuffer.Write(Data, Len);
if cWritten >= Len then
bMore := FALSE
else begin
Len := Len - cWritten;
Data := PChar(Data) + cWritten;
if Len < 0 then
bMore := FALSE
else begin
oBuffer := TBuffer.Create(FBufSize);
FBufList.Add(oBuffer);
end;
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ Return -1 if error, else return number of byte written }
function TCustomWSocket.Send(Data : Pointer; Len : Integer) : integer;
begin
if FState <> wsConnected then begin
WSocket_WSASetLastError(WSAENOTCONN);
SocketError('Send');
Result := -1;
Exit;
end;
bAllSent := FALSE;
if Len <= 0 then
Result := 0
else begin
Result := Len;
PutDataInSendBuffer(Data, Len);
end;
if bAllSent then
Exit;
TryToSend;
if bAllSent then begin
{ We post a message to fire the FD_WRITE message wich in turn will }
{ fire the OnDataSent event. We cannot fire the event ourself }
{ because the event handler will eventually call send again. }
{ Sending the message prevent recursive call and stack overflow. }
{ The PostMessage function posts (places) a message in a window's }
{ message queue and then returns without waiting for the }
{ corresponding window to process the message. The message will be }
{ seen and routed by Delphi a litle later, when we will be out of }
{ the send function. }
PostMessage(Handle,
WM_ASYNCSELECT,
FHSocket,
MakeLong(FD_WRITE, 0));
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ Return -1 if error, else return number of byte written }
function TCustomWSocket.SendStr(Str : String) : integer;
begin
Result := Send(@Str[1], Length(Str));
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.SendText(Str : String);
begin
SendStr(Str);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.ASyncReceive(Error : Word);
var
bMore : Boolean;
lCount : LongInt;
TrashCan : array [0..1023] of char;
begin
bMore := TRUE;
while bMore do begin
FLastError := 0;
try
if not TriggerDataAvailable(Error) then begin
{ Nothing wants to receive, we will receive and throw away 23/07/98 }
if DoRecv(TrashCan, SizeOf(TrashCan), 0) = SOCKET_ERROR then begin
FLastError := WSocket_WSAGetLastError;
if FLastError = WSAEWOULDBLOCK then begin
FLastError := 0;
break;
end;
end;
end;
if FLastError <> 0 then
bMore := FALSE
{* Check if we have something new arrived, if yes, process it *}
else if WSocket_ioctlsocket(FHSocket, FIONREAD,
lCount) = SOCKET_ERROR then begin
FLastError := WSocket_WSAGetLastError;
bMore := FALSE;
end
else if lCount = 0 then
bMore := FALSE;
except