Top.Mail.Ru
Мастера DELPHI, Delphi programming community Титульная страница Поиск, карта сайта Написать письмо 
| Новости | Поиск | FAQ | Статьи | Книги | Новости VCL |
| Форумы ЧАТ | Орешник | KOL и MCK |
Форумы -» Основная («Начинающим»)/ Базы / WinAPI / Компоненты / Сети / Media / Игры / Corba и COM / KOL / FreePascal / .Net / Прочее / RSDN.ORG

« предыдущая ветвь | форум | следующая ветвь »

Потоки и пинг [D7, WinXP]


Страницы:   1 2 3 4

S46E ©   (2006-07-18 08:36:00) 

Задача: паралельный пинг всех ip в списке Hosts без зависания программы.

Код который имеется:
unit Unit1;

interface

uses
 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
 Dialogs, StdCtrls, IdBaseComponent, IdComponent, IdRawBase, IdRawClient,
 IdIcmpClient;

type
 TForm1 = class(TForm)
   Icmp: TIdIcmpClient;
   Button1: TButton;
   hosts: TMemo;
   Log: TMemo;
   procedure Button1Click(Sender: TObject);
 private
   { Private declarations }
 public
   { Public declarations }
 end;

TNew = class(TThread)
 private
   n: integer;
   procedure AddStr;
   { Private declarations }
 protected
 procedure Execute; override;
end;

var
 Form1: TForm1;
 New, New2: TNew;

implementation

{$R *.dfm}

procedure TNew.Execute;
begin
Synchronize(AddStr);
end;

procedure TNew.AddStr;
begin
Form1.Icmp.Host:=Form1.Hosts.Lines[n];
Form1.Icmp.Ping('');
Form1.Log.Lines.Add('Ping '+Form1.Icmp.ReplyStatus.FromIpAddress+'______RTTime: '+InttoStr(Form1.Icmp.ReplyStatus.MsRoundTripTime)+'_______TTL: '+InttoStr(Form1.Icmp.ReplyStatus.TimeToLive));
end;

{---}

procedure TForm1.Button1Click(Sender: TObject);
begin
New := TNew.Create(true);
New.FreeOnTerminate := true;
New.Priority := tpNormal;
New2 := TNew.Create(true);
New2.FreeOnTerminate := true;
New2.Priority := tpNormal;
New.n:=0;
New2.n:=1;
New.Resume;
New2.Resume;
end;

end.

Пусик   (2006-07-22 14:31:00) [1]

В приведенном выше примере как в конструкторе, так и в поточной функции, каждый оператор несен вполне определенную смысловую нагрузку.
Естественно, если некоторые операторы из кода "выкинуть", то в целом код не будет выполнять поставленную задачу.
Для написания многопоточных приложений необходимо четко понимать, что делает код.
Рекомендую почитать статьи:
1. http://forum.vingrad.ru/index.php?showtopic=60076
2. http://www.delphimaster.ru/articles/panov/index.html

S46E   (2006-07-22 14:31:00) [2]

Ух ты как. Я полон позитива! Спасибо Пусик!

Пусик   (2006-07-22 14:19:00) [3]


> S46E ©   (22.07.06 13:59) [75]
> constructor TPingThread.Create(Host: String; OnTerminateEvent:
>  TNotifyEvent; aSeq: Word);begin inherited Create(True);
>  FreeOnTerminate := True; FHost := Host; FSeq := aSeq; OnTerminate
> := OnTerminateEvent;end;не сложно. эффект тот же.


Слушай, так и будем по строчке добавлять?
Сравни код у меня в конструкторе и у себя. Найди отличия.

S46E   (2006-07-22 13:59:00) [4]

constructor TPingThread.Create(Host: String; OnTerminateEvent: TNotifyEvent; aSeq: Word);
begin
inherited Create(True);
FreeOnTerminate := True;
FHost := Host;
FSeq := aSeq;
OnTerminate := OnTerminateEvent;
end;
не сложно. эффект тот же.

Пусик   (2006-07-22 13:50:00) [5]


> У меня Не работает. Вообще ничего не выводит, только разве
> при многократном нажатии на пинг, дельфи виснет и вылетает
> с ошибкой насчет памяти=)


FSeq := aSeq;
OnTerminate := OnTerminateEvent;

