Hi

I had the need of a socket server to receive emergency request signals from remote sites via TCP/IP. So just in case someone else has the need for a socket server in VFP I have posted my code below.

With the help of Anatoliy at News2News.com I was able to build the socket server in VFP. In my case the program must send out email notifications when an emergency request was received. So the actual work was done in the DoNotify method. The rest of the code was used to setup the socket server in non-blocking mode and check for connections. I used a timer to check for a connection every 5 sec. You can set the interval to whatever you like. I installed this program as a service on Windows 2003 Server using InstSrv.exe and Srvany.exe from the Windows Resource Kit. It has been running now for about 1 month without any problems.

One thing to note is that if no connection is available and you check the error code after trying to accept a connection you will get the error "Would Block" which to me is a little misleading because this error can also be caused by having too many unanswered requests in the buffer or the fact that the data you are receiving is bigger than the buffer. In either of these two cases the solution is to make your buffer bigger otherwise when no connections are available this error can simply be ignored.

Simon

*
* dcBlueTree.prg --- Blue Tree Wireless Modem Monitoring
*
#DEFINE dC_TCPPort       10002
#DEFINE dC_TimerInt      5000
#DEFINE WSADATA_SIZE     398
#DEFINE WS_VERSION       0x0202  && in case of an error try 0x0101
#DEFINE AF_INET         2
#DEFINE SOCK_STREAM     1
#DEFINE IPPROTO_TCP     6
#DEFINE SOCKET_ERROR   -1
#DEFINE INVALID_SOCKET  0
#DEFINE SOMAXCONN       0x7FFFFFFF
#DEFINE SD_RECEIVE      0x00
#DEFINE SD_SEND         0x01
#DEFINE SD_BOTH         0x02
#DEFINE INADDR_ANY      0x00000000
#DEFINE READ_SIZE       0x00ff
#DEFINE HOSTENT_SIZE    16
#DEFINE M0              256
#DEFINE M1              65536
#DEFINE M2              16777216
#DEFINE FIONBIO         -0x7FFB9982      

Set Bell Off
Set Print Off
Set Escape Off
Set Device To Screen
Set CPDialog Off
Set Compatible Off
Set Resource Off
Set Century On
Set Confirm On
Set Decimals To 5
Set Deleted On
Set Exclusive Off
Set Near Off
Set Reprocess To 2
Set Safety Off
Set TablePrompt Off
Set Talk Off
Set Procedure to dCBlueTree.prg


Try

   Local llQuit,ln,lnSize,lnMilliSec,lcRX,lcTxt,loT
   pnSocket=0
   pcLocalName=""
   pcLocalIP=""
   lnSize=0

   On Shutdown Clear Events
   =DeclareFunctions()
    
   _Screen.WindowState=Iif(Version(2)=0,1,0)

   If InitWinsock()
      loT=CreateObject("timSerial")
      loT.Interval=DC_TIMERINT
      =GetLocalIP()
      If StartServer()
         Set Message to "Server is Running..."
         Read Events
      Else
         =StopServer()
         Set Message to "Server is NOT Running..."
      EndIf
   Else
*
* Log Error Condition here
*
   EndIf
Catch to loErr
*
* Log VFP Error here
*
   loErr=""
   Set Message To ""
   Clear Events
EndTry   
loT=""
On Shutdown
Set Message To "Shutting Down..."
=StopServer(pnSocket)
=WSACleanup()
Clear All
Close Database
If Version(2)=0
   Quit   
EndIf

Function buf2dword(tcBuffer)
Return Asc(SubStr(tcBuffer,1,1))+BitLShift(Asc(SubStr(tcBuffer,2,1)),8)+;
                                 BitLShift(Asc(SubStr(tcBuffer,3,1)),16)+;
                                 BitLShift(Asc(SubStr(tcBuffer,4,1)),24)
