Помогите перевести функцию с PHP на VB

[SeT]

Сама функция вот:

Код: Выделить всё

function GetServerInfo($server,$port) {
     $fp = fsockopen("udp://".$server, $port);
     if (!$fp) die("Ошибка сокетов");
     @fwrite($fp,"\xFF\xFF\xFF\xFF\x54\x53\x6F\x75\x72\x63\x65\x20\x  45\x6E\x67\x69\x6E\x65\x20\x51\x75\x65\x72\x79\x00  ".chr(10));
     $start=time();
     socket_set_timeout($fp,1);
     $st=fread($fp,1);
     $r=socket_get_status($fp);
     $r=$r["unread_bytes"];
     if ($r == 0) { @fclose($fp); return false;}
     $st.=fread($fp,$r);
     @fclose($fp);
     $st=substr($st,5);
     $address=SubStr($st,0,StrPos($st,chr(0)));
     $address=str_replace(chr(0),"|",$address);
     $st=SubStr($st,StrPos($st,chr(0))+1);
     $name=SubStr($st,0,StrPos($st,chr(0)));
     $st=SubStr($st,StrPos($st,chr(0))+1);
     $map=SubStr($st,0,StrPos($st,chr(0)));
     $st=SubStr($st,StrPos($st,chr(0))+1);
     $st=SubStr($st,StrPos($st,chr(0))+1);
     $st=SubStr($st,StrPos($st,chr(0))+1);
     $current=ord(SubStr($st,0,1));
     $max=ord(SubStr($st,1,1));
     if ($map == "") return false;
     $result['map'] = $map;
     $result['name']= $name;
     $result['current'] = $current;
     $result['max'] = $max;
     return $result;
}

Смысл функции - коннект к КС-серверу с запросом. В зависимости от запроса выдаются разные параметры. В принципе коннект осуществляется через сокеты, да и строку распарсить смогу. А как обратиться к серверу по протоколу UDP?

[alibek]

Выбери протокол UDP.

[SeT]

Я использую контрол дашарма. В нем нет выбора протокола.
Напиши компонент с поддержкой такого протокола (ctl желательно)

[iGrok]

Ну возьми обычный винсок - он поддерживает.

[SeT]

Обычный винсок молчит как partizanen, не реагируя ни на какое внутреннее событие

Код: Выделить всё

Private Sub Form_Load()

    T1.Connect "77.220.180.147", 27017
    T1.SendData "\xFF\xFF\xFF\xFF\x54\x53\x6F\x75\x72\x63\x65\x20\x  45\x6E\x67\x69\x6E\x65\x20\x51\x75\x65\x72\x79\x00  " + Chr(10)
   
End Sub

Private Sub Form_Unload(Cancel As Integer)
    T1.Close
End Sub

Private Sub T1_DataArrival(ByVal bytesTotal As Long)
MsgBox T1.GetData
End Sub

Private Sub T1_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
    MsgBox Description
End Sub

Private Sub T1_SendComplete()
MsgBox "Отправили!"
End Sub

Private Sub T1_SendProgress(ByVal bytesSent As Long, ByVal bytesRemaining As Long)
MsgBox "отправляем"
End Sub

[JohnK]

А так попробуй:

Код: Выделить всё

f=chr$(255)
....
ws.protocol=sckUDPProtocol
ws.remotehost="Твой сервак"
ws.remoteport=27015
...
ws.senddata f&f&f&f& "infostring" & chr$(0)
ws.senddata f&f&f&f& "Tsource Engine Query" &  chr$(0)


Дальше парсишь, думаю протокол ты нашел...

[SeT]

всё равно молчит

[djalex777]

Обычный винсок молчит как partizanen, не реагируя ни на какое внутреннее событие

Код: Выделить всё

Private Sub Form_Load()

    T1.Connect "77.220.180.147", 27017
    T1.SendData "\xFF\xFF\xFF\xFF\x54\x53\x6F\x75\x72\x63\x65\x20\x  45\x6E\x67\x69\x6E\x65\x20\x51\x75\x65\x72\x79\x00  " + Chr(10)
   
End Sub

Private Sub Form_Unload(Cancel As Integer)
    T1.Close
End Sub

Private Sub T1_DataArrival(ByVal bytesTotal As Long)
MsgBox T1.GetData
End Sub

Private Sub T1_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
    MsgBox Description
End Sub

