Wiki Home

WinSock OCXSample


Namespace: VFP
I'm experimented with Eeva webserver a lot (Web Server In FoxPro) and have found, that the code like this is unusable.
I tested it under vfp 5 and vfp 7. It seems that mswinsock ocx is not released after sendcomplete. It remains in strange state and causes VFP to use processor 100%, to stop responging and to run out of memory.
You can reproduce this by sending requests to server continuously and
looking kernel krocessor usage in windows system monitor.

In 2.02 release of Web Server In FoxPro I removed all code from events, set _vfp.autoyield=.t. in some parts and this works OK.
Andrus Moor
---
During an actual project, I had a real hard time to figure out, how that WinSock control can be used in VFP. My search for code samples was not very succesful, so I decided to make my own ones. As a result here are now two little sample apps, showing a TCP server and a TCP client.

Thanks to Grigore Dolghin, who had a look on the code and stripped it from (I hope all) my bugs. :-)

You can run the apps either on the same or on different machines, that are connected by a TCP/IP network. You also can connect more than one client to the server. Remember that we are using Winsock.oxc, thus this must be installed on the machines. I tested the code with the one that came with VFP6.
I've encountered the clientobject to lock up when trying to access the server (clicking [connect]) in VFP 9.0 - add the FORCE command extension to the DOEVENT to get it to behave correctly again! -- Burkhard Stiller

This code uses an abstract class in the server, and two derived classes. This fails when deployed in a runtime environment, and needs to be put into .vcx files instead. See microsoft knowledge base article Q192693 Offsite link to http://support.microsoft.com/default.aspx?scid=kb;EN-US;Q192693. -- Tony Wallace

Ok now, first the server ...

*-----------------| Location Section |--------------------
*) Procedure..: A simple TCP/IP server test form
*} Library....:
*} Class......:
*} Method.....:
*) Author........: Markus Voellmy
*) Company.......:
*) Description...: A server for TCP/IP. Uses Winsock OCX for communications.
*-------------------| Usage Section |---------------------
*$ Scope.........:
*$ Parameters....: tnPort - Numeric. The port number. If not supplied, 63333 is used.
*$ Usage.........: Simple run it. Parameter is optional.
*$ Example.......: DO tcpserver WITH 63333
*$ Returns.......:
*-------------------| Various Info |----------------------
*@ Precondition Invariants.....:
*@ Post-condition Invariants...:
*----------------| Maintenance Section |------------------
*? To Do............:
*= Methods Called...:
** Process..........: This test server uses the Winsock OCX for communications
*^ Change Log.......:
*--------------------------------------------------------- 

LPARAMETERS tnPort
#DEFINE EOT CHR(4)	&& End of Transmission sign
CLEAR
IF VARTYPE(tnPort) # "N"
  tnPort = 63333
ENDIF
oForm = CREATEOBJECT('myForm',tnPort)
READ EVENTS
RELEASE oForm
RETURN
* --- The form class
DEFINE CLASS MyForm AS FORM
  nProtocol 	= 0
  nPort		= 0  && this should be filled with a normally unusued port
  AutoCenter 	= .T.
  Caption 	= 'TCP-Server --- Port '+ALLTRIM(STR( This.nPort) )
  nstat		= 0

  PROCEDURE Load
   SYS(2333,0)
   _VFP.AutoYield = .F.
   RETURN
  ENDPROC

  PROCEDURE Unload
   _VFP.AutoYield = .T.
   RETURN
  ENDPROC

  PROCEDURE QueryUnload
   CLEAR EVENTS
   RETURN
  ENDPROC

  PROCEDURE Init
   LPARAMETERS tnPort
   This.nPort = tnPort
   This.AddObject('EditOut', 'bEditBox')
   WITH This.EditOut
    .Top      = 60
    .Left     = 10
    .Width    = This.Width-20
    .Height   = This.Height-(.Top+5)
    .ReadOnly = .T.
    .Value    = ''
    .Visible  = .T.
   ENDWITH
   This.AddObject('txtStat', 'TextBox')
   WITH this.txtStat
    .Top      = 10
    .Left     = 10
    .Width    = 20
    .Readonly = .T.
    .ControlSource = "ThisForm.nStat"
    .Visible  = .T.
   ENDWITH
   This.AddObject('oSock', 'frmSock' )
   This.oSock.Listen()
   This.Visible = .T.
   RETURN
  ENDPROC