Procedure DeclareFunctions
   DECLARE INTEGER inet_addr IN ws2_32 STRING cp
   DECLARE STRING inet_ntoa IN ws2_32 INTEGER in_addr
   DECLARE INTEGER htons IN ws2_32 INTEGER hostshort
   DECLARE INTEGER WSAGetLastError IN ws2_32
   DECLARE INTEGER closesocket IN ws2_32 INTEGER s
   DECLARE INTEGER select IN ws2_32 AS ws_select INTEGER nfds, STRING @readfds, STRING @writefds, STRING @exceptfds, STRING @tmout
   DECLARE INTEGER connect IN ws2_32 AS ws_connect INTEGER s, STRING @sname, INTEGER namelen
   DECLARE INTEGER recv IN ws2_32 INTEGER s, STRING @buf, INTEGER buflen, INTEGER flags
   DECLARE INTEGER accept IN ws2_32 INTEGER s, STRING @addr, INTEGER @addrlen
   Declare Integer socket IN ws2_32 INTEGER af, INTEGER socktype, INTEGER protocol
   Declare Integer bind IN ws2_32 As ws_bind INTEGER s, STRING @sockaddr, INTEGER namelen
   Declare Integer listen IN ws2_32 INTEGER s, INTEGER backlog
   DECLARE INTEGER gethostbyname IN ws2_32 STRING hostname
   DECLARE INTEGER gethostname IN ws2_32 STRING @hstname, INTEGER namlen
   DECLARE RtlMoveMemory IN kernel32 As CopyMemory STRING @dst, INTEGER src, INTEGER nLen
   Declare Integer WSAStartup In ws2_32 Integer wVerRq, String @lpWSAData
   Declare Integer WSACleanup in ws2_32
   Declare Integer ioctlsocket in ws2_32 Integer s,Integer cmd, Integer @lnVal
   DECLARE INTEGER send IN ws2_32 INTEGER s, STRING @buf, INTEGER buflen, INTEGER flags
   DECLARE INTEGER shutdown IN ws2_32 INTEGER s, INTEGER how
  
EndProc
Procedure DoNotify
*
* Put your custom code here when a valid connection is obtained
*
   LParameter tcBuffer,tnSocket

EndProc

Procedure DoRun
*   If IsDataAvailable()  && an alternate method for checking of Data suggested by www.News2News.com

      LOCAL lhNewsock, lcBuffer, lnBufsize, lnError, lcRecv, lnRecv,lnFlags, lnClientPort, lcClientIP
      lnBufsize = READ_SIZE
      lcBuffer = Repli(Chr(0), lnBufsize)
      lhNewsock = accept(pnSocket, @lcBuffer, @lnBufsize)
      IF lhNewsock <> INVALID_SOCKET .And.lhNewSock<>SOCKET_ERROR
         lnClientPort = Asc(SUBSTR(lcBuffer, 3,1)) * 256 +Asc(SUBSTR(lcBuffer, 4,1))
         lcClientIP = inet_ntoa(buf2dword(SUBSTR(lcBuffer,5,4)))
         lcBuffer = ""
         lnRecv=99
         Do While lnRecv>0
            lcRecv = Repli(Chr(0), READ_SIZE)
            lnRecv = recv(lhNewsock, @lcRecv, READ_SIZE, 0)
            IF lnRecv > 0
               lcBuffer = lcBuffer + LEFT(lcRecv, lnRecv)
            EndIf
         EndDo
         If ""<>lcBuffer
            =DoNotify(lcBuffer,lhNewSock)
         EndIf
      	 =shutdown(lhNewsock, SD_BOTH)
         = closesocket(lhNewsock)
      Else
         lnError = WSAGetLastError()   && Used for debugging
*
* Log Error if desired
*
      EndIf
*  EndIf
EndProc
Function GetBindBuf(tcIP, tnPort)
   LOCAL lcBuffer, lcPort, lcHost
   lcPort = num2word(htons(tnPort))
   lcHost = num2dword(inet_addr(tcIP))
   RETURN num2word(AF_INET) + lcPort + lcHost + Repli(Chr(0),8)
