home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 December / Chip_2001-12_cd1.bin / zkuste / delphi / unity / d23456 / SYNAPSE.ZIP / source / lib / SNTPsend.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2001-09-23  |  4.9 KB  |  169 lines
  1. {==============================================================================|
  2. | Project : Delphree - Synapse                                   | 002.000.002 |
  3. |==============================================================================|
  4. | Content: SNTP client                                                         |
  5. |==============================================================================|
  6. | The contents of this file are subject to the Mozilla Public License Ver. 1.1 |
  7. | (the "License"); you may not use this file except in compliance with the     |
  8. | License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
  9. |                                                                              |
  10. | Software distributed under the License is distributed on an "AS IS" basis,   |
  11. | WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for |
  12. | the specific language governing rights and limitations under the License.    |
  13. |==============================================================================|
  14. | The Original Code is Synapse Delphi Library.                                 |
  15. |==============================================================================|
  16. | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
  17. | Portions created by Lukas Gebauer are Copyright (c)2000,2001.                |
  18. | All Rights Reserved.                                                         |
  19. |==============================================================================|
  20. | Contributor(s):                                                              |
  21. |==============================================================================|
  22. | History: see HISTORY.HTM from distribution package                           |
  23. |          (Found at URL: http://www.ararat.cz/synapse/)                       |
  24. |==============================================================================}
  25.  
  26. {$Q-}
  27. {$WEAKPACKAGEUNIT ON}
  28.  
  29. unit SNTPsend;
  30.  
  31. interface
  32.  
  33. uses
  34.   SysUtils,
  35.   synsock, blcksock;
  36.  
  37. const
  38.   cNtpProtocol = 'ntp';
  39.  
  40. type
  41.   PNtp = ^TNtp;
  42.   TNtp = packed record
  43.     mode: Byte;
  44.     stratum: Byte;
  45.     poll: Byte;
  46.     Precision: Byte;
  47.     RootDelay: Longint;
  48.     RootDisperson: Longint;
  49.     RefID: Longint;
  50.     Ref1: Longint;
  51.     Ref2: Longint;
  52.     Org1: Longint;
  53.     Org2: Longint;
  54.     Rcv1: Longint;
  55.     Rcv2: Longint;
  56.     Xmit1: Longint;
  57.     Xmit2: Longint;
  58.   end;
  59.  
  60.   TSNTPSend = class(TObject)
  61.   private
  62.     FNTPReply: TNtp;
  63.     FNTPTime: TDateTime;
  64.     FSntpHost: string;
  65.     FTimeout: Integer;
  66.     FSock: TUDPBlockSocket;
  67.     FBuffer: string;
  68.   public
  69.     constructor Create;
  70.     destructor Destroy; override;
  71.     function DecodeTs(Nsec, Nfrac: Longint): TDateTime;
  72.     function GetNTP: Boolean;
  73.     function GetBroadcastNTP: Boolean;
  74.   published
  75.     property NTPReply: TNtp read FNTPReply;
  76.     property NTPTime: TDateTime read FNTPTime;
  77.     property SntpHost: string read FSntpHost write FSntpHost;
  78.     property Timeout: Integer read FTimeout write FTimeout;
  79.     property Sock: TUDPBlockSocket read FSock;
  80.   end;
  81.  
  82. implementation
  83.  
  84. constructor TSNTPSend.Create;
  85. begin
  86.   inherited Create;
  87.   FSock := TUDPBlockSocket.Create;
  88.   FSock.CreateSocket;
  89.   FTimeout := 5000;
  90.   FSntpHost := cLocalhost;
  91. end;
  92.  
  93. destructor TSNTPSend.Destroy;
  94. begin
  95.   FSock.Free;
  96.   inherited Destroy;
  97. end;
  98.  
  99. function TSNTPSend.DecodeTs(Nsec, Nfrac: Longint): TDateTime;
  100. const
  101.   maxi = 4294967296.0;
  102. var
  103.   d, d1: Double;
  104. begin
  105.   Nsec := synsock.htonl(Nsec);
  106.   Nfrac := synsock.htonl(Nfrac);
  107.   d := Nsec;
  108.   if d < 0 then
  109.     d := maxi + d - 1;
  110.   d1 := Nfrac;
  111.   if d1 < 0 then
  112.     d1 := maxi + d1 - 1;
  113.   d1 := d1 / maxi;
  114.   d1 := Trunc(d1 * 1000) / 1000;
  115.   Result := (d + d1) / 86400;
  116.   Result := Result + 2;
  117. end;
  118.  
  119. function TSNTPSend.GetBroadcastNTP: Boolean;
  120. var
  121.   NtpPtr: PNtp;
  122.   x: Integer;
  123. begin
  124.   Result := False;
  125.   FSock.Bind('0.0.0.0', cNtpProtocol);
  126.   if FSock.CanRead(Timeout) then
  127.   begin
  128.     x := FSock.WaitingData;
  129.     SetLength(FBuffer, x);
  130.     FSock.RecvBufferFrom(Pointer(FBuffer), x);
  131.     if (SntpHost = '0.0.0.0') or (FSock.GetRemoteSinIP = SntpHost) then
  132.       if x >= SizeOf(NTPReply) then
  133.       begin
  134.         NtpPtr := Pointer(FBuffer);
  135.         FNTPReply := NtpPtr^;
  136.         FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2);
  137.         Result := True;
  138.       end;
  139.   end;
  140. end;
  141.  
  142. function TSNTPSend.GetNTP: Boolean;
  143. var
  144.   q: TNtp;
  145.   NtpPtr: PNtp;
  146.   x: Integer;
  147. begin
  148.   Result := False;
  149.   FSock.Connect(sntphost, cNtpProtocol);
  150.   FillChar(q, SizeOf(q), 0);
  151.   q.mode := $1B;
  152.   FSock.SendBuffer(@q, SizeOf(q));
  153.   if FSock.CanRead(Timeout) then
  154.   begin
  155.     x := FSock.WaitingData;
  156.     SetLength(FBuffer, x);
  157.     FSock.RecvBuffer(Pointer(FBuffer), x);
  158.     if x >= SizeOf(NTPReply) then
  159.     begin
  160.       NtpPtr := Pointer(FBuffer);
  161.       FNTPReply := NtpPtr^;
  162.       FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2);
  163.       Result := True;
  164.     end;
  165.   end;
  166. end;
  167.  
  168. end.
  169.