Original code with include files at http://www.greatwebdivide.com/files/rserver2.zip
Code:
#PBFORMS CREATED V1.51 'Original code with include files at [URL]http://www.greatwebdivide.com/files/rserver2.zip[/URL] ' ' rserver.bas ' ' multi-threaded, multi-homed, tcp-based, remote binary data server ' ' By Don Dickinson modified by Mike Doty 9/15/09 for use with PBFORMS ' Hereby Public Domain ' Use implies that you hold the author, Don Dickinson, harmless from any ' responsibility for effects or side-effects of using this code. It is ' provided in good faith by the auther - you are using it at your own ' risk. #COMPILE EXE #DIM ALL '------------------------------------------------------------------------------ ' ** Includes ** '------------------------------------------------------------------------------ #PBFORMS BEGIN INCLUDES #IF NOT %DEF(%WINAPI) #INCLUDE "WIN32API.INC" #ENDIF #PBFORMS END INCLUDES '------------------------------------------------------------------------------ '------------------------------------------------------------------------------ ' ** Constants ** '------------------------------------------------------------------------------ #PBFORMS BEGIN CONSTANTS %LOG_DETAILED = 0 '* %labIP = 801 %labPort = 802 %labDate = 803 %labHits = 804 %labActive = 805 %labAction = 806 %btnStop = 807 %timer1 = 808 %IDD_DIALOG1 = 101 #PBFORMS END CONSTANTS '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' Included files '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ #INCLUDE "win32api.inc" 'windows api, constants, structures #INCLUDE "wsconst.inc" 'winsock structures and constants #INCLUDE "pb_file.bas" 'various file and directory routines #INCLUDE "pb_ini.bas" '.ini file handling #INCLUDE "rserver.inc" 'rserver specific constants and structures REM %DEFAULT_PORT 'might make these variables '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' Globals '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ GLOBAL gDlgMain AS LONG 'handle for main dialog window GLOBAL gLog AS LONG 'handle to log file GLOBAL gShutdown AS LONG 'flag telling system to abort and close conns GLOBAL gSock() AS LONG 'array of client connection sockets GLOBAL gMainSock() AS LONG 'array of listening sockets GLOBAL gThread() AS LONG 'array of running threads GLOBAL gThreadRunning() AS LONG 'array that indicates if a thread has finished GLOBAL gActive AS LONG 'number of active connections GLOBAL gHits AS LONG 'total hits GLOBAL gPort AS LONG 'connection port GLOBAL gIPAddr() AS LONG 'array of ip addresses being listed to GLOBAL gIPCount AS LONG 'count of ip addresses being listed to GLOBAL gCS AS CRITICAL_SECTION 'critical section structure GLOBAL gIniFile AS STRING 'ini file name and path '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' tcpSafeReceive ' Specify a length of data to wait for and this function ' retrieves data until all data has filled the buffer or ' an error occurs. ' Returns: %True on success, %False on error '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ FUNCTION tcpSafeReceive(BYVAL hSocket AS LONG, BYVAL iBufferLen AS LONG, _ recBuff AS STRING) AS LONG DIM iLeft AS LONG DIM sBuffer AS STRING recBuff = "" iLeft = iBufferLen DO sBuffer = SPACE$(iLeft) TCP RECV hSocket, iLeft, sBuffer IF ERR THEN FUNCTION = %False EXIT FUNCTION END IF recBuff = recBuff + LEFT$(sBuffer,iLeft) IF LEN(recBuff) >= iBufferLen THEN EXIT DO ELSEIF LEN(RecBuff) = 0 THEN EXIT DO ELSEIF LEN(sBuffer) = 0 THEN EXIT DO END IF iLeft = iBufferLen - LEN(recBuff) SLEEP 5 LOOP FUNCTION = %True END FUNCTION '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' FormatIP '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ FUNCTION FormatIP(RawAddr AS LONG) AS STRING DIM sAddr AS STRING sAddr = MKL$(RawAddr) FUNCTION = FORMAT$(ASC(MID$(sAddr, 1, 1))) + "." + _ FORMAT$(ASC(MID$(sAddr, 2, 1))) + "." + _ FORMAT$(ASC(MID$(sAddr, 3, 1))) + "." + _ FORMAT$(ASC(MID$(sAddr, 4, 1))) END FUNCTION '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' LogEvent '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ SUB LogEvent(BYVAL buffer AS STRING) IF gLog THEN PRINT #gLog, DATE$ + " " + TIME$ + " " + Buffer END IF END SUB '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' EnterCritical '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ SUB EnterCritical EnterCriticalSection gCS END SUB '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' LeaveCritical '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ SUB LeaveCritical LeaveCriticalSection gCS END SUB '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' DisplayEvent '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ SUB DisplayEvent(BYVAL buffer AS STRING) gHits = gHits + 1 IF gHits > 2000000000 THEN gHits = 1 END IF CONTROL SET TEXT gDlgMain, %labAction, TIME$ + " " + Buffer CONTROL SET TEXT gDlgMain, %labActive, FORMAT$(gActive) CONTROL SET TEXT gDlgMain, %labHits, FORMAT$(gHits) END SUB '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' ThreadCleanup ' If a thread has finished executing, but the thread handle ' has not been closed, I close it here. This is called by a ' timer that goes off every %TIMER_INTERVAL milliseconds '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ SUB ThreadCleanup() DIM i AS LONG DIM foo AS LONG FOR i = 1 TO %MAX_CONNECTIONS IF gThread(i) THEN IF gThreadRunning(i) = %False THEN THREAD CLOSE gThread(i) TO foo gThread(i) = 0 END IF END IF NEXT i END SUB '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' InitListen ' Starts all ip ports listening '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ SUB InitListen() 'called by InitDialog DIM i AS LONG FOR i = 1 TO %MAX_IP_WAIT 'how many interfaces in rserver.inc IF gIPAddr(i) <> 0 THEN gMainSock(i) = FREEFILE TCP OPEN SERVER ADDR gIPAddr(i) PORT gPort AS gMainSock(i) TIMEOUT %TCP_TIMEOUT IF ERR THEN MSGBOX "Unable to listen to " + FormatIP$(gIPAddr(i)) + _ " Err=" + FORMAT$(ERR) ELSE TCP NOTIFY gMainSock(i), ACCEPT TO gDlgMain AS %TCP_CONNECT END IF END IF NEXT i END SUB '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' rsCommand '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ FUNCTION rsCommand (BYVAL iCurrentSocket AS LONG, rIn AS XFER_BUFFER_TYPE, _ sInBuffer AS STRING) AS LONG DIM i AS LONG DIM iMoreLeft AS LONG DIM iLen AS LONG DIM sFile AS STRING DIM sReturn AS STRING DIM sBuffer AS STRING DIM rOut AS XFER_BUFFER_TYPE iMoreLeft = %True SELECT CASE rIn.iCommand '-------- OPEN FILE FOR SHARED ACCESS CASE %RSERVER_OPEN_FILE '- The length of the file name is the first ' two bytes (integer) after the structure. ' The file name follows it's length ' sFile = TRIM$(MID$(sInBuffer, 3, CVI(MID$(sInBuffer, 1, 2)))) LogEvent "OPEN " + sFile DisplayEvent "Open File " + sFile '- Open the file. If there's an error, the error ' is stored in the iResult member. Otherwise, ' the file handle is given to the iFile member. ' EnterCritical ON ERROR RESUME NEXT rOut.iFile = FREEFILE OPEN sFile FOR BINARY SHARED AS #rOut.iFile IF ERR THEN rOut.iFile = 0 END IF rOut.iResult = ERR rOut.iDataLen = 0 LeaveCritical '- Send back the results structure sReturn = SPACE$(LEN(rOut)) LSET sReturn = rOut TCP SEND iCurrentSocket, sReturn '-------- CLOSE FILE CASE %RSERVER_CLOSE_FILE LogEvent "CLOSE FILE " + FORMAT$(rIn.iFile) DisplayEvent "CLOSE " + FORMAT$(rIn.iFile) CLOSE #rIn.iFile rOut.iResult = 0 rOut.iDataLen = 0 rOut.iFile = 0 sReturn = SPACE$(LEN(rOut)) LSET sReturn = rOut TCP SEND iCurrentSocket, sReturn '-------- GET DATA FROM FILE CASE %RSERVER_GET DisplayEvent "GET " + FORMAT$(rIn.iFile) '- How much data do they want? iLen = CVL(LEFT$(sInBuffer, 4)) '- Retrieve the data from the file ON ERROR RESUME NEXT sBuffer = SPACE$(iLen) GET #rIn.iFile,, sBuffer IF ERR THEN sBuffer = "" rOut.iDataLen = 0 ELSE rOut.iDataLen = LEN(sBuffer) END IF rOut.iResult = ERR rOut.iFile = rIn.iFile '- Send back the response with the data sReturn = SPACE$(LEN(rOut)) LSET sReturn = rOut sReturn = sReturn + sBuffer TCP SEND iCurrentSocket, sReturn '-------- WRITE DATA TO FILE CASE %RSERVER_PUT DisplayEvent "PUT " + FORMAT$(rIn.iFile) ON ERROR RESUME NEXT 'Write everything to disk in 1-shot 'Mike Doty PUT #rIn.iFile,, sInBuffer FLUSH #rIn.iFile 'Mike Doty rOut.iResult = ERR rOut.iFile = rIn.iFile rOut.iDataLen = 0 sReturn = SPACE$(LEN(rOut)) LSET sReturn = rOut TCP SEND iCurrentSocket, sReturn '-------- SEEK A POSITION IN THE FILE CASE %RSERVER_SEEK DisplayEvent "SEEK " + FORMAT$(rIn.iFile) ON ERROR RESUME NEXT SEEK #rIn.iFile, CVL(LEFT$(sInBuffer, 4)) rOut.iFile = rIn.iFile rOut.iResult = ERR rOut.iDataLen = 0 sReturn = SPACE$(LEN(rOut)) LSET sReturn = rOut TCP SEND iCurrentSocket, sReturn '-------- GET LENGTH OF THE FILE CASE %RSERVER_LOF DisplayEvent "LOF " + FORMAT$(rIn.iFile) ON ERROR RESUME NEXT i = LOF(rIn.iFile) IF ERR THEN rOut.iDataLen = 0 sBuffer = "" ELSE rOut.iDataLen = 4 sBuffer = MKL$(i) END IF rOut.iFile = rIn.iFile rOut.iResult = ERR sReturn = SPACE$(LEN(rOut)) LSET sReturn = rOut sReturn = sReturn + sBuffer TCP SEND iCurrentSocket, sReturn '----------- No more to come CASE %RSERVER_QUIT iMoreLeft = %False '----------- UNKNOWN instruction CASE ELSE LogEvent "UNKNOWN INSTRUCTION:" + STR$(rIn.iCommand) DisplayEvent "Unknown Instruction:" + STR$(rIn.iCommand) rOut.iResult = 0 rOut.iFile = 0 rOut.iDataLen = 0 sReturn = SPACE$(LEN(rOut)) LSET sReturn = rOut TCP SEND iCurrentSocket, sReturn END SELECT FUNCTION = iMoreLeft END FUNCTION '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' tcpHandleConnection ' This function is called to create a new thread. It sits in a loop ' responding to requests until the socket is closed (this generates an ' error an the loop bails out. When it finishes, it closes the socket. '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ THREAD FUNCTION tcpHandleConnection( BYVAL iWhich AS LONG ) AS LONG DIM i AS LONG DIM iCurrentSocket AS LONG DIM iLen AS LONG DIM sFile AS STRING DIM sResult AS STRING DIM sBuffer AS STRING DIM sInBuffer AS STRING DIM rOut AS XFER_BUFFER_TYPE DIM rIn AS XFER_BUFFER_TYPE gThreadRunning(iWhich) = %True iCurrentSocket = gSock(iWhich) DO '- If this fails, then there was a tcp error IF tcpSafeReceive(iCurrentSocket, LEN(rIn), sBuffer) = %False THEN EXIT DO '- Monitor the global shutdown flag ELSEIF gShutdown THEN EXIT DO '- Process the data ELSE LSET rIn = sBuffer '- Get the variable portion of the buffer IF rIn.iDataLen > 0 THEN tcpSafeReceive iCurrentSocket, rIn.iDatalen, sInBuffer END IF '- This returns %False if the client sent a disconnect IF rsCommand(iCurrentSocket, rIn, sInBuffer) = %False THEN EXIT DO END IF END IF SLEEP 5 LOOP TCP CLOSE gSock(iWhich) gSock(iWhich) = %INVALID_SOCKET gThreadRunning(iWhich) = %False gActive = gActive - 1 DisplayEvent "Disconnect: " + FORMAT$(iWhich) FUNCTION = %True END FUNCTION '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' StopButton '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ CALLBACK FUNCTION btnStop_Click() DIALOG END gDlgMain, 0 FUNCTION = 1 END FUNCTION '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' Initialize '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ FUNCTION Initialize() AS LONG DIM i AS LONG '- The configuration file is called rserver.ini ' and must be in the same directory as rserver.exe ' gIniFile = TRIM$(ExtractPath(GetExeName())) IF RIGHT$(gIniFile, 1) <> "\" THEN gIniFile = gIniFile + "\" END IF gIniFile = gIniFile + "rserver.ini" '- This is a multi-threaded application. ' I use a critical section to resolve thread conflicts ' InitializeCriticalSection gCS '- This program can be set to be multi-homed - that is, ' listen on more than one IP address. The IP addresses ' are specified in the rserver.ini file required to be ' in the same directory as rserver.exe. If it is not ' there, then the default IP address for this computer ' is assumed. This is based on what is returned ' by Host ADDR "" To ' gIPCount = 0 REDIM gIPAddr(%MAX_IP_WAIT) AS LONG FOR i = 1 TO %MAX_IP_WAIT gIPAddr(i) = INT(VAL(GetIni(gIniFile, "server", "IPAddr" + FORMAT$(i), "0"))) IF gIPAddr(i) <> 0 THEN INCR gIPCount END IF NEXT i REDIM gMainSock(%MAX_IP_WAIT) AS LONG '- Set the default if none were found in the .ini IF gIPCount < 1 THEN gIPCount = 1 HOST ADDR "" TO gIPAddr(1) END IF '- The port is an .ini setting. There is a constant ' for the default. ' gPort = INT(VAL(GetIni(gIniFile, "server", "port", FORMAT$(%DEFAULT_PORT)))) '- These are our connection place holders. Fill up the list with ' invalid connections. ' REDIM gSock(1 TO %MAX_CONNECTIONS) AS LONG FOR i = 1 TO %MAX_CONNECTIONS gSock(i) = %INVALID_SOCKET NEXT i '- There will be on thread ID per connection REDIM gThread(1 TO %MAX_CONNECTIONS) AS LONG REDIM gThreadRunning(1 TO %MAX_CONNECTIONS) AS LONG gShutdown = %False '- Open the log file ON ERROR RESUME NEXT gLog = FREEFILE OPEN "rserver.log" FOR APPEND AS #gLog IF ERR THEN MSGBOX "Unable to create log file. Error =" + STR$(ERR) gLog = 0 ELSE PRINT #gLog, "" PRINT #gLog, "**********************************************" PRINT #gLog, "START UP " + DATE$ + " " +TIME$ PRINT #gLog, "----------------------------------------------" END IF FUNCTION = %True END FUNCTION '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' ShutDown '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ SUB ShutDown() DIM i AS LONG DIM foo AS LONG '- All threads monitor this flag and ' will bail as soon as possible after ' seeing this. ' gShutdown = %True SLEEP 100 '- Make sure to clean up any open sockets ' By closing a socket, the blocking tcp calls ' will stop blocking and error out. This ' allows the threads to finish executing. ' FOR i = 1 TO %MAX_CONNECTIONS IF gSock(i) <> %INVALID_SOCKET THEN TCP CLOSE gSock(i) gSock(i) = %INVALID_SOCKET END IF NEXT i '- Free any running threads FOR i = 1 TO %MAX_CONNECTIONS IF gThread(i) <> 0 THEN THREAD CLOSE gThread(i) TO foo '- Wait for the thread to finish running ' When a thread finishes running, it sets its ' gThreadRunning() variable to be zero ' DO UNTIL gThreadRunning(i) = %False SLEEP 10 LOOP END IF NEXT i '- Close any open files IF gLog THEN CLOSE #gLog gLog = 0 END IF CLOSE DeleteCriticalSection gCS END SUB '------------------------------------------------------------------------------ ' ** Declarations ** '------------------------------------------------------------------------------ DECLARE CALLBACK FUNCTION ShowDIALOG1Proc() DECLARE FUNCTION ShowDIALOG1(BYVAL hParent AS DWORD) AS LONG #PBFORMS DECLARATIONS '------------------------------------------------------------------------------ '------------------------------------------------------------------------------ ' ** Main Application Entry Point ** '------------------------------------------------------------------------------ FUNCTION PBMAIN() Initialize ShowDIALOG1 %HWND_DESKTOP ShutDown END FUNCTION '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' gDlgMain_WinProc ' This is the event loop for the application '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ REM CALLBACK FUNCTION gDlgMain_WinProc CALLBACK FUNCTION ShowDIALOG1Proc() DIM i AS LONG DIM iFound AS LONG DIM iCurrentSocket AS LONG DIM iCount AS LONG DIM iEmpty AS LONG DIM iMain AS LONG SELECT CASE CBMSG CASE %WM_INITDIALOG InitListen '- Create a timer to handle thread cleanup SetTimer gDlgMain, %timer1, %CLEANUP_TIMER_INTERVAL, BYVAL %NULL CASE %WM_TIMER IF CBWPARAM = %timer1 THEN ThreadCleanup END IF CASE %TCP_CONNECT '- wparam contains the handle of the socket (FileAttr(hSock, 2) from accept event) SELECT CASE LOWRD(CBLPARAM) '- Someone is attempting to connect to the server CASE %FD_ACCEPT EnterCritical iFound = 0 '- Find an empty connection iEmpty = 0 FOR i = 1 TO %MAX_CONNECTIONS IF gSock(i) = %INVALID_SOCKET THEN iEmpty = i EXIT FOR END IF NEXT i '- Figure out which socket this is coming in on. iMain = 0 FOR i = 1 TO %MAX_IP_WAIT IF FILEATTR(gMainSock(i), 2) = CBWPARAM THEN iMain = i END IF NEXT i '- Now we know which socket the connect request is coming ' in on and which one we should assign it to, ' so accept the connection and specify the notify events ' IF (iMain > 0) AND (iEmpty > 0) THEN '- Accept the connection gSock(iEmpty) = FREEFILE TCP ACCEPT gMainSock(iMain) AS gSock(iEmpty) 'Tcp Notify gSock(iEmpty), To gDlgMain As %TCP_CONNECT DisplayEvent "FD_ACCEPT: " + STR$(gSock(iEmpty)) + " " + STR$(gMainSock(iMain)) LogEvent "CONNECT" gActive = gActive + 1 THREAD CREATE tcpHandleConnection(iEmpty) TO gThread(iEmpty) END IF LeaveCritical END SELECT FUNCTION = 1 CASE %WM_NCACTIVATE STATIC hWndSaveFocus AS DWORD IF ISFALSE CBWPARAM THEN ' Save control focus hWndSaveFocus = GetFocus() ELSEIF hWndSaveFocus THEN ' Restore control focus SetFocus(hWndSaveFocus) hWndSaveFocus = 0 END IF CASE %WM_COMMAND ' Process control notifications SELECT CASE AS LONG CBCTL CASE %btnstop KillTimer gDlgMain, %Timer1 'added this DIALOG END CBHNDL FUNCTION = 1 END SELECT CASE %WM_SYSCOMMAND IF CBWPARAM = %SC_CLOSE THEN KillTimer gDlgMain, %timer1 END IF CASE %WM_DESTROY IF gLog THEN PRINT #gLog, "----------------------------------------------" PRINT #gLog, "SHUT DOWN " + DATE$ + " " + TIME$ PRINT #gLog, " Active Clients:" + STR$(gActive) PRINT #gLog, " Total Hits:" + STR$(gHits) PRINT #gLog, "**********************************************" END IF END SELECT END FUNCTION '------------------------------------------------------------------------------ ' ** Dialogs ** '------------------------------------------------------------------------------ FUNCTION ShowDIALOG1(BYVAL hParent AS DWORD) AS LONG LOCAL lRslt AS LONG #PBFORMS BEGIN DIALOG %IDD_DIALOG1->-> LOCAL hDlg AS DWORD DIALOG NEW hParent, "", 1063, 7, 200, 200, %WS_MINIMIZEBOX OR %WS_CAPTION _ OR %WS_SYSMENU OR %WS_VISIBLE OR %DS_3DLOOK OR %DS_NOFAILCREATE OR _ %DS_SETFONT, %WS_EX_LEFT OR %WS_EX_LTRREADING OR _ %WS_EX_RIGHTSCROLLBAR OR %WS_EX_CONTROLPARENT, TO hDlg CONTROL ADD LABEL, hDlg, -1, "Server IP(s)", 17, 10, 40, 8, %SS_RIGHT OR _ %WS_CHILD OR %WS_VISIBLE, %WS_EX_LEFT OR %WS_EX_LTRREADING CONTROL ADD LABEL, hDlg, -1, "Port", 17, 25, 40, 8, %SS_RIGHT OR _ %WS_CHILD OR %WS_VISIBLE, %WS_EX_LEFT OR %WS_EX_LTRREADING CONTROL ADD LABEL, hDlg, -1, "Started", 17, 40, 40, 8, %SS_RIGHT OR _ %WS_CHILD OR %WS_VISIBLE, %WS_EX_LEFT OR %WS_EX_LTRREADING CONTROL ADD LABEL, hDlg, -1, "Total Hits", 17, 55, 40, 8, %SS_RIGHT OR _ %WS_CHILD OR %WS_VISIBLE, %WS_EX_LEFT OR %WS_EX_LTRREADING CONTROL ADD LABEL, hDlg, -1, "Active Clients", 17, 70, 40, 8, %SS_RIGHT _ OR %WS_CHILD OR %WS_VISIBLE, %WS_EX_LEFT OR %WS_EX_LTRREADING CONTROL ADD LABEL, hDlg, -1, "Last Action", 17, 85, 40, 8, %SS_RIGHT OR _ %WS_CHILD OR %WS_VISIBLE, %WS_EX_LEFT OR %WS_EX_LTRREADING CONTROL ADD LABEL, hDlg, %labIP, "", 65, 10, 180, 8 CONTROL ADD LABEL, hDlg, %labPort, "", 65, 25, 80, 8 CONTROL ADD LABEL, hDlg, %labDate, "", 65, 40, 80, 8 CONTROL ADD LABEL, hDlg, %labHits, "0", 65, 55, 80, 8 CONTROL ADD LABEL, hDlg, %labActive, "0", 65, 70, 80, 8 CONTROL ADD LABEL, hDlg, %labAction, "", 65, 85, 135, 8 CONTROL ADD BUTTON, hDlg, %btnStop, "&Stop", 150, 177, 40, 15 #PBFORMS END DIALOG gDlgMain = hDlg 'Main handle in rserver2 DIM i AS LONG DIM ipa AS STRING '- Get a list of the IP addresses for display purposes FOR i = 1 TO gIPCount IF ipa = "" THEN ipa = FormatIP(gIPAddr(i)) ELSE ipa = ipa + "; " + FormatIP(gIPAddr(i)) END IF NEXT i DIALOG SET TEXT hDlg, "rServer2 for PBFORMS on Port" + STR$(%DEFAULT_PORT) CONTROL SET TEXT gDlgMain, %LabIP, ipa CONTROL SET TEXT gDlgMain, %labPort, FORMAT$(gPort) CONTROL SET TEXT gDlgMain, %labDate, DATE$ + " " + TIME$ REM DIALOG SHOW MODAL hDlg, CALL gDlgMain_WinProc DIALOG SHOW MODAL hDlg, CALL ShowDIALOG1Proc TO lRslt #PBFORMS BEGIN CLEANUP %IDD_DIALOG1 #PBFORMS END CLEANUP FUNCTION = lRslt END FUNCTION