// \SAMPLES\SOCKET1.PRG// FiveWin WinSocket.dll support !!!/* 25/05/2021
MODIFICACION DE LA CLASE ORIGINAL TSOCKET:
El problema radicaba en que la clase TSocket original de FiveWin no gestiona los errores
cuando trata de enviar datos, EL FALLO CONSISTE en que deja al método SendData en un bucle
infinito. He modificado TSockets para gestionarlo.
Referencia de sockets propios de harbour (No usados en esta clase).
https://github.com/Petewg/harbour-core/wiki/Harbour-Socket-API
*/#include "FiveWin.ch"#include "Fileio.ch"#define AF_INET
2#define SOCK_STREAM
1#define IPPROTO_IP
0#define SOL_SOCKET
-1#define FD_READ
1#define FD_WRITE
2#define FD_OOB
4#define FD_ACCEPT
8#define FD_CONNECT
16#define FD_CLOSE
32#define SD_RECEIVE
0#define SD_SEND
1#define SD_BOTH
2#define SO_REUSEADDR
4#define FILE_BLOCK
30000/* ERRORES DE CONEXION SOCKETS DE WINSOCK2 :
https://docs.microsoft.com/es-es/window ... or-codes-2 */#define WSAEWOULDBLOCK
10035 // El buffer de envío está lleno./* WSAEWOULDBLOCK is not really an error but simply tells you that your send buffers are full.
This can happen if you saturate the network or if the other side simply doesn't acknowledge the received data.*/#define WSAECONNRESET
10054 // El host remoto cortó la conexión.#define WSAENOTCONN
10057 /* Socket is not connected.
A request to send or receive data was disallowed because the socket is not connected
and (when sending on a datagram socket using sendto) no address was supplied.
Any other type of operation might also return this error—for example,
setsockopt setting SO_KEEPALIVE if the connection has been reset. */#ifdef __XPP__
#define New _New
#endif
// ----------------------------------------------------------------------------//CLASS GSocket
DATA nPort AS NUMERIC
INIT 0 // socket port number DATA cIPAddr AS String
INIT "" // socket IP address DATA nTimeOut AS NUMERIC
INIT 30 DATA nBackLog AS NUMERIC
INIT 5 DATA nSocket AS NUMERIC
INIT -1 DATA hFile AS NUMERIC
INIT 0 DATA bAccept, bRead, bWrite, bClose, bConnect, bOOB
DATA lDebug
DATA cLogFile
DATA cMsg, nRetCode, Cargo
DATA aBuffer
// data sending buffer DATA lSending
// sending in progress CLASSDATA aSockets
INIT {} METHOD New( nPort, oWnd
) CONSTRUCTOR
MESSAGE ACCEPT
METHOD _Accept
( nSocket
) METHOD End
() METHOD HandleEvent
( nSocket, nOperation, nErrorCode
) METHOD GetData
() METHOD SendBin
( pMemory, nSize
) INLINE SendBinary
( pMemory, nSize
) METHOD SendChunk
( nBlockSize
) METHOD SendFile
( cFileName, nBlockSize
) METHOD SendData
( cData
) MESSAGE Listen
METHOD _Listen
() METHOD Close
() METHOD Connect
( cIPAddr, nPort
) INLINE ;
ConnectTo
( ::
nSocket,
If( nPort !=
NIL, nPort, ::
nPort ), cIPAddr
) METHOD Refresh() INLINE SocketSelect
( ::
nSocket ) METHOD OnAccept
() INLINE If( ::
bAccept !=
NIL, Eval
( ::
bAccept,
Self ),
) METHOD OnRead
() INLINE If( ::
bRead !=
NIL, Eval
( ::
bRead,
Self ),
) METHOD OnWrite
() INLINE If( ::
bWrite !=
NIL, Eval
( ::
bWrite,
Self ),
) METHOD OnClose
() INLINE If( ::
bClose !=
NIL, Eval
( ::
bClose,
Self ),
) METHOD OnConnect
( nErrorCode
) INLINE If( ::
bConnect !=
NIL, Eval
( ::
bConnect,
Self, nErrorCode
),
) METHOD OnOOB
() INLINE If( ::
bOOB !=
NIL, Eval
( ::
bOOB,
Self ),
) METHOD ClientIP
() INLINE GetPeerName
( ::
nSocket )ENDCLASS// ----------------------------------------------------------------------------//METHOD New( nPort, oWnd
) CLASS GSocket
DEFAULT oWnd := WndMain
(), ::
aSockets :=
{} IF Len
( ::
aSockets ) ==
0 IF WSAStartup
() !=
0 MsgAlert
( "WSAStartup error" ) ENDIF ENDIF IF ( ::
nSocket := Socket
( AF_INET, SOCK_STREAM, IPPROTO_IP
) ) ==
0 MsgAlert
( "Socket creation error: " + Str
( WsaGetLastError
() ) ) ENDIF // msginfo(::nSocket,"wintpv: Nuevo socket creado") ::
cIPAddr = GetHostByName
( GetHostName
() ) // "127.1.1.1" ::
aBuffer =
{} ::
lSending = .F.
::
lDebug = .F.
IF nPort !=
nil ::
nPort = nPort
BindToPort
( ::
nSocket, nPort
) // Bind is not needed for connect sockets ENDIF AAdd
( ::
aSockets,
Self ) // msginfo(Len( ::aSockets ),"Sockets totales creados con este nuevo:") IF oWnd !=
nil oWnd:
bSocket =
{| nSocket, nLParam | ::
HandleEvent( nSocket, ;
nLoWord
( nLParam
), nHiWord
( nLParam
) ) } WSAAsyncSelect
( ::
nSocket, oWnd:
hWnd, WM_ASYNCSELECT, ;
nOr
( FD_ACCEPT, FD_OOB, FD_READ, FD_CLOSE, FD_CONNECT, FD_WRITE
) ) ELSE MsgAlert
( "You must create a main window in order to use a GSocket object" ) ENDIF RETURN Self// ----------------------------------------------------------------------------//METHOD _Accept
( nSocket
) CLASS GSocket
::
nSocket = Accept
( nSocket
) ::
aBuffer =
{} ::
lSending = .F.
::
lDebug = .F.
AAdd
( ::
aSockets,
Self ) WSAAsyncSelect
( ::
nSocket, WndMain
():
hWnd, WM_ASYNCSELECT, ;
nOr
( FD_ACCEPT, FD_OOB, FD_READ, FD_CLOSE, FD_CONNECT, FD_WRITE
) ) RETURN Self// ----------------------------------------------------------------------------//METHOD GetData
() CLASS GSocket
LOCAL cData :=
"" ::
nRetCode = Recv
( ::
nSocket, @cData
) IF ::
lDebug .AND. ! Empty
( ::
cLogFile ) LogFile
( ::
cLogFile,
{ cData
} ) ENDIF RETURN cData
// ----------------------------------------------------------------------------//METHOD _Listen
() CLASS GSocket
LOCAL nRetCode := Listen
( ::
nSocket, ::
nBackLog ) RETURN ( nRetCode ==
0 )// ----------------------------------------------------------------------------//METHOD End
() CLASS GSocket
LOCAL nAt := AScan
( ::
aSockets,
{| oSocket | oSocket:
nSocket == ::
nSocket } ) LOCAL nShutdown :=
0 WHILE ::
lSending SysRefresh
() END
/* if nAt != 0
ADel( ::aSockets, nAt )
ASize( ::aSockets, Len( ::aSockets ) - 1 )
if Len( ::aSockets ) == 0
msginfo("antes de WSACleanUp()")
WSACleanUp()
endif
endif */ // Añadido el 23/05/2021 para ver si al salir del programa y volver a entrar no hay problema // para volver a conectar con el servidor. IF ( nShutdown := shutdown
( ::
nSocket, SD_BOTH
) ) <>
0 // msginfo( nShutdown, "Shutdown()" ) // msgwait('ERROR: ShutDown(), WSAGetLastError = '+alltrim(str(WSAGetLastError())),"oSocket:ShutDown()",3) EscribeEnFichTxt
( DToS
( Date
() ) +
' ' + Time
() + ;
' ERROR: ShutDown(' + AllTrim
( Str
( ::
nSocket ) ) +
'), WSAGetLastError = ' + AllTrim
( Str
( WSAGetLastError
() ) ), ;
'LOG_SOCKETS.TXT', .T.,
2 ) // else // msgwait('OK, ShutDown() == '+str(nShutdown),"oSocket:ShutDown()",2) ENDIF IF ! Empty
( ::
nSocket ) CloseSocket
( ::
nSocket ) ::
nSocket =
0 ENDIF IF nAt !=
0 ADel
( ::
aSockets, nAt
) ASize
( ::
aSockets, Len
( ::
aSockets ) -
1 ) IF Len
( ::
aSockets ) ==
0 // msginfo("antes de WSACleanUp()") // EscribeEnFichTxt(dtos(Date())+" "+time()+" WSACleanUp() OK",'LOG_SOCKETS.TXT',.T.,2) WSACleanUp
() ENDIF ENDIF RETURN NIL// ----------------------------------------------------------------------------//METHOD Close
() CLASS GSocket
WHILE ::
lSending SysRefresh
() END
RETURN CloseSocket
( ::
nSocket )// ----------------------------------------------------------------------------//METHOD HandleEvent
( nSocket, nOperation, nErrorCode
) CLASS GSocket
LOCAL nAt := AScan
( ::
aSockets,
{| oSocket | oSocket:
nSocket == nSocket
} ) LOCAL oSocket
IF nAt !=
0 oSocket = ::
aSockets[ nAt
] DO CASE CASE nOperation == FD_ACCEPT
IF ::
lDebug .AND. ! Empty
( ::
cLogFile ) LogFile
( ::
cLogFile,
{ "Accept", ;
"Socket handle:" + Str
( nSocket
) } ) ENDIF oSocket:
OnAccept() CASE nOperation == FD_READ
IF ::
lDebug .AND. ! Empty
( ::
cLogFile ) LogFile
( ::
cLogFile,
{ "Read", ;
"Socket handle:" + Str
( nSocket
) } ) ENDIF oSocket:
OnRead() CASE nOperation == FD_WRITE
IF ::
lDebug .AND. ! Empty
( ::
cLogFile ) LogFile
( ::
cLogFile,
{ "Write", ;
"Socket handle:" + Str
( nSocket
) } ) ENDIF oSocket:
OnWrite() CASE nOperation == FD_CLOSE
IF ::
lDebug .AND. ! Empty
( ::
cLogFile ) LogFile
( ::
cLogFile,
{ "Close", ;
"Socket handle:" + Str
( nSocket
) } ) ENDIF oSocket:
OnClose() CASE nOperation == FD_CONNECT
IF ::
lDebug .AND. ! Empty
( ::
cLogFile ) LogFile
( ::
cLogFile,
{ "Connect", ;
"Socket handle:" + Str
( nSocket
) } ) ENDIF oSocket:
OnConnect( nErrorCode
) CASE nOperation == FD_OOB
IF ::
lDebug .AND. ! Empty
( ::
cLogFile ) LogFile
( ::
cLogFile,
{ "OOB", ;
"Socket handle:" + Str
( nSocket
) } ) ENDIF oSocket:
OnOOB() OTHERWISE IF ::
lDebug .AND. ! Empty
( ::
cLogFile ) LogFile
( ::
cLogFile,
{ "nOperation not recognized", ;
Str
( nOperation
) } ) ENDIF ENDCASE ENDIF RETURN NIL// ----------------------------------------------------------------------------//METHOD SendChunk
( nBlockSize
) CLASS GSocket
LOCAL cBuffer, nBytes :=
0 DEFAULT nBlockSize := FILE_BLOCK
cBuffer = Space
( nBlockSize
) IF ::
hFile !=
0 nBytes = FRead
( ::
hFile, @cBuffer, nBlockSize
) IF nBytes < nBlockSize
cBuffer =
SubStr( cBuffer,
1, nBytes
) FClose
( ::
hFile ) ::
hFile =
0 ENDIF ::
SendData( cBuffer
) END
RETURN nBytes
// ----------------------------------------------------------------------------//METHOD SendFile
( cFileName, nBlockSize
) CLASS GSocket
DEFAULT nBlockSize := FILE_BLOCK
IF ! Empty
( cFileName
) .AND. File
( cFileName
) If( ( ::
hFile := FOpen
( cFileName
) ) !=
-1 ) WHILE ::
SendChunk( nBlockSize
) == nBlockSize
END
ENDIF ENDIF RETURN NILMETHOD SendData
( cData
) CLASS GSocket
LOCAL nSize := Len
( cData
) LOCAL nLen := nSize
LOCAL nSent :=
0 LOCAL nIntentos :=
3 LOCAL nErrorWSA :=
0, cErrDesc :=
"" IF ! ::
lSending ::
lSending = .T.
ELSE AAdd
( ::
aBuffer, cData
) RETURN nSize
ENDIF WHILE ( nLen >
0 .AND. ;
( nSent := SocketSend
( ::
nSocket, cData
) ) < nLen
) .OR. ;
Len
( ::
aBuffer ) >
0 SYSREFRESH
() // Check for buffered packets to send IF nLen ==
0 .AND. Len
( ::
aBuffer ) >
0 cData = ::
aBuffer[ 1 ] ADel
( ::
aBuffer,
1 ) ASize
( ::
aBuffer, Len
( ::
aBuffer ) -
1 ) ENDIF IF nSent !=
-1 // No hay error en el envío. cData =
SubStr( cData, nSent +
1 ) nLen = Len
( cData
) ELSE // Ha habido error en el envío. nErrorWSA = WSAGetLastError
() IF nErrorWSA != WSAEWOULDBLOCK
// Buffer lleno EXIT
ELSE // WSAEWOULDBLOCK => Buffer lleno. Reintenta el envío hasta nIntentos veces. IF nIntentos >
0 nIntentos = nIntentos -
1 RetardoSecs
(1) LOOP
ELSE EXIT
// 14/08/2018 Sale para no quedar en un bucle sin fin si hay errores WINSOCK2. ENDIF ENDIF ENDIF ENDDO IF nSent ==
-1 // Descripción del Error: DO CASE CASE nErrorWSA == WSAENOTCONN
// Socket is not connected. cErrDesc :=
"Socket is not connected." // Tiene que volver a conectar el Socket porque se ha desconectado. CASE nErrorWSA == WSAECONNRESET
// El host remoto cortó la conexión. cErrDesc :=
"El host remoto cortó la conexión." CASE nErrorWSA != WSAEWOULDBLOCK
cErrDesc :=
"Buffer Send lleno." ENDCASE // msgwait('ERROR: SocketSend(), WSAGetLastError = '+alltrim(str(nErrorWSA)),"oSocket:SendData",2) EscribeEnFichTxt
( DToS
( Date
() ) +
' ' + Time
() + ;
' ERROR: SocketSend(), WSAGetLastError = ' + AllTrim
( Str
( nErrorWSA
) ) + ;
' FROM ' + iif
( Empty
( ::
cIPAddr ),
"ip ???", ::
cIPAddr ) +
":" + iif
( Empty
( ::
nPort ),
"port ???", AllTrim
( Str
( ::
nPort ) ) ) +
" = " + cErrDesc,
'LOG_SOCKETS.TXT', .T.,
2 ) ENDIF // if ::lDebug .AND. ! Empty( ::cLogFile ) // LogFile( ::cLogFile, { cData } ) // endif ::
lSending = .F.
RETURN nSent
// Propongo nSent en vez de nSize porque Si nSent = -1 es que la instrucción no ha ido bien, hay errores. //nSize// ----------------------------------------------------------------------------//FUNCTION GShowIP
() LOCAL oSocket := GSocket
():
New( 2000 ) LOCAL cIp := oSocket:
cIPAddr oSocket:
End() RETURN cIp
// ----------------------------------------------------------------------------///* Escribe en un fichero txt.
Añade la línea si lAppend:=.t. o NIL
Devuelve: .F. si no tuvo exito al abrir el fichero.
.T. si tuvo exito.
*/FUNCTION EscribeEnFichTxt
( cMensaje, cFich, lAppend, Intentos, lAvisoError, lBorraFichExistente, lAnadeCRLFfinal
) LOCAL lValRet := .F.
LOCAL nLongFichero :=
0 LOCAL nLongRec := Len
( cMensaje
) LOCAL nManejador :=
-1 DEFAULT cFich :=
"LOG.TXT" DEFAULT lAppend := .T.
DEFAULT Intentos :=
1 DEFAULT lAvisoError := .T.
DEFAULT lBorraFichExistente := .F.
DEFAULT lAnadeCRLFfinal := .T.
IF lBorraFichExistente
FErase
( cFich
) ENDIF WHILE lValRet = .F. .AND. intentos >
0 SYSREFRESH
() intentos = intentos -
1 nManejador := iif
( File
( cFich
), ;
FOpen
( cfich, FO_READWRITE + FO_SHARED
), ;
FCreate
( cFich, FC_NORMAL
) ) IF FError
() =
0 // Longitud del fichero y se sitúa al final del fichero. nLongFichero := FSeek
( nManejador,
0, FS_END
) // Devuelve a la posición inicial si lAppend=.f. iif
( lAppend,
NIL, FSeek
( nManejador,
0 ) ) // Escribe el mensaje iif
( FWrite
( nManejador, cMensaje + iif
( lAnadeCRLFfinal, CRLF,
"" ) ) < nLongRec, lValRet := .F., lValRet := .T.
) FClose
( nManejador
) ELSE IF lAvisoError
msgwait
( 'ERROR AL ABRIR FICHERO:' + CRLF + cFich,
'EscribeFich',
1 ) ENDIF ENDIF ENDDO RETURN lValRet
FUNCTION RetardoSecs
(nSecs, lVerMsgProceso, cMensaje
) local nSecIni:=Secs
(Time
()) local nElapsed:=
0 local oDlg, oSay, oFont
default cMensaje:=
'Sistema procesando, espere...' default lVerMsgProceso:=.f.
if lVerMsgProceso
DEFINE DIALOG oDlg
TITLE 'PROCESO EN CURSO' FROM 6,
10 TO 15,
60 ;
FONT oFont
@
1,
2 SAY oSay
VAR cMensaje
FONT oFont
OF oDlg
ACTIVATE DIALOG oDlg
NOWAIT //sysrefresh() endif while nElapsed < nSecs
nElapsed:=Secs
(Time
())-nSecIni
if nElapsed <
0 nElapsed:=nElapsed
+86400 endif enddo if lVerMsgProceso
oDlg:
end() //sysrefresh() endifRETURN NILDLL32
STATIC FUNCTION shutdown
( dwReserved AS LONG, lpdwReserved AS LONG
);
AS LONG PASCAL
FROM "shutdown" LIB
"ws2_32.dll" // "wsock32.dll" también vale// FIN 