ENDDEFINE
* --- WinSock ActiveX Abstract
DEFINE CLASS  aWinSock AS OleControl
  OleClass = "MSWinsock.Winsock"

  PROCEDURE Init
   This.protocol  = Thisform.nProtocol
   This.localport = Thisform.nPort
  ENDPROC

  PROCEDURE Error
   LPARAMETERS number, description, scode, source, helpfile,             helpcontext, canceldisplay

   * It's used for error displaying purposes
   WITH ThisForm.EditOut
    .Value = .Value + CHR(13) + CHR(10)
    .Value = .Value + 'Error ' + STR(number) + " " + ;
    Description + chr(13) + chr(10)
    .Refresh()
   ENDWITH
  ENDPROC
ENDDEFINE
* --- WinSock ActiveX "the listener"
DEFINE CLASS  frmSock AS aWinSock

* Because it might be, that we want to have more than one single
* connection active, we need a method to do a pseudo multi
* threading. I have "stolen" this idea from EETAServer ---
* Thx btw --- and have later on noticed that this already is
* recommended in the online help.

  PROCEDURE ConnectionRequest
   LPARAMETER tnRequestID

* This ActiveX is a performance hog, so we need to get
* rid of older connections that aren't active anymore.
* So before adding a new one we check if we can skip
* another.

  FOR EACH lControl IN ThisForm.Controls

* This DoEvent might not really be necessary, but
* it helps to get a correct state from the instance

   DOEVENTS
   IF LOWER(lControl.Class) != 'frmsock2' or ;
      ((seconds()-lControl.nCreateTime) < 5 or lControl.State = 7)
      LOOP
   ENDIF
* If we have an instance to skip we show this to the user
   WITH ThisForm.EditOut
    .Value = .Value + 'Info ' + 'Remove ' + lControl.name + chr(13) + chr(10)
    .Refresh()
   EndWith
   Thisform.RemoveObject(lControl.name )
  ENDFOR

* Now let's add another TCP server, that is able to handle
* the intended connection. The SYS(2015) function is a simple
* way to get an almost unique object name. In a serious production
* app it might be necessary to catch it's weaknesses for fast
* consequtive calls.

  ThisForm.Addobject( SYS(2015), 'frmSock2', m.tnRequestID )
* If we have an instance to add we also show this to the user
   WITH ThisForm.EditOut
    .Value = .Value + 'Info ' + 'Connection added ID ' + ;
    STR(m.tnRequestID) + chr(13) + chr(10)
    .Refresh()
   ENDWITH
   RETURN
  ENDPROC
ENDDEFINE
* --- WinSock ActiveX for multiple Connections
DEFINE CLASS  frmSock2 AS aWinSock
  nCreateTime = 0     && The creation time
  cReceiveBuffer = '' && a buffer to stitch incomming transmission together

  PROCEDURE Init
   LPARAMETERS tnRequestID
   LOCAL llRetVal
   This.nCreateTime = SECONDS()
   This.Accept(tnRequestID)
   ThisForm.nstat = this.State
   ThisForm.Refresh()
   RETURN
  ENDPROC

  PROCEDURE DataArrival
   LPARAMETERS tnByteCount
   LOCAL lcBuffer
   lcBuffer = SPACE(tnByteCount)

* This gets the data from the socket. It can happen, that the data isn't
* received in a single rush. Thus we need a EOT (end of transmission)
* sign to be sure, the data is complete. Until we get this, the data
* is stuffed into cReceiveBuffer.

   This.GetData( @lcBuffer, , tnByteCount )
   IF AT( EOT, lcBuffer ) = 0	&& Not yet finished
    This.cReceiveBuffer = This.cReceiveBuffer + lcBuffer
   ELSE
    This.cReceiveBuffer = This.cReceiveBuffer +  LEFT( lcBuffer, AT( EOT, lcBuffer ) -1 )

