Announcement

Collapse
No announcement yet.

rServer2 for PBFORMS

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • rServer2 for PBFORMS

    Original code with include files at http://www.greatwebdivide.com/files/rserver2.zip
    Code:
     
    #PBFORMS CREATED V1.51
    'Original code with include files at http://www.greatwebdivide.com/files/rserver2.zip
    '
    '  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
    Last edited by Mike Doty; 15 Sep 2009, 10:26 PM.
    How long is an idea? Write it down.
Working...
X