А вот эти строки сложно было скопировать тоже в конструкторе?

S46E   (2006-07-22 13:19:00) [6]

Скажите, насколько будет экологично использовать?


for i:=1 to 244 do WinExec('ping 192.168.2.'+i+' > c:\ping_192_168_2_'+i+'.tmp', SW_hide);
//далее читаем программного результаты пинга из кучи файлов по циклу и пишем в лог.

S46E   (2006-07-22 09:18:00) [7]

Поразительно...такая примитивная распрастраненная мелнькая задачка как пинговалка и столько хлопот...:) Как буд-то я и не велосипед придумываю..)

S46E   (2006-07-22 09:16:00) [8]

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, IdBaseComponent, IdComponent, IdRawBase, IdRawClient,
IdIcmpClient, ExtCtrls;

type

TPingThread=class(Tthread)
private
FHost: String;
FResult: String;
FSeq: Word;
function Pinghost: string;
procedure IdIcmpClient1Reply(ASender: TComponent; const AReplyStatus: TReplyStatus);
protected
procedure Execute; override;
public
constructor Create(Host: String; OnTerminateEvent: TNotifyEvent; aSeq: Word);
property Result: String read FResult;
end;

TForm1 = class(TForm)
  Button1: TButton;
  Log: TMemo;
  procedure Button1Click(Sender: TObject);
private
  procedure PingTerminated(Sender: TObject);
  { Private declarations }
public
  { Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

{ TPingThread }

constructor TPingThread.Create(Host: String; OnTerminateEvent: TNotifyEvent; aSeq: Word);
begin
inherited Create(True);
FreeOnTerminate := True;
FHost := Host;
end;

procedure TPingThread.Execute;
begin
FResult := PingHost;
end;

function TPingThread.Pinghost: string;
var
Pinger: TIdIcmpClient;
begin
Pinger := TIdIcmpClient.Create(nil);
Pinger.Host := FHost;
Pinger.OnReply := IdIcmpClient1Reply;
Pinger.Ping('',FSeq);
Result:=FHost+': '+FResult;
end;

procedure TForm1.PingTerminated(Sender: TObject);
begin
Log.Lines.Add(TPingThread(Sender).Result);
end;

procedure TPingThread.IdIcmpClient1Reply(ASender: TComponent;
const AReplyStatus: TReplyStatus);
begin
FResult := '';
case AReplyStatus.ReplyStatusType of
rsEcho:
 FResult := FResult+
  ' RoundTripTime: '+IntToStr(AReplyStatus.MsRoundTripTime)+
  ' TTL: '+IntToStr(AReplyStatus.TimeToLive);
rsError:
 FResult := 'ping error';
rsTimeOut:
 FResult := 'ping time out'+
  ' RoundTripTime: '+IntToStr(AReplyStatus.MsRoundTripTime)+
  ' TTL: '+IntToStr(AReplyStatus.TimeToLive);
rsErrorUnreachable:
 FResult := 'host unreachable';
rsErrorTTLExceeded:
 FResult:='time out exceeded';
end;

end;

procedure TForm1.Button1Click(Sender: TObject);
var
i: integer;
begin
for i := 1 to 254 do
begin
TPingThread.Create('192.168.2.'+IntToStr(i),PingTerminated,i);
end;

end;

end.
У меня Не работает. Вообще ничего не выводит, только разве при многократном нажатии на пинг, дельфи виснет и вылетает с ошибкой насчет памяти=)

Пусик   (2006-07-22 02:01:00) [9]


> XeON ©   (21.07.06 23:49) [68]
>Попробуй воспользоваться
> компонентами, которые называются ICS

Зачем?


>Или возьми обычный  сокет


Что такое "Обычный сокет"


> и привинти к нему исключения Try Except и т.п.


Try Except будет посылать пакеты удаленному хосту?

Шпиён   (2006-07-22 00:18:00) [10]


> XeON ©   (21.07.06 23:49) [68]


> Или возьми обычный сокет и привинти к нему исключения Try
> Except и т.п. Тоже мона сделать пинг!

Можно. Но работать этот пинг будет только если у пользователя есть права администратора.

Кстати, хотелось бы посмотреть на Вашу реализацию.

XeON   (2006-07-21 23:49:00) [11]