Private Sub T1_SendComplete()
MsgBox "Отправили!"
End Sub

Private Sub T1_SendProgress(ByVal bytesSent As Long, ByVal bytesRemaining As Long)
MsgBox "отправляем"
End Sub

Я так понимаю коннект происходит (т.е. T1.Connect выполнено успешно). А вот это что??

Код: Выделить всё

T1.SendData "\xFF\xFF\xFF\xFF\x54\x53\x6F\x75\x72\x63\x65\x20\x  45\x6E\x67\x69\x6E\x65\x20\x51\x75\x65\x72\x79\x00  " + Chr(10)


Это нисколько не тоже самое что

Код: Выделить всё

@fwrite($fp,"\xFF\xFF\xFF\xFF\x54\x53\x6F\x75\x72\x63\x65\x20\x  45\x6E\x67\x69\x6E\x65\x20\x51\x75\x65\x72\x79\x00  ".chr(10));

Тебе экранирование ни о чем не говорит?

[JohnK]

Странно, потому как у меня этот код (МОЙ) в локалке работает. Сервер CS 1.6

[SeT]

ок, сделал

Код: Выделить всё

ws.SendData Chr$(255) & Chr$(255) & Chr$(255) & Chr$(255) & Chr$(84) & Chr$(83) & Chr$(111) & _
Chr$(117) & Chr$(114) & Chr$(99) & Chr$(101) & Chr$(32) & " " & Chr$(69) & Chr$(110) & Chr$(103) & _
Chr$(105) & Chr$(110) & Chr$(101) & Chr$(32) & Chr$(81) & Chr$(117) & Chr$(101) & Chr$(114) & _
Chr$(121) & "  " & Chr$(10)

приходят лишь вопросительные знаки

JohnK, покажи, как парсинг делаешь

[JohnK]

А почему ты явно строку не шлешь? Так как это UDP, попробуй по таймауту послать еще запрос. У меня тоже не всегда приходит ответ с сервера.

[SeT]

ок, могу и напрямую:

'яяяяgetchallenge valve'; //Используеться для определения наличия серверана!!!
'яяяяinfostring'; //получаем информацию о сервере (кол. игроков, ботов, карта и.т.д)
'яяяяTSource Engine Query.';
'яяяяdetails'; //тожесамое что и SendData2 только для CS Steam
'яяяяping'; //используеться для определения времени отклика сервера
'яяяяplayers'; //Список ников играющих

Осталось распарсить получаемые данные. Вот тут у меня ступор

[SeT]

м. во: как перевести набор шестнадцатеричных данных в читабельный текст?

[JohnK]

Писал давно, поэтому без оптимизации:

Код: Выделить всё

Private Sub WS_DataArrival(ByVal bytesTotal As Long)
Dim str As String * 255
Dim ret() As Byte
On Error Resume Next

ReDim ret(bytesTotal)
WS.GetData ret()
Call Parse_CS_Response(ret())
End Sub

