"This should be considered a very simple server, with many functions not implemented, and only one framework. I don't think there are many people who need this thing, but I have spent a lot of time researching this thing (I have only seen it for 3 years and practiced it for 30 years to reach today's situation). Therefore, if you download the code, you must give me points."
"Personally, I think the performance of this device should be quite good (the number of bursts should be better than the winsock control). It can achieve 10W of IO per second, and it also has a memory pool implemented to avoid memory fragmentation, which is not bad in terms of stability. However, it is much more difficult to truly write a specific application than the winsock control, but the performance it brings is indeed worth it."
Private Sub Form_Load()
Dim i As Long
If Initsockdll() = False Then
MsgBox "Init socket dll err"
End
End If
Dbgprint "Successfully initialized Winsock"
hIOCP = CreateIOCP()
If hIOCP = 0 Then
MsgBox "Create IOCP err"
End
End If
Dbgprint "Create IOCP Port Successfully " & hIOCP
hListenSck = CreateSocket
If hListenSck = INVALID_SOCKET Then
MsgBox "Create socket err"
End
End If
Dbgprint "Successfully created the socket"
If BindServerSocket(hListenSck, 5150, "") = False Then
MsgBox "bind err"
End
End If
Dbgprint "Bind to Port 5150 Successfully"
Dim lpThreadId As Long
Dbgprint "Start worker thread"
hThread(0) = CreateThread(0, 0, AddressOf ListenFunc, ByVal 0&, 0, lpThreadId) '监听线程
'这里是固定好的12个线程 但是在实际应用中这个应该根据CPU的数目或者实际测试得出具体数目
For i = 1 To 12
hThread(i) = CreateThread(0, 0, AddressOf WorkFunc, ByVal 0&, 0, lpThreadId)
Next
Dbgprint "Startup complete port 5150"
End Sub
Private Sub Form_Unload(Cancel As Integer)
Dim i As Long
For i = 0 To 13
TerminateThread hThread(i), 0
Next
End Sub
Private Sub Timer1_Timer()
Dim Speed As Long
txtText6.Text = InterlockedExchange(SendPackageCount, 0)
txtText7.Text = InterlockedExchange(RecvPackageCount, 0)
txtText8.Text = Val(txtText6.Text) + Val(txtText7.Text)
txtText2.Text = Round(InterlockedExchange(SendBytesCount, 0) / 1024, 3)
txtText3.Text = Round(InterlockedExchange(RecvBytesCount, 0) / 1024, 3)
txtText9.Text = Val(txtText3.Text) + Val(txtText2.Text) & "KB/S"
txtText5.Text = PerDataCount
txtText4.Text = ClientCount
End Sub
Last edited by xiaoyao; Mar 20th, 2023 at 03:51 AM.
'======================================================================================
'模块说明: IOCP
'开发人员: 菜鸟学飞 & 专业路过
'创建时间: 2010-10-2
'博 客: http://hi.baidu.com/专业路过_H/home
'邮 箱: Professionalpassing@gmail.com
'版权说明: 本模块可以用于任何目的 但请保留此版权信息，谢谢。
'======================================================================================
Option Explicit
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Declare Sub ZeroMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, ByVal numBytes As Long)
Public Declare Function InterlockedDecrement Lib "kernel32" (ByRef lpAddend As Long) As Long
Public Declare Function InterlockedExchange Lib "kernel32" (Target As Long, ByVal Value As Long) As Long
Public Declare Function InterlockedIncrement Lib "kernel32" (ByRef lpAddend As Long) As Long
Public Declare Function InterlockedCompareExchange Lib "kernel32" (Destination As Long, ByVal Exchange As Long, ByVal Comperand As Long) As Long
Public Declare Function InterlockedExchangeAdd Lib "kernel32" (Addend As Long, ByVal Value As Long) As Long
Public Declare Sub EnterCriticalSection Lib "kernel32" (lpCriticalSection As CRITICAL_SECTION)
Public Declare Sub InitializeCriticalSection Lib "kernel32" (lpCriticalSection As CRITICAL_SECTION)
Public Declare Sub LeaveCriticalSection Lib "kernel32" (lpCriticalSection As CRITICAL_SECTION)
Public Declare Function CreateIoCompletionPort Lib "kernel32" (ByVal FileHandle As Long, ByVal ExistingCompletionPort As Long, ByVal CompletionKey As Long, ByVal NumberOfConcurrentThreads As Long) As Long
Public Declare Function GetQueuedCompletionStatus Lib "kernel32" (ByVal CompletionPort As Long, ByRef lpNumberOfBytesTransferred As Long, ByRef lpCompletionKey As Long, ByRef lpOverlapped As Long, ByVal dwMilliseconds As Long) As Long
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
' 8B4424 04 mov eax, dword ptr [esp+4]
' 8B00 mov eax, dword ptr [eax]
' C2 0400 retn 4
Public Asmbin1(13) As Byte
'8B4424 04 mov eax, dword ptr [esp+4]
'0FB600 movzx eax, byte ptr [eax]
'C2 0400 retn 4
Public Asmbin2(13) As Byte
Public Const INVALID_HANDLE_VALUE = -1
Public Const INFINITE = &HFFFF
Public Type CRITICAL_SECTION
DebugInfo As Long
LockCount As Long
RecursionCount As Long
OwningThread As Long
LockSemaphore As Long
SpinCount As Long
End Type
Public Type OVERLAPPED
Internal As Long
InternalHigh As Long
Offset As Long
OffsetHigh As Long
hEvent As Long
End Type
Public Enum IOType
IOAccept
IOSend
IORecv
IORecvZero
IOClose
End Enum
Public Type ClientListStruct
tag As Long '保存数组索引
sck As Long '保存客户端socket
ip As Long '保存客户端IP
End Type
Public Type PerDataStruct
tag As Long '保存数组索引
ovlap As OVERLAPPED '这个结构初始化的时候要清零 (不知道是不是每次操作都要清零 反正我是每次投递操作都做了清零的)
operation As IOType '保存 IO操作类型
nLen As Long '保存数据长度
buf(1023) As Byte '数据缓冲区
End Type
Public FormLock As CRITICAL_SECTION '输出调试信息的所
Public Logcount As Long '调试信息总条数 数目太多就清空
Public Const MAX_PERBUFLEN = 1024 '单 IO数据 buf长度
Public PerDataCount As Long '剩余空闲 单IO数据 总数
Public Const MAX_PERDATACOUNT = 100000
Public ClientCount As Long '剩余空闲 客户端数据结构 总数
Public Const MAX_CLIENTCOUNT = 10000 '最大连接数
Public hIOCP As Long '完成端口句柄
Public hListenSck As Long '服务器监听socket
Public nThreadCount As Long '线程总数 这里还没用到
Public hThread(16) As Long '工作线程句柄
Public PerData() As PerDataStruct '单IO数据结构
Public Clientlist() As ClientListStruct '存储客户端信息的结果 包括客户端socket ip等
Public SendPackageCount As Long '发送数据包总数
Public RecvPackageCount As Long '接收数据包总数
Public SendBytesCount As Long '发送数据字节数
Public RecvBytesCount As Long '接收数据字节数
Sub Main()
Dim i As Long
InitializeCriticalSection FormLock
PerDataCount = MAX_PERDATACOUNT
ClientCount = MAX_CLIENTCOUNT
ReDim PerData(MAX_PERDATACOUNT)
ReDim Clientlist(MAX_CLIENTCOUNT)
Asmbin1(0) = &H8B
Asmbin1(1) = &H44
Asmbin1(2) = &H24
Asmbin1(3) = &H4
Asmbin1(4) = &H8B
Asmbin1(5) = &H0
Asmbin1(6) = &HC2
Asmbin1(7) = &H4
Asmbin1(8) = &H0
Asmbin2(0) = &H8B
Asmbin2(1) = &H44
Asmbin2(2) = &H24
Asmbin2(3) = &H4
Asmbin2(4) = &HF
Asmbin2(5) = &HB6
Asmbin2(6) = &H0
Asmbin2(7) = &HC2
Asmbin2(8) = &H4
Asmbin2(9) = &H0
'8B4424 04 mov eax, dword ptr [esp+4]
'8B00 mov eax, dword ptr [eax]
'C2 0400 retn 4
WriteProcessMemory -1, ByVal TmpGetAddr(AddressOf GetPointInt), Asmbin1(0), 9, i
'8B4424 04 mov eax, dword ptr [esp+4]
'0FB600 movzx eax, byte ptr [eax]
'C2 0400 retn 4
WriteProcessMemory -1, ByVal TmpGetAddr(AddressOf GetPointByte), Asmbin2(0), 10, i
Form1.Show
End Sub
Public Function Dbgprint(ByVal log As String) As Long '输出调试信息
EnterCriticalSection FormLock
Logcount = Logcount + 1
If Logcount >= 500 Then
Logcount = 0
Form1.txtText1.Text = ""
End If
Form1.txtText1.Text = log + vbNewLine + Form1.txtText1.Text
LeaveCriticalSection FormLock
End Function
Public Function NewPerData() As Long '分配1个空闲的单IO数据出来 返回的是空闲数据的数组 索引
Dim i As Long
Dim nRet As Long
For i = 1 To MAX_PERDATACOUNT
'tag=0 表示这个单元为空闲 可以分配出去 分配出去后 tag改成数组的索引
If PerData(i).tag = 0 Then
nRet = InterlockedCompareExchange(PerData(i).tag, i, 0) '这里作线程同步 不解释. 详见MSDN
'如果 nRet<> 0 则说明有人提前分配出去了 直接找下一个空闲的单元
If nRet = 0 Then
InterlockedDecrement PerDataCount
NewPerData = i
Exit Function
End If
End If
Next
NewPerData = -1
End Function
Public Function ReleasePerData(ByVal i As Long) As Long '回收释放数据 参数是数据数组索引
Dim nRet As Long
nRet = InterlockedCompareExchange(PerData(i).tag, 0, i) ',这里作线程同步 不解释.实际上这里不用线程同步应该也可以的
InterlockedIncrement PerDataCount '计数
End Function
Public Function NewClient() As Long '分配1个空闲的客户端数据出来 返回的是空闲数据的数组 索引
Dim i As Long
Dim nRet As Long
For i = 1 To MAX_CLIENTCOUNT
'所有注释同上
If Clientlist(i).tag = 0 Then
nRet = InterlockedCompareExchange(Clientlist(i).tag, i, 0)
If nRet = 0 Then
InterlockedDecrement ClientCount
NewClient = i
Exit Function
End If
End If
Next
NewClient = -1
End Function
Public Function ReleaseClient(ByVal i As Long) As Long '回收释放数据 参数是数据数组索引
Dim nRet As Long
closesocket Clientlist(i).sck '释放socket
' Dim ip As String
' ip = Str(GetPointByte(VarPtr(Clientlist(i).ip))) + "." + Str(GetPointByte(VarPtr(Clientlist(i).ip) + 1)) + "." + Str(GetPointByte(VarPtr(Clientlist(i).ip) + 2)) + "." + Str(GetPointByte(VarPtr(Clientlist(i).ip) + 3))
' Dbgprint ("IP" + ip + "断开 销毁内存" & i)
nRet = InterlockedCompareExchange(Clientlist(i).tag, 0, i)
InterlockedIncrement ClientCount
End Function
Public Function GetPointInt(ByVal p As Long) As Long '从一个指针返回长整形 这里会在初始化的时候进行硬编码 详见 sub main
Dim nRet As Long
CopyMemory nRet, ByVal p, 4
GetPointInt = nRet
End Function
Public Function GetPointByte(ByVal p As Long) As Byte '从一个指针返回字节型 这里会在初始化的时候进行硬编码 详见 sub main
Dim nRet As Long
CopyMemory nRet, ByVal p, 1
GetPointByte = nRet
End Function
Public Function CreateIOCP() As Long '创建一个IOCP端口
CreateIOCP = CreateIoCompletionPort(INVALID_HANDLE_VALUE, 0, -1, 0) '这个函数的参数有点复杂 详见 百度 GG MSDN
End Function
Public Function BindIOCP(ByVal h As Long, ByVal completKey) As Long '绑定一个句柄到IOCP h是要绑定的句柄 completKey是完成键
BindIOCP = CreateIoCompletionPort(h, hIOCP, completKey, 0)
End Function
Public Function Recv(ByVal s As Long, ByRef pPerData As PerDataStruct) As Long '投递一个WSARecv 参数 s是要投递的socket pPerData是要投递的单IO数据
Dim nRet As Long
Dim tmp As WSABUF
Dim nBytes As Long
Dim nFlag As Long
nFlag = 0
tmp.pBuf = VarPtr(pPerData.buf(0))
tmp.nLen = MAX_PERBUFLEN
'根据MSDN wsabuf 可以用临时变量 WSARecv 内部会复杂一份出去
'overlapp结构 清零
pPerData.ovlap.hEvent = 0
pPerData.ovlap.Internal = 0
pPerData.ovlap.InternalHigh = 0
pPerData.ovlap.Offset = 0
pPerData.ovlap.OffsetHigh = 0
pPerData.operation = IORecv '重点 operation是用来识别每次IO是什么操作的重要标志
nRet = WSARecv(s, tmp, 1, nBytes, nFlag, pPerData.ovlap, 0) '参数有点多 详见 百度 GG MSDN
If nRet = SOCKET_ERROR And Err.LastDllError <> WSA_IO_PENDING Then
Recv = -1
Else
Recv = 0
End If
End Function
Public Function Send(ByVal s As Long, ByRef pPerData As PerDataStruct) As Long '投递一个WSASend 参数 s是要投递的socket pPerData是要投递的单IO数据
Dim nRet As Long
Dim tmp As WSABUF
Dim nBytes As Long
Dim nFlag As Long
nFlag = 0
tmp.pBuf = VarPtr(pPerData.buf(0))
tmp.nLen = pPerData.nLen
pPerData.ovlap.hEvent = 0
pPerData.ovlap.Internal = 0
pPerData.ovlap.InternalHigh = 0
pPerData.ovlap.Offset = 0
pPerData.ovlap.OffsetHigh = 0
pPerData.operation = IOSend '''''注释同上
nRet = WSASend(s, tmp, 1, nBytes, nFlag, pPerData.ovlap, 0)
If nRet = SOCKET_ERROR And Err.LastDllError <> WSA_IO_PENDING Then
Send = -1
Else
Send = 0
End If
End Function
'独立开一个监听线程 实际情况中可能用不着开一个监听线程 可以直接在IOCP中投递一个AcceptEx 利用IOCP的来接受连接 这里偷懒 直接开一个线程来处理了
Public Function ListenFunc(ByVal s As Long) As Long
CreateIExprSrvObj 0, 4, 0
CoInitialize 0
Dim nRet As Long
Dim nClientIndex As Long
Dim nPerDataIndex As Long
Dim pOverlap As Long
Dim nBytes As Long
Dim nPerIndex As Long
Dim sAddr As sockaddr_in
Dim sAddrLen As Long
Dim ip As String
listen hListenSck, 100
Do While True
sAddrLen = 16
nRet = accept(hListenSck, sAddr, sAddrLen)
'/ip = Str(GetPointByte(VarPtr(sAddr.sin_addr))) + "." + Str(GetPointByte(VarPtr(sAddr.sin_addr) + 1)) + "." + Str(GetPointByte(VarPtr(sAddr.sin_addr) + 2)) + "." + Str(GetPointByte(VarPtr(sAddr.sin_addr) + 3))
If nRet = SOCKET_ERROR Then
Exit Do
End If
nClientIndex = NewClient() '分配一个内存
Clientlist(nClientIndex).ip = sAddr.sin_addr '保存IP
Clientlist(nClientIndex).sck = nRet '保存 接受的socket
'关联到IOCP中 这里我用数组的索引作完成建 当GQCS返回的时候 那里返回的 完成键 就是这里关联的数组索引 通过这数组索引就可以得到client数据 然后进行IO操作
CreateIoCompletionPort nRet, hIOCP, nClientIndex, 0
nPerDataIndex = NewPerData() '分配一个数据
'接受链接后 投递一个 WSARecv 等待数据 当收到数据的时候 WSARecv(s, tmp, 1, nBytes, nFlag, pPerData.ovlap, 0) 这里投递的信息以及收到的数据 会通过GQCS就会返回
nRet = Recv(Clientlist(nClientIndex).sck, PerData(nPerDataIndex))
If nRet = -1 Then
ReleaseClient (nClientIndex)
ReleasePerData (nPerDataIndex)
End If
Loop
CoUninitialize
End Function
'IOCP的工作线程 IOCP中最繁忙的就是这里了
Public Function WorkFunc(ByVal l As Long) As Long
CreateIExprSrvObj 0, 4, 0
CoInitialize 0
Dim nRet As Long
Dim ComKey As Long '完成键 是client数组的索引
Dim pOverlap As Long '一个指针 指向一个overlapped结构 这个结构是WSARecv或者WSASend投递进去的
Dim nBytes As Long '发送或者接受 处理了多少数据
Dim nPerIndex As Long '数据索引
Do While True
'这里参数也很多 详见 百度 GG MSDN
nRet = GetQueuedCompletionStatus(hIOCP, nBytes, ComKey, pOverlap, INFINITE)
'我们要得到我们投递的 IO数据信息 详见上面的 PerDataStruct 结构
'pOverlap指针 - 4 就是得到 tag成员 tag成员标识 的是数组索引
nPerIndex = GetPointInt(pOverlap - 4)
If nPerIndex <> -1 Then
'得到数组索引我们就可以看到我们的操作结果了 operation是标识我们做的是上面操作 在WSARecv 和WSASend中 填充
Select Case PerData(nPerIndex).operation
Case IOSend
nRet = -1
'如果数据长度是0 则说明断开连接了 当然 实际有多种情况 这里只做简单判断
If nBytes <> 0 Then
PerData(nPerIndex).nLen = MAX_PERBUFLEN
nRet = Recv(Clientlist(ComKey).sck, PerData(nPerIndex))
'如果投递失败( 返回-1) 则说明断开连接了 实际有多种情况 这里只做简单判断
InterlockedIncrement SendPackageCount
InterlockedExchangeAdd SendBytesCount, nBytes
End If
If nRet = -1 Then
ReleaseClient (ComKey)
ReleasePerData (nPerIndex)
End If
Case IORecv
nRet = -1
'如果数据长度是0 则说明断开连接了 当然 实际有多种情况 这里只做简单判断
If nBytes <> 0 Then
PerData(nPerIndex).nLen = nBytes
nRet = Send(Clientlist(ComKey).sck, PerData(nPerIndex))
'如果投递失败( 返回-1) 则说明断开连接了 实际有多种情况 这里只做简单判断
InterlockedIncrement RecvPackageCount
InterlockedExchangeAdd RecvBytesCount, nBytes
End If
If nRet = -1 Then
ReleaseClient (ComKey)
ReleasePerData (nPerIndex)
End If
End Select
End If
Loop '循环 得到下一个IO
CoUninitialize
End Function
Public Function TmpGetAddr(ByVal a) As Long
TmpGetAddr = a
End Function
Option Explicit
Public Declare Function WSAGetLastError Lib "ws2_32.dll" () As Long
Public Declare Function WSAStartup Lib "ws2_32.dll" (ByVal wVersionRequired As Long, lpWSADATA As WSAData) As Long
Public Declare Function WSACleanup Lib "ws2_32.dll" () As Long
Public Declare Function WSASocketA Lib "ws2_32.dll" (ByVal af As Long, ByVal ntype As Long, ByVal protocol As Long, ByVal lpProtocolInfo As Long, ByVal g As Long, ByVal dwFlags As Long) As Long
Public Declare Function WSASend Lib "ws2_32.dll" (ByVal s As Long, ByRef Buffers As WSABUF, ByVal dwBufferCount As Long, ByRef lpNumberOfBytesSent As Long, ByVal dwFlags As Long, lpOverlapped As OVERLAPPED, ByVal lpCompletionRoutine As Long) As Long
Public Declare Function WSARecv Lib "ws2_32.dll" (ByVal s As Long, ByRef Buffers As WSABUF, ByVal dwBufferCount As Long, ByRef lpNumberOfBytesSent As Long, ByRef dwFlags As Long, lpOverlapped As OVERLAPPED, ByVal lpCompletionRoutine As Long) As Long
Public Declare Function socket Lib "ws2_32.dll" (ByVal af As Long, ByVal s_type As Long, ByVal protocol As Long) As Long
Public Declare Function connect Lib "ws2_32.dll" (ByVal s As Long, ByRef name As sockaddr_in, ByVal namelen As Long) As Long
Public Declare Function bind Lib "ws2_32.dll" (ByVal s As Long, ByRef name As sockaddr_in, ByRef namelen As Long) As Long
Public Declare Function listen Lib "ws2_32.dll" (ByVal s As Long, ByVal backlog As Long) As Long
Public Declare Function accept Lib "ws2_32.dll" (ByVal s As Long, ByRef addr As sockaddr_in, ByRef addrlen As Long) As Long
Public Declare Function ioctlsocket Lib "ws2_32.dll" (ByVal s As Long, ByVal cmd As Long, ByRef argp As Long) As Long
Public Declare Function closesocket Lib "ws2_32.dll" (ByVal s As Long) As Long
''''''''''''
Public Declare Function getsockname Lib "ws2_32.dll" (ByVal s As Long, ByRef name As sockaddr_in, ByRef namelen As Long) As Long
Public Declare Function getpeername Lib "ws2_32.dll" (ByVal s As Long, ByRef name As sockaddr_in, ByRef namelen As Long) As Long
Public Declare Function gethostname Lib "ws2_32.dll" (ByVal host_name As String, ByVal namelen As Long) As Long
Public Declare Function gethostbyname Lib "ws2_32.dll" (ByVal host_name As String) As Long
Public Declare Function inet_addr Lib "ws2_32.dll" (ByVal cp As String) As Long
Public Declare Function inet_ntoa Lib "ws2_32.dll" (ByVal inn As Long) As Long
Public Declare Function htons Lib "ws2_32.dll" (ByVal hostshort As Integer) As Integer
Public Declare Function ntohs Lib "ws2_32.dll" (ByVal netshort As Integer) As Integer
Public Declare Function getsockopt Lib "ws2_32.dll" (ByVal s As Long, ByVal level As Long, ByVal optname As Long, optval As Any, optlen As Long) As Long
Public Declare Function setsockopt Lib "ws2_32.dll" (ByVal s As Long, ByVal level As Long, ByVal optname As Long, optval As Any, ByVal optlen As Long) As Long
Public Declare Function gethostbyaddr Lib "ws2_32.dll" (addr As Long, ByVal addr_len As Long, ByVal addr_type As Long) As Long
Public Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Any) As Long
Public Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As Long) As Long
Public Type WSABUF
nLen As Long ' /* the length of the buffer */
pBuf As Long '* the pointer to the buffer */
End Type
Public Const SOMAXCONN As Long = 5
Public Enum ProtocolConstants
sckTCPProtocol = 0
sckUDPProtocol = 1
End Enum
Public Const MSG_PEEK As Long = &H2
Public Const SOCKET_ERROR As Integer = -1
Public Const INVALID_SOCKET As Integer = -1
Public Const INADDR_NONE As Long = &HFFFF
Public Const WSADESCRIPTION_LEN As Integer = 257
Public Const WSASYS_STATUS_LEN As Integer = 129
Public Enum WinsockVersion
SOCKET_VERSION_11 = &H101
SOCKET_VERSION_22 = &H202
End Enum
Public Const MAXGETHOSTSTRUCT = 1024
Public Const AF_INET As Long = 2
Public Const SOCK_STREAM As Long = 1
Public Const SOCK_DGRAM As Long = 2
Public Const IPPROTO_TCP As Long = 6
Public Const IPPROTO_UDP As Long = 17
Public Const IPPROTO_IP As Long = 0
Public Const WSA_FLAG_OVERLAPPED As Long = &H1
Public Const OFFSET_2 = 65536
Public Const MAXINT_2 = 32767
Public Const LOCAL_HOST_BUFF As Integer = 256
Public Const SOL_SOCKET As Long = 65535
Public Const SO_SNDBUF As Long = &H1001&
Public Const SO_RCVBUF As Long = &H1002&
Public Const SO_MAX_MSG_SIZE As Long = &H2003
Public Const SO_BROADCAST As Long = &H20
Public Const FIONREAD As Long = &H4004667F
'==============================================================================
'ERROR CODES
'==============================================================================
Public Const WSA_IO_PENDING As Long = 997
Public Const WSABASEERR As Long = 10000
Public Const WSAEINTR As Long = (WSABASEERR + 4)
Public Const WSAEACCES As Long = (WSABASEERR + 13)
Public Const WSAEFAULT As Long = (WSABASEERR + 14)
Public Const WSAEINVAL As Long = (WSABASEERR + 22)
Public Const WSAEMFILE As Long = (WSABASEERR + 24)
Public Const WSAEWOULDBLOCK As Long = (WSABASEERR + 35)
Public Const WSAEINPROGRESS As Long = (WSABASEERR + 36)
Public Const WSAEALREADY As Long = (WSABASEERR + 37)
Public Const WSAENOTSOCK As Long = (WSABASEERR + 38)
Public Const WSAEDESTADDRREQ As Long = (WSABASEERR + 39)
Public Const WSAEMSGSIZE As Long = (WSABASEERR + 40)
Public Const WSAEPROTOTYPE As Long = (WSABASEERR + 41)
Public Const WSAENOPROTOOPT As Long = (WSABASEERR + 42)
Public Const WSAEPROTONOSUPPORT As Long = (WSABASEERR + 43)
Public Const WSAESOCKTNOSUPPORT As Long = (WSABASEERR + 44)
Public Const WSAEOPNOTSUPP As Long = (WSABASEERR + 45)
Public Const WSAEPFNOSUPPORT As Long = (WSABASEERR + 46)
Public Const WSAEAFNOSUPPORT As Long = (WSABASEERR + 47)
Public Const WSAEADDRINUSE As Long = (WSABASEERR + 48)
Public Const WSAEADDRNOTAVAIL As Long = (WSABASEERR + 49)
Public Const WSAENETDOWN As Long = (WSABASEERR + 50)
Public Const WSAENETUNREACH As Long = (WSABASEERR + 51)
Public Const WSAENETRESET As Long = (WSABASEERR + 52)
Public Const WSAECONNABORTED As Long = (WSABASEERR + 53)
Public Const WSAECONNRESET As Long = (WSABASEERR + 54)
Public Const WSAENOBUFS As Long = (WSABASEERR + 55)
Public Const WSAEISCONN As Long = (WSABASEERR + 56)
Public Const WSAENOTCONN As Long = (WSABASEERR + 57)
Public Const WSAESHUTDOWN As Long = (WSABASEERR + 58)
Public Const WSAETIMEDOUT As Long = (WSABASEERR + 60)
Public Const WSAEHOSTUNREACH As Long = (WSABASEERR + 65)
Public Const WSAECONNREFUSED As Long = (WSABASEERR + 61)
Public Const WSAEPROCLIM As Long = (WSABASEERR + 67)
Public Const WSASYSNOTREADY As Long = (WSABASEERR + 91)
Public Const WSAVERNOTSUPPORTED As Long = (WSABASEERR + 92)
Public Const WSANOTINITIALISED As Long = (WSABASEERR + 93)
Public Const WSAHOST_NOT_FOUND As Long = (WSABASEERR + 1001)
Public Const WSATRY_AGAIN As Long = (WSABASEERR + 1002)
Public Const WSANO_RECOVERY As Long = (WSABASEERR + 1003)
Public Const WSANO_DATA As Long = (WSABASEERR + 1004)
'==============================================================================
'WINSOCK CONTROL ERROR CODES
'==============================================================================
Public Const sckOutOfMemory = 7
Public Const sckBadState = 40006
Public Const sckInvalidArg = 40014
Public Const sckUnsupported = 40018
Public Const sckInvalidOp = 40020
'==============================================================================
'STRUCTURES
'==============================================================================
Public Type WSAData
wVersion As Integer
wHighVersion As Integer
szDescription As String * WSADESCRIPTION_LEN
szSystemStatus As String * WSASYS_STATUS_LEN
iMaxSockets As Integer
iMaxUdpDg As Integer
lpVendorInfo As Long
End Type
Public Type HOSTENT
hName As Long
hAliases As Long
hAddrType As Integer
hLength As Integer
hAddrList As Long
End Type
Public Type sockaddr_in
sin_family As Integer
sin_port As Integer
sin_addr As Long
sin_zero(1 To 8) As Byte
End Type
Public Function BindServerSocket(ByVal s As Long, ByVal port As Integer, ByVal ip As String) As Boolean
Dim nRet As Long
Dim sAddr As sockaddr_in
sAddr.sin_family = AF_INET
If ip <> "" Then
sAddr.sin_addr = inet_addr(ip)
Else
sAddr.sin_addr = 0
End If
sAddr.sin_port = htons(port)
nRet = bind(hListenSck, sAddr, LenB(sAddr))
If nRet = SOCKET_ERROR Then
BindServerSocket = False
Else
BindServerSocket = True
End If
End Function
Public Function CreateSocket() As Long
CreateSocket = WSASocketA(AF_INET, SOCK_STREAM, IPPROTO_IP, 0, 0, WSA_FLAG_OVERLAPPED)
End Function
Public Function Initsockdll() As Boolean
Dim tmp As WSAData
Dim nRet As Long
nRet = WSAStartup(SOCKET_VERSION_22, tmp)
If nRet <> 0 Then
Initsockdll = False
Else
Initsockdll = True
End If
End Function
Public Sub Releasesockdll()
Call WSACleanup
End Sub
Public Function GetErrorDescription(ByVal lngErrorCode As Long) As String
Select Case lngErrorCode
Case WSAEACCES
GetErrorDescription = "Permission denied."
Case WSAEADDRINUSE
GetErrorDescription = "Address already in use."
Case WSAEADDRNOTAVAIL
GetErrorDescription = "Cannot assign requested address."
Case WSAEAFNOSUPPORT
GetErrorDescription = "Address family not supported by protocol family."
Case WSAEALREADY
GetErrorDescription = "Operation already in progress."
Case WSAECONNABORTED
GetErrorDescription = "Software caused connection abort."
Case WSAECONNREFUSED
GetErrorDescription = "Connection refused."
Case WSAECONNRESET
GetErrorDescription = "Connection reset by peer."
Case WSAEDESTADDRREQ
GetErrorDescription = "Destination address required."
Case WSAEFAULT
GetErrorDescription = "Bad address."
Case WSAEHOSTUNREACH
GetErrorDescription = "No route to host."
Case WSAEINPROGRESS
GetErrorDescription = "Operation now in progress."
Case WSAEINTR
GetErrorDescription = "Interrupted function call."
Case WSAEINVAL
GetErrorDescription = "Invalid argument."
Case WSAEISCONN
GetErrorDescription = "Socket is already connected."
Case WSAEMFILE
GetErrorDescription = "Too many open files."
Case WSAEMSGSIZE
GetErrorDescription = "Message too long."
Case WSAENETDOWN
GetErrorDescription = "Network is down."
Case WSAENETRESET
GetErrorDescription = "Network dropped connection on reset."
Case WSAENETUNREACH
GetErrorDescription = "Network is unreachable."
Case WSAENOBUFS
GetErrorDescription = "No buffer space available."
Case WSAENOPROTOOPT
GetErrorDescription = "Bad protocol option."
Case WSAENOTCONN
GetErrorDescription = "Socket is not connected."
Case WSAENOTSOCK
GetErrorDescription = "Socket operation on nonsocket."
Case WSAEOPNOTSUPP
GetErrorDescription = "Operation not supported."
Case WSAEPFNOSUPPORT
GetErrorDescription = "Protocol family not supported."
Case WSAEPROCLIM
GetErrorDescription = "Too many processes."
Case WSAEPROTONOSUPPORT
GetErrorDescription = "Protocol not supported."
Case WSAEPROTOTYPE
GetErrorDescription = "Protocol wrong type for socket."
Case WSAESHUTDOWN
GetErrorDescription = "Cannot send after socket shutdown."
Case WSAESOCKTNOSUPPORT
GetErrorDescription = "Socket type not supported."
Case WSAETIMEDOUT
GetErrorDescription = "Connection timed out."
Case WSAEWOULDBLOCK
GetErrorDescription = "Resource temporarily unavailable."
Case WSAHOST_NOT_FOUND
GetErrorDescription = "Host not found."
Case WSANOTINITIALISED
GetErrorDescription = "Successful WSAStartup not yet performed."
Case WSANO_DATA
GetErrorDescription = "Valid name, no data record of requested type."
Case WSANO_RECOVERY
GetErrorDescription = "This is a nonrecoverable error."
Case WSASYSNOTREADY
GetErrorDescription = "Network subsystem is unavailable."
Case WSATRY_AGAIN
GetErrorDescription = "Nonauthoritative host not found."
Case WSAVERNOTSUPPORTED
GetErrorDescription = "Winsock.dll version out of range."
Case Else
GetErrorDescription = "Unknown error."
End Select
End Function
ThreadMod.bas
Code:
Option Explicit
Public Declare Function CreateThread Lib "kernel32" (ByVal lpThreadA As Long, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, ByVal lpParameter As Long, ByVal dwCreationFlags As Long, lpThreadId As Long) As Long
Public Declare Function WriteProcessMemory Lib "kernel32" (ByVal hProcess As Long, lpBaseAddress As Any, lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
Public Declare Function TerminateThread Lib "kernel32" (ByVal hThread As Long, ByVal dwExitCode As Long) As Long
Public Declare Function CoInitialize Lib "ole32.dll" (ByVal pvReserved As Long) As Long
Public Declare Sub CoUninitialize Lib "ole32.dll" ()
Public Declare Function CreateIExprSrvObj Lib "msvbvm60.dll" (ByVal p1_0 As Long, ByVal p2_4 As Long, ByVal p3_0 As Long) As Long
Like yourself, I have been quite interested in enabling a server to be able to service multiple connections efficiently. My own SimpleServer is adequate, but it has limitations when trying to service multiple connections. With multi-core CPUs being very common these days, using multiple threads only makes sense. Because managing multiple threads is not easily handled by VB6, I have pretty much steered clear of it in the past, but maybe it is time to take another look at it.
One problem that surfaced very quickly was that when the program was exited, the listening socket was left open. This caused a "Bind" error the next time the program was attempted to be run. Adding "Releasesockdll" to the form unload solved that.
Yes, if you multithread a URL task with hundreds of thousands of lines in a text file, 10 threads open 10 URLs in different locations. Uch as 102, 105, and 106. If they are closed carelessly or manually, these records need to be reprocessed next time. These are some of the troublesome things about multithreading.
When attempting to transfer a 66,956 byte file to the server, it stops after 29,725 bytes. I believe this is caused by the client closing the connection after sending the data. A socket connection normally enters a CLOSE_WAIT state when the client closes the connection, but obviously the threaded version does not. If I delay the closing of the client connection, the full 66,956 bytes gets received.
Just like winsock control, there should be a way to know whether the transmission is successful or not
By using a Packet Viewer, I found that this program was sending the same thing back to the client. The reason the program stopped receiving was that the client was not recovering any of those packets, and when it closed the socket, the server detected that and stopped receiving. It became very obvious that the intention of this program was to stress test IOCP, rather than actually sending and recovering data.
My attempts to fix the program have not met with success. When I remove the "Send" instruction from the WorkFunc routine, the program drops the last record, and I have not been able to figure out why.
maybe yor are right.
if you want to send data and receive,will not lost data,you need add some code for check ,like
Code:
Private Sub Winsock1_SendComplete()
End Sub
The data is being sent. the last record is just not being recovered by the server, and it is difficult to figure out what the worker function is doing. It is entered and exited multiple times.
Most of the examples I could find were in C++, and virtually all of them were what they called "Echo Servers". So I was left with the good old trial & error method. Removing the "Send" from "Case IORecv" did not work. Setting the buffer length to 0 also did not work. Setting the buffer length to 1 sort of worked. However, an additional record consisting of the last record and part of the second last record were received. Using a buffer length of 1, and clearing the buffer seemed to produce a more accurate result
Code:
Case IORecv
nRet = -1
If nBytes <> 0 Then
PerData(nPerIndex).nLen = nBytes
Debug.Print Utf8ToStr(PerData(nPerIndex).buf)
Erase PerData(nPerIndex).buf
PerData(nPerIndex).nLen = 1
nRet = Send(Clientlist(ComKey).sck, PerData(nPerIndex))
'There are actually many situations. Here we only make a simple judgment.
InterlockedIncrement RecvPackageCount
InterlockedExchangeAdd RecvBytesCount, nBytes
End If
If nRet = -1 Then
ReleaseClient (ComKey)
ReleasePerData (nPerIndex)
End If
Why on earth would it need an echo record to work?
'Wait for I/O to complete on any socket associated with the completion port
nRet = GetQueuedCompletionStatus(hIOCP, nBytes, ComKey, pOverlap, INFINITE)
'Get array index
nPerIndex = GetPointInt(pOverlap - 4)
If nPerIndex <> -1 Then
'Service the completed I/O request. You can determine which I/O request has just
'completed by looking at the OperationType field contained in the per-I/O operation data.
Select Case PerData(nPerIndex).operation
Case IORecv
If nBytes = 0 Then
'A zero BytesTransferred indicates that the socket has been closed by the peer, so
'you should close the socket. Note: Per-handle data was used to reference the
'socket associated with the I/O operation.
nRet = -1
Else
PerData(nPerIndex).nLen = nBytes
Dbgprint Utf8ToStr(PerData(nPerIndex).buf)
nRet = Recv(Clientlist(ComKey).sck, PerData(nPerIndex))
InterlockedIncrement RecvPackageCount
InterlockedExchangeAdd RecvBytesCount, nBytes
End If
End Select
If nRet = -1 Then 'The sender disconnected.
ReleaseClient (ComKey)
ReleasePerData (nPerIndex)
End If
End If
To say that it simplified the process would be a gross overstatement, but at least it got me on the right track. The posting of a send or receive simply appears to enable the thread to react to the actual send or receive.
Programmers are indeed very lonely because what you say is difficult for others to understand.
This source code was reposted by me, and I am not sure what its ultimate purpose is and whether it can be used in commercial engineering.
Pudn is another research life-saving path under the business model of CSDN, where I often lose contact with GitHub in China. My ideas 1, 2, and 3, which I am about to modify, are all inspired by the initial code of Pudn. I haven't written any new research code for more than half a year, and I am so sad to find that the website is gone. Other floors have also written about intellectual property issues, and everyone has opened them up in various ways with the purpose of sharing. Domestic GitHub is often affected by domain names and cannot enter, so there will be some movement on Pudn. This is understandable, and it is always more emotional than the fee code transferred on CSdn. The excellent search function of Pudn has really helped me a lot. When I saw the first floor, it seemed like the webmaster was speaking, and it was a pity to close the website. Today, through searching, I found that many local websites have been stopped. We need a good online environment, and we also hope everyone can do their best, so as not to let kindness chill their hearts
I finally figured out how to start a Send function. The Recv function is triggered by the incoming packet, but I was having difficulty in starting the Send.
Code:
Private Sub Command1_Click()
Dim bMsg() As Byte
Dim bLen As Long
Dim pPerData(1) As PerDataStruct
bLen = 12
bMsg = StrToUtf8("Hello World!")
pPerData(1).buf(0) = 1
pPerData(1).buf(1) = 3
pPerData(1).buf(2) = 3
pPerData(1).buf(4) = bLen
CopyMemory pPerData(1).buf(5), bMsg(0), bLen
pPerData(1).nLen = bLen + 5
bLen = Send(Clientlist(1).sck, pPerData(1))
End Sub
In this case, the client required a 5 byte header. The client establishes the connection, and the server must then be instructed to send the first packet. Once the first packet is sent, it will carry on with the rest of the record using the Worker thread.
Which brings up another question. Winsock 1 used to default to a packet size of 4K bytes. In this case the term "packet" is not being used to describe the network packet size (MTU size), but rather the packet returned by Winsock (buffer size). Winsock 2 appears to default to 64K. This leaves me in a quandary as to what the best size is for the IOCP buffer. 1K seems a bit low, unless the small size is more efficient for a large number of connections.
There is no best size on TCP/IP layer because MTU depends on underlying (think ethernet) physical layer which might use jumbo packets or SPF+ optical cables (instead of copper) which have different defaults.
There is no best size on TCP/IP layer because MTU depends on underlying (think ethernet) physical layer which might use jumbo packets or SPF+ optical cables (instead of copper) which have different defaults.
I have long said that Ethernet MTU size is about 1500 bytes. In actual fact it is 28 bytes less, or 1472 bytes, which accounts for the overhead that accompanies each MTU packet. You can test your own network router by issuing the following command from the Command Prompt:
ping 192.168.x.x -f -l 1472
with the address being that of the router. Adjusting the last number will show you where the limit is. The overhead data is used by the router to make sure the packets are reassembled in the correct order after fragmentation. Packets that are fragmented are slightly slower than non-fragmented packets, but these days that is not much of an issue.
But MTU size has little to do with what Winsock reports back to the operating system. As long as the data comes in at a sufficient speed, Winsock will report back once its buffer is full, or after a timeout. With Winsock 1, the default is 4,096 bytes (4K). With Winsock 2, the default is 65,536 bytes (64K). I do not know if Winsock is capable of reassembling packets should they comes in out of order. I suspect that it is not capable, as some IOCP writeups suggest that it could be a problem. Those same writeups also suggest that buffer size should be adjusted for the intended application, which is the reason for my question. My intended application is file transfer.
J.A. Coutts
Last edited by couttsj; Apr 12th, 2023 at 01:08 PM.
Reply With Quote
Originally Posted by SearchingDataOnly