Вот это тут понаворотили ответов... Попробуй воспользоваться компонентами, которые называются ICS, там кажсь был контрол специальный. Который так и назывался: ПИНГ. Или возьми обычный сокет и привинти к нему исключения Try Except и т.п. Тоже мона сделать пинг!

Пусик   (2006-07-21 20:23:00) [12]

unit Unit5;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, IdBaseComponent, IdComponent, IdRawBase, IdRawClient,
IdIcmpClient, ExtCtrls;

type

TPingThread=class(Tthread)
private
 FHost: String;
 FResult: String;
 FSeq: Word;
 function Pinghost: string;
 procedure IdIcmpClient1Reply(ASender: TComponent;
  const AReplyStatus: TReplyStatus);
protected
 procedure Execute; override;
public
 constructor Create(Host: String; OnTerminateEvent: TNotifyEvent; aSeq: Word);
 property Result: String read FResult;
end;

TForm5 = class(TForm)
 Memo1: TMemo;
 Panel1: TPanel;
 Button1: TButton;
   IdIcmpClient1: TIdIcmpClient;
 procedure Button1Click(Sender: TObject);
private
 { Private declarations }
public
 { Public declarations }
 procedure PingTerminated(Sender: TObject);
end;

var
Form5: TForm5;

implementation

{$R *.dfm}

procedure TForm5.Button1Click(Sender: TObject);
var
i: integer;
begin
for i := 1 to 254 do
begin
 TPingThread.Create('10.0.0.'+IntToStr(i),PingTerminated,i);
end;

end;

procedure TForm5.PingTerminated(Sender: TObject);
begin
Memo1.Lines.Add(TPingThread(Sender).Result);
end;

{ TPingThread }

constructor TPingThread.Create(Host: String; OnTerminateEvent: TNotifyEvent; aSeq: Word);
begin
inherited Create(True);
FreeOnTerminate := True;
FHost := Host;
FSeq := aSeq;
OnTerminate := OnTerminateEvent;
Resume;
end;

procedure TPingThread.Execute;
begin
FResult := PingHost;
end;

function TPingThread.Pinghost: string;
var
Pinger: TIdIcmpClient;
begin
Pinger := TIdIcmpClient.Create(nil);
Pinger.Host := FHost;
Pinger.OnReply := IdIcmpClient1Reply;
Pinger.Ping('',FSeq);
Result:=FHost+': '+FResult;
end;

procedure TPingThread.IdIcmpClient1Reply(ASender: TComponent;
const AReplyStatus: TReplyStatus);
begin
Fresult := '';
case AReplyStatus.ReplyStatusType of
 rsEcho:
  FResult := FResult+
   ' RoundTripTime: '+IntToStr(AReplyStatus.MsRoundTripTime)+
   ' TTL: '+IntToStr(AReplyStatus.TimeToLive);
 rsError:
  FResult := 'ping error';
 rsTimeOut:
  FResult := 'ping time out'+
   ' RoundTripTime: '+IntToStr(AReplyStatus.MsRoundTripTime)+
   ' TTL: '+IntToStr(AReplyStatus.TimeToLive);
 rsErrorUnreachable:
  FResult := 'host unreachable';
 rsErrorTTLExceeded:
  FResult:='time out exceeded';
end;

end;

end.

S46E   (2006-07-21 15:32:00) [13]

Могу на мыло выслать исходник который такое выдает - проверишь у себя))

S46E   (2006-07-21 15:28:00) [14]

>> Работает как часы...
...для одного последнего хоста:)

Хосты:
192.168.2.1 (on)
192.168.2.2 (off)
192.168.2.3 (off)
192.168.2.4 (off)
192.168.2.5 (off)
192.168.2.6 (off)
192.168.2.7 (on)
192.168.2.8 (on)
192.168.2.9 (on)
192.168.2.10 (off)
Результат:
192.168.2.3 RoundTripTime: 0 TTL: 64
192.168.2.1 RoundTripTime: 0 TTL: 64
192.168.2.2 RoundTripTime: 0 TTL: 64
192.168.2.4 RoundTripTime: 16 TTL: 128
192.168.2.5 RoundTripTime: 0 TTL: 128
192.168.2.9 RoundTripTime: 16 TTL: 128
192.168.2.6 RoundTripTime: 16 TTL: 128
192.168.2.7 RoundTripTime: 16 TTL: 128
192.168.2.8 RoundTripTime: 16 TTL: 128
192.168.2.10 ping time out