EndFunc   
PROCEDURE GetLocalIP
   LOCAL lcBuffer, lnResult, lnAddr
   lcBuffer = Repli(Chr(0), 250)
   lnResult = gethostname(@lcBuffer, Len(lcBuffer))
   pcLocalName = Iif(lnResult=0, SUBSTR(lcBuffer, 1,AT(Chr(0),lcBuffer)-1), "")
   lnAddr = gethostbyname(pcLocalName)
   IF lnAddr <> 0
      lcBuffer = Repli(Chr(0), HOSTENT_SIZE)
      = CopyMemory(@lcBuffer, lnAddr, HOSTENT_SIZE)
      lnAddr = buf2dword(SUBSTR(lcBuffer, 13,4)) && ptr to list of addresses
      lcBuffer = Repli(Chr(0), 4)
      = CopyMemory(@lcBuffer, lnAddr, 4)
      lnAddr = buf2dword(lcBuffer)
      = CopyMemory(@lcBuffer, lnAddr, 4)
      lnAddr = buf2dword(lcBuffer)
      pcLocalIP = inet_ntoa(lnAddr)
   EndIf
EndProc   
Function HexToDec
   LParameters tcHex
   Local lnLen,lnP,lnDec,ln
   Store Len(tcHex) To lnLen,lnP
   lnDec=0
   For ln=1 To lnLen
      lnP=lnP-1
      lnDec=lnDec+At(Substr(tcHex,ln,1),"123456789ABCDEF")*16^lnP
   EndFor
   Return Int(lnDec)
EndFunc
Function InitWinsock
   
   Local lcWSADATAln, lnInitResult
   lcWSADATA = Replicate(Chr(0), WSADATA_SIZE)
   lnInitResult = WSAStartup(WS_VERSION, @lcWSADATA)

   Return lnInitResult=0
EndFunc   
Function IsDataAvailable
   Local lcRead, lcWrite, lcError, lnCount, lcTimeout
   STORE num2dword(1) + num2dword(pnSocket) TO lcRead, lcWrite, lcError
   lcTimeout = num2dword(2) + num2dword(1)
   lnCount = ws_select(0, @lcRead, @lcWrite, @lcError, @lcTimeout)
   RETURN lnCount <> 0 And (buf2dword(SUBSTR(lcRead,1,4)) > 0)
EndFunc
Function num2dword(tnValue)
   If tnValue < 0
      tnValue = 0x100000000 + tnValue
   Endif
   Local lb0, lb1, lb2, lb3

   lb3 = Int(tnValue/M2)
   lb2 = Int((tnValue - lb3*M2)/M1)
   lb1 = Int((tnValue - lb3*M2 - lb2*M1)/M0)
   lb0 = Mod(tnValue, M0)

   Return Chr(lb0)+Chr(lb1)+Chr(lb2)+Chr(lb3)
EndFunc   
Function num2word(tnValue)
   Return Chr(Mod(tnValue,256))+Chr(Int(tnValue/256))
   
Procedure StartServer

   pnSocket = socket(AF_INET, SOCK_STREAM, IPPROTO_TCP)

   If pnSocket = INVALID_SOCKET
      Return .F.
   Endif
   Local lcBuffer, lnError,lnMode,lnRtn
*   lcBuffer = GetBindBuf(pcLocalIP, DC_TCPPORT)
*
* I chose to hard code the IP Address because the server had been assigned public and private IP
* addresses and I needed to use the private IP address which would be routed over a VPN
*
   lcBuffer = GetBindBuf("192.168.10.2", DC_TCPPORT) 
   IF ws_bind(pnSocket, @lcBuffer, Len(lcBuffer)) <> 0
      lnError = WSAGetLastError()
*
* Log Error Here
*
      Return .F.
   EndIf
   lnMode=1   && Non-Blocking
   Return ioctlsocket(pnsocket,FIONBIO,@lnMode)=0.And.listen(pnSocket, SOMAXCONN)=0
EndProc
Procedure StopServer
   LParameters tnSocket
   If Vartype(tnSocket)="N".And.tnSocket <> 0
      = closesocket(tnSocket)
      tnSocket = 0
   Endif
EndProc

Define Class timSerial As Timer
   Procedure Timer
      This.Interval=0
      =DoRun()
      This.Interval=DC_TIMERINT
   EndProc
   
EndDefine