Option Explicit

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Private Declare Function ZCompress Lib "zlib.dll" Alias "compress" (dest As Any, destLen As Any, src As Any, ByVal srcLen As Long) As Long
Private Declare Function ZUncompress Lib "zlib.dll" Alias "uncompress" (dest As Any, destLen As Any, src As Any, ByVal srcLen As Long) As Long

Public Function Compress(Data, Optional Key)
   Dim lKey As Long  'original size
   Dim sTmp As String  'string buffer
   Dim bData() As Byte  'data buffer
   Dim bRet() As Byte  'output buffer
   Dim lCSz As Long  'compressed size
   
   If TypeName(Data) = "Byte()" Then 'if given byte array data
      bData = Data  'copy to data buffer
   ElseIf TypeName(Data) = "String" Then 'if given string data
      If Len(Data) > 0 Then 'if there is data
         sTmp = Data 'copy to string buffer
         ReDim bData(Len(sTmp) - 1) 'allocate data buffer
         CopyMemory bData(0), ByVal sTmp, Len(sTmp) 'copy to data buffer
         sTmp = vbNullString 'deallocate string buffer
      End If
   End If
   If StrPtr(bData) <> 0 Then 'if data buffer contains data
      lKey = UBound(bData) + 1 'get data size
      lCSz = lKey + (lKey * 0.01) + 12 'estimate compressed size
      ReDim bRet(lCSz - 1) 'allocate output buffer
      Call ZCompress(bRet(0), lCSz, bData(0), lKey) 'compress data (lCSz returns actual size)
      ReDim Preserve bRet(lCSz - 1) 'resize output buffer to actual size
      Erase bData 'deallocate data buffer
      If IsMissing(Key) Then 'if Key variable not supplied
         ReDim bData(lCSz + 3) 'allocate data buffer
         CopyMemory bData(0), lKey, 4 'copy key to buffer
         CopyMemory bData(4), bRet(0), lCSz 'copy data to buffer
         Erase bRet 'deallocate output buffer
         bRet = bData 'copy to output buffer
         Erase bData 'deallocate data buffer
      Else 'Key variable is supplied
         Key = lKey 'set Key variable
      End If
      If TypeName(Data) = "Byte()" Then 'if given byte array data
         Compress = bRet 'return output buffer
      ElseIf TypeName(Data) = "String" Then 'if given string data
         sTmp = Space(UBound(bRet) + 1) 'allocate string buffer
         CopyMemory ByVal sTmp, bRet(0), UBound(bRet) + 1 'copy to string buffer
         Compress = sTmp 'return string buffer
         sTmp = vbNullString 'deallocate string buffer
      End If
      Erase bRet 'deallocate output buffer
   End If
End Function

Public Function Uncompress(Data, Optional ByVal Key)
   Dim lKey As Long  'original size
   Dim sTmp As String  'string buffer
   Dim bData() As Byte  'data buffer
   Dim bRet() As Byte  'output buffer
   Dim lCSz As Long  'compressed size
   
   If TypeName(Data) = "Byte()" Then 'if given byte array data
      bData = Data 'copy to data buffer
   ElseIf TypeName(Data) = "String" Then 'if given string data
      If Len(Data) > 0 Then 'if there is data
         sTmp = Data 'copy to string buffer
         ReDim bData(Len(sTmp) - 1) 'allocate data buffer
         CopyMemory bData(0), ByVal sTmp, Len(sTmp) 'copy to data buffer
         sTmp = vbNullString 'deallocate string buffer
      End If
   End If
   If StrPtr(bData) <> 0 Then 'if there is data
      If IsMissing(Key) Then 'if Key variable not supplied
         lCSz = UBound(bData) - 3 'get actual data size
         CopyMemory lKey, bData(0), 4 'copy key value to key
         ReDim bRet(lCSz - 1) 'allocate output buffer
         CopyMemory bRet(0), bData(4), lCSz 'copy data to output buffer
         Erase bData 'deallocate data buffer
         bData = bRet 'copy to data buffer
         Erase bRet 'deallocate output buffer
      Else 'Key variable is supplied
         lCSz = UBound(bData) + 1 'get data size
         lKey = Key 'get Key
      End If
      ReDim bRet(lKey - 1) 'allocate output buffer
      Call ZUncompress(bRet(0), lKey, bData(0), lCSz) 'decompress to output buffer
      Erase bData 'deallocate data buffer
      If TypeName(Data) = "Byte()" Then 'if given byte array data
         Uncompress = bRet 'return output buffer
      ElseIf TypeName(Data) = "String" Then 'if given string data
         sTmp = Space(lKey) 'allocate string buffer
         CopyMemory ByVal sTmp, bRet(0), lKey 'copy to string buffer
         Uncompress = sTmp 'return string buffer
         sTmp = vbNullString 'deallocate string buffer
      End If
      Erase bRet 'deallocate return buffer
   End If
End Function