isasa   (2006-07-21 15:26:00) [15]

S46E ©   (21.07.06 15:20) [62]
... Чето потоки между друг другом трутся..

Ага, намылить бы их ... :)

isasa   (2006-07-21 15:24:00) [16]

Собака порылась где?
Потоки запустились и нигде не видно их состояния.
Запускаем(я пускал на 8 адресах) и идем курим, или вставляем индикатор выполнения потоков, или завершения последнего активного.

S46E   (2006-07-21 15:20:00) [17]

>> Это уже твоя задача - отладить и разобраться, почему так происходит

Так я в этой ветке и пытаюсь разобраться:) Этим сообщением я имел ввиду что все так же как и было)) Чето потоки между друг другом трутся..

isasa   (2006-07-21 15:20:00) [18]

Вот юнит на основе Пусика(с) класса. Только что проверил. Работает как часы.
Мочаливые IP - ждут и поток возвращает ' ping time out', естесственно, немного погодя.
Берем книги, ровняем руки. :)

unit Unit1;

interface

uses
 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
 Dialogs, IdBaseComponent, {IdComponent, IdRawBase, IdRawClient,}
 IdIcmpClient, StdCtrls;

type

TPingThread=class(Tthread)
private
 FHost: String;
 FResult: String;
 function Pinghost: string;
protected
 procedure Execute; override;
public
 constructor Create(Host: String);
end;

 TForm1 = class(TForm)
   Log: TMemo;
   Button1: TButton;
   hosts: TMemo;
   procedure Button1Click(Sender: TObject);
 private
   procedure PingTerminated(Sender: TObject);
   { Private declarations }
 public
   { Public declarations }
 end;

var
 Form1: TForm1;

implementation

{$R *.dfm}

{ TPingThread }

constructor TPingThread.Create(Host: String);
begin
 inherited Create(True);
 FreeOnTerminate := True;
 FHost := Host;
 //Resume;
end;

procedure TPingThread.Execute;
begin
 FResult := PingHost;
end;

function TPingThread.Pinghost: string;
var
 Pinger: TIdIcmpClient;
begin
 Pinger := TIdIcmpClient.Create(nil);
 Pinger.Host := FHost;
 Pinger.Ping();
 Result:=FHost;
 case Pinger.ReplyStatus.ReplyStatusType of
   rsEcho:
     Result:=Result+
       ' RoundTripTime: '+InttoStr(Pinger.ReplyStatus.MsRoundTripTime)+
       ' TTL: '+InttoStr(Pinger.ReplyStatus.TimeToLive);
   rsError:
     Result:=Result+' ping error';
   rsTimeOut:
     Result:=Result+' ping time out';
   rsErrorUnreachable:
     Result:=Result+' host unreachable';
   rsErrorTTLExceeded:
     Result:=Result+' time out exceeded';
 end;
end;

procedure TForm1.PingTerminated(Sender: TObject);
var
 PR: TPingThread;
begin
 PR := TPingThread(Sender);
 Log.Lines.Add(PR.FResult);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
 i: integer;
begin
For i:=0 to Hosts.Lines.Count-1 do
begin
  with TPingThread.Create(Hosts.Lines[i]) do
  begin
    OnTerminate := PingTerminated;
    Resume;
  end;
end;
end;

end.

StriderMan   (2006-07-21 15:07:00) [19]


> Не очень качественно пингует мертвые хосты

сдается мне надо покопаться в исходниках Indy. может при многопоточном пинговании не разруливается какие ответы какому потоку предназначены?

Пусик   (2006-07-21 14:55:00) [20]


> Не очень качественно пингует мертвые хосты. Если в списке
> помимо реал-мертвых есть хоть один реал-живой то в логе
> все оказываются живыми. Если нету - то все ок. Т.е. достаточно
> одного реал-живого хоста в списке - выводит всех как живых
> без всяких раздумий. Раздумия идут если все реал-мертвые,
>  5 сек:)


Это уже твоя задача - отладить и разобраться, почему так происходит.

Страницы:   1 2 3 4

Наверх

Титульная страница Поиск, карта сайта Написать письмо