home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 November / Chip_2002-11_cd1.bin / zkuste / delphi / kompon / d3456 / SYNAPSE.ZIP / source / lib / PINGsend.pas < prev    next >
Pascal/Delphi Source File  |  2002-08-08  |  7KB  |  214 lines

  1. {==============================================================================|
  2. | Project : Delphree - Synapse                                   | 002.003.001 |
  3. |==============================================================================|
  4. | Content: PING sender                                                         |
  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. |==============================================================================|
  41. | History: see HISTORY.HTM from distribution package                           |
  42. |          (Found at URL: http://www.ararat.cz/synapse/)                       |
  43. |==============================================================================}
  44.  
  45. {
  46. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  47. See 'winsock2.txt' file in distribute package!
  48. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  49. }
  50.  
  51. {$Q-}
  52. {$WEAKPACKAGEUNIT ON}
  53.  
  54. unit PINGsend;
  55.  
  56. interface
  57.  
  58. uses
  59. {$IFDEF LINUX}
  60.   Libc,
  61. {$ELSE}
  62.   Windows,
  63. {$ENDIF}
  64.   SysUtils,
  65.   synsock, blcksock, SynaUtil;
  66.  
  67. const
  68.   ICMP_ECHO = 8;
  69.   ICMP_ECHOREPLY = 0;
  70.  
  71. type
  72.   TIcmpEchoHeader = record
  73.     i_type: Byte;
  74.     i_code: Byte;
  75.     i_checkSum: Word;
  76.     i_Id: Word;
  77.     i_seq: Word;
  78.     TimeStamp: ULONG;
  79.   end;
  80.  
  81.   TPINGSend = class(TSynaClient)
  82.   private
  83.     FSock: TICMPBlockSocket;
  84.     FBuffer: string;
  85.     FSeq: Integer;
  86.     FId: Integer;
  87.     FPacketSize: Integer;
  88.     FPingTime: Integer;
  89.     function Checksum: Integer;
  90.     function ReadPacket: Boolean;
  91.   public
  92.     function Ping(const Host: string): Boolean;
  93.     constructor Create;
  94.     destructor Destroy; override;
  95.   published
  96.     property PacketSize: Integer read FPacketSize Write FPacketSize;
  97.     property PingTime: Integer read FPingTime;
  98.     property Sock: TICMPBlockSocket read FSock;
  99.   end;
  100.  
  101. function PingHost(const Host: string): Integer;
  102.  
  103. implementation
  104.  
  105. {==============================================================================}
  106.  
  107. constructor TPINGSend.Create;
  108. begin
  109.   inherited Create;
  110.   FSock := TICMPBlockSocket.Create;
  111.   FSock.CreateSocket;
  112.   FTimeout := 5000;
  113.   FPacketSize := 32;
  114.   FSeq := 0;
  115.   Randomize;
  116. end;
  117.  
  118. destructor TPINGSend.Destroy;
  119. begin
  120.   FSock.Free;
  121.   inherited Destroy;
  122. end;
  123.  
  124. function TPINGSend.ReadPacket: Boolean;
  125. begin
  126.   FBuffer := FSock.RecvPacket(Ftimeout);
  127.   Result := FSock.LastError = 0;
  128. end;
  129.  
  130. function TPINGSend.Ping(const Host: string): Boolean;
  131. var
  132.   IPHeadPtr: ^TIPHeader;
  133.   IpHdrLen: Integer;
  134.   IcmpEchoHeaderPtr: ^TICMPEchoHeader;
  135.   n: Integer;
  136.   t: Boolean;
  137. begin
  138.   Result := False;
  139.   FSock.Bind(FIPInterface, cAnyPort);
  140.   FSock.Connect(Host, '0');
  141.   FBuffer := StringOfChar(#0, SizeOf(TICMPEchoHeader) + FPacketSize);
  142.   IcmpEchoHeaderPtr := Pointer(FBuffer);
  143.   with IcmpEchoHeaderPtr^ do
  144.   begin
  145.     i_type := ICMP_ECHO;
  146.     i_code := 0;
  147.     i_CheckSum := 0;
  148.     FId := Random(32767);
  149.     i_Id := FId;
  150.     TimeStamp := GetTick;
  151.     Inc(FSeq);
  152.     i_Seq := FSeq;
  153.     for n := Succ(SizeOf(TIcmpEchoHeader)) to Length(FBuffer) do
  154.       FBuffer[n] := #$55;
  155.     i_CheckSum := CheckSum;
  156.   end;
  157.   FSock.SendString(FBuffer);
  158.   repeat
  159.     t := ReadPacket;
  160.     if not t then
  161.       break;
  162.     IPHeadPtr := Pointer(FBuffer);
  163.     IpHdrLen := (IPHeadPtr^.VerLen and $0F) * 4;
  164.     IcmpEchoHeaderPtr := @FBuffer[IpHdrLen + 1];
  165.   until (IcmpEchoHeaderPtr^.i_type <> ICMP_ECHO) and (IcmpEchoHeaderPtr^.i_id = FId);
  166.   //it discard sometimes possible 'echoes' of previosly sended packet...
  167.   if t then
  168.     if (IcmpEchoHeaderPtr^.i_type = ICMP_ECHOREPLY) then
  169.       if (IcmpEchoHeaderPtr^.i_id = FId) then
  170.       begin
  171.         FPingTime := GetTick - IcmpEchoHeaderPtr^.TimeStamp;
  172.         Result := True;
  173.       end;
  174. end;
  175.  
  176. function TPINGSend.Checksum: Integer;
  177. type
  178.   TWordArray = array[0..0] of Word;
  179. var
  180.   WordArr: ^TWordArray;
  181.   CkSum: DWORD;
  182.   Num, Remain: Integer;
  183.   n: Integer;
  184. begin
  185.   Num := Length(FBuffer) div 2;
  186.   Remain := Length(FBuffer) mod 2;
  187.   WordArr := Pointer(FBuffer);
  188.   CkSum := 0;
  189.   for n := 0 to Num - 1 do
  190.     CkSum := CkSum + WordArr^[n];
  191.   if Remain <> 0 then
  192.     CkSum := CkSum + Ord(FBuffer[Length(FBuffer)]);
  193.   CkSum := (CkSum shr 16) + (CkSum and $FFFF);
  194.   CkSum := CkSum + (CkSum shr 16);
  195.   Result := Word(not CkSum);
  196. end;
  197.  
  198. {==============================================================================}
  199.  
  200. function PingHost(const Host: string): Integer;
  201. begin
  202.   with TPINGSend.Create do
  203.   try
  204.     if Ping(Host) then
  205.       Result := PingTime
  206.     else
  207.       Result := -1;
  208.   finally
  209.     Free;
  210.   end;
  211. end;
  212.  
  213. end.
  214.