Sub SendQueuedData()
Dim ECloc As Integer
Dim lR As Long

  Dim i As Integer, N As Long
  Dim TmpStr As String
 
  For i = 1 To MAX_PLAYERS
    If frmServer.lblOnOff.Caption = "OFFLINE" Then Exit Sub
    TmpStr = ""
    With ConQueues(i)
      If Not .Lock Then
        If frmServer.Socket(i).State <> 7 Then
          .Lines = ""
        End If
        If Len(.Lines) = 0 And QueueDisconnect(i) = True Then
          Call CloseSocket(i)
          QueueDisconnect(i) = False
        Else
          If Len(.Lines) > 0 Then
             If Len(.Lines) < MAX_PACKETLEN Then
               TmpStr = .Lines
             Else
               TmpStr = Left(.Lines, MAX_PACKETLEN)
             End If
             ECloc = InStr(1, .Lines, END_CHAR)
             TmpStr = Left(.Lines, ECloc)
             .Lines = Right(.Lines, Len(.Lines) - Len(TmpStr))
          End If
        End If
        If Len(TmpStr) > 0 Then
             Debug.Print "Sending: " & TmpStr
             TmpStr = Compress(TmpStr, lR)
             TmpStr = lR & SEP_CHAR & TmpStr
             Call frmServer.Socket(i).SendData(TmpStr)
        End If
      End If
    End With
    DoEvents
  Next
End Sub

Sub IncomingData(ByVal Index As Long, ByVal DataLength As Long)
Dim Buffer As String
Dim Packet As String
Dim top As String * 3
Dim Start As Integer
Dim lR As Long
Dim Sploc As Integer
    If Index > 0 Then
        frmServer.Socket(Index).GetData Buffer, vbString, DataLength
       
        Sploc = InStr(1, Buffer, SEP_CHAR)
             lR = Mid(Buffer, 1, Sploc - 1)
             Buffer = Mid(Buffer, Sploc + 1, Len(Buffer) - Sploc)
             'Debug.Print lR & vbCrLf & "Parse(1):" & vbCrLf & Buffer & vbCrLf & "Buffer:"
             Buffer = Uncompress(Buffer, lR)
        Debug.Print Buffer
        If Buffer = "top" Then
             top = STR(TotalOnlinePlayers)
             Call SendDataTo(Index, top)
             QueueDisconnect(Index) = True
        End If
             
        Player(Index).Buffer = Player(Index).Buffer & Buffer
       
        Start = InStr(Player(Index).Buffer, END_CHAR)
        Do While Start > 0
             Packet = Mid(Player(Index).Buffer, 1, Start - 1)
             Player(Index).Buffer = Mid(Player(Index).Buffer, Start + 1, Len(Player(Index).Buffer))
             Player(Index).DataPackets = Player(Index).DataPackets + 1
             Start = InStr(Player(Index).Buffer, END_CHAR)
             If Len(Packet) > 0 Then
                 Call HandleData(Index, Packet)
             End If
        Loop
                 
        ' Check if elapsed time has passed
        Player(Index).DataBytes = Player(Index).DataBytes + DataLength
        If GetTickCount >= Player(Index).DataTimer + 1000 Then
             Player(Index).DataTimer = GetTickCount
             Player(Index).DataBytes = 0
             Player(Index).DataPackets = 0
             Exit Sub
        End If
       
        ' Check for data flooding
        If Player(Index).DataBytes > 1000 And GetPlayerAccess(Index) <= 0 Then
             Call HackingAttempt(Index, "Data Flooding")
             Exit Sub
        End If
       
        ' Check for packet flooding
        If Player(Index).DataPackets > 25 And GetPlayerAccess(Index) <= 0 Then
             Call HackingAttempt(Index, "Packet Flooding")
             Exit Sub
        End If
    End If
End Sub

Sub IncomingData(ByVal DataLength As Long)
Dim Buffer As String
Dim Packet As String
Dim Top As String * 3
Dim Start As Integer
Dim Sploc As Integer
Dim lR As Long

    frmMirage.Socket.GetData Buffer, vbString, DataLength
    Sploc = InStr(1, Buffer, SEP_CHAR)
        lR = Mid(Buffer, 1, Sploc - 1)
        Buffer = Mid(Buffer, Sploc + 1, Len(Buffer) - Sploc)
        Debug.Print lR & vbCrLf & "Parse(1):" & vbCrLf & Buffer & vbCrLf & "Buffer:"
        Buffer = Uncompress(Buffer, lR)
    PlayerBuffer = PlayerBuffer & Buffer
       
    Start = InStr(PlayerBuffer, END_CHAR)
    Do While Start > 0
        Packet = Mid(PlayerBuffer, 1, Start - 1)
        PlayerBuffer = Mid(PlayerBuffer, Start + 1, Len(PlayerBuffer))
        Start = InStr(PlayerBuffer, END_CHAR)
        If Len(Packet) > 0 Then
             Call HandleData(Packet)
        End If
    Loop
End Sub

Sub SendData(ByVal Data As String)
Dim lR As Long
    Debug.Print Data
    If IsConnected Then
        Data = Compress(Data, lR)
             Data = lR & SEP_CHAR & Data
             frmMirage.Socket.SendData Data
        DoEvents
    End If
End Sub