Tweet
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