FreeBasic

Получение точного времени по протоколу NTP/SNTP

Платформа: Windows
Автор: ShadEx

#INCLUDE Once "win/winsock2.bi"

Function get_NTP_sec(ntpServ As Zstring, ntpPort As Integer = 123, cu_sec As Byte = 0) As Uinteger
    If(Len(ntpServ) < 5 Or Instr(ntpServ, ".") = 0) Then
        ntpServ = "pool.ntp.org" '"193.27.209.1"
    Endif
    Dim tdiff_ns2us As Uinteger = 2208988800

    Dim wsa_ptr As WSAData

    If WSAStartup(MAKEWORD(2, 0), @wsa_ptr) = SOCKET_ERROR Then
        Return 0
    End If

    If(wsa_ptr.wVersion <> MAKEWORD(2, 0)) Then
        WSACleanup()
        Return 0
    End If

    Dim sock As socket

    sock = OpenSocket(AF_INET, SOCK_DGRAM, IPPROTO_UDP)
    If(sock = INVALID_SOCKET) Then
        WSACleanup()
        Return 0
    Endif

    'Dim Bcast As Bool = TRUE
    'setsockopt(sock,SOL_SOCKET,SO_BROADCAST,@Bcast,sizeof(BOOL))

    Dim ia As in_addr
    Dim hostentry As hostent Ptr
    Dim ip_iaddr As u_long

    ia.s_addr = inet_addr(Strptr(ntpServ))

    If (ia.s_addr = INADDR_NONE Or ia.s_addr = 0) Then
        hostentry = gethostbyname(ntpServ)
        If (hostentry = 0) Then
            WSACleanup()
            Return 0
        End If
        ip_iaddr = *Cast(Uinteger Ptr, *hostentry->h_addr_list)
    Else
        ip_iaddr = ia.s_addr
    End If

    Dim saddr As sockaddr_in
    saddr.sin_family = AF_INET
    saddr.sin_port    = htons(ntpPort)
    saddr.sin_addr.s_addr =  ip_iaddr 'inet_addr(ntpServ)

    If(connect(sock, Cast(PSOCKADDR, @saddr), Len(saddr)) = SOCKET_ERROR) Then
        'Var WSA_err = WSAGetLastError()
        '? "WSA_err = " &  WSA_Err
        closesocket(sock)
        WSACleanup()
        Return 0
    Endif

    Dim ps_buff As Ubyte Ptr = Callocate(68, Sizeof(Byte))
    ps_buff[0] = &h1B

    If(send(sock, ps_buff, 68, 0) <= 0) Then
        closesocket(sock)
        WSACleanup()
        Return 0
    End If
    Dim pr_buff As Ubyte Ptr = Callocate(68, Sizeof(Byte))
    Dim rcv_len As Integer = 255
    Dim rcv_bytes As Integer = recv(sock, pr_buff, rcv_len, 0)
    If(rcv_bytes < 44 Or Cast(Ubyte,pr_buff[40]) < 127) Then
        closesocket(sock)
        WSACleanup()
        Return 0
    End If

    Dim res_sec As Uinteger = 0

    res_sec  = pr_buff[40] Shl 24
    res_sec += pr_buff[41] Shl 16
    res_sec += pr_buff[42] Shl 8
    res_sec += pr_buff[43] Shl 0

    If(res_sec <= tdiff_ns2us) Then
        Return 0
    Endif
    If(cu_sec <> 0) Then
        Return (res_sec - tdiff_ns2us)
    Endif

    Return res_sec
End Function

#INCLUDE Once "crt/time.bi"

Shell "chcp 1251"

Var curr_sec = get_NTP_sec("",,1)

If(curr_sec > 0) Then
    Var tcurr_sec = Cast(time_t,curr_sec)
    Var ptime_GM = gmtime(@tcurr_sec)
    Dim As Zstring * 255 tstr_GM
    Var res=strftime(tstr_GM,128,"%a, %d %b %Y %H:%M:%S",ptime_GM)
    Print "Точное время по Гринвичу: " & tstr_GM

    curr_sec += (3600 * 4)
    Var tcurr_sec_4h = Cast(time_t,curr_sec)
    Var ptime_MSK = gmtime(@tcurr_sec_4h)
    Dim As Zstring * 255 tstr_MSK
    res=strftime(tstr_MSK,128,"%a, %d %b %Y %H:%M:%S",ptime_MSK)
    Print "Точное время по Москве:   " & tstr_MSK
Else
    Print "Произошла ошибка при получении временой метки..."
Endif

Sleep