home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 November / Chip_2002-11_cd1.bin / zkuste / delphi / kompon / d3456 / SYNAPSE.ZIP / source / lib / SNTPsend.pas < prev    next >
Pascal/Delphi Source File  |  2002-07-07  |  9KB  |  269 lines
  1. {==============================================================================|
  2. | Project : Delphree - Synapse                                   | 002.002.000 |
  3. |==============================================================================|
  4. | Content: SNTP client                                                         |
  5. |==============================================================================|
  6. | Copyright (c)1999-2002, Lukas Gebauer                                        |
  7. | All rights reserved.                                                         |
  8. |                                                                              |
  9. | Redistribution and use in source and binary forms, with or without           |
  10. | modification, are permitted provided that the following conditions are met:  |
  11. |                                                                              |
  12. | Redistributions of source code must retain the above copyright notice, this  |
  13. | list of conditions and the following disclaimer.                             |
  14. |                                                                              |
  15. | Redistributions in binary form must reproduce the above copyright notice,    |
  16. | this list of conditions and the following disclaimer in the documentation    |
  17. | and/or other materials provided with the distribution.                       |
  18. |                                                                              |
  19. | Neither the name of Lukas Gebauer nor the names of its contributors may      |
  20. | be used to endorse or promote products derived from this software without    |
  21. | specific prior written permission.                                           |
  22. |                                                                              |
  23. | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
  24. | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
  25. | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
  26. | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
  27. | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
  28. | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
  29. | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
  30. | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
  31. | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
  32. | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
  33. | DAMAGE.                                                                      |
  34. |==============================================================================|
  35. | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
  36. | Portions created by Lukas Gebauer are Copyright (c)2000,2001.                |
  37. | All Rights Reserved.                                                         |
  38. |==============================================================================|
  39. | Contributor(s):                                                              |
  40. |   Patrick Chevalley                                                          |
  41. |==============================================================================|
  42. | History: see HISTORY.HTM from distribution package                           |
  43. |          (Found at URL: http://www.ararat.cz/synapse/)                       |
  44. |==============================================================================}
  45.  
  46. {$Q-}
  47. {$WEAKPACKAGEUNIT ON}
  48.  
  49. unit SNTPsend;
  50.  
  51. interface
  52.  
  53. uses
  54.   SysUtils,
  55.   synsock, blcksock, SynaUtil;
  56.  
  57. const
  58.   cNtpProtocol = 'ntp';
  59.  
  60. type
  61.   PNtp = ^TNtp;
  62.   TNtp = packed record
  63.     mode: Byte;
  64.     stratum: Byte;
  65.     poll: Byte;
  66.     Precision: Byte;
  67.     RootDelay: Longint;
  68.     RootDisperson: Longint;
  69.     RefID: Longint;
  70.     Ref1: Longint;
  71.     Ref2: Longint;
  72.     Org1: Longint;
  73.     Org2: Longint;
  74.     Rcv1: Longint;
  75.     Rcv2: Longint;
  76.     Xmit1: Longint;
  77.     Xmit2: Longint;
  78.   end;
  79.  
  80.   TSNTPSend = class(TSynaClient)
  81.   private
  82.     FNTPReply: TNtp;
  83.     FNTPTime: TDateTime;
  84.     FNTPOffset: double;
  85.     FNTPDelay: double;
  86.     FMaxSyncDiff: double;
  87.     FSyncTime: Boolean;
  88.     FSock: TUDPBlockSocket;
  89.     FBuffer: string;
  90.     FLi, FVn, Fmode : byte;
  91.   public
  92.     constructor Create;
  93.     destructor Destroy; override;
  94.     function DecodeTs(Nsec, Nfrac: Longint): TDateTime;
  95.     procedure EncodeTs(dt: TDateTime; var Nsec, Nfrac: Longint);
  96.     function GetSNTP: Boolean;
  97.     function GetNTP: Boolean;
  98.     function GetBroadcastNTP: Boolean;
  99.   published
  100.     property NTPReply: TNtp read FNTPReply;
  101.     property NTPTime: TDateTime read FNTPTime;
  102.     property NTPOffset: Double read FNTPOffset;
  103.     property NTPDelay: Double read FNTPDelay;
  104.     property MaxSyncDiff: double read FMaxSyncDiff write FMaxSyncDiff;
  105.     property SyncTime: Boolean read FSyncTime write FSyncTime;
  106.     property Sock: TUDPBlockSocket read FSock;
  107.   end;
  108.  
  109. implementation
  110.  
  111. constructor TSNTPSend.Create;
  112. begin
  113.   inherited Create;
  114.   FSock := TUDPBlockSocket.Create;
  115.   FSock.CreateSocket;
  116.   FTimeout := 5000;
  117.   FTargetPort := cNtpProtocol;
  118.   FMaxSyncDiff := 3600;
  119.   FSyncTime := False;
  120. end;
  121.  
  122. destructor TSNTPSend.Destroy;
  123. begin
  124.   FSock.Free;
  125.   inherited Destroy;
  126. end;
  127.  
  128. function TSNTPSend.DecodeTs(Nsec, Nfrac: Longint): TDateTime;
  129. const
  130.   maxi = 4294967295.0;
  131. var
  132.   d, d1: Double;
  133. begin
  134.   Nsec := synsock.htonl(Nsec);
  135.   Nfrac := synsock.htonl(Nfrac);
  136.   d := Nsec;
  137.   if d < 0 then
  138.     d := maxi + d + 1;
  139.   d1 := Nfrac;
  140.   if d1 < 0 then
  141.     d1 := maxi + d1 + 1;
  142.   d1 := d1 / maxi;
  143.   d1 := Trunc(d1 * 10000) / 10000;
  144.   Result := (d + d1) / 86400;
  145.   Result := Result + 2;
  146. end;
  147.  
  148. procedure TSNTPSend.EncodeTs(dt: TDateTime; var Nsec, Nfrac: Longint);
  149. const
  150.   maxi = 4294967295.0;
  151.   maxilongint = 2147483647;
  152. var
  153.   d, d1: Double;
  154. begin
  155.   d  := (dt - 2) * 86400;
  156.   d1 := frac(d);
  157.   d  := trunc(d);
  158.   if d>maxilongint then
  159.      d := d - maxi - 1;
  160.   d1 := Trunc(d1 * 10000) / 10000;
  161.   d1 := d1 * maxi;
  162.   if d1>maxilongint then
  163.      d1 := d1 - maxi - 1;
  164.   Nsec:=trunc(d);
  165.   Nfrac:=trunc(d1);
  166.   Nsec := synsock.htonl(Nsec);
  167.   Nfrac := synsock.htonl(Nfrac);
  168. end;
  169.  
  170. function TSNTPSend.GetBroadcastNTP: Boolean;
  171. var
  172.   NtpPtr: PNtp;
  173.   x: Integer;
  174. begin
  175.   Result := False;
  176.   FSock.Bind(FIPInterface, cAnyPort);
  177.   FBuffer := FSock.RecvPacket(FTimeout);
  178.   if FSock.LastError = 0 then
  179.   begin
  180.     x := Length(FBuffer);
  181.     if (FTargetHost = '0.0.0.0') or (FSock.GetRemoteSinIP = FTargetHost) then
  182.       if x >= SizeOf(NTPReply) then
  183.       begin
  184.         NtpPtr := Pointer(FBuffer);
  185.         FNTPReply := NtpPtr^;
  186.         FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2);
  187.         if FSyncTime and ((abs(FNTPTime - GetUTTime) * 86400) <= FMaxSyncDiff) then
  188.           SetUTTime(FNTPTime);
  189.         Result := True;
  190.       end;
  191.   end;
  192. end;
  193.  
  194. function TSNTPSend.GetSNTP: Boolean;
  195. var
  196.   q: TNtp;
  197.   NtpPtr: PNtp;
  198.   x: Integer;
  199. begin
  200.   Result := False;
  201.   FSock.Bind(FIPInterface, cAnyPort);
  202.   FSock.Connect(FTargetHost, FTargetPort);
  203.   FillChar(q, SizeOf(q), 0);
  204.   q.mode := $1B;
  205.   FSock.SendBuffer(@q, SizeOf(q));
  206.   FBuffer := FSock.RecvPacket(FTimeout);
  207.   if FSock.LastError = 0 then
  208.   begin
  209.     x := Length(FBuffer);
  210.     if x >= SizeOf(NTPReply) then
  211.     begin
  212.       NtpPtr := Pointer(FBuffer);
  213.       FNTPReply := NtpPtr^;
  214.       FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2);
  215.       if FSyncTime and ((abs(FNTPTime - GetUTTime) * 86400) <= FMaxSyncDiff) then
  216.         SetUTTime(FNTPTime);
  217.       Result := True;
  218.     end;
  219.   end;
  220. end;
  221.  
  222. function TSNTPSend.GetNTP: Boolean;
  223. var
  224.   q: TNtp;
  225.   NtpPtr: PNtp;
  226.   x: Integer;
  227.   t1, t2, t3, t4 : TDateTime;
  228. begin
  229.   Result := False;
  230.   FSock.Bind(FIPInterface, cAnyPort);
  231.   FSock.Connect(FTargetHost, FTargetPort);
  232.   FillChar(q, SizeOf(q), 0);
  233.   q.mode := $1B;
  234.   t1 := GetUTTime;
  235.   EncodeTs(t1,q.org1,q.org2);
  236.   FSock.SendBuffer(@q, SizeOf(q));
  237.   FBuffer := FSock.RecvPacket(FTimeout);
  238.   if FSock.LastError = 0 then
  239.   begin
  240.     x := Length(FBuffer);
  241.     t4 := GetUTTime;
  242.     if x >= SizeOf(NTPReply) then
  243.     begin
  244.       NtpPtr := Pointer(FBuffer);
  245.       FNTPReply := NtpPtr^;
  246.       FLi := (NTPReply.mode and $C0) shr 6;
  247.       FVn := (NTPReply.mode and $38) shr 3;
  248.       Fmode := NTPReply.mode and $07;
  249.       if (Fli < 3) and (Fmode = 4) and
  250.          (NTPReply.stratum >= 1) and (NTPReply.stratum <= 15) and
  251.          (NTPReply.Rcv1 <> 0) and (NTPReply.Xmit1 <> 0)
  252.          then begin
  253.            t2 := DecodeTs(NTPReply.Rcv1, NTPReply.Rcv2);
  254.            t3 := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2);
  255.            FNTPDelay := (T4 - T1) - (T2 - T3);
  256.            FNTPTime := t3 + FNTPDelay / 2;
  257.            FNTPOffset := (((T2 - T1) + (T3 - T4)) / 2) * 86400;
  258.            FNTPDelay := FNTPDelay * 86400;
  259.            if FSyncTime and ((abs(FNTPTime - t1) * 86400) <= FMaxSyncDiff) then
  260.              SetUTTime(FNTPTime);
  261.            Result := True;
  262.            end
  263.          else result:=false;
  264.     end;
  265.   end;
  266. end;
  267.  
  268. end.
  269.