Wiki Home

VFP Port Listener


Namespace: Wiki
TCP Chat Server

This takes a different approach from Slighthaze's UDP Chat ( http://www.tek-tips.com/faqs.cfm?fid=3883 faq184-3883 on Tek Tips ForumsOffsite link to http://www.tek-tips.com
), which uses the asynchronous, connectionless UDP protocol.

This example, uses the connection-oriented, synchronous TCP protocol, and a client-server structure for the two chat 'participants'.

This concept can be extended, so that at the "chat" server is actually just a VFP program, rather than an actual person, as a server program for any purpose you can imagine:
The possibilities are as endless as the internet itself, since this is the basic structure for all server-oriented things happening on the internet.

The basic structure of this example are four classes in this hierarchy:

	Form
	 |
	 +-- frmChat -- Provides basic TCP interfaces to a Form
	 |    |
	 |    +--frmClient -- uses TCP to connect to a chat server
	 |    |
	 |    +--frmInstanceServer -- uses TCP to be connected to
	 |
	 +--frmServer -- Opens a socket waiting for connections.  When an incoming connection is
detected, this form launches a "frmInstanceServer" to handle the connecting-client. This leaves
this server's socket free to receive another client's connection.


Potentially, frmInstanceServer could be encapsulated in a multi-threaded DLL (of course, with no user interface... I'm not sure being based on the form class would work in this way or not...) and could be instantiated through COM by the frmServer to provide a Multi-Threaded server.

( For some reason, you must run the client in a different VFP instance than you run the server in... I haven't determined why this .PRG based example acts this way, because the original .VCX based code doesn't have this problem. )

Pardon me for jumping in here, but this seems like it could be very useful for a current project I'm trying to spec out. I need to do some "behind the scenes" messaging between 2 workstations (A & B) running VFP8 app designed for touchscreen navigation. Basically, a truck driver walks up to a touchscreen terminal with a signature capture device (workstation B) for signing that their load was dumped and that they have reviewed the QC information. They press a big button that says "Display Ticket for Signature" and a message gets sent (somehow) to another PC (workstation A) and a dialog is displayed that "Driver Waiting for Ticket". Workstation A brings up a the appropriate record and presses a button that says "Display Ticket for Driver Signature" and a message is sent back to workstation B causing a screen to appear and prompting for a signature. Workstation B touches a "Finished" button after they are finished signing. Screen goes back to first screen that prompts the next driver to display a ticket. A message is sent to Workstation A that signature is captured and ticket is ready for printing.
Now, I'm thinking that using this socket control would be ideal for this, but I'm not sure. Are there better ways to accomplish this with tables, timer objects, etc? (these 2 stations will be sharing a Foxpro database) Keep in mind that workstation A will be doing "other" data entry in the same application (entering weights, etc.) and we don't want their work to be interrupted, but they still need to get the "messages" from workstation B. Any thoughts, considerations, etc. would be appreciated -- Randy Jean

Randy, In VFP you could do this communication via tables. With a transaction type table that adds requests and another with a timer that looks for and responds to them. However, if you want to do this more at the system you might want to consider MSMQ and/or COMPlus Events. I know Marcus did an article on COMPlus Events in CODE a while ago. I think Randy Brown has an article on them too. -- Bob Archer

Tables work quite well, though if there's no UI interaction on A, then I would reccommend a loop (it'll be simpler to program, you can assume a process won't be interrupted. Something like:
DO WHILE llDontQuit
 SCAN FOR lNotHandled
  DoSomething()
 ENDSCAN
 InKey(.1)
ENDDO
-- Peter Crabtree

Randy - you could contact Andrew Coates who just did an eventhandler session at OzFox as he mentioned the example of binding to the com event that occurs when a file is written to a folder. You could simply shoot files from one machine to the other and your app would react to them. -- Jamie Osborn

On my PC, when I run tcpChat as a server, close it, and rerun it, FoxPro hangs on the Listen line, and sometimes crashes. This seems to happen with other WinSock listeners in the same way. Does anyone else have this problem? Rick Graves

* Program: tcpChat.PRG
*  Author: William GC Steinford
*
* Pass in a .T. if this is to be a listening server,
*  or pass in .F. if you want to instantiate a client
*
LPARAMETERS plServer

* DEFINE Constants could be extracted into a header file so they could
* be referred to by VCX classes. * Winsock Constants #DEFINE sckClosed 0 #DEFINE sckOpen 1 #DEFINE sckListening 2 #DEFINE sckConnectionPending 3 #DEFINE sckResolvingHost 4 #DEFINE sckHostResolved 5 #DEFINE sckConnecting 6 #DEFINE sckConnected 7 #DEFINE sckClosing 8 #DEFINE sckError 9 ******************************** #DEFINE crlf chr(13)+chr(10) ******************************** if plServer RELEASE oServer PUBLIC oServer oServer = CreateObject('frmServer') oServer.Show else RELEASE oClient PUBLIC oClient oClient = CreateObject('frmClient') oClient.Show endif READ EVENTS RETURN * End of main code **************************************************************** * DEFINES's could be extracted into a header file like this: *#INCLUDE "c:\source\chat\ex\chatexample.h" DEFINE CLASS frmchat AS form Top = 0 Left = 0 Height = 382 Width = 449 DoCreate = .T. Caption = "Chat Client" datatosend = ('') server = '127.0.0.1' serverport = 8181 username = ('') incomingdata = ('') enableonerror = .F. Name = "frmchat" incomingcommand = .F. ADD OBJECT sock AS WSControl ADD OBJECT tmrstate AS timer WITH ; Top = 13, ; Left = 42, ; Height = 23, ; Width = 23, ; Enabled = .T., ; Interval = 50, ; Name = "tmrState" ADD OBJECT lblstate AS label WITH ; AutoSize = .T., ; Caption = "State", ; Height = 17, ; Left = 75, ; Top = 10, ; Width = 30, ; Name = "lblState" ADD OBJECT lblsnd AS label WITH ; AutoSize = .T., ; FontBold = .T., ; Caption = ". . . .", ; Height = 17, ; Left = 3, ; Top = 3, ; Width = 23, ; Name = "lblSnd" ADD OBJECT lblrcv AS label WITH ; AutoSize = .T., ; FontBold = .T., ; Caption = ". . . .", ; Height = 17, ; Left = 3, ; Top = 21, ; Width = 23, ; Name = "lblRcv" PROCEDURE senddata LPARAMETERS pcData EXTERNAL ARRAY pcData LOCAL lcOutData, lcSendingData, lcDataToSend lcOutData = '' do case case type('pcData[1]')!='U' && it is an array lnR = ALEN(pcData,1) && Rows lnC = ALEN(pcData,2) && Cols, 0 if one dimension lcOutData = "ARRAY ROWS="+tran( max(lnR,1) )+"&COLS="+tran( max(lnC,1) )+"&DATA=" if lnC=0 for lnI = 1 to lnR lcOutData = lcOutData+THISFORM.URLEncode(tran(pcData[lnI]))+"," endfor else for lnI = 1 to lnR lcOutData = lcOutData+"(" for lnJ = 1 to lnC lcOutData = lcOutData+THISFORM.URLEncode(tran(pcData[lnI,lnJ]))+"," endfor lcOutData = lcOutData+")," endfor endif if Right(lcOutData,1)=',' lcOutData = left( lcOutData, Len(lcOutData)-1 ) endif case type('pcData')='C' lcOutData = pcData case inlist(VARTYPE(pcData),'D','T','N','L') lcOutData = tran(pcData) otherwise lcOutData = 'ERROR BAD%20DATA' endcase if right(lcOutData,2)!=chr(13)+chr(10) lcOutData = lcOutData+chr(13)+chr(10) endif if THISFORM.sock.State=sckConnected lcSendingData = lcOutData DO WHILE Len(lcSendingData)>0 if len(lcSendingData)>1024 lcDataToSend = LEFT(lcSendingData,1024) lcSendingData = Substr(lcSendingData,1025) else lcDataToSend = lcSendingData lcSendingData = '' endif THISFORM.Sending() THISFORM.Sock.object.SendData( (lcDataToSend) ) && CANNOT be passed by Reference!! * StrToFile( 'SENT ['+lcDataToSend+']'+chr(10)+chr(13), 'CHAT.TXT', .T. ) ENDDO else THISFORM.AddHistory('Not Connected! State='+tran(THISFORM.sock.State)) endif ENDPROC PROCEDURE sendmessage LPARAMETERS pcMsg if type('pcMsg')='C' THISFORM.AddHistory("Sending Message: "+pcMsg) THISFORM.SendData('CHAT '+THISFORM.UrlEncode(pcMsg)) endif ENDPROC PROCEDURE connected THISFORM.AddHistory("Connected at "+tran(datetime())) ENDPROC PROCEDURE addhistory LPARAMETERS pcMsg ENDPROC PROCEDURE handlecommand LPARAMETER pcCommand pcCommand = strTran(pcCommand,CRLF,' ') * Command descriptor is followed by a space, * then, if applicable, by a URL encoded string of parameters * (just like a form submission) * Finally, a CrLf ends the command. LOCAL lcVal,lcResp,laArr[1],lnCnt,lnI * THISFORM.AddHistory( pcCommand ) do case case pcCommand='OK ' or pcCommand=='OK' * Nothing necessary case pcCommand='CHAT ' lcVal = THISFORM.URLUnEncode( SubStr(pcCommand,6) ) THISFORM.AddHistory('CHAT '+lcVal) THISFORM.SendData('OK') case pcCommand='ERROR ' THISFORM.AddHistory(pcCommand) case pcCommand='PING ' or pcCommand=='PING' THISFORM.SendData('PONG') THISFORM.AddHistory('PING requested. PONG sent.') case pcCommand='PONG ' or pcCommand=='PONG' THISFORM.AddHistory('PONG received.') THISFORM.SendData('OK') case pcCommand='BYE ' or pcCommand=='BYE' THISFORM.AddHistory('Other side said "BYE"') THISFORM.SendData('OK') THISFORM.Close OTHERWISE THISFORM.SendData('ERROR Unrecognized Command ('+alltrim(pcCommand)+')') endcase ENDPROC PROCEDURE handledata LPARAM pcData LOCAL lcCommands, lnCmds, lnI, laCmds[1] * If HandleData gets called again before this one ends, the new command * might execute before all the commands this is processing (particularly * if some of *these* commands take a long time) * We really Should Queue the commands, and let a separate process run them, * maybe a process on a timer (not one command per tick, but check at each * tick for commands, and process all commands till empty) * THISFORM.AddHistory("Data Received: "+alltrim(pcData)) * StrToFile( 'RCV ['+pcData+']'+chr(10)+chr(13), 'CHAT.TXT', .T. ) THISFORM.IncomingData = THISFORM.IncomingData + pcData THISFORM.Receiving() if chr(13)+chr(10) $ THISFORM.IncomingData && Complete Line + lcCommands = THISFORM.IncomingData * Clear all complete lines: THISFORM.IncomingData = iif( right(THISFORM.IncomingData,2)=chr(13)+chr(10), ; '', Substr( THISFORM.IncomingData, RAT(chr(13)+chr(10),THISFORM.IncomingData)+2 ) ) * Take only complete lines: lcCommands = iif( right(lcCommands,2)=chr(13)+chr(10), ; lcCommands, LEFT( lcCommands, RAT(chr(13)+chr(10),THISFORM.IncomingData)-1 ) ) lnCmds = ALINES(laCmds,lcCommands) for lnI = 1 to lnCmds THISFORM.IncomingCommand = laCmds[lnI] if not empty(laCmds[lnI]) THISFORM.HandleCommand(laCmds[lnI]) endif endfor endif ENDPROC PROCEDURE setstate THISFORM.lblState.caption = tran(THISFORM.sock.state) do case case THISFORM.sock.state=sckClosed THISFORM.lblState.caption = THISFORM.lblState.caption+' Closed' case THISFORM.sock.state=sckOpen THISFORM.lblState.caption = THISFORM.lblState.caption+' Open' case THISFORM.sock.state=sckListening THISFORM.lblState.caption = THISFORM.lblState.caption+' Listening' case THISFORM.sock.state=sckConnectionPending THISFORM.lblState.caption = THISFORM.lblState.caption+' Connection Pending...' case THISFORM.sock.state=sckResolvingHost THISFORM.lblState.caption = THISFORM.lblState.caption+' Resolving Host...' case THISFORM.sock.state=sckHostResolved THISFORM.lblState.caption = THISFORM.lblState.caption+' Host Resolved' case THISFORM.sock.state=sckConnecting THISFORM.lblState.caption = THISFORM.lblState.caption+' Connecting...' case THISFORM.sock.state=sckConnected THISFORM.lblState.caption = THISFORM.lblState.caption+' Connected' case THISFORM.sock.state=sckClosing THISFORM.lblState.caption = THISFORM.lblState.caption+' Closing...' case THISFORM.sock.state=sckError THISFORM.lblState.caption = THISFORM.lblState.caption+' Error' endcase ENDPROC PROCEDURE close THISFORM.Sock.object.Close ENDPROC PROCEDURE sending if len(THISFORM.lblSnd.caption)>16 THISFORM.lblSnd.caption = '.' else THISFORM.lblSnd.caption = THISFORM.lblSnd.caption + ' .' endif THISFORM.FastDoEvents ENDPROC PROCEDURE receiving if len(THISFORM.lblRcv.caption)>16 THISFORM.lblRcv.caption = '.' else THISFORM.lblRcv.caption = THISFORM.lblRcv.caption + ' .' endif THISFORM.FastDoEvents ENDPROC PROCEDURE fastdoevents DOEVENTS RETURN local lnRow, lnCol, lcWindow lcWindow = wontop() lnRow = mrow( lcWindow ) lnCol = mcol( lcWindow ) if ( lnRow > 0 ) and ( lnCol > 0 ) * mouse still within VFP window, so it's ok to mouse mouse at mrow(), mcol() window (lcWindow) else keyboard " " =inkey() endif DoEvents ENDPROC PROCEDURE sendfile LPARAMETERS pcFile LOCAL lcCont, lcRes if File(pcFile) lcCont = FileToStr( pcFile ) lcRes = 'FILE name='+THISFORM.UrlEncode(JustFName(pcFile))+'&' ; +'compressed=No&' ; +'size='+Tran(len(lcCont))+'&' ; +'content='+THISFORM.URLEncode( lcCont ) THISFORM.SendData(lcRes) RETURN .T. endif RETURN .F. ENDPROC PROCEDURE parsedata LPARAMETERS pcData * pcData is a form-encoded string, * in the form "name=value&name2=value2" * where each piece of the string has been URL encoded. * The return value should be a collection object LOCAL laLines[1], lnLines, loRet loRet = CREATEOBJECT( "aasCollection" ) lnLines = ALINES(laLines,StrTran(pcData,'&',chr(13))) for lnI = 1 to lnLines lnAt = AT('=',laLines[lnI]) if lnAt>0 lcNm = left( laLines[lnI], lnAt-1 ) lcVl = SUBSTR( laLines[lnI], lnAt+1 ) lcNm = THISFORM.URLUnEncode( lcNm ) lcVl = THISFORM.URLUnEncode( lcVl ) loRet.Add( lcVl, lcNm ) endif endfor RETURN loRet ENDPROC PROCEDURE receivefile LPARAMETERS pcCommand LOCAL lcData, loData, lcNm, lcCmp, llCmp, lnSize, lcCont lcFileName = '' lcData = SUBSTR(pcCommand,6) loData = THISFORM.ParseData( lcData ) lcNm = iif( loData.indexOf('name')>0, loData.Items['name'], 'Unknown' ) lcNm = set('defa')+curdir()+JustFName(lcNm) && make sure no path info is provided lcCmp = iif( loData.indexOf('compressed')>0, loData.Items['compressed'], 'No' ) llCmp = iif( upper(lcCmp)='Y', .T., .f. ) lnSize = val( iif( loData.indexOf('size')>0, loData.Items['size'], '0' ) ) lcCont = iif( loData.indexOf('content')>0, loData.Items['content'], '' ) THISFORM.AddHistory('File Name='+lcNm+' Size='+tran(lnSize)+' '+iif(llCmp,'Compressed','Not Compressed') ) DO WHILE .T. if lnSize = 0 or empty(lcCont) THISFORM.SendData('ERROR Missing Descriptors') EXIT endif if lnSize!=Len(lcCont) THISFORM.SendData('ERROR Incorrect Size of Data (reported '+tran(lnSize)+'; actual '+tran(Len(lcCont))+')') EXIT endif if llCmp lcCont = '' && TODO..Add compression/decompression if empty(lcCont) THISFORM.SendData('ERROR Corrupted Compressed Data') EXIT endif endif if File( lcNm ) if NOT THISFORM.SafeDel(lcNm) THISFORM.SendData('ERROR Could not overwrite local file') EXIT endif endif STRTOFILE(lcCont,lcNm) if file(lcNm) THISFORM.SendData('OK') lcFileName = lcNm else THISFORM.SendData('ERROR Could not create local file') endif EXIT enddo RETURN lcFileName ENDPROC PROCEDURE getarray * THISFORM.GetArray( @laData, pcCommand ) LPARAMETERS paData, pcCommand * Format for pcCommand: * ARRAY ROWS=##&COLS=##&DATA=(1,2,3),(1,2,3),(1,2,3) LOCAL laDt[3], lcDT, lnI, laCols[1], lnRw, lnCl ALINES( laDt, strtran(substr(pcCommand,7),'&',chr(13) ) ) lnRows = val( Substr(laDt[1],6 ) ) lnCols = val( Substr(laDt[2],6 ) ) lcDt = Substr( laDt[3], 6 ) paData = '' IF lnRows>0 and lnCols>0 DIMENSION paData[lnRows,lnCols] paData = '' lcDt = strtran( lcDt, '),(', chr(13) ) lcDt = chrtran( lcDt, ')(', '' ) && delete start/end () lnRw = ALINES(laDT, lcDt ) for lnI = 1 to Min( lnRw, lnRows ) lnCl = ALINES( laCols, StrTran( laDt[lnI], ',', chr(13) ) ) for lnJ = 1 to Min( lnCl, lnCols ) paData[lnI, lnJ] = THISFORM.UrlUnencode( laCols[lnJ] ) endfor endfor RETURN .T. ENDIF RETURN .F. ENDPROC PROCEDURE Load _VFP.AutoYield = .F. ENDPROC PROCEDURE Error LPARAMETERS nError, cMethod, nLine THISFORM.AddHistory("Internal ERROR #"+tran(nError)+" Msg:"+Message()+" Method:"+tran(cMethod)+" Line:"+tran(nLine)) if THISFORM.EnableOnError err=ON("ERROR") &Err endif ENDPROC PROCEDURE Unload DODEFAULT() ENDPROC PROCEDURE sock.DataArrival *** ActiveX Control Event *** LPARAMETERS bytestotal LOCAL lcData lcData = space(bytesTotal) THIS.GetData(@lcData) THISFORM.HandleData(lcData) ENDPROC PROCEDURE sock.Connect *** ActiveX Control Event *** THISFORM.Connected ENDPROC PROCEDURE sock.Close *** ActiveX Control Event *** THIS.Object.Close ENDPROC PROCEDURE sock.Error LPARAMETERS nError, description, scode, source, helpfile, helpcontext, canceldisplay *** ActiveX Control Event *** THISFORM.AddHistory("Socket ERROR #"+tran(nError)+": "+description+" sCode:"+tran(sCode)) THIS.Object.Close ENDPROC PROCEDURE tmrstate.Timer THISFORM.SetState ENDPROC PROCEDURE lblstate.MouseMove LPARAMETERS nButton, nShift, nXCoord, nYCoord THISFORM.SetState ENDPROC PROCEDURE lblsnd.MouseMove LPARAMETERS nButton, nShift, nXCoord, nYCoord THISFORM.SetState ENDPROC PROCEDURE lblrcv.MouseMove LPARAMETERS nButton, nShift, nXCoord, nYCoord THISFORM.SetState ENDPROC *********************************************************** Function URLunencode PARAMETER pcInStr * ' unencode EVERY %XX * ' (keep track of current position so you don't unencode * ' a percent that just came out of an URLencoded char LOCAL I, tStr, tChr, tOut tStr = pcInStr tOut = "" tStr = StrTran(tStr, "+", " ") I = 1 do While I <= Len(tStr) If (SubStr(tStr, I, 1) = "%") ; And SubStr(tStr, I + 1, 1) $ "0123456789ABCDEF" ; And SubStr(tStr, I + 2, 1) $ "0123456789ABCDEF" tChr = (( At( SubStr(tStr, I + 1, 1), "0123456789ABCDEF" )-1) * 16 ) ; + (( At( SubStr(tStr, I + 2, 1), "0123456789ABCDEF" )-1) ) I = I + 2 *03/18/03 Zero's are now allowed. if between(tChr,0,255) && 03/18/03 * if tChr > 0 and tChr < 255 tOut = tOut + chr( tChr ) endif else tOut = tOut + SubStr(tStr, I, 1) EndIf I = I + 1 EndDo RETURN tOut ********************************************************** Function URLencode PARAMETER pcInStr * ' encode Percent signs * ' Double Quotes * ' CarriageReturn / LineFeeds * Thanks to Michael's contribution on Fox.Wikis.com, * this now encodes everything except the characters * that are specifically allowed by http://www.ietf.org/rfc/rfc2396.txt LOCAL lcOut, lnI lcOut = '' for lnI = 1 to len(pcInStr) lcCh = Substr(pcInStr,lnI,1) DO CASE CASE ISALPHA(lcCh) ; OR ISDIGIT(lcCh) ; OR INLIST(lcCh, "-" , "_" , "." , "!" , "~" , "*" , "'" , "(" , ")") * do nothing CASE lcch = " " lcCh = "+" OTHERWISE lcCh = '%' + RIGHT( TRANSFORM(ASC(lcCh),'@0'), 2 ) ENDCASE lcOut = lcOut + lcCh endfor RETURN lcOut ENDFUNC *********************************************************** * SafeDel - Returns .T. if the file was deleted successfully * (DeleteFile returns 0 if there is an error) FUNCTION SafeDel LPARAMETERS pcFile DECLARE INTEGER DeleteFile IN kernel32 ; STRING lpFileName res = DeleteFile(pcFile) RETURN res!=0 ENDFUNC ENDDEFINE * *-- EndDefine: frmchat ************************************************** ************************************************** *-- Class: frmclient (c:\source\chat\ex\chatexample.vcx) *-- ParentClass: frmchat (c:\source\chat\ex\chatexample.vcx) *-- BaseClass: form *-- Time Stamp: 05/23/03 01:59:10 PM * * DEFINES's could be extracted into a header file like this: *#INCLUDE "c:\source\chat\ex\chatexample.h" * DEFINE CLASS frmclient AS frmchat Top = 0 Left = 0 Height = 411 Width = 449 ShowWindow = 0 DoCreate = .T. Caption = "Chat Client" WindowType = 0 localalias = ('') datatosend = ('') server = '127.0.0.1' serverport = 8181 username = ('') incomingdata = ('') enableonerror = .F. Name = "frmclient" Sock.Top = 10 Sock.Left = 10 Sock.Height = 100 Sock.Width = 100 Sock.Name = "Sock" tmrState.Name = "tmrState" lblState.TabIndex = 17 lblState.Name = "lblState" lblSnd.TabIndex = 18 lblSnd.Name = "lblSnd" lblRcv.TabIndex = 19 lblRcv.Name = "lblRcv" ADD OBJECT timer1 AS timer WITH ; Top = 13, ; Left = 42, ; Height = 23, ; Width = 23, ; Enabled = .F., ; Interval = 50, ; Name = "Timer1" ADD OBJECT label1 AS label WITH ; AutoSize = .T., ; Caption = "User Name", ; Height = 17, ; Left = 16, ; Top = 50, ; Width = 66, ; TabIndex = 1, ; Name = "Label1" ADD OBJECT text1 AS textbox WITH ; ControlSource = "THISFORM.UserName", ; Height = 23, ; Left = 90, ; TabIndex = 2, ; Top = 50, ; Width = 290, ; Name = "Text1" ADD OBJECT label2 AS label WITH ; AutoSize = .T., ; Caption = "Server", ; Height = 17, ; Left = 41, ; Top = 82, ; Width = 37, ; TabIndex = 3, ; Name = "Label2" ADD OBJECT text3 AS textbox WITH ; ControlSource = "THISFORM.ServerPort", ; Height = 23, ; Left = 302, ; TabIndex = 6, ; Top = 79, ; Width = 80, ; Name = "Text3" ADD OBJECT label3 AS label WITH ; AutoSize = .T., ; Caption = "Port", ; Height = 17, ; Left = 270, ; Top = 82, ; Width = 24, ; TabIndex = 5, ; Name = "Label3" ADD OBJECT combo1 AS combobox WITH ; RowSourceType = 1, ; RowSource = "127.0.0.1", ; ControlSource = "THISFORM.Server", ; Height = 24, ; Left = 89, ; TabIndex = 4, ; Top = 79, ; Width = 151, ; Name = "Combo1" ADD OBJECT list AS listbox WITH ; Height = 160, ; Left = 10, ; TabIndex = 13, ; Top = 239, ; Width = 340, ; ItemTips = .T., ; Name = "List" ADD OBJECT command3 AS commandbutton WITH ; Top = 359, ; Left = 370, ; Height = 23, ; Width = 59, ; Caption = "Close", ; TabIndex = 15, ; Name = "Command3" ADD OBJECT cmdsend AS commandbutton WITH ; Top = 139, ; Left = 380, ; Height = 23, ; Width = 59, ; Caption = "Send", ; TabIndex = 10, ; Name = "cmdSend" ADD OBJECT edit1 AS editbox WITH ; Height = 60, ; Left = 10, ; SelectOnEntry = .T., ; TabIndex = 9, ; Top = 139, ; Width = 361, ; ControlSource = "THISFORM.DataToSend", ; Name = "Edit1" ADD OBJECT label4 AS label WITH ; AutoSize = .T., ; Caption = "Enter a message to send to Tech Support", ; Height = 17, ; Left = 10, ; Top = 119, ; Width = 230, ; TabIndex = 8, ; Name = "Label4" ADD OBJECT label5 AS label WITH ; AutoSize = .T., ; Caption = "History", ; Height = 17, ; Left = 10, ; Top = 219, ; Width = 40, ; TabIndex = 12, ; Name = "Label5" ADD OBJECT command2 AS commandbutton WITH ; Top = 319, ; Left = 370, ; Height = 23, ; Width = 59, ; Caption = "Ping", ; TabIndex = 14, ; Name = "Command2" ADD OBJECT command4 AS commandbutton WITH ; Top = 179, ; Left = 380, ; Height = 40, ; Width = 59, ; FontSize = 8, ; WordWrap = .T., ; Caption = "Send Command", ; TabIndex = 11, ; Name = "Command4" ADD OBJECT cmdconnect AS commandbutton WITH ; Top = 60, ; Left = 390, ; Height = 40, ; Width = 59, ; FontSize = 8, ; WordWrap = .T., ; Caption = "Connect", ; TabIndex = 7, ; Name = "cmdConnect" PROCEDURE connect if THISFORM.Sock.state!=sckClosed THISFORM.Sock.Object.Close endif THISFORM.Sock.RemoteHost = THISFORM.Server THISFORM.Sock.RemotePort = THISFORM.ServerPort THISFORM.Sock.object.Connect ENDPROC PROCEDURE setstate DODEFAULT() IF not THISFORM.LocalAlias==alias() THISFORM.LocalAlias = Alias() THISFORM.SendData("ALIAS "+alias()) ENDIF ENDPROC PROCEDURE Unload DODEFAULT() CLEAR EVENTS ENDPROC PROCEDURE Init THISFORM.left = sysmetric(1) - ( THISFORM.width + 8 ) DODEFAULT() ENDPROC PROCEDURE handlecommand LPARAMETER pcCommand pcCommand = strTran(pcCommand,CRLF,' ') * Command descriptor is followed by a space, * then, if applicable, by a URL encoded string of parameters * (just like a form submission) * Finally, a CrLf ends the command. LOCAL lcVal,lcResp,laArr[1],lnCnt,lnI,laArr2[1] * THISFORM.AddHistory( 'C: Got Command: '+pcCommand ) do case case pcCommand='DIR ' lcVal = THISFORM.URLUnEncode( SubStr(pcCommand,5) ) lcVal = ChrTran(lcVal, '"', '' ) if not empty(lcVal) lnCnt = aDir(laArr,lcVal,'DHS') else lnCnt = aDir(laArr,SET('DEFA')+curDir(),'DHS') endif THISFORM.SendData(@laArr) case pcCommand='CD ' lcVal = THISFORM.URLUnEncode( SubStr(pcCommand,4) ) lcVal = ChrTran(lcVal, '"', '' ) Err = 'OK' if not empty(lcVal) THISFORM.EnableOnError=.T. oErr = ON('ERROR') ON ERROR ERR='ERROR:'+tran(ERROR())+':'+Message() SET DEFAULT TO (lcVal) ON ERROR &oErr THISFORM.EnableOnError=.F. endif if ERR="ERROR" THISFORM.SendData(Err) else THISFORM.SendData('PATH '+Set('DEFA')+CurDir()) endif case pcCommand='CMD ' lcVal = THISFORM.URLUnEncode( SubStr(pcCommand,5) ) Err = 'OK' if not empty(lcVal) THISFORM.EnableOnError=.T. oErr = ON('ERROR') ON ERROR ERR='ERROR:'+tran(ERROR())+':'+Message() &lcVal ON ERROR &oErr THISFORM.EnableOnError=.F. endif THISFORM.SendData(Err) case pcCommand='USE ' lcVal = THISFORM.URLUnEncode( SubStr(pcCommand,5) ) Err = 'OK' if not empty(lcVal) THISFORM.EnableOnError=.T. oErr = ON('ERROR') ON ERROR ERR='ERROR:'+tran(ERROR())+':'+Message() USE &lcVal ON ERROR &oErr THISFORM.EnableOnError=.F. endif THISFORM.SendData(Err) case pcCommand='FUNC ' lcVal = THISFORM.URLUnEncode( SubStr(pcCommand,6) ) llIsArr = (Type(lcVal)!='U' and type(lcVal+'[1]')!='U') Err = 'OK' lcRes = '' if not empty(lcVal) and not llIsArr THISFORM.EnableOnError=.T. oErr = ON('ERROR') ON ERROR ERR='ERROR '+tran(ERROR())+': '+Message() lcRes = &lcVal ON ERROR &oErr THISFORM.EnableOnError=.F. endif do case case ERR='OK' and llIsArr THISFORM.SendData(@&lcVal) && Translate array case ERR='OK' THISFORM.SendData('RESULT '+Tran(lcRes)) otherwise THISFORM.SendData(Err) endcase case pcCommand='GET ' lcVal = THISFORM.URLUnEncode( alltrim(SubStr(pcCommand,5)) ) lcPath = JustPath(lcVal) if empty(lcPath) lcPath = Set('Defa')+curdir() lcVal = lcPath+lcVal endif lcPath = addbs(lcPath) lnCnt = adir(laArr,lcVal,'HS') && find all matching files if lnCnt = 0 THISFORM.AddHistory('no files found matching '+lcVal) endif for lnI = 1 to lnCnt THISFORM.AddHistory('Sending File '+lcPath+laArr[1]) THISFORM.SendFile(lcPath+laArr[1]) THISFORM.AddHistory('Done.') endfor case pcCommand='FILE ' * data items: Name (no path allowed) * Compressed: Y/N * Size: (of uuencoded data) Before Uncompressing. * Content: the actual file. THISFORM.AddHistory('Incoming File!') THISFORM.ReceiveFile(pcCommand) case pcCommand='SCATTER ' or pcCommand=='SCATTER' if not empty(alias()) SCATTER TO laArr lnCnt = Min( aLen(laArr,1), FCOUNT() ) if lnCnt > 0 DIMENSION laArr2[ lnCnt, 2 ] for lnI = 1 to lnCnt laArr2[lnI,1] = Field(lnI) laArr2[lnI,2] = laArr[lnI] endfor THISFORM.SendData( @laArr2 ) endif endif *!* CASE pcCommand='PRTSCR ' or pcCommand=='PRTSCR' *!* THISFORM.AddHistory('Sending Screenshot...') OTHERWISE DODEFAULT(pcCommand) endcase ENDPROC PROCEDURE addhistory LPARAMETERS pcMsg THISFORM.List.AddItem(pcMsg) THISFORM.List.ListIndex = THISFORM.List.ListCount ENDPROC PROCEDURE connected THISFORM.AddHistory("Connected at "+tran(datetime())) THISFORM.SendData('USER '+THISFORM.UserName) THISFORM.SendData('USERIP '+THISFORM.sock.LocalIP) THISFORM.SendData('PATH '+Set("DEFA")+CurDir()) ENDPROC PROCEDURE timer1.Timer THISFORM.SetState ENDPROC PROCEDURE combo1.LostFocus if empty(THISFORM.Server) and not empty(THIS.DisplayValue) THIS.RowSource = alltrim(ThiS.RowSource)+','+alltrim(THIS.DisplayValue) THISFORM.Server = THIS.DisplayValue endif ENDPROC PROCEDURE command3.Click THISFORM.SendData('BYE') THISFORM.Close ENDPROC PROCEDURE cmdsend.Click THISFORM.SendMessage( THISFORM.DataToSend ) ENDPROC PROCEDURE edit1.KeyPress LPARAMETERS nKeyCode, nShiftAltCtrl if nKeyCode=13 THIS.Parent.cmdSend.SetFocus THISFORM.SendMessage NODEFAULT THIS.SetFocus endif ENDPROC PROCEDURE command2.Click THISFORM.SendData('PING') ENDPROC PROCEDURE command4.Click THISFORM.SendData(THISFORM.DataToSend) ENDPROC PROCEDURE cmdconnect.Click THISFORM.Connect ENDPROC ENDDEFINE * *-- EndDefine: frmclient ************************************************** ************************************************** *-- Class: frminstanceserver (c:\source\chat\ex\chatexample.vcx) *-- ParentClass: frmchat (c:\source\chat\ex\chatexample.vcx) *-- BaseClass: form *-- Time Stamp: 05/23/03 01:55:04 PM * * DEFINES's could be extracted into a header file like this: *#INCLUDE "c:\source\chat\ex\chatexample.h" * DEFINE CLASS frminstanceserver AS frmchat Top = 0 Left = 0 Height = 418 Width = 549 ShowWindow = 0 DoCreate = .T. Caption = "Instance Server" WindowType = 0 csessioninfo = ('') remoteuser = ('') remoteip = ('') connecttime = {} chatmsg = ('') cmd = ('') remotepath = ('') result = ('') now = {} lcmd = ('') vfpcmd = ('') totcmds = 1 thiscmd = 1 remotealias = ('') incomingcommand = ('') incomingdata = ('') Name = "frminstanceserver" Sock.Top = 10 Sock.Left = 10 Sock.Height = 100 Sock.Width = 100 Sock.ZOrderSet = 1 Sock.Name = "Sock" tmrState.Interval = 200 tmrState.Name = "tmrState" lblState.Left = 2 lblState.Top = 56 lblState.TabIndex = 17 lblState.ZOrderSet = 19 lblState.Name = "lblState" lblSnd.Left = 3 lblSnd.Top = 62 lblSnd.TabIndex = 18 lblSnd.ZOrderSet = 3 lblSnd.Name = "lblSnd" lblRcv.Left = 3 lblRcv.Top = 70 lblRcv.TabIndex = 19 lblRcv.ZOrderSet = 0 lblRcv.Name = "lblRcv" DIMENSION acmds[100] ADD OBJECT list AS listbox WITH ; Height = 119, ; Left = 0, ; TabIndex = 16, ; Top = 111, ; Width = 542, ; ZOrderSet = 4, ; ItemTips = .T., ; Name = "List" ADD OBJECT edtchat AS editbox WITH ; Comment = "", ; Height = 27, ; Left = 0, ; SelectOnEntry = .T., ; TabIndex = 1, ; Top = 240, ; Width = 437, ; ZOrderSet = 5, ; ControlSource = "THISFORM.ChatMsg", ; Name = "edtChat" ADD OBJECT edtcmd AS editbox WITH ; Height = 41, ; Left = 0, ; SelectOnEntry = .T., ; TabIndex = 4, ; Top = 288, ; Width = 437, ; ZOrderSet = 6, ; ControlSource = "THISFORM.Cmd", ; Name = "edtCMD" ADD OBJECT cmdsendchat AS commandbutton WITH ; Top = 240, ; Left = 449, ; Height = 27, ; Width = 84, ; Caption = "Send Chat", ; TabIndex = 2, ; ZOrderSet = 7, ; Name = "cmdSendChat" ADD OBJECT cmdsendcmd AS commandbutton WITH ; Top = 295, ; Left = 449, ; Height = 27, ; Width = 84, ; Caption = "Send Cmd", ; TabIndex = 5, ; ZOrderSet = 8, ; Name = "cmdSendCmd" ADD OBJECT label1 AS label WITH ; AutoSize = .T., ; Caption = "History", ; Height = 17, ; Left = 4, ; Top = 91, ; Width = 40, ; TabIndex = 15, ; ZOrderSet = 9, ; Name = "Label1" ADD OBJECT sessioninfo AS editbox WITH ; FontSize = 7, ; BorderStyle = 1, ; Height = 102, ; Left = 340, ; TabIndex = 14, ; Top = 7, ; Width = 200, ; BackColor = RGB(192,192,192), ; ZOrderSet = 10, ; ControlSource = "THISFORM.cSessionInfo", ; Name = "SessionInfo" ADD OBJECT lblsessioninfo AS label WITH ; AutoSize = .T., ; Caption = "Session Info", ; Height = 17, ; Left = 346, ; Top = -3, ; Width = 71, ; TabIndex = 13, ; ZOrderSet = 11, ; Name = "lblSessionInfo" ADD OBJECT command3 AS commandbutton WITH ; Top = 26, ; Left = 0, ; Height = 28, ; Width = 49, ; Caption = "Close", ; TabIndex = 10, ; ZOrderSet = 12, ; Name = "Command3" ADD OBJECT label3 AS label WITH ; AutoSize = .T., ; FontSize = 8, ; FontCondense = .T., ; Caption = "DIR, CD, LCD, CMD, FUNC, ?, CHAT, PING, GET, PUT, USE, SCATTER, SELECT, PUBLIC,", ; Height = 16, ; Left = 10, ; Top = 272, ; Width = 418, ; TabIndex = 3, ; ZOrderSet = 14, ; Name = "Label3" ADD OBJECT chat AS listbox WITH ; Height = 110, ; Left = 60, ; TabIndex = 11, ; Top = 0, ; Width = 270, ; ZOrderSet = 15, ; ItemTips = .T., ; Name = "Chat" ADD OBJECT lblchatlog AS label WITH ; AutoSize = .T., ; Caption = "Chat Log", ; Height = 17, ; Left = 4, ; Top = 5, ; Width = 52, ; TabIndex = 20, ; ZOrderSet = 16, ; Name = "lblChatLog" ADD OBJECT edtlcmd AS editbox WITH ; Height = 27, ; Left = 0, ; SelectOnEntry = .T., ; TabIndex = 8, ; Top = 385, ; Width = 437, ; ZOrderSet = 17, ; ControlSource = "THISFORM.lCmd", ; Name = "edtLCMD" ADD OBJECT edtvfpcmd AS editbox WITH ; Height = 27, ; Left = 0, ; SelectOnEntry = .T., ; TabIndex = 6, ; Top = 340, ; Width = 437, ; ZOrderSet = 17, ; ControlSource = "THISFORM.VfpCmd", ; Name = "edtVfpCmd" ADD OBJECT cmdsendvfpcmd AS commandbutton WITH ; Top = 340, ; Left = 449, ; Height = 27, ; Width = 84, ; Caption = "Send VFP", ; TabIndex = 7, ; ZOrderSet = 18, ; Name = "cmdSendVfpCmd" ADD OBJECT cmdlocalcmd AS commandbutton WITH ; Top = 385, ; Left = 449, ; Height = 27, ; Width = 84, ; Caption = "Local VFP", ; TabIndex = 9, ; ZOrderSet = 18, ; Name = "cmdLocalCmd" PROCEDURE refreshinfo LOCAL lcCnct lcCnct ='' if THISFORM.Sock.State=sckConnected THISFORM.Now = DateTime() else lcCnct = "Disconnected!" endif THISFORM.cSessionInfo = ; +'Session Started '+tran(THISFORM.ConnectTime)+crlf; +'Remote User: '+THISFORM.RemoteUser+crlf; +'Remote IP: '+THISFORM.RemoteIP+crlf; +'Remote Dir: '+THISFORM.RemotePath+crlf; +'Remote Alias: '+THISFORM.RemoteAlias+crlf; +'Local Dir: '+set('defa')+CurDir()+crlf; +'Connected Time: '+tran(THISFORM.Now-THISFORM.ConnectTime)+' min'+crlf; +lcCnct if empty(THISFORM.RemoteUser) THISFORM.Caption = [Chat Server: Connected to "]+THISFORM.RemoteIP+["] else THISFORM.Caption = [Chat Server: Connected to "]+THISFORM.RemoteUser+["] endif THISFORM.SessionInfo.Refresh ENDPROC PROCEDURE addchat LPARAMETERS pcNote THISFORM.Chat.AddItem(pcNote) THISFORM.Chat.ListIndex = THISFORM.Chat.ListCount ENDPROC PROCEDURE sendcommand LOCAL lcCmd, lcStr, lcLine, lcArg, lnI, lnCnt, laArr[1], lcPath lcLine = alltrim(THISFORM.Cmd) if lcLine='?' lcLine = "FUNC "+SubStr(lcLine,2) endif if upper(lcLine)='CD\' lcLine = "CD \"+SubStr(lcLine,4) endif if upper(alltrim(lcLine))=='DIR' lcLine = "DIR *.*" endif if ' ' $ lcLine * UrlEncode the Data for the command lcCmd = UPPER( Left(lcLine, at(' ',lcLine)-1 ) ) lcArg = Substr(lcLine, at(' ',lcLine)+1 ) lcStr = THISFORM.UrlEncode(lcArg) lcLine = lcCmd+' '+lcStr else lcCmd = upper(lcLine) lcArg = '' lcStr = '' lcLine = lcCmd endif if not THISFORM.aCmds[THISFORM.TotCmds] == lcLine if THISFORM.TotCmds < alen(THISFORM.aCmds) THISFORM.TotCmds = THISFORM.TotCmds+1 else for lnI = 2 to THISFORM.TotCmds THISFORM.aCmds[lnI-1] = THISFORM.aCmds[lnI] endfor endif THISFORM.aCmds[THISFORM.TotCmds] = THISFORM.Cmd endif THISFORM.ThisCmd = THISFORM.TotCmds do case case lcCmd='SELECT ' or lcCmd='PUBLIC ' THISFORM.SendData('CMD '+lcLine) && Handle Local commands case lcCmd='LCD' && Local CD SET DEFAULT TO (lcArg) case lcCmd='PUT' && Send a file lcVal = lcArg lcPath = JustPath(lcVal) if empty(lcPath) lcPath = Set('Defa')+curdir() lcVal = lcPath+lcVal endif lcPath = addbs(lcPath) lnCnt = adir(laArr,lcVal,'HS') && find all matching files if lnCnt = 0 THISFORM.AddHistory('no files found matching '+lcVal) endif for lnI = 1 to lnCnt THISFORM.AddHistory('Sending File '+lcPath+laArr[1]) lcCont = FileToStr( lcPath+laArr[1] ) *TODO: Add compression lcRes = 'FILE name='+THISFORM.UrlEncode(laArr[1])+'&' ; +'compressed=No&' ; +'size='+Tran(len(lcCont))+'&' ; +'content='+THISFORM.URLEncode( lcCont ) THISFORM.SendData(lcRes) THISFORM.AddHistory('Done.') endfor otherwise THISFORM.SendData(lcLine) endcase ENDPROC PROCEDURE sendvfpcommand LOCAL lcLine lcLine = 'CMD '+alltrim(THISFORM.VfpCmd) THISFORM.SendData(lcLine) ENDPROC PROCEDURE sendmessage LPARAMETER pcMsg DODEFAULT(pcMsg) THISFORM.AddChat('<< '+alltrim(pcMsg)) ENDPROC PROCEDURE handlecommand LPARAMETER pcCommand if NOT ' ' $ pcCommand pcCommand = pcCommand + ' ' endif * Command descriptor is followed by a space, * then, if applicable, by a URL encoded string of parameters * (just like a form submission) * Finally, a CrLf ends the command. THISFORM.AddHistory("IS: Got Command (Len="+tran(len(pcCommand))+" CR Cnt="+tran(occurs(chr(13),pcCommand))+") "+pcCommand) LOCAL lcVal, lnData, lcData, laData[1,1], loData do case case pcCommand='CHAT ' lcVal = THISFORM.URLUnEncode( SubStr(pcCommand,6) ) THISFORM.SendData('OK') THISFORM.AddChat('>> '+lcVal) case pcCommand='USER ' THISFORM.SendData('OK') THISFORM.RemoteUser = alltrim( THISFORM.URLUnencode(Substr(pcCommand,5)) ) THISFORM.RefreshInfo case pcCommand='USERIP ' THISFORM.SendData('OK') THISFORM.RemoteIP = alltrim( THISFORM.URLUnencode(Substr(pcCommand,7)) ) THISFORM.RefreshInfo case pcCommand='PATH ' THISFORM.SendData('OK') THISFORM.RemotePath = alltrim( THISFORM.URLUnencode(Substr(pcCommand,5)) ) THISFORM.RefreshInfo case pcCommand='ALIAS ' THISFORM.SendData('OK') THISFORM.RemoteAlias = alltrim( THISFORM.URLUnencode(Substr(pcCommand,7)) ) THISFORM.RefreshInfo case pcCommand='RESULT ' THISFORM.SendData('OK') RELEASE Result PUBLIC Result THISFORM.Result = THISFORM.URLUnencode(Substr(pcCommand,8)) m.Result = THISFORM.Result THISFORM.AddHistory('RESULT = '+THISFORM.Result) case pcCommand='FILE ' * data items: Name (no path allowed) * Compressed: Y/N * Size: (of uuencoded data) Before Uncompressing. * Content: the actual file. THISFORM.AddHistory('Incoming File!') lcFile = THISFORM.ReceiveFile(pcCommand) if '.BMP' $ lcFile && View image DO FORM ResultViewer with lcFile, THISFORM endif case pcCommand='XMLDBF ' * data items: CursorToXml'd table. * TODO: Convert XML back to a table THISFORM.AddHistory('Incoming XML File!') THISFORM.SendData('OK') case pcCommand='TABLE ' * data items: CursorToXml'd table. * TODO: Convert XML back to a table... This could be the result of a SELECT query. THISFORM.AddHistory('Incoming Table!') THISFORM.SendData('OK') case pcCommand='ARRAY ' THISFORM.AddHistory('Incoming Array!') if THISFORM.GetArray( @laData, pcCommand ) * TODO: Show array to the user somehow WAIT WINDOW NOWAIT "TODO: Launching Array Viewer" else THISFORM.AddHistory('Array is Malformed!') endif THISFORM.SendData('OK') case pcCommand='BYE ' THISFORM.AddHistory('Other side said "BYE"') THISFORM.SendData('OK') THISFORM.Close OTHERWISE DODEFAULT(pcCommand) endcase ENDPROC PROCEDURE addhistory LPARAMETERS pcNote THISFORM.List.AddItem(pcNote) THISFORM.List.ListIndex = THISFORM.List.ListCount ENDPROC PROCEDURE Resize WITh thiSFORM .List.Width = .Width - .List.Left .cmdSendChat.Left = .Width - .cmdSendChat.Width - 15 .cmdSendCmd.Left = .Width - .cmdSendCmd.Width - 15 .cmdLocalCmd.Left = .Width - .cmdLocalCmd.Width - 15 .edtChat.width = .cmdSendChat.Left - 15 - .edtChat.Left .edtCmd.width = .cmdSendCmd.Left - 15 - .edtCmd.Left .edtLCmd.width = .cmdLocalCmd.Left - 15 - .edtLCmd.Left .Chat.Width = (.Width - .Chat.Left )/2 .SessionInfo.Left = .Chat.Left + .Chat.Width + 4 .lblSessionInfo.Left = .SessionInfo.Left + 4 .SessionInfo.Width = .Width - .SessionInfo.Left - 4 ENDWITH ENDPROC PROCEDURE Load _vfp.autoyield=.f. THISFORM.aCmds = '' && Clear the array ENDPROC PROCEDURE Init LPARAMETER pcReqID if THISFORM.Sock.State!=sckClosed THISFORM.Sock.Close endif THISFORM.Sock.Accept( pcReqID ) THISFORM.ConnectTime = dateTime() THISFORM.RefreshInfo ENDPROC PROCEDURE setstate DODEFAULT() THISFORM.RefreshInfo ENDPROC PROCEDURE edtchat.KeyPress LPARAMETERS nKeyCode, nShiftAltCtrl if nKeyCode=13 THISFORM.cmdSendChat.SetFocus THISFORM.cmdSendChat.Click THIS.SetFocus NODEFAULT endif ENDPROC PROCEDURE edtcmd.KeyPress LPARAMETERS nKeyCode, nShiftAltCtrl do case case nKeyCode=13 THISFORM.cmdSendCmd.SetFocus THISFORM.cmdSendCmd.Click THIS.SetFocus NODEFAULT case nKeyCode=18 or nKeyCode=3 && pgup,pgdn if nKeyCode=18 && pgup IF THISFORM.ThisCmd > 1 THISFORM.ThisCmd = THISFORM.ThisCmd - 1 endif else && pgDn IF THISFORM.ThisCmd < THISFORM.TotCmds THISFORM.ThisCmd = THISFORM.ThisCmd + 1 endif endif THISFORM.Cmd = THISFORM.aCmds[THISFORM.ThisCmd] THISFORM.edtCmd.Refresh endcase ENDPROC PROCEDURE cmdsendchat.Click THISFORM.SendMessage(THISFORM.ChatMsg) THISFORM.ChatMsg = '' THISFORM.edtChat.SetFocus ENDPROC PROCEDURE cmdsendcmd.Click THISFORM.SendCommand ENDPROC PROCEDURE command3.Click THISFORM.Close ENDPROC PROCEDURE edtlcmd.KeyPress LPARAMETERS nKeyCode, nShiftAltCtrl if nKeyCode=13 THISFORM.cmdLocalCmd.SetFocus THISFORM.cmdLocalCmd.Click THIS.SetFocus NODEFAULT endif ENDPROC PROCEDURE edtvfpcmd.KeyPress LPARAMETERS nKeyCode, nShiftAltCtrl if nKeyCode=13 THISFORM.cmdSendVfpCmd.SetFocus THISFORM.cmdSendVfpCmd.Click THIS.SetFocus NODEFAULT endif ENDPROC PROCEDURE cmdsendvfpcmd.Click THISFORM.SendVfpCommand ENDPROC PROCEDURE cmdlocalcmd.Click LOCAL lcCmd, lcStr, lcLine lcLine = alltrim(THISFORM.LCmd) ACTIVATE SCREEN &lcLine THISFORM.edtLCMD.SetFocus ENDPROC ENDDEFINE * *-- EndDefine: frminstanceserver ************************************************** ************************************************** *-- Class: frmserver (c:\source\chat\ex\chatexample.vcx) *-- ParentClass: form *-- BaseClass: form *-- Time Stamp: 05/23/03 01:48:01 PM * * DEFINES's could be extracted into a header file like this: *#INCLUDE "c:\source\chat\ex\chatexample.h" * DEFINE CLASS frmserver AS form Top = 0 Left = 0 Height = 227 Width = 527 ShowWindow = 0 DoCreate = .T. Caption = "Chat Server" Name = "frmserver" ADD OBJECT sock AS WSControl ADD OBJECT list AS listbox WITH ; Height = 201, ; Left = 70, ; Top = 13, ; Width = 450, ; Name = "List" ADD OBJECT command1 AS commandbutton WITH ; Top = 110, ; Left = 10, ; Height = 40, ; Width = 50, ; Caption = "Close", ; Name = "Command1" ADD OBJECT command2 AS commandbutton WITH ; Top = 180, ; Left = 10, ; Height = 40, ; Width = 50, ; WordWrap = .T., ; Caption = "Launch Client", ; Name = "Command2" PROCEDURE acceptrequest LPARAM ReqID THISFORM.List.AddItem(tran(dateTime())+" Server Connection Requested ID:"+tran(ReqID)) LOCAL lcName lcName = sys(2015) PUBLIC &lcName &lcName = CreateObject('frmInstanceServer',ReqID) &lcName..Show ENDPROC PROCEDURE senddata LPARAMETERS pcData THISFORM.Server.Object.SendData(pcData) ENDPROC PROCEDURE Init _VFP.AutoYield = .F. THISFORM.List.AddItem(tran(dateTime())+" Tech Support Server Started") THISFORM.Sock.LocalPort = 8181 THISFORM.Sock.object.Listen THISFORM.Left = _SCREEN.Width - THISFORM.Width ENDPROC PROCEDURE Unload DODEFAULT() CLEAR EVENTS ENDPROC PROCEDURE sock.DataArrival *** ActiveX Control Event *** LPARAMETERS len LOCAL lcData lcData = space(len*2) lcData = THIS.Object.GetData(@lcData) THISFORM.List.AddItem(tran(dateTime())+" Sock Data Received:("+tran(len)+")"+alltrim(lcData)) THIS.Object.SendData(lcData) ENDPROC PROCEDURE sock.Connect *** ActiveX Control Event *** THISFORM.List.AddItem(tran(dateTime())+" Sock Connect Event") ENDPROC PROCEDURE sock.ConnectionRequest *** ActiveX Control Event *** LPARAMETERS requestid THISFORM.AcceptRequest(RequestID) ENDPROC PROCEDURE sock.Close *** ActiveX Control Event *** THIS.Object.Close THISFORM.List.AddItem("Sock Close Event") ENDPROC PROCEDURE command1.Click THISFORM.Sock.Object.Close THISFORM.Release ENDPROC PROCEDURE command2.Click IF 1=MessageBox('You must start another VFP instance to view the client.'+chr(13); +'Click "OK" to try to do this now...'+chr(13); +chr(13)+'or open another VFP window, and type "DO tcpChat"',1,'Launch Client') DECLARE INTEGER ShellExecute IN SHELL32.DLL ; INTEGER nWinHandle, STRING cOperation, STRING cFileName, STRING cParameters,; STRING cDirectory, INTEGER nShowWindow ShellExecute( 0, 'OPEN', FullPath('tcpChat.prg'), '', set('default')+curdir(), 1 ) ENDIF RETURN .f. LOCAL lcName lcName = sys(2015) PUBLIC &lcName &lcName = CreateObject('frmClient') &lcName..Show ENDPROC ENDDEFINE * *-- EndDefine: frmserver ************************************************** Define Class WSControl As OleControl * Thanks for Slighthaze for this WinSock control class * that can be added to a form in a DEFINE CLASS! OleClass='MSWinsock.Winsock.1' Top = 228 Left = 24 Height = 100 Width = 100 Name = "Sock" PROCEDURE Init this.object.Protocol = 0 && TCP ENDPROC Enddefine

Author: wgcs
There is I believe a problem with the URLencode function used here
(I've seen it in other places too).

I noticed it first when trying to URLencode something that had a # in it (don't ask - well, OK, it's an Audio Tron application). This code does not escape it, but it should. When I've fixed the code, I'll post a replacement here.

Michael


Here is the code I used:
FUNCTION urlencode
*
* from http://www.tek-tips.com/gviewthread.cfm/lev2/4/lev3/27/pid/184/qid/597112
* also http://fox.wikis.com/wc.dll?Wiki~VFPPortListener~VFP
* I'm confused by this code.
* I believe it doesn't translate spaces correctly
*
* a proper definition is in: http://www.ietf.org/rfc/rfc2396.txt
* starting about half way down page 5
* unreserved characters include all alphas, all digits and the following unreserved marks
* mark  = "-" | "_" | "." | "!" | "~" | "*" | "'" | "(" | ")"
*
LPARAMETER pcinstr
*  ' encode Percent signs
*  '        Double Quotes
*  '        CarriageReturn / LineFeeds
LOCAL lcout, lni
lcout = ''
FOR lni = 1 TO LEN(pcinstr)
	lcch = SUBSTR(pcinstr,lni,1)
	DO CASE
		CASE ISALPHA(lcch) OR ISDIGIT(lcch) OR INLIST(lcch, "-" , "_" , "." , "!" , "~" , "*" , "'" , "(" , ")")
			* do nothing
		CASE lcch = " "
			lcch = "+"
		OTHERWISE
			lcch = '%' + RIGHT( TRANSFORM(ASC(lcch),'@0'), 2 )
	ENDCASE
	lcout = lcout + lcch
ENDFOR
RETURN lcout
ENDFUNC && UrlEncode

Michael
#n# Now Michael's code is incorporated into the Classes above. Thanks Michael, for doing the research to find out what exactly UrlEncode ing requires. -- wgcs
See also: What are Sockets? http://www.developerweb.net/forum/showthread.php?t=2961
Category Code Samples Category Client / Server
( Topic last updated: 2006.09.11 10:50:14 PM )