* First we strip off the EOT sign that has done it's purpose ...
* then follows the "real" action. All we want to do should be done
* here now. For a sample we show the incoming text in an
* editbox
    WITH ThisForm.EditOut
     .Value = .Value + This.cReceiveBuffer + CHR(13) + CHR(10)
     .Refresh()
    ENDWITH
			
* But we can do a lot more of course eg ...
* return the time of the servers machine when we get a request
* for it ...

    IF UPPER( LEFT( This.cReceiveBuffer, 7 ) ) = 'GETTIME'

* Again in a production app we would have to be a little
* more careful. If the connection got lost meanwhile this
* returns an ugly error with a a popping up Messagebox :-(

     This.SendData( TTOC(datetime()) + EOT )
    ENDIF
			
* Finally the receive Buffer has to be cleared again to
* be ready for the next transmission

    This.cReceiveBuffer = ''
   ENDIF
   RETURN
  ENDPROC

  PROCEDURE Close
   This.Object.Close()
  ENDPROC

ENDDEFINE

* --- AutoScrolling EditBox

DEFINE CLASS  bEditBox AS EditBox
  PROCEDURE refresh
   WITH This
     .SelStart = len(.text)
   ENDWITH
  ENDPROC
ENDDEFINE


... and now the client application ..


*-----------------| Location Section |--------------------
*) Procedure..: A simple TCP/IP client test form
*} Library....:
*} Class......:
*} Method.....:
*) Author........: Markus Voellmy
*) Company.......:
*) Description...: A client for TCP/IP. Uses Winsock OCX for communications.
*-------------------| Usage Section |---------------------
*$ Scope.........:
*$ Parameters....: tnPort - Numeric. The port number. If not supplied, 63333 is used.
*$                 tcRemoteHost - Character. The remote host address. If not supplied, "localhost" is used.
*$ Usage.........: Simple run it. Parameters are optional.
*$ Example.......: DO tcpclient WITH 63333, "localhost"
*$ Returns.......:
*-------------------| Various Info |----------------------
*@ Precondition Invariants.....:
*@ Post-condition Invariants...:
*----------------| Maintenance Section |------------------
*? To Do............:
*= Methods Called...:
** Process..........: This test client uses the Winsock OCX and stores the received data in a temporary
**                    buffer until the EndOfTransmission (EOT = CHR(4)) is received.
*^ Change Log.......:
*---------------------------------------------------------

LPARAMETERS tnPort, tcRemoteHost
#DEFINE EOT  CHR(4) && End of Transmission sign
CLEAR
IF VARTYPE(tnPort) # "N"
 tnPort = 63333
ENDIF
IF VARTYPE(tcRemoteHost) # "C"
 tcRemoteHost = "localhost"
ENDIF
oForm = CREATEOBJECT('frmTCPClient',tnPort,tcRemoteHost)
READ EVENTS
RELEASE oForm
RETURN

*) -- The form definition --

DEFINE CLASS frmTCPClient AS FORM
  nProtocol  = 0
  nPort	     = 0 
&& there a normal unusued port will be filled
  cRMHost    = ""
  AutoCenter = .T.
  Caption    = 'TCP-Client'
  nStat      = 0
  Width	     = 500
  lConnected = .F.  && Semaphore to signal the connection state

  PROCEDURE Load
   SYS(2333,0)
   _VFP.AutoYield = .F.
   RETURN
  ENDPROC

  PROCEDURE Unload
   _VFP.AutoYield = .T.
   RETURN
  ENDPROC

  PROCEDURE QueryUnload
   CLEAR EVENTS
   RETURN
  ENDPROC

  PROCEDURE Init
   LPARAMETERS tnPort, tcRemoteHost
   ThisForm.nPort   = tnPort
   ThisForm.cRMHost = tcRemoteHost
   This.AddObject('EditOut', 'bEditBox')
   WITH This.EditOut
    .Top      = 120
    .Left     = 10
    .Width    = This.Width-20
    .Height   = This.Height-(.Top+5)
    .Readonly = .t.
    .Value    = ''
    .Visible  = .T.
   ENDWITH
   This.AddObject('txtRMHost', 'rTextBox')
   WITH This.txtRMHost
    .Top      = 30
    .Left     = 10
    .Width    = 100
    .Enabled  = .T.
    .ControlSource = 'ThisForm.cRMHost'
    .Visible  = .t.
   ENDWITH
   This.AddObject('lblRemoteHost', 'label')
   WITH This.lblRemoteHost
    .Top      = 10
    .Left     = 10
    .Autosize = .T.
    .Caption  = 'RemoteHost'
    .Visible  = .T.
   ENDWITH
   This.AddObject('txtRemotePort', 'rTextBox')
   WITH This.txtRemotePort
    .Top      = 30
    .Left     = 130
    .Width    = 50
    .Enabled  = .T.
    .ControlSource = 'ThisForm.nPort'
    .Visible  = .T.
   ENDWITH
   This.AddObject('lblTCPPort', 'label')
   WITH This.lblTCPPort
    .Top      = 10
    .Left     = 130
    .AutoSize = .T.
    .Caption  = 'TCP-Port'
    .Visible  = .T.
   ENDWITH
   This.AddObject('cmdConnect', 'myConnCB')
   WITH This.cmdConnect
    .Top      = 30
    .Left     = 240
    .Height   = 24
    .Width    = 100
    .Visible  = .T.
   ENDWITH
   This.AddObject('cmdDisconnect', 'myDisconnCB')
   WITH this.cmdDisconnect
    .Top      = 30
    .Left     = 360
    .Height   = 24
    .Width    = 100
    .Visible  = .T.
   ENDWITH
   This.AddObject('txtInbox', 'r2TextBox')
   WITH This.txtInbox
    .Top      = 80
    .Left     = 10
    .Height   = 24
    .Width    = 370
    .Value    = "" && An empty string
    .Visible  = .T.
   ENDWITH
   This.AddObject('cmdSend', 'mySendCB')
   WITH This.cmdSend
    .Top     = 80
    .Left    = 390
    .Height  = 24
    .Width   = 100
    .Visible = .T.
   ENDWITH
   This.AddObject('oSock', 'frmSock' )
   This.AddObject('txtStat', 'TextBox')
   WITH This.txtStat
    .Top     = 30
    .Left    = 200
    .Width   = 20
    .Enabled = .F.
    .ControlSource = 'Thisform.oSock.State'
    .Visible = .T.
   ENDWITH

   This.Refresh()
   This.Visible = .T.
   RETURN
  ENDPROC
ENDDEFINE
* -------- WinSock ActiveX
DEFINE CLASS  frmSock AS OleControl
  OleClass = "MSWinsock.Winsock"
  cReceiveBuffer = ''					

  && a buffer to stitch incomming transmission together

  PROCEDURE Error
   LPARAMETERS Number, Description, Scode, Source, Helpfile, Helpcontext, Canceldisplay
* This method is used only for error diplaying purposes.
   WITH Thisform.EditOut
    .Value = .Value + CHR(13) + CHR(10) +;
    "Error ---- " + STR(Number) +'  - ' + Description + CHR(13) + CHR(10)
    .Refresh()
   EndWith
ENDPROC
  PROCEDURE Close

* This is necessary to really close the socket, without it you will end up
* in a timeout
   This.Object.Close()
  ENDPROC

  PROCEDURE Destroy
* It's used to close the socket if the user close the form
   This.Object.Close()
  ENDPROC

  PROCEDURE DataArrival
   LPARAMETERS tnByteCount
   LOCAL lcBuffer
   lcBuffer = SPACE(tnByteCount)

* This gets the data from the socket.  It happens, that the data
* isn't received in a single rush. Thus we use a EOT (end of transmission)
* sign to be sure, the data is complete. Until we get this, the data is stuffed
*  into cRecieveBuffer.

   This.GetData( @lcBuffer, , tnByteCount )
   IF AT( EOT, lcBuffer ) = 0  && CHR(4) not found, not yet finished
    This.cReceiveBuffer = This.cReceiveBuffer + lcBuffer
   ELSE
    This.cReceiveBuffer = This.cReceiveBuffer +  LEFT( lcBuffer, AT( EOT, lcBuffer ) -1 )
* Other than the server this only shows the results 
    With ThisForm.EditOut
     .Value = .Value+This.cReceiveBuffer+chr(13)+chr(10)
     ThisForm.refresh()
    Endwith

* Finally the receive Buffer has to be cleared again to
* be ready for the next transmission

    This.cReceiveBuffer = ''
   ENDIF
   RETURN
  ENDPROC
ENDDEFINE
* --- Send CommandButton
DEFINE CLASS  mySendCB AS CommandButton
  Caption = 'Send'

  PROCEDURE Refresh
   This.Enabled = ThisForm.lConnected
  ENDPROC
	
  PROCEDURE Click
   WITH ThisForm.oSock
    IF .state = 7	
&& No connection, no send
     .SendData(ALLTRIM(ThisForm.txtInbox.Value)+EOT)
    ELSE
     .Error( -1, 'Connection lost', , , , , .T. )
     .Close()
     ThisForm.lConnected = .F.
    ENDIF
   ENDWITH
   ThisForm.Refresh()
  ENDPROC
ENDDEFINE
* --- Connect CommandButton
DEFINE CLASS  myConnCB AS CommandButton
  Caption = 'Connect'

  PROCEDURE Refresh
   This.Enabled = Not ThisForm.lConnected
  ENDPROC
	
  PROCEDURE Click
   WITH ThisForm.oSock
   IF .state != 0  							

&& The connection isn't idle ... we simply close it
    .Object.Close()
   ENDIF
   .protocol = 0  && TCP
   .remoteHost = ALLTRIM(ThisForm.crmhost) 
&& RemoteHostname
   .remotePort = ThisForm.nPort	  
&& RemotePort
   .localPort = 0   && Takes any available LocalPort
   .Object.Connect()
   DO WHILE .Object.state < 7
    DOEVENTS	 && we must check for the State
    ThisForm.txtStat.Refresh() 
&& and show it on the form
    IF .state = 9
     EXIT
    ENDIF
   ENDDO
    IF .object.state = 7
     ThisForm.lConnected = .T.
    ELSE       && we Couldn't connect :-(
     ThisForm.lConnected = .F.
    ENDIF
   ENDWITH
   ThisForm.Refresh()
  ENDPROC
ENDDEFINE
* --- Disconnect CommandButton
DEFINE CLASS  myDisConnCB AS CommandButton
  Caption = 'Disconnect'

  PROCEDURE Refresh
   This.Enabled = ThisForm.lConnected
  ENDPROC
	
  PROCEDURE Click
   Thisform.oSock.Object.Close()
   DO WHILE Thisform.oSock.state > 0
    DOEVENTS
    ThisForm.txtStat.Refresh()
   ENDDO
   ThisForm.lConnected = .F.
   ThisForm.Refresh()
  ENDPROC
ENDDEFINE
* --- Controlled Texbox, reacts on disconnect
DEFINE CLASS  rTextBox AS TextBox
  PROCEDURE Refresh
   This.Enabled = NOT ThisForm.lConnected
  ENDPROC
ENDDEFINE
* --- Controlled Texbox, reacts on connect
DEFINE CLASS  r2TextBox AS TextBox
  PROCEDURE Refresh
   This.Enabled = ThisForm.lConnected
  ENDPROC
ENDDEFINE
* --- AutoScrolling EditBox
DEFINE CLASS  bEditBox AS EditBox
  PROCEDURE refresh
   WITH This
     .SelStart = len(.text)
   ENDWITH
  ENDPROC
ENDDEFINE

Contributors: Markus Voellmy
Has anyone had any success with an assign method on state for Mswinsock? Despite autoyield, mine doesn't seem to get called. I was hoping to update a textbox with the current state as it changes, but no luck. Is this a known limitation of activex controls?
Michael Wagner
Category Code Samples Category ActiveX
( Topic last updated: 2006.07.21 12:29:49 AM )