Find all our projects in development below.
All source code is GNU General Public License (GPL)
Browsing clsTcpServer.vb (6.21 KB)
Option Explicit On
Imports System.Net
Imports System.Net.Sockets
Imports System.Text.Encoding
Imports System.Threading
Public Class clsTcpServer
Implements IDisposable
Public Clients As New Collection
Public MaxClients As Integer = 0
Private thisSock As Socket = Nothing
Private thisListener As TcpListener = Nothing
Private thisThread As Thread = Nothing
Private callbackNewClientSub As TcpServerNewClientSub = Nothing
Private callbackDisconnectSub As TcpServerClientDisconnectSub = Nothing
Public Delegate Sub TcpServerNewClientSub(ByVal newClient As clsTcpClient)
Public Delegate Sub TcpServerClientDisconnectSub(ByVal thisClient As clsTcpClient)
Public Const DefaultMaxClients As Integer = 0 ' no limit
Private Const SOCKET_RECV_TIMEOUT = 2000 ' 2 seconds
Private Const SOCKET_SEND_TIMEOUT = 2000 ' 2 seconds
Private Const LOOP_SLEEP_DELAY = 10 ' 1/100 second
Public Sub New(ByVal ip As String, ByVal port As Integer, _
Optional ByVal max_clients As Integer = DefaultMaxClients, _
Optional ByVal clientDisconnectCallback As TcpServerClientDisconnectSub = Nothing)
Me.MaxClients = max_clients
Me.callbackDisconnectSub = clientDisconnectCallback
' instantiate a new tcp socket
thisSock = New Socket(AddressFamily.InterNetwork, SocketType.Stream, ProtocolType.Tcp)
' configure the socket
thisSock.SetSocketOption(SocketOptionLevel.Socket, SocketOptionName.ReceiveTimeout, SOCKET_RECV_TIMEOUT)
thisSock.SetSocketOption(SocketOptionLevel.Socket, SocketOptionName.SendTimeout, SOCKET_SEND_TIMEOUT)
Dim hostEndpoint As IPEndPoint = Nothing
If ip Is Nothing Then
hostEndpoint = New IPEndPoint(IPAddress.Any, port)
Else
hostEndpoint = New IPEndPoint(IPAddress.Parse(ip), port)
End If
thisListener = New TcpListener(hostEndpoint)
End Sub
Public ReadOnly Property Ready() As Boolean
Get
Return Not (thisSock Is Nothing)
End Get
End Property
Public ReadOnly Property IsListening() As Boolean
Get
Return Not (thisThread Is Nothing)
End Get
End Property
Public Sub StartListener(ByVal newClientCallback As TcpServerNewClientSub)
If thisThread Is Nothing Then
callbackNewClientSub = newClientCallback
thisListener.Start()
thisThread = New Thread(AddressOf _threadedListener)
thisThread.Priority = ThreadPriority.BelowNormal
thisThread.IsBackground = True
thisThread.Start(Me)
End If
End Sub
Public Sub StopListener()
If Not (thisThread Is Nothing) Then
thisThread.Abort()
thisThread = Nothing
thisListener.Stop()
End If
End Sub
Public Sub Dispose() Implements IDisposable.Dispose
Do While Clients.Count > 0
Dim thisTcpClient As clsTcpClient = Clients.Item(Clients.Count)
Clients.Remove(thisTcpClient.ToString)
thisTcpClient.Dispose()
Loop
StopListener()
thisSock.Close()
End Sub
Public Sub _threadedListener(ByVal tcpObject As Object)
Dim thisTcpServer As clsTcpServer = tcpObject
Do Until Not thisTcpServer.IsListening
' check for pending connection
If thisTcpServer.thisListener.Pending() Then
' check for max connections
If thisTcpServer.MaxClients = 0 Or _
thisTcpServer.Clients.Count < thisTcpServer.MaxClients Then
Try
' accept the incoming connection on a new thread
With New Thread(AddressOf _threadedAccept)
.IsBackground = True
.Priority = ThreadPriority.AboveNormal
.Start(thisTcpServer)
End With
Catch
End Try
Else
Try
Dim thisSock As Socket = thisTcpServer.thisListener.AcceptSocket()
thisSock.Close()
Catch
End Try
End If
End If
' sleep for a duration of time
Thread.Sleep(LOOP_SLEEP_DELAY)
Loop
End Sub
Private Sub _threadedAccept(ByVal tcpObject As Object)
Dim thisTcpServer As clsTcpServer = tcpObject
Dim newClient As clsTcpClient = Nothing
Try
' dummy object used for sync locking
Dim objLock As New Object
' lock the object to this thread
SyncLock objLock
' accept the incoming connection
newClient = New clsTcpClient(thisTcpServer, thisTcpServer.thisListener.AcceptSocket(), _
New clsTcpClient.TcpClientDisconnectSub(AddressOf _clientDisconnectCallback))
End SyncLock
objLock = Nothing
' validate the new connection
If Not (newClient Is Nothing) Then
' add the new client to the collection
thisTcpServer.Clients.Add(newClient, newClient.ToString)
' raise new client callback func
If Not (thisTcpServer.callbackNewClientSub Is Nothing) Then _
thisTcpServer.callbackNewClientSub.Invoke(newClient)
End If
Catch
End Try
End Sub
Private Sub _clientDisconnectCallback(ByVal thisTcpClient As clsTcpClient)
Dim thisTcpServer As clsTcpServer = thisTcpClient.TcpServer
If Not (thisTcpServer Is Nothing) Then
' remove the disconnected client
thisTcpServer.Clients.Remove(thisTcpClient.ToString)
' raise client disconnect callback
If Not (thisTcpServer.callbackDisconnectSub Is Nothing) Then _
thisTcpServer.callbackDisconnectSub.Invoke(thisTcpClient)
End If
End Sub
End Class