Private Sub Parse_CS_Response(sd1() As Byte)
Dim str2 As String
Dim jjj() As String
str2 = TranslateIntoStr(sd1())
If Mid(str2, 1, 4) = Chr(255) & Chr(255) & Chr(255) & Chr(255) Then

  If InStr(1, str2, "infostringresponse") Then
   jjj = Split(str2, "\")
    If UBound(jjj()) > 1 Then
     Text2.Text = Text2.Text & "Address: " & jjj(4) & vbCrLf
     Text2.Text = Text2.Text & "players: " & jjj(6) & vbCrLf
     Text2.Text = Text2.Text & "max: " & jjj(12) & vbCrLf
     Text2.Text = Text2.Text & "name: " & jjj(20) & vbCrLf
     Text2.Text = Text2.Text & "map: " & jjj(22) & vbCrLf
     WS.RemoteHost = Mid(jjj(4), 1, InStr(1, jjj(4), ":"))
     WS.SendData Chr$(255) & Chr$(255) & Chr$(255) & Chr$(255) & "players" & Chr$(0)
    End If
   
    ElseIf InStr(1, str2, "j") Then
     Text2.Text = Text2.Text & "ping: " & vbCrLf
   
    ElseIf InStr(1, str2, "players") Then
     Text2.Text = Text2.Text & "players: " & vbCrLf
 
  End If

End If

Private Function TranslateIntoStr(sd() As Byte) As String
Dim i As Long
TranslateIntoStr = ""
For i = 0 To UBound(sd())
  If sd(i) = 0 Then
   TranslateIntoStr = TranslateIntoStr & vbCrLf
    Else
   TranslateIntoStr = TranslateIntoStr & Chr(sd(i))
  End If
Next i
End Function
End Sub


Последнюю можно заменить на:

Код: Выделить всё

Public Sub Copy_Bytes2Str(sB() As Byte, sS As String)
sS = StrConv(sB(), vbUnicode)
End Sub


[Хакер]

шестнадцатеричных данных

Таких не бывает.

[SeT]

посидел, пофтыкал протокол. Вот что вышло:

Код: Выделить всё

Private Sub Command2_Click()
    f = Chr$(255)
    ws.SendData f & f & f & f & "U" & Chr$(65) & Chr$(54) & Chr$(80) & Chr$(99) & Chr$(7) & Chr$(0)
End Sub

Private Sub Command3_Click()
    f = Chr$(255)
    ws.SendData f & f & f & f & Chr$(87) & Chr$(0)
End Sub

Private Sub Command4_Click()
    f = Chr$(255)
    ws.SendData f & f & f & f & "ping" & Chr$(0)
End Sub

Private Sub Command5_Click()
    MsgBox Chr$(Text3.text)
    Text3 = ""
End Sub

Private Sub WS_DataArrival(ByVal bytesTotal As Long)
Dim str As String * 255
Dim ret() As Byte
'On Error Resume Next

ReDim ret(bytesTotal)
ws.GetData ret()
Call Parse_CS_Response(ret())
End Sub

Private Sub Parse_CS_Response(sd1() As Byte)
Dim str2 As String
Dim jjj() As String
Dim i As Long


str2 = TranslateIntoStr(sd1)
Text2 = str2
jjj = Split(str2, vbNewLine)
Text1.text = ""

If jjj(0) = "m" Then
     Text1.text = Text1.text & "Адрес: " & jjj(1) & vbCrLf
     Text1.text = Text1.text & "Название: " & jjj(2) & vbCrLf
     Text1.text = Text1.text & "Карта: " & jjj(3) & vbCrLf
     Text1.text = Text1.text & "Игроков: " & jjj(6) & "/" & jjj(7) & vbCrLf
     
ElseIf jjj(0) = "j" Then
     Text1.text = Text1.text & "Сервер доступен " & vbCrLf
     
ElseIf jjj(0) = "D" Then
    For i = 1 To UBound(jjj) Step 2
        If jjj(i) <> "" Then Text1.text = Text1.text & jjj(i) & " [" & jjj(i + 1) & "]" & vbCrLf
    Next i
End If
   
End Sub

Private Function TranslateIntoStr(sd() As Byte) As String
    Dim i, s As Long
    Dim v, x As Integer
   
    TranslateIntoStr = ""
    'MsgBox Chr$(sd(4))
    If Chr$(sd(4)) = "m" Then
        TranslateIntoStr = "m" & vbCrLf
        For i = 5 To UBound(sd)
            If sd(i) = 0 Then
                TranslateIntoStr = TranslateIntoStr & vbCrLf
                s = s + 1
            Else
                If s = 5 Or s = 6 Then
                    TranslateIntoStr = TranslateIntoStr & sd(i) & vbCrLf
                    s = s + 1
                Else
                    TranslateIntoStr = TranslateIntoStr & Chr$(sd(i))
                End If
            End If
        Next i
   
    ElseIf Chr$(sd(4)) = "j" Then
        TranslateIntoStr = "j" & vbCrLf
   
    ElseIf Chr$(sd(4)) = "D" Then
        TranslateIntoStr = "D" & vbCrLf
        v = 7
        For i = 7 To UBound(sd)
       
            If sd(i) = 0 And sd(i - 1) = 0 And sd(i - 2) = 0 And sd(i - 4) = 0 Then
                                   
                For x = v To i - 5
                    TranslateIntoStr = TranslateIntoStr & Chr$(sd(x))
                Next x
                TranslateIntoStr = TranslateIntoStr & vbNewLine & sd(i - 3) & vbNewLine
                i = i + 6
                v = i
            End If
        Next i
   
    Else
        For i = 5 To UBound(sd)
            TranslateIntoStr = TranslateIntoStr & Chr$(sd(i))
        Next i
    End If
   
End Function


т.о. скрипт обрабатывает команды ping, players и Тquery