Конференция "Сети" » Нужно сделать ping на Delphi [D7, WinXP]
 
  • apic (26.06.18 11:41) [0]
    Всем доброго времени суток! Задача избитая, но полноценного решения не нашел. Нужно сделать ping на Delphi. Нашел вроде хороший пример http://www.delphimaster.ru/articles/icmp.html , но не хватает мозгов как сделать, что бы размер буффера можно бло указывать произвольно? Не хватает мозгов переделать на динамический массив буффера данных. Кроме того хотелось бы услышать мнение по правильности этого кода, есть мнение, что этот код может вызывать утечки памяти... И еще интересно - в Delphi XE случайно не сделали "обертку" под использование функций из ICMP.DLL?
  • megavoid © (26.06.18 12:49) [1]
    Именно на дельфи принципиально? В других языках можно сделать подключением библиотеки в одну-две строчки.
    https://github.com/geerlingguy/Ping
  • apic (26.06.18 13:50) [2]
    Да, мне нужно н Делфи. В общем вместо
    pingBuffer : array [0..31] of AnsiChar;


    я написал
    pingBuffer : array of AnsiChar;


    Потом инициализирую переменную
    SetLength(pingBuffer, 1452);


    и заменил везде
    sizeof(pingBuffer)


    на
    Length(pingBuffer)


    Адрес массива передаю также:
    pIpe.Data := @pingBuffer;


    Вроде все работает, но вопрос - правильно ли я все сделал? Больше всего волнует вопрос: передача адреса на статический и динамический массив одинаково выполняется в Делфи? Я имею ввиду синтаксически...
  • RWolf © (26.06.18 14:48) [3]
    Неодинаково.
    @StaticArr = @StaticArr[0] — указатель на первый элемент
    @DynArr[0] — указатель на первый элемент
    @DynArr — указатель на указатель на первый элемент
  • apic (26.06.18 15:08) [4]
    Спасибо! Подправил
  • apic (05.07.18 07:04) [5]
    Люди добрые а как переделать этот пример http://www.delphimaster.ru/articles/icmp.html что бы добавить поддержку IPv6?
  • megavoid © (06.07.18 10:01) [6]
  • cryptologic © (16.08.18 02:10) [7]
    unit Pings;

    interface

    USES windows, WinSock, Error;

    type

      //TPingParamOut = ();

       ip_option_information = packed record  // Информация заголовка IP (Наполнение
          // этой структуры и формат полей описан в RFC791.
           Ttl : byte;             // Время жизни (используется traceroute-ом)
           Tos : byte;             // Тип обслуживания, обычно 0
           Flags : byte;           // Флаги заголовка IP, обычно 0
           OptionsSize : byte;     // Размер данных в заголовке, обычно 0, максимум 40
           OptionsData : Pointer;  // Указатель на данные
       end;

      icmp_echo_reply = packed record
           Address : u_long;                // Адрес отвечающего
           Status : u_long;                 // IP_STATUS (см. ниже)
           RTTime : u_long;                 // Время между эхо-запросом и эхо-ответом
                                            // в миллисекундах
           DataSize : u_short;              // Размер возвращенных данных
           Reserved : u_short;              // Зарезервировано
           Data : Pointer;                  // Указатель на возвращенные данные
           Options : ip_option_information; // Информация из заголовка IP
       end;

       PIPINFO = ^ip_option_information;
       PVOID = Pointer;

    var
     ping_error: DWORD;
     Ping_error_message: string;

    function IcmpCreateFile() : THandle; stdcall; external 'ICMP.DLL' name 'IcmpCreateFile';
    function IcmpCloseHandle(IcmpHandle : THandle) : BOOL; stdcall; external 'ICMP.DLL'  name 'IcmpCloseHandle';
    function IcmpSendEcho(
                         IcmpHandle : THandle;    // handle, возвращенный IcmpCreateFile()
                         DestAddress : u_long;    // Адрес получателя (в сетевом порядке)
                         RequestData : PVOID;     // Указатель на посылаемые данные
                         RequestSize : Word;      // Размер посылаемых данных
                         RequestOptns : PIPINFO;  // Указатель на посылаемую структуру
                                                      // ip_option_information (может быть nil)
                         ReplyBuffer : PVOID;     // Указатель на буфер, содержащий ответы.
                         ReplySize : DWORD;       // Размер буфера ответов
                         Timeout : DWORD          // Время ожидания ответа в миллисекундах
                         ) : DWORD; stdcall; external 'ICMP.DLL' name 'IcmpSendEcho';

    function GetPing(HostName: String): Integer;

    implementation

    function GetPing(HostName: String): Integer;
    var
       hIP : THandle;
       pingBuffer : array [0..31] of Char;
       pIpe : ^icmp_echo_reply;
       pHostEn : PHostEnt;
       wVersionRequested : WORD;
       lwsaData : WSAData;
       error : DWORD;
       destAddress : In_Addr;
       ping: Integer;
    begin

       // Создаем handle
       hIP    := IcmpCreateFile();
       Result := -1;

       GetMem(pIpe, sizeof(icmp_echo_reply) + sizeof(pingBuffer));
       pIpe.Data     := @pingBuffer;
       pIpe.DataSize := sizeof(pingBuffer);

       wVersionRequested := MakeWord(1,1);
       error := WSAStartup(wVersionRequested, lwsaData);
       if (error <> 0) then
       begin
         ping_error := error;
         Ping_error_message := 'Error: WSAStartup() to exit; ' + SystemErrorMessage(error);
         //mm.SetTextBuf('Error in call to ' + 'WSAStartup().');
         //mm.Lines.Add('Error code: '+IntToStr(error));
         Exit;
       end;

       pHostEn := gethostbyname(PAnsiChar(AnsiString(HostName)));
       error := GetLastError();
       if (error <> 0) then
       begin
         ping_error := error;
         Ping_error_message := 'Error: gethostbyname() to exit; ' + SystemErrorMessage(error);
         //mm.SetTextBuf('Error in call to' + 'gethostbyname().');
         //mm.Lines.Add('Error code: '+IntToStr(error));
         Exit;
       end;

       destAddress := PInAddr(pHostEn^.h_addr_list^)^;

      // Посылаем ping-пакет
      //mm.Lines.Add('Pinging ' + pHostEn^.h_name+' ['+ inet_ntoa(destAddress)+'] '+
      //             ' with '+ IntToStr(sizeof(pingBuffer)) + ' bytes of data:');

      IcmpSendEcho(hIP,
                    destAddress.S_addr,
                    @pingBuffer,
                    sizeof(pingBuffer),
                    Nil,
                    pIpe,
                    sizeof(icmp_echo_reply) + sizeof(pingBuffer),
                    500);

       error := GetLastError();
       if (error <> 0) then
       begin
         ping_error := error;
         Ping_error_message := 'Error: IcmpSendEcho() to exit; '  + SystemErrorMessage(error);
         //mm.SetTextBuf('Error in call to ' + 'IcmpSendEcho()');
         //mm.Lines.Add('Error code: '+IntToStr(error));
         Exit;
       end;

        // Смотрим некоторые из вернувшихся данных
       //mm.Lines.Add('Reply from '+
       //            IntToStr(LoByte(LoWord(pIpe^.Address)))+'.'+
       //            IntToStr(HiByte(LoWord(pIpe^.Address)))+'.'+
       //            IntToStr(LoByte(HiWord(pIpe^.Address)))+'.'+
       //            IntToStr(HiByte(HiWord(pIpe^.Address))));
       //mm.Lines.Add('Reply time: '+IntToStr(pIpe.RTTime)+' ms');

       Result := pIpe.RTTime;
       if Result = 0 then Result := 1;

       IcmpCloseHandle(hIP);
       WSACleanup();
       FreeMem(pIpe);
    end;

    end.

  • cryptologic © (16.08.18 02:13) [8]
    Пинг реализован в отдельном потоке (модуль может быть с ошибками)

    unit ThrPings;

    interface

    uses
     System.Classes, System.SysUtils , Dialogs, Windows, WinSock, Error;

    type
      //TPingParamOut = ();
       ip_option_information = packed record  // Информация заголовка IP (Наполнение
          // этой структуры и формат полей описан в RFC791.
           Ttl : byte;             // Время жизни (используется traceroute-ом)
           Tos : byte;             // Тип обслуживания, обычно 0
           Flags : byte;           // Флаги заголовка IP, обычно 0
           OptionsSize : byte;     // Размер данных в заголовке, обычно 0, максимум 40
           OptionsData : Pointer;  // Указатель на данные
       end;

      icmp_echo_reply = packed record
           Address : u_long;                // Адрес отвечающего
           Status : u_long;                 // IP_STATUS (см. ниже)
           RTTime : u_long;                 // Время между эхо-запросом и эхо-ответом
                                            // в миллисекундах
           DataSize : u_short;              // Размер возвращенных данных
           Reserved : u_short;              // Зарезервировано
           Data : Pointer;                  // Указатель на возвращенные данные
           Options : ip_option_information; // Информация из заголовка IP
       end;

       PIPINFO = ^ip_option_information;
       PVOID = Pointer;

    type
     ThreadPings = class(TThread)
     private
       FHostName   : AnsiString;
       FPingResult : Integer;
       FInterval   : Word;
       procedure SetHosName(StrValue: String);
       procedure SetPingResult(IntValue: Integer);
       procedure SetInterval(IntValue: WORD);
       function GetInterval: WORD;
       function GetHostName: String;
       function GetPingResult: Integer;
     protected
       hIP               : THandle;
       pIpe              : ^icmp_echo_reply;
       wVersionRequested : WORD;
       lwsaData          : WSAData;
       pHostEn           : PHostEnt;
       destAddress       : In_Addr;
       error             : DWORD;
       pingBuffer : array [0..31] of Char;
       StrSendText: String;
       procedure SendMemo;
       procedure Execute; override;
     public
       LastErrorMessage: string;
       Property PingResult: Integer read GetPingResult write SetPingResult;
       Property HostName: string read GetHostName write SetHosName;
       Property Interval: WORD read GetInterval write SetInterval;
       procedure Ping;
       constructor Create;
       destructor Destroy; Override;
     end;

    function IcmpCreateFile() : THandle; stdcall; external 'ICMP.DLL' name 'IcmpCreateFile';
    function IcmpCloseHandle(IcmpHandle : THandle) : BOOL; stdcall; external 'ICMP.DLL'  name 'IcmpCloseHandle';
    function IcmpSendEcho(
                         IcmpHandle : THandle;    // handle, возвращенный IcmpCreateFile()
                         DestAddress : u_long;    // Адрес получателя (в сетевом порядке)
                         RequestData : PVOID;     // Указатель на посылаемые данные
                         RequestSize : Word;      // Размер посылаемых данных
                         RequestOptns : PIPINFO;  // Указатель на посылаемую структуру
                                                      // ip_option_information (может быть nil)
                         ReplyBuffer : PVOID;     // Указатель на буфер, содержащий ответы.
                         ReplySize : DWORD;       // Размер буфера ответов
                         Timeout : DWORD          // Время ожидания ответа в миллисекундах
                         ) : DWORD; stdcall; external 'ICMP.DLL' name 'IcmpSendEcho';

    implementation

    USES UFrmMain;

    constructor ThreadPings.Create;
    begin
       inherited Create(True); //CreateSuspended

       hIP    := IcmpCreateFile();
       GetMem(pIpe, sizeof(icmp_echo_reply) + sizeof(pingBuffer));
       pIpe.Data := @pingBuffer;
       pIpe.DataSize := sizeof(pingBuffer);
       wVersionRequested := MakeWord(1,1);
       error := WSAStartup(wVersionRequested, lwsaData);
       if (error <> 0) then
       begin
         LastErrorMessage := 'Error: gethostbyname() ' + SystemErrorMessage(error);
         Terminate;
       end;
    end;

    destructor ThreadPings.Destroy;
    begin
     IcmpCloseHandle(hIP);
     WSACleanup();
     FreeMem(pIpe);
     inherited;
    end;

    procedure ThreadPings.Execute;
    var BgnTime: Cardinal;
    begin
     NameThreadForDebugging('TPings');
     { Place thread code here }

     BgnTime := GetTickCount;
     While Not Terminated do
     begin

       if LastErrorMessage <> '' then Continue;

       if ((GetTickCount - BgnTime) div 1000) >= FInterval Then
       begin

         IcmpSendEcho(hIP,
                      destAddress.S_addr,
                      @pingBuffer,
                      sizeof(pingBuffer),
                      Nil,
                      pIpe,
                      sizeof(icmp_echo_reply) + sizeof(pingBuffer),
                      5000);

         error := GetLastError();
         if (error <> 0) then
         begin
           LastErrorMessage := 'Error: IcmpSendEcho() '  + SystemErrorMessage(error);
           Continue;
         end;

         if pIpe.RTTime = 0 then PingResult := 1
         else PingResult := pIpe.RTTime;

         StrSendText := 'Ping: '+IntToStr(PingResult);
         Synchronize(SendMemo);

         BgnTime := GetTickCount;

       end;
       sleep(50);

     end;
    end;

    function ThreadPings.GetHostName: String;
    begin
     Result := FHostName;
    end;

    function ThreadPings.GetInterval: WORD;
    begin
     Result := FInterval;
    end;

    function ThreadPings.GetPingResult: Integer;
    begin
     Result := FPingResult;
    end;

    procedure ThreadPings.Ping;
    begin
     Resume;
    end;

    procedure ThreadPings.SendMemo;
    begin
     FrmMain.mm.lines.add(StrSendText);
    end;

    procedure ThreadPings.SetHosName(StrValue: String);
    begin
     FPingResult      := 0;
     pHostEn := gethostbyname(PAnsiChar(AnsiString(StrValue)));
     error := GetLastError();
     if (error <> 0) then
     begin
       LastErrorMessage := 'Error: gethostbyname() ' + SystemErrorMessage(error);
       ShowMessage(LastErrorMessage);
       Exit;
     end;
     destAddress := PInAddr(pHostEn^.h_addr_list^)^;
     LastErrorMessage := '';
    end;

    procedure ThreadPings.SetInterval(IntValue: WORD);
    begin
     FInterval := IntValue;
     if IntValue < 3 then FInterval := 3;
     if IntValue > 300 then FInterval := 300;
    end;

    procedure ThreadPings.SetPingResult(IntValue: Integer);
    begin
     FPingResult := IntValue;
    end;

    end.

  • cryptologic © (16.08.18 02:30) [9]
    Пояснения модуля ThrPings работающего в потоке
    Классический пример из поста cryptologic ©   (16.08.18 02:10) [7]  т.е. функцию function GetPing(HostName: String): Integer; ее части кода раскидал по процедурам класса потока:

    1. выделение буфера  
    GetMem(pIpe, sizeof(icmp_echo_reply) + sizeof(pingBuffer));

    вписал в метод
    ThreadPings.Create;

    а уничтожение буфера в destroy т.е. буфер создается один раз и используется на всем протяжении жизни потока.
    И вот возникает проблема правомерно ли так делать? периодически вываливается ошибка о недостаточности ресурсов. Может нужно буфер создавать и освобождать при каждом вызове пинга? Кто встречался с подобным отпешитесь?
  • cryptologic © (16.08.18 02:35) [10]
    Модуль Error.pas для для обоих вышеупомянутых модулей
    Позволяет получить локализованный  ответ об ошибке согласно установленной языковой версии windows

    Unit Error;

    interface

    Uses Windows;

    function SystemErrorMessage(ErrorCode: Integer): string;
    function GetSysErrorMessage(ErrorCode: Integer): String;
    procedure SaveErrorMessage(DebugMsg: String);

    var
     LAST_ERROR_MESSAGE : String;

    implementation

    procedure SaveErrorMessage(DebugMsg: String);
    begin
     if DebugMsg <> '' then
       LAST_ERROR_MESSAGE := DebugMsg+' '+GetSysErrorMessage(GetLastError)
     else LAST_ERROR_MESSAGE := GetSysErrorMessage(GetLastError)
    end;

    {------------------------- GetSysErrorMessage ---------------------------------}
    function GetSysErrorMessage(ErrorCode: Integer): String;
    Var s: string;
    begin
     Str(ErrorCode:0,S);
     Result:='System Error. Code: '+s+' '+SystemErrorMessage(ErrorCode)+'.';
    end;

    {------------------------- SystemErrorMessage ---------------------------------}
    function SystemErrorMessage(ErrorCode: Integer): string;
    var
     Buffer : array[0..255] of Char;
     Len    : Integer;
    begin
     Len := FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_IGNORE_INSERTS or
                          FORMAT_MESSAGE_ARGUMENT_ARRAY, nil, ErrorCode, 0, Buffer,
                          SizeOf(Buffer), nil);
     while (Len > 0) and (Buffer[Len - 1] in [ #0..#32, '.']) do Dec(Len);
     SetString(Result, Buffer, Len);
    end;

    end.

  • cryptologic © (16.08.18 02:53) [11]
    Почему пинг в отдельном потоке, потому что при отсутствии узла и цикличном пинговании у приложения возникают невероятные фризы
    Мини инструкция как использовать модуль:

    var Tpings: ThreadPings;

    Tpings := ThreadPings.Create;     // Экземпляр потока создается в спящем режиме
    TPings.Interval   := 3;           // здесь задается интервал пингования в секундах, мин. = 3 макс. = 300 секунд
    TPings.HostName   := 'Yandex.ru'; // задаем хост для пинга
    TPings.Ping;                      // стартуем пингование
    TPings.PingResult // получаем ресультат пинга в типе integer если -1 то возникла ошибка ее смотрим TPings.LastErrorMessage, если более 0 то все норм.
    mm.Lines.Add('TPings.PingResult: ' + IntToStr(TPings.PingResult)); // читаем результат пинга.

  • имя (04.09.18 13:15) [12]
    Удалено модератором
  • Wonder © (19.10.18 19:58) [13]
    Офигеть! Через столько лет вспомнили нашу с Серегой статью про icmp. Только почему из авторов убрали Сергея?
 
Конференция "Сети" » Нужно сделать ping на Delphi [D7, WinXP]
Есть новые Нет новых   [103768   +20][b:0.001][p:0.021]