ICMP-Echo-API ("Ping") Wrapper-Unit v1.04

Narses · Verfasst: So 18.12.05 02:30

Moin!

Ich habe endlich mal diese leidige Ping-API-Wrapper-Unit auf einen aktuellen Stand gebracht, der AFAIK konform zur aktuellen Doku im MSDN ist. Konkret heißt das:

Es wird versucht, die IPHLPAPI.DLL zu verwenden; erst wenn das nicht klappt, wird als Fallback auf die ICMP.DLL zurückgegriffen. Damit sollte optimale Kompatibilität gewährleistet sein (getestet auf W98SE, W2Ksp4, WXPsp1+2, W7). Da die ICMP.DLL nie zum "offiziellen" Kanon des Systems gezählt hat, die IP-Helper-API das jetzt aber ist, sollte mit diesem Verhalten immer ein Ergebnis erzielt werden können.
Es kann nicht nur ein ICMP-Status-Reply empfangen werden, sondern auch mehrere, so dass ältere Anfragen nicht mehr zu Problemen führen können.
Die Returncodes der API-Funktionen werden sauber ausgewertet, so dass eine feine Unterscheidung zwischen System- und funktionalen Fehlern möglich ist (es gibt auch eine eigene Fehlertext-Auflösung).
Es sind zwei WSA-GetHostByName-Wrapper-Funktionen enthalten, die sowohl eine, als auch alle IP-Adressen eines Hosts ermitteln können (auch die des lokalen PCs!).
Synchrone und asynchrone Ping-Ausführung (per Thread mit Callback) möglich; mit dieser Unit ist ein threadbasierter Ping ganz leicht durchzuführen, so dass die Anwendung nicht während des Ping-Vorgangs "stehen" bleibt.

Hier zunächst die Unit:

markieren

Delphi-Quelltext

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
224:
225:
226:
227:
228:
229:
230:
231:
232:
233:
234:
235:
236:
237:
238:
239:
240:
241:
242:
243:
244:
245:
246:
247:
248:
249:
250:
251:
252:
253:
254:
255:
256:
257:
258:
259:
260:
261:
262:
263:
264:
265:
266:
267:
268:
269:
270:
271:
272:
273:
274:
275:
276:
277:
278:
279:
280:
281:
282:
283:
284:
285:
286:
287:
288:
289:
290:
291:
292:
293:
294:
295:
296:
297:
298:
299:
300:
301:
302:
303:
304:
305:
306:
307:
308:
309:
310:
311:
312:
313:
314:
315:
316:
317:
318:
319:
320:
321:
322:
323:
324:
325:
326:
327:
328:
329:
330:
331:
332:
333:
334:
335:
336:
337:
338:
339:
340:
341:
342:
343:
344:
345:
346:
347:
348:
349:
350:
351:
352:
353:
354:
355:
356:
357:
358:
359:
360:
361:
362:
363:
364:
365:
366:
367:
368:
369:
370:
371:
372:
373:
374:
375:
376:
377:
378:
379:
380:
381:
382:
383:
384:
385:
386:
387:
388:
389:
390:
391:
392:
393:
394:
395:
396:
397:
398:
399:
400:
401:
402:
403:
404:
405:
406:
407:
408:
409:
410:
411:
412:
413:
414:
415:
416:
417:
418:
419:
420:
421:
422:
423:
424:
425:
426:
427:
428:
429:
430:
431:
432:
433:
434:
435:
436:
437:
438:
439:
440:
441:
442:
443:
444:
445:
446:
447:
448:
449:
450:
451:
452:
453:
454:
455:
456:
457:
458:
459:
460:
461:
462:
463:
464:
465:
466:
467:
468:
469:
470:
471:
472:
473:
474:
475:
476:
477:
478:
479:
480:
481:
482:
483:
484:
485:
486:
487:
488:
489:
490:
491:
492:
493:
494:
495:
496:
497:
498:
499:
500:
501:
502:
503:
504:
505:
506:
507:
508:
509:
510:
511:
512:
513:
514:
515:
516:
517:
518:
519:
520:
521:
522:
523:
524:
525:
526:
527:
528:
529:
530:
531:
532:
533:
534:
535:
536:
537:
538:
539:
540:
541:
542:
543:
544:
545:
546:
547:
548:
549:
550:
551:
552:
553:
554:
555:
556:
557:
558:
559:
560:
561:
562:
563:
564:
565:
566:
567:
568:
569:
570:
571:
572:
573:
574:
575:
576:
577:
578:
579:
580:
581:
582:
583:
584:
585:
586:
587:
588:
589:
590:
591:
592:
593:
594:
595:
596:
597:
598:
599:
600:
601:
602:
603:
604:
605:
606:
607:
608:
609:
610:
611:
612:
613:
614:
615:
616:
617:
618:
619:
620:
621:
622:
623:
624:
625:
626:
627:
628:
629:
630:
631:
632:
633:
634:
635:
636:
637:
638:
639:
640:
641:
642:
643:
644:
645:
646:
647:
648:
649:
650:
651:
652:
653:
654:
655:
656:
657:
658:
659:
660:
661:
662:
663:
664:
665:
666:
667:
668:
669:
670:
671:
672:
673:
674:
675:
676:
677:
678:
679:
680:
681:
682:
683:
684:
685:
686:
687:
688:
689:
690:
691:
692:
693:
694:
695:
696:
697:
698:
699:
700:
701:
702:
703:
704:
705:
706:
707:
708:
709:
710:
711:
712:
713:
714:
715:
716:
717:
718:
719:
720:
721:
722:
723:
724:
725:
726:
727:
728:
729:
730:
731:
732:
733:
734:
735:
736:
737:
738:
739:
740:
741:
742:
743:
744:
745:
746:
747:
748:
749:
750:
751:
752:
753:
754:
755:
756:
757:
758:
759:
760:
761:
762:
763:
764:
765:
766:
767:
768:
769:
770:
771:
772:
773:
774:
775:
776:
777:
778:
779:
780:
781:
782:
783:
784:
785:
786:
787:
788:
789:
790:
791:
792:
793:
794:
795:
796:
797:
798:
799:
800:
801:
802:
803:
804:
805:
806:
807:
808:
809:
810:
811:
812:
813:
814:
815:
816:
817:
818:
819:
820:
821:
822:
823:
824:

// -----------------------------------------------------------------------------
// ICMP-Echo-API-Wrapper (Ping) für Delphi V1.04 vom 08.09.2011, (C) by Narses
// -----------------------------------------------------------------------------

unit Ping;

interface

uses
  Windows, WinSock;


// === öffentliche Konstanten, Typen und Variablen =============================


const
  // Standard-Wartezeit auf ein Echo (Ping-Antwort) in Millisekunden
  PING_DEFAULT_TIMEOUT = 1000;

  // eigene Fehlercodes; darüber hinaus werden noch WSA-Fehler weitergereicht
  PING_ERR_BASE = $20000000; // Custom-Error-Flag setzen -> eigene Fehlernummern
  PING_OK                  = 0;                // kein Fehler, alles OK
  PING_GENERAL_ERROR       = PING_ERR_BASE +1; // nicht näher definierter Fehler
  PING_LOAD_DLL            = PING_ERR_BASE +2; // DLL konnte nicht geladen werden
  PING_ICMP_INVALID_HANDLE = PING_ERR_BASE +3; // Fehler beim Verwenden der ICMP-Funktionen
  PING_WSASTARTUP          = PING_ERR_BASE +4; // Fehler beim Initialisieren der WSA

type
  // Ergebnistyp IP-Adress-Liste: dynamisches Array aus WSA-IPv4-Adressen
  in_addr_list = array of in_addr;

  // Ergebniswerte eines asynchronen Ping-Auftrags deklarieren
  // -> wird von der Callback-Prozedur benutzt, um das Ergbnis abzuliefern
  TAsyncPingResult = record
    RefID: Integer;     // beim Aufruf mitgegebener Referenzwert
    IPv4: in_addr;      // Adresse, die angepingt wurde
    RTT,                // Round Trip Time in ms oder -1: kein Echo, -2: Fehler
    Timeout,            // in diesem Aufruf verwendete Timeout-Zeit in ms
    ErrorCode: Integer; // Fehlercode im Fehlerfall, sonst 0 (=PING_OK)
  end;

  // Callback-Prozedur für asynchronen Ping deklarieren
  // mit so einer Prozedur wird das Ergebnis des asynchronen Pings abgeliefert
  TPingCallback = procedure(PingResult: TAsyncPingResult) of Object;

var
  // Handle der verwendeten DLL oder 0 im Fehlerfall
  DllHandle: THandle;

  // aktueller Fehlercode der _synchronen_ Funktionen (die asynchronen
  // Funktionen liefern ihr Ergebniss per Callback-Prozedur ab!)
  LastError: Integer;


// === öffentliche Funktionen ==================================================


// Klartext zu einem Fehlercode ermitteln
// -----------------------------------------------------------------------------
// Parameter:
//   Error: Ping-Unit-Fehlercode (z.B. LastError)

function ErrorToText(const ErrorCode: Integer): ShortString;

// Klartext des letzten Fehlers der synchronen Funktionen
// -----------------------------------------------------------------------------

function LastErrorText: ShortString;


// Ermitteln der (ersten) IP-Adresse zu einem Hostnamen
// -----------------------------------------------------------------------------
// Parameter:
//   Hostname:
//     Hostname, dessen IP-Adresse ermittelt werden soll; ein Leerstring steht
//     für localhost (die "eigene" Maschine)
//     Beispiele: 'localhost', 'www.delphi-forum.de'
//   IPv4:
//     enthält nach dem Aufruf die IP(v4)-Adresse oder -1 im Fehlerfall
//
// mögliche Funktionswerte:
//   FALSE:
//     Der Hostname konnte nicht aufgelöst werden, Fehlercode in LastError
//   TRUE:
//     Der Hostname wurde erfolgreich aufgelöst
//
// Hinweis: Es ist durchaus möglich, dass einem Host mehr als eine IP-Adresse
// zugeordnet ist! Beispiel: wenn zwei Netzwerkadapter (Kabel, WLAN) vorhanden
// sind, kann jede Schnittstelle eine eigene Adresse haben; auch das DNS sieht
// durchaus die Möglichkeit vor, dass einem Host mehrere IP-Adressen zugeordnet
// sind. Diese Funktion ermittelt die erste Adresse, die von der Windows-Socket-
// API (WSA) geliefert wurde.

function GetIPByName(const Hostname : AnsiString;
                     var   IPv4     : in_addr
                     ): Boolean; overload;


// Ermitteln aller IP-Adressen zu einem Hostnamen
// -----------------------------------------------------------------------------
// Parameter:
//   Hostname:
//     Hostname, dessen IP-Adressen ermittelt werden sollen; ein Leerstring
//     steht für localhost (die "eigene" Maschine)
//     Beispiele: 'localhost', 'www.delphi-forum.de'
//   IPv4List:
//     enthält nach dem Aufruf die IP(v4)-Adressen als dynamisches Array
//     oder ist NIL im Fehlerfall
//
// mögliche Funktionswerte:
//   FALSE:
//     Der Hostname konnte nicht aufgelöst werden, Fehlercode in LastError
//   TRUE:
//     Der Hostname wurde erfolgreich aufgelöst

function GetIPByName(const Hostname : AnsiString;
                     var   IPv4List : in_addr_list
                     ): Boolean; overload;


// Ping mit Adressauflösung (synchron)
// -----------------------------------------------------------------------------
// Parameter:
//   Hostname:
//     Hostname, dessen Erreichbarkeit geprüft werden soll; ein Leerstring steht
//     für localhost (die "eigene" Maschine)
//     Beispiele: 'localhost', 'www.delphi-forum.de'
//   Timeout:
//     Zeit (in ms), die auf eine Antwort gewartet werden soll; der Wert kann
//     beim Aufruf ausgelassen werden, dann wird der Standardwert verwendet:
//     1.000ms = 1sec
//
// mögliche Funktionswerte:
//     -2: Systemfehler; Fehlercode in LastError
//     -1: Timeout, keine Antwort erhalten; Fehlercode in LastError
//   >= 0: Round-Trip-Time (RTT, Antwortzeit) in Millisekunden

function Execute(const Hostname : AnsiString;
                 const Timeout  : Word = PING_DEFAULT_TIMEOUT
                 ): Integer; overload;


// direkter Ping an eine bereits aufgelöste Adresse (synchron)
// -----------------------------------------------------------------------------
// Parameter:
//   IPv4:
//     IP-Adresse des Host, dessen Erreichbarkeit geprüft werden soll
//   Timeout:
//     Zeit (in ms), die auf eine Antwort gewartet werden soll; der Wert kann
//     beim Aufruf ausgelassen werden, dann wird der Standardwert verwendet:
//     1.000ms = 1sec
//
// mögliche Funktionswerte:
//     -2: Systemfehler; Fehlercode in LastError
//     -1: Timeout, keine Antwort erhalten; Fehlercode in LastError
//   >= 0: Round-Trip-Time (RTT, Antwortzeit) in Millisekunden

function Execute(const IPv4    : in_addr;
                 const Timeout : Word = PING_DEFAULT_TIMEOUT
                 ): Integer; overload;


// Ping mit Adressauflösung (_a_synchron -> Rückruf)
// -----------------------------------------------------------------------------
// Parameter:
//   RefID:
//     Über diesen Wert kann in der Rückruf-Prozedur die Anfrage identifiziert
//     werden (z.B. fortlaufende Nummer); der Wert selbst hat auf die Funktion
//     keinen Einfluss
//   Hostname:
//     Hostname, dessen Erreichbarkeit geprüft werden soll; ein Leerstring steht
//     für localhost (die "eigene" Maschine)
//     Beispiele: 'localhost', 'www.delphi-forum.de'
//   Callback:
//     Adresse der Rückruf-Funktion, mit der das Ergebnis gemeldet wird. Dieser
//     Funktion (Deklaration siehe weiter oben) wird das Ergebnis der Echo-
//     Anforderung per Status-record übergeben.
//   Timeout:
//     Zeit (in ms), die auf eine Antwort gewartet werden soll; der Wert kann
//     beim Aufruf ausgelassen werden, dann wird der Standardwert verwendet:
//     1.000ms = 1sec
//
// mögliche Funktionswerte:
//   TRUE:
//     Die Anforderung wurde akzeptiert, es erfolgt ein Rükruf an Callback
//   FALSE:
//     Die Anforderung wurde NICHT akzeptiert, es erfolgt KEIN Rückruf!

function ExecuteAsync(const RefID    : Integer;
                      const Hostname : AnsiString;
                      Callback       : TPingCallback;
                      const Timeout  : Word = PING_DEFAULT_TIMEOUT
                      ): Boolean; overload;


// direkter Ping an eine bereits aufgelöste Adresse (_a_synchron -> Rückruf)
// -----------------------------------------------------------------------------
// Parameter:
//   RefID:
//     Über diesen Wert kann in der Rückruf-Prozedur die Anfrage identifiziert
//     werden (z.B. fortlaufende Nummer); der Wert selbst hat auf die Funktion
//     keinen Einfluss
//   IPv4:
//     IP-Adresse des Host, dessen Erreichbarkeit geprüft werden soll
//   Callback:
//     Adresse der Rückruf-Funktion, mit der das Ergebnis gemeldet wird. Dieser
//     Funktion (Deklaration siehe weiter oben) wird das Ergebnis der Echo-
//     Anforderung per Status-record übergeben.
//   Timeout:
//     Zeit (in ms), die auf eine Antwort gewartet werden soll; der Wert kann
//     beim Aufruf ausgelassen werden, dann wird der Standardwert verwendet:
//     1.000ms = 1sec
//
// mögliche Funktionswerte:
//   TRUE:
//     Die Anforderung wurde akzeptiert, es erfolgt ein Rükruf an Callback
//   FALSE:
//     Die Anforderung wurde NICHT akzeptiert, es erfolgt KEIN Rückruf!

function ExecuteAsync(const RefID   : Integer;
                      const IPv4    : in_addr;
                      Callback      : TPingCallback;
                      const Timeout : Word = PING_DEFAULT_TIMEOUT
                      ): Boolean; overload;


// === Ende des öffentlichen Teils =============================================


implementation

uses
  Classes; // für TThread

const
  IPHLPAPI_DLL   = 'IPHLPAPI.DLL'; // bevorzugte Bibliothek
  ICMP_DLL       = 'ICMP.DLL';     // Default-Fallback (alte API)
  MAX_ECHO_REPLY = 2;              // max. erwartete Anzahl ICMP-Status-Replies -1

  IP_STATUS_BASE = 11000;
  IP_SUCCESS               = 0;
// diese IP_STATUS-Codes kollidieren mit WSA-Fehlercodes, deshalb "verschieben":
//  IP_BUF_TOO_SMALL         <-> WSAHOST_NOT_FOUND
//  IP_DEST_NET_UNREACHABLE  <-> WSATRY_AGAIN
//  IP_DEST_HOST_UNREACHABLE <-> WSANO_RECOVERY
//  IP_DEST_PROT_UNREACHABLE <-> WSANO_DATA
  IP_BUF_TOO_SMALL         = IP_STATUS_BASE +  1 + PING_ERR_BASE;
  IP_DEST_NET_UNREACHABLE  = IP_STATUS_BASE +  2 + PING_ERR_BASE;
  IP_DEST_HOST_UNREACHABLE = IP_STATUS_BASE +  3 + PING_ERR_BASE;
  IP_DEST_PROT_UNREACHABLE = IP_STATUS_BASE +  4 + PING_ERR_BASE;
  IP_DEST_PORT_UNREACHABLE = IP_STATUS_BASE +  5;
  IP_NO_RESOURCES          = IP_STATUS_BASE +  6;
  IP_BAD_OPTION            = IP_STATUS_BASE +  7;
  IP_HW_ERROR              = IP_STATUS_BASE +  8;
  IP_PACKET_TOO_BIG        = IP_STATUS_BASE +  9;
  IP_REQ_TIMED_OUT         = IP_STATUS_BASE + 10;
  IP_BAD_REQ               = IP_STATUS_BASE + 11;
  IP_BAD_ROUTE             = IP_STATUS_BASE + 12;
  IP_TTL_EXPIRED_TRANSIT   = IP_STATUS_BASE + 13;
  IP_TTL_EXPIRED_REASSEM   = IP_STATUS_BASE + 14;
  IP_PARAM_PROBLEM         = IP_STATUS_BASE + 15;
  IP_SOURCE_QUENCH         = IP_STATUS_BASE + 16;
  IP_OPTION_TOO_BIG        = IP_STATUS_BASE + 17;
  IP_BAD_DESTINATION       = IP_STATUS_BASE + 18;
  IP_GENERAL_FAILURE       = IP_STATUS_BASE + 50;

type
  PIPOptionInformation = ^TIPOptionInformation;
  TIPOptionInformation = record
    Ttl         : Byte;                   // time to live
    Tos         : Byte;                   // type of service
    Flags       : Byte;                   // ip header flags
    OptionsSize : Byte;                   // size in bytes of options data
    OptionsData : ^Byte;                  // pointer to options data
  end;

  TIcmpEchoReply = record
    Address       : in_addr;              // replying address
    Status        : ULONG;                // reply ip_status
    RoundTripTime : ULONG;                // rtt in milliseconds
    DataSize      : ULONG;                // reply data size in bytes
    Reserved      : ULONG;                // reserved for system use
    Data          : Pointer;              // pointer to the reply data
    Options       : PIPOptionInformation; // reply options
  end;

  TIcmpCreateFile = function: THandle; stdcall;
  TIcmpCloseHandle = function(IcmpHandle: THandle): BOOL; stdcall;
  TIcmpSendEcho = function(IcmpHandle         : THandle;
                           DestinationAddress : in_addr;
                           RequestData        : Pointer;
                           RequestSize        : Word;
                           RequestOptions     : PIPOptionInformation;
                           ReplyBuffer        : Pointer;
                           ReplySize          : DWORD;
                           Timeout            : DWORD
                           ): DWORD; stdcall;

  TPingThread = class(TThread)
    FResolve: Boolean;
    FHostname: AnsiString;
    FPingResult: TAsyncPingResult;
    FCallback: TPingCallback;
  protected
    procedure Execute; Override;
    procedure DoCallbackVCL;
  public
    constructor Create(const RefID: Integer;
                       const Hostname: AnsiString;
                       Callback: TPingCallback;
                       const Timeout: Word); overload;
    constructor Create(const RefID: Integer;
                       const IPv4: in_addr;
                       Callback: TPingCallback;
                       const Timeout: Word); overload;
  end;

var
  IcmpCreateFile: TIcmpCreateFile;
  IcmpCloseHandle: TIcmpCloseHandle;
  IcmpSendEcho: TIcmpSendEcho;

// -----------------------------------------------------------------------------

function ErrorToText(const ErrorCode: Integer): ShortString;
begin
  case ErrorCode of
    PING_OK:
      Result := 'OK';
      // kein Fehler, alles OK
    PING_GENERAL_ERROR:
      Result := 'GENERAL_ERROR';
      // allgemeiner Fehler
    PING_LOAD_DLL:
      Result := 'LOAD_LIBRARY_FAILED';
      // ICMP-DLL konnte nicht geladen werden
    PING_ICMP_INVALID_HANDLE:
      Result := 'ICMP_INVALID_HANDLE';
    PING_WSASTARTUP:
      Result := 'WSASTARTUP_FAILED';
      // Fehler beim Initialisieren der WSA

    WSANOTINITIALISED:
      Result := 'WSANOTINITIALISED';
      // Missing WSAStartup call.
    WSAENETDOWN:
      Result := 'WSAENETDOWN';
      // The network subsystem has failed.
    WSAHOST_NOT_FOUND:
      Result := 'WSAHOST_NOT_FOUND';
      // Authoritative answer host not found.
    WSATRY_AGAIN:
      Result := 'WSATRY_AGAIN';
      // Nonauthoritative host not found, or server failure.
    WSANO_DATA:
      Result := 'WSANO_DATA';
      // Valid name, no data record of requested type.
    WSANO_RECOVERY:
      Result := 'WSANO_RECOVERY';
      // A nonrecoverable error occurred.
    WSAEINPROGRESS:
      Result := 'WSAEINPROGRESS';
      // A blocking Windows Sockets 1.1 call is in progress, or the service
      // provider is still processing a callback function.
    WSAEFAULT:
      Result := 'WSAEFAULT';
      // The name parameter is not a valid part of the user address space.
    WSAEINTR:
      Result := 'WSAEINTR';
      // A blocking Windows Socket 1.1 call was canceled through WSACancelBlockingCall.

    IP_BUF_TOO_SMALL:
      Result := 'IP_BUF_TOO_SMALL';
    IP_DEST_NET_UNREACHABLE:
      Result := 'IP_DEST_NET_UNREACHABLE';
    IP_DEST_HOST_UNREACHABLE:
      Result := 'IP_DEST_HOST_UNREACHABLE';
    IP_DEST_PROT_UNREACHABLE:
      Result := 'IP_DEST_PROT_UNREACHABLE';
    IP_DEST_PORT_UNREACHABLE:
      Result := 'IP_DEST_PORT_UNREACHABLE';
    IP_NO_RESOURCES:
      Result := 'IP_NO_RESOURCES';
    IP_BAD_OPTION:
      Result := 'IP_BAD_OPTION';
    IP_HW_ERROR:
      Result := 'IP_HW_ERROR';
    IP_PACKET_TOO_BIG:
      Result := 'IP_PACKET_TOO_BIG';
    IP_REQ_TIMED_OUT:
      Result := 'IP_REQ_TIMED_OUT';
    IP_BAD_REQ:
      Result := 'IP_BAD_REQ';
    IP_BAD_ROUTE:
      Result := 'IP_BAD_ROUTE';
    IP_TTL_EXPIRED_TRANSIT:
      Result := 'IP_TTL_EXPIRED_TRANSIT';
    IP_TTL_EXPIRED_REASSEM:
      Result := 'IP_TTL_EXPIRED_REASSEM';
    IP_PARAM_PROBLEM:
      Result := 'IP_PARAM_PROBLEM';
    IP_SOURCE_QUENCH:
      Result := 'IP_SOURCE_QUENCH';
    IP_OPTION_TOO_BIG:
      Result := 'IP_OPTION_TOO_BIG';
    IP_BAD_DESTINATION:
      Result := 'IP_BAD_DESTINATION';
    IP_GENERAL_FAILURE:
      Result := 'IP_GENERAL_FAILURE';

    else // unbekannter Fehlercode
      Result := 'NO_ERROR_TEXT';
  end;
end;

function LastErrorText: ShortString;
begin
  Result := ErrorToText(LastError);
end;

// GetLastError und ICMP-ReplyStatus liefern 4 Fehlercodes, die mit der WSA
// kollidieren; diese Überladung auflösen -> die IP_-Codes verschieben
function CheckErrorCode(ErrorCode: Integer): Integer;
begin
  Result := ErrorCode;
  if ( (Result = WSAHOST_NOT_FOUND) or
       (Result = WSATRY_AGAIN) or
       (Result = WSANO_RECOVERY) or
       (Result = WSANO_DATA) ) then
    Inc(Result,PING_ERR_BASE);
end;

// =============================================================================

function GetIPByName(const Hostname: AnsiString;
                     var IPv4: in_addr
                     ): Boolean;
  var
    WSAData: TWSAData;
    HostInfo: PHostEnt;
begin
  // Default-Werte setzen
  Result := FALSE; // Auflösung hat nicht geklappt
  IPv4.S_addr := -1; // Adresse im Fehlerfall: 255.255.255.255

  LastError := PING_WSASTARTUP; // wenn die WSA nicht initialisiert werden kann
  if (WSAStartup($0101, WSAData) = 0) then // WSA initialisieren
    try // was auch immer passiert...

      // Namensauflösung anfordern; Leerstring als "localhost" interpretieren
      if (Hostname <> '') then
        HostInfo := WinSock.GetHostByName(PAnsiChar(Hostname))
      else
        HostInfo := WinSock.GetHostByName(NIL); // -> localhost abfragen

      // hat die Auflösung ein Ergebnis gebracht?
      if Assigned(HostInfo) then begin
        // dann die erste Adresse aus der gelieferten Liste nehmen
        IPv4.S_addr := PInAddr(HostInfo^.h_addr_list^)^.S_addr;

        LastError := PING_OK; // kein Fehler
        Result := TRUE; // Auflösung hat geklappt
      end { if Assigned(HostInfo) }

      else // Fehler, Auflösung hat nicht geklappt
        LastError := WSAGetLastError; // Fehlercode ermitteln; ist threadsave!

    finally // ...auf jeden Fall die WSA wieder deinitialisieren!
      WSACleanUp;
    end;
end;

// -----------------------------------------------------------------------------

function GetIPByName(const Hostname: AnsiString;
                     var IPv4List: in_addr_list
                     ): Boolean;
  var
    WSAData: TWSAData;
    HostInfo: PHostEnt;
    AddrList: ^PInAddr;
    i: Integer;
begin
  // Default-Werte setzen
  Result := FALSE; // Auflösung hat nicht geklappt
  IPv4List := NIL; // im Fehlerfall auch kein dyn. Array liefern

  LastError := PING_WSASTARTUP; // wenn die WSA nicht initialisiert werden kann
  if (WSAStartup($0101, WSAData) = 0) then // WSA initialisieren
    try // was auch immer passiert...

      // Namensauflösung anfordern; Leerstring als "localhost" interpretieren
      if (Hostname <> '') then
        HostInfo := WinSock.GetHostByName(PAnsiChar(Hostname))
      else
        HostInfo := WinSock.GetHostByName(NIL); // -> localhost abfragen

      // hat die Auflösung ein Ergebnis gebracht?
      if Assigned(HostInfo) then begin
        // dann die Anzahl der Adressen in der Liste bestimmen...
        i := 0;
        AddrList := Pointer(HostInfo^.h_addr_list);
        while Assigned(AddrList^) do begin
          Inc(i);
          Inc(AddrList);
        end;
        SetLength(IPv4List,i); // ...das dyn. Array passend dimensionieren...
        Move(HostInfo^.h_addr_list^^,IPv4List[0],i*SizeOf(in_addr)); // und kopieren
{       // Kopieren als Schleifen-Version (wem das Byteskopieren nicht zusagt...)
        i := 0;
        AddrList := Pointer(HostInfo^.h_addr_list);
        while Assigned(AddrList^) do begin
          IPv4List[i].S_addr := AddrList^^.S_addr;
          Inc(i);
          Inc(AddrList);
        end;
}
        LastError := PING_OK; // kein Fehler
        Result := TRUE; // Auflösung hat geklappt
      end { if Assigned(HostInfo) }

      else // Fehler, Auflösung hat nicht geklappt
        LastError := WSAGetLastError; // Fehlercode ermitteln; ist threadsave!

    finally // ...auf jeden Fall die WSA wieder deinitialisieren!
      WSACleanUp;
    end;
end;

// =============================================================================

function Execute(const IPv4: in_addr;
                 const Timeout: Word = PING_DEFAULT_TIMEOUT
                 ): Integer;
  var
    Handle: THandle;
    ReplyBuffer: array[0..MAX_ECHO_REPLY] of TIcmpEchoReply;
    ReplyCount,
    i: Integer;
begin
  // Default-Werte setzen
  LastError := PING_LOAD_DLL; // wenn keine DLL zur Verfügung steht
  Result := -2; // Standard: Systemfehler

  if (DllHandle <> 0) then begin // ICMP-Funktionen verfügbar?
    // dann versuchen, ein Handle für den Echo-Request zu bekommen
    LastError := PING_ICMP_INVALID_HANDLE; // falls wir kein Handle bekommen
    Handle := IcmpCreateFile; // ICMP-Funktion ausführen

    if (Handle <> INVALID_HANDLE_VALUE) then // gültiges Handle erhalten?
      try // was auch immer passiert...

        // ICMP-Echo-Request (Ping) senden
        ReplyCount := IcmpSendEcho(Handle,
                                   IPv4,
                                   NIL, 0,
                                   NIL,
                                   @ReplyBuffer[0], SizeOf(ReplyBuffer),
                                   Timeout);

        if (ReplyCount > 0) then begin // es sind ICMP-Status-Replies da
          Result := -1; // Standard: Timeout (nicht mehr Systemfehler), es gab ja Replies!

          // Anzahl der Antwortpakete auf 0..MAX_ECHO_REPLY bringen -> Arrayindex
          Dec(ReplyCount);
          if (ReplyCount > MAX_ECHO_REPLY) then
            ReplyCount := MAX_ECHO_REPLY;

          // solange Replies auswerten, bis eine Antwort dabei ist; dabei den
          // letzten ausgewerteten Status-Code übernehmen
          i := 0;
          while ( (Result < 0) and (i <= ReplyCount) ) do begin
            LastError := CheckErrorCode(ReplyBuffer[i].Status); // WSA-Fehlercode-Problem...
            if (LastError = IP_SUCCESS) then // Antwort erhalten?
              Result := ReplyBuffer[i].RoundTripTime; // dann ist RTT auch gültig
            Inc(i);
          end;
        end

        else begin // IcmpSendEcho hat nicht geklappt; Grund auswerten
          LastError := CheckErrorCode(GetLastError); // Windows-Fehler ermitteln; threadsave!
          if (LastError = IP_REQ_TIMED_OUT) then // Timeout?
            Result := -1; // das ist dann kein Systemfehler
        end;

      finally // ...auf jeden Fall das Handle wieder freigeben!
        IcmpCloseHandle(Handle);
      end;
  end;
end;

// -----------------------------------------------------------------------------

function Execute(const Hostname: AnsiString;
                 const Timeout: Word = PING_DEFAULT_TIMEOUT
                 ): Integer;
  var
    IP: in_addr;
begin
  // Namensauflösung in IP-Adresse versuchen:
  if (GetIPByName(Hostname, IP)) then // hat geklappt, ...
    // ...also Anfrage mit IP-Adresse weiterreichen
    Result := Execute(IP, Timeout)

  else // hat nicht geklappt, ...
    case LastError of // ...also Fehlergrund untersuchen:
      WSAHOST_NOT_FOUND, WSATRY_AGAIN:
        Result := -1; // ungültige Hostnamen nicht als Systemfehler interpretieren
      else
        Result := -2; // Systemfehler
    end;
end;

// =============================================================================

function ExecuteAsync(const RefID: Integer;
                      const IPv4: in_addr;
                      Callback: TPingCallback;
                      const Timeout: Word = PING_DEFAULT_TIMEOUT
                      ): Boolean;
begin
  Result := (DllHandle <> 0); // ICMP-Funktionen verfügbar?
  if (Result) then // ja, dann Thread starten
    TPingThread.Create(RefID, IPv4, Callback, Timeout);
end;

// -----------------------------------------------------------------------------

function ExecuteAsync(const RefID: Integer;
                      const Hostname: AnsiString;
                      Callback: TPingCallback;
                      const Timeout: Word = PING_DEFAULT_TIMEOUT
                      ): Boolean;
begin
  Result := (DllHandle <> 0); // ICMP-Funktionen verfügbar?
  if (Result) then // ja, dann Thread starten
    TPingThread.Create(RefID, Hostname, Callback, Timeout);
end;

// =============================================================================

constructor TPingThread.Create(const RefID: Integer;
                               const IPv4: in_addr;
                               Callback: TPingCallback;
                               const Timeout: Word);
begin
  inherited Create(TRUE); // Thread gestoppt erzeugen
  FreeOnTerminate := TRUE;
  // Werte in lokale Threadvariablen eintragen
  FPingResult.RefID := RefID;
  FPingResult.Timeout := Timeout;
  FPingResult.IPv4 := IPv4;
  FResolve := FALSE; // Adresse ist schon aufgelöst
  FCallback := Callback;
  // Thread starten, ruft .Execute auf
  Suspended := FALSE;
end;

constructor TPingThread.Create(const RefID: Integer;
                               const Hostname: AnsiString;
                               Callback: TPingCallback;
                               const Timeout: Word);
begin
  inherited Create(TRUE); // Thread gestoppt erzeugen
  FreeOnTerminate := TRUE;
  // Werte in lokale Threadvariablen eintragen
  FPingResult.RefID := RefID;
  FPingResult.Timeout := Timeout;
  FResolve := TRUE; // Adresse muss noch aufgelöst werden
  FHostname := Hostname;
  FCallback := Callback;
  // Thread starten, ruft .Execute auf
  Suspended := FALSE;
end;

procedure TPingThread.Execute;
  var
    WSAData: TWSAData;
    HostInfo: PHostEnt;
    Handle: THandle;
    ReplyBuffer: array[0..MAX_ECHO_REPLY] of TIcmpEchoReply;
    ReplyCount, i: Integer;
begin
  // Default-Werte setzen
  FPingResult.RTT := -2; // Standard-Ergebnis: Systemfehler
  FPingResult.ErrorCode := PING_GENERAL_ERROR;

  // Adresse noch auflösen?
  if (FResolve) then begin // ja:
    // Default-Werte setzen
    FResolve := FALSE; // Auflösung hat nicht geklappt
    FPingResult.IPv4.S_addr := -1; // Adresse im Fehlerfall: 255.255.255.255

    FPingResult.ErrorCode := PING_WSASTARTUP; // wenn die WSA nicht initialisiert werden kann
    if (WSAStartup($0101, WSAData) = 0) then // WSA initialisieren
      try // was auch immer passiert...

      // Namensauflösung anfordern; Leerstring als "localhost" interpretieren
        if (FHostname <> '') then
          HostInfo := WinSock.GetHostByName(PAnsiChar(FHostname))
        else
          HostInfo := WinSock.GetHostByName(NIL); // -> localhost abfragen

        // hat die Auflösung ein Ergebnis gebracht?
        if Assigned(HostInfo) then begin
          // dann die erste Adresse aus der gelieferten Liste nehmen
          FPingResult.IPv4.S_addr := PInAddr(HostInfo^.h_addr_list^)^.S_addr;

          FPingResult.ErrorCode := PING_OK; // kein Fehler
          FResolve := TRUE; // Auflösung hat geklappt
        end { if Assigned(HostInfo) }

        else begin // Fehler, Auflösung hat nicht geklappt...
          FPingResult.ErrorCode := WSAGetLastError; // ...also Fehlercode ermitteln; ist threadsave!
          if ( (FPingResult.ErrorCode = WSAHOST_NOT_FOUND)
               or
               (FPingResult.ErrorCode = WSATRY_AGAIN) ) then
            FPingResult.RTT := -1; // ungültige Hostnamen nicht als Systemfehler interpretieren
        end;

      finally // ...auf jeden Fall die WSA wieder deinitialisieren!
        WSACleanUp;
      end;
  end { if (FResolve) }

  else // Adresse liegt bereits aufgelöst vor
    FResolve := TRUE; // Echo-Request kann direkt erfolgen

  // FResolve zeigt jetzt an, ob noch ein Ping versucht werden soll
  if (FResolve) then begin // IP-Adresse liegt vor, Echo-Request senden

    // versuchen, ein Handle für den Echo-Request zu bekommen
    FPingResult.ErrorCode := PING_ICMP_INVALID_HANDLE; // falls wir kein Handle bekommen
    Handle := IcmpCreateFile; // ICMP-Funktion ausführen

    if (Handle <> INVALID_HANDLE_VALUE) then // gültiges Handle erhalten?
      try // was auch immer passiert...

        // ICMP-Echo-Request (Ping) senden
        ReplyCount := IcmpSendEcho(Handle,
                                   FPingResult.IPv4,
                                   NIL, 0,
                                   NIL,
                                   @ReplyBuffer[0], SizeOf(ReplyBuffer),
                                   FPingResult.Timeout);

        if (ReplyCount > 0) then begin // es sind ICMP-Status-Replies da
          FPingResult.RTT := -1; // Standard: Timeout (nicht mehr Systemfehler), es gab ja Replies!

          // Anzahl der Antwortpakete auf 0..MAX_ECHO_REPLY bringen -> Arrayindex
          Dec(ReplyCount);
          if (ReplyCount > MAX_ECHO_REPLY) then
            ReplyCount := MAX_ECHO_REPLY;

          // solange Replies auswerten, bis eine Antwort dabei ist; dabei den
          // letzten ausgewerteten Status-Code übernehmen
          i := 0;
          while ( (FPingResult.RTT < 0) and (i <= ReplyCount) ) do begin
            FPingResult.ErrorCode := CheckErrorCode(ReplyBuffer[i].Status); // WSA-Fehlercode-Problem...
            if (FPingResult.ErrorCode = IP_SUCCESS) then // Antwort erhalten?
              FPingResult.RTT := ReplyBuffer[i].RoundTripTime; // dann ist RTT auch gültig
            Inc(i);
          end;
        end

        else begin // IcmpSendEcho hat nicht geklappt; Grund auswerten
          FPingResult.ErrorCode := CheckErrorCode(GetLastError); // Windows-Fehler ermitteln; threadsave!
          if (FPingResult.ErrorCode = IP_REQ_TIMED_OUT) then // Timeout?
            FPingResult.RTT := -1; // das ist dann kein Systemfehler
        end;

      finally // ...auf jeden Fall das Handle wieder freigeben!
        IcmpCloseHandle(Handle);
      end;
  end;

  if Assigned(FCallback) then // Callback-Funktion übergeben?
    Synchronize(DoCallbackVCL); // dann VCL-fähig ausführen
end;

// Da nicht bekannt ist, "was" da zurückgerufen wird, sicherheitshalber mit dem
// Haupt-Thread der Anwendung synchronisieren (sonst können keine VCL-Komponenten
// in der Rückrüffunktion bearbeitet werden, da VCL-Prozeduren nicht direkt aus
// Threads aufgerufen werden dürfen).
procedure TPingThread.DoCallbackVCL;
begin
  FCallback(FPingResult);
end;

// --- Unit initialisieren (DLL bestimmen und laden) ---------------------------

initialization
  LastError := PING_LOAD_DLL;
  DllHandle := LoadLibrary(PChar(IPHLPAPI_DLL));
  if (DllHandle <> 0) then begin
    @IcmpCreateFile := GetProcAddress(DllHandle, 'IcmpCreateFile');
    if (NOT Assigned(IcmpCreateFile)) then begin
      FreeLibrary(DllHandle);
      DllHandle := 0;
    end;
  end;
  if (DllHandle = 0) then begin
    DllHandle := LoadLibrary(PChar(ICMP_DLL));
    if (DllHandle <> 0) then begin
      @IcmpCreateFile := GetProcAddress(DllHandle, 'IcmpCreateFile');
      if (NOT Assigned(IcmpCreateFile)) then begin
        FreeLibrary(DllHandle);
        DllHandle := 0;
      end;
    end;
  end;
  if (DllHandle <> 0) then begin
    @IcmpCloseHandle := GetProcAddress(DllHandle, 'IcmpCloseHandle');
    @IcmpSendEcho := GetProcAddress(DllHandle, 'IcmpSendEcho');
    LastError := 0;
  end;

// --- Unit deinitialisieren (DLL wieder freigeben, wenn noch geladen) ---------

finalization
  if (DllHandle <> 0) then
    FreeLibrary(DllHandle);

end.

Öffnen, kompilieren, die Ping.dcu in das \Lib-Verzeichnis, optional die Ping.pas in ein Source-Verzeichnis legen (nicht notwendig, die .dcu reicht), dann kann über uses ..., Ping; auf die Unit zugegriffen werden. Es kann für den Typ in_addr (IPv4-Adresse) nötig sein, noch WinSock in die uses-Klausel einzufügen.

Ich habe noch eine Demo-Anwendung beigelegt, die die Verwendung veranschaulicht.

Die Unit ist frei verwendbar, unter der Voraussetzung, dass mein Autorenverweis erhalten bleibt (mind. Erwähnung in den Credits einer Anwendung, die auf die Unit zugreift).

Bitte testet doch mal ausgiebig und sagt mir eure Meinung dazu, Danke. :wink:

//EDIT: seit Version 1.04 ist die Unit auch für Unicode-Delphi-Versionen geeignet. Getestet mit D2k10.

cu
Narses

Einloggen, um Attachments anzusehen!

_________________
There are 10 types of people - those who understand binary and those who don´t.

reichemi · Beiträge: 41 WinXP home + prof, SUSE 9.2 Delphi 6

hallo!

ich hab mir gerad deine unit sowie die demo runtergeladen, und muss sagen: das sieht seeehr gut und vielversprechend aus!! gefällt mir

beim quelltext-durchschauen ist mir aber aufgefallen: warum läßt du dir beim IcmpSendEcho()-Aufruf nicht auch die IPOptionInformation zurückgeben und schreibst diese mit in den TAsyncPingResult-Record (im asynchronen fall)? hattest du einen grund, oder gab es einfach keinen bedarf dafür? :wink:

Narses · Verfasst: Fr 03.03.06 14:28

Moin und

im Forum!

reichemi hat folgendes geschrieben:

ich hab mir gerad deine unit sowie die demo runtergeladen, und muss sagen: das sieht seeehr gut und vielversprechend aus!! gefällt mir

Danke für das Lob!

reichemi hat folgendes geschrieben:

beim quelltext-durchschauen ist mir aber aufgefallen: warum läßt du dir beim IcmpSendEcho()-Aufruf nicht auch die IPOptionInformation zurückgeben und schreibst diese mit in den TAsyncPingResult-Record (im asynchronen fall)? hattest du einen grund, oder gab es einfach keinen bedarf dafür? :wink:

Ich hab keinen Grund gesehen, das zurückzuliefern. Hast du einen sinnvollen Grund gefunden? :wink:

Ausser der RTT und einem möglichst umfangreichen, aber zentralen Fehlerstatus braucht man bei einem Ping doch eigentlich nix... :gruebel:

Bis für Vorschläge offen!

cu
Narses

_________________
There are 10 types of people - those who understand binary and those who don´t.

reichemi · Beiträge: 41 WinXP home + prof, SUSE 9.2 Delphi 6

Narses hat folgendes geschrieben:

Moin und

im Forum!

danke

Narses hat folgendes geschrieben:

Ausser der RTT und einem möglichst umfangreichen, aber zentralen Fehlerstatus braucht man bei einem Ping doch eigentlich nix...

joaaa.... eigentlich ;-)

aber dagegen sprechen zwei dinge:

1) ich finde die TTL noch ganz interessant ;-)

2) sollte man bei einer komponente doch dem programmierer möglichst viele informationen anbieten, und ihm die auswahl der für ihn sinnvollen infos überlassen -- oder? :gruebel:

Narses hat folgendes geschrieben:

vom 05.03.-21.03. offline

na da hab ich ja glück gehabt, dass ich dich noch erwischt hab

Narses · Verfasst: Fr 03.03.06 21:19

Moin!

reichemi hat folgendes geschrieben:

joaaa.... eigentlich ;-)

aber dagegen sprechen zwei dinge:
1) ich finde die TTL noch ganz interessant ;-)

Echt? Wozu hast du die (bei einem Ping!) jemals gebraucht... :gruebel:

reichemi hat folgendes geschrieben:

2) sollte man bei einer komponente doch dem programmierer möglichst viele informationen anbieten, und ihm die auswahl der für ihn sinnvollen infos überlassen -- oder? :gruebel:

Ja, aber nach der Maxime: soviel wie nötig, so knapp wie möglich. :wink:

Versteh mich recht, ich hab nix dagegen die z.B. TTL auch mit abzuliefern, aber es sollte auch einen Sinn haben. Funktionen, die parameterüberladen sind, nutzen selten viele davon aus, und nur weil es die Info grundsätzlich gibt, muss man sie ja nicht unbedingt immer gleich weiterreichen.

Abgesehen davon: für genau diesen Fall habe ich ja den Quelltext veröffentlicht. :wink:

Wenn dir eigene Erweiterungen einfallen (die aber eher für dich spezifisch wichtig sind), dann kannste du dir die Unit ja nach deinem Ermessen für dich erweitern...

reichemi hat folgendes geschrieben:

Narses hat folgendes geschrieben:

vom 05.03.-21.03. offline

na da hab ich ja glück gehabt, dass ich dich noch erwischt hab

Irgendwann muss der Mensch auch mal Urlaub machen.

Abgesehen davon, ich verbringe glaub ich im Moment viel zuviel Zeit im DF, ich sollte auch mal wieder etwas Abstand nehmen

cu
Narses

_________________
There are 10 types of people - those who understand binary and those who don´t.

reichemi · Beiträge: 41 WinXP home + prof, SUSE 9.2 Delphi 6

Narses hat folgendes geschrieben:

Abgesehen davon: für genau diesen Fall habe ich ja den Quelltext veröffentlicht. :wink:

stimmt schon

mal sehen ob ichs mir noch dazu programmier...

trotzdem danke nochmal für die super unit und die schnelle antwort! :wave:

reddevil · Beiträge: 23

Hallo

Zuerst einmal großes Lob an Dich. Du hast eine sehr schöne und nützliche Unit geschrieben.

Was mir jedoch aufgefallen ist, wenn oft die Funktion ExecuteAsync mit einem unaufgelösten Hostname aufgerufen wird, so steigt der Speicherverbrauch des Programms an. Er scheint linear mit der Anzahl der Aufrufe zu steigen, könnte also irgendwelcher Speicher sein der nicht wieder freigegeben wird.
Wenn anstelle des Hostname die Funktion mit der entsprechenden in_addr Struktur aufgerufen wird, so tritt dieser Effekt nicht auf. Ich würde daher vermuten, dass "der Fehler" zwischen Zeile 688 und 724 liegt (konnte ihn jedoch nicht finden).

Um den oben beschriebenen Effekt festzustellen reicht es in deinem PingDemo Programm einen Host (z.B. www.heise.de) etwa 20mal in die Hostliste hinzufügt und anschließend mehrfach asynchron anzupingen. Den Speicherbedarf kann man dabei im Taskmanager beobachten.

Ich hoffe du oder jemand anderes kann dieses Problem beheben.

Natürlich wünsche ich dir noch einen schönen Urlaub

red

Narses · Verfasst: Di 21.03.06 01:16

Moin!

reddevil hat folgendes geschrieben:

Zuerst einmal großes Lob an Dich. Du hast eine sehr schöne und nützliche Unit geschrieben.

Danke für das Lob!

reddevil hat folgendes geschrieben:

Was mir jedoch aufgefallen ist, wenn oft die Funktion ExecuteAsync mit einem unaufgelösten Hostname aufgerufen wird, so steigt der Speicherverbrauch des Programms an. Er scheint linear mit der Anzahl der Aufrufe zu steigen

Ja, weil du (zu)viele Threads startest, die du gar nicht brauchst. Nebenbei: ein Programm sollte AFAIK nicht mehr als 16 Threads laufen haben.

reddevil hat folgendes geschrieben:

Ich würde daher vermuten, dass "der Fehler" zwischen Zeile 688 und 724 liegt (konnte ihn jedoch nicht finden).

Es ist kein Fehler in der Unit, sondern in der "Benutzung". :wink:

Im Anhang ist ein kleines Beispielprogramm, wie man das asynchrone Anpingen einer Liste von Hosts mit meiner Ping-Unit lösen könnte. Der "Trick" besteht darin, über die Callback-Funktion eine Ereignisverkettung aufzubauen. So laufen nie mehr als 2 Ping-Threads gleichzeitig (und brauchen auch nicht mehr Speicher, als nötig).

cu
Narses

Hinweis: Falls die Anhänge nicht da sind, die Seite (ggfs. auch mehrfach) neu laden, dann tauchen die Anhänge irgendwann auf (ist ein Bug in der aktuellen Forensoftware). :wink:

Einloggen, um Attachments anzusehen!

Ehemaliges Mitglied Erhaltene Danke: 1

Narses hat folgendes geschrieben:

Nebenbei: ein Programm sollte AFAIK nicht mehr als 16 Threads laufen haben.

Warum? Wie kommst du auf diese Zahl? In meinem Suche in der Delphi-PRAXiS

LUCKIEPING erzeuge ich 255 Threads auf einen Schlag.

Zitat:

reddevil hat folgendes geschrieben:

Ich würde daher vermuten, dass "der Fehler" zwischen Zeile 688 und 724 liegt (konnte ihn jedoch nicht finden).

Es ist kein Fehler in der Unit, sondern in der "Benutzung". :wink:

Nein, es ist ein Fehler in deinem Code. Du hast wahrschenlich da irgendwo ein Speicherleck.

reddevil · Beiträge: 23

Hallo

Ich habe mir dein neues Beispielprogramm angeschaut und festgestellt, dass dort das Speicherproblem nicht auftritt. Allerdings find ich das Programm auch relativ "sinnfrei", denn so wie du es dort umgesetzt hast, könnte man auch direkt syncron pingen.

Den von mir oben beschriebenen Effekt kannst du auch schon mit nur zwei Einträgen in der Hostliste deines PingDemo-Programmes feststellen. Die etwa 20 Einträge von mir waren nur gewählt, damit der Effekt deutlicher wird.
Bei nur einem Eintrag in der Hostliste steigt der Speicherverbrauch bei mir nicht an.
Daher könnte es vielleicht auch an irgendwelchen "nicht thread-sicheren" Windowsfunktionen liegen.

red

Narses · Verfasst: Di 21.03.06 11:25

Moin!

Luckie hat folgendes geschrieben:

Narses hat folgendes geschrieben:

Nebenbei: ein Programm sollte AFAIK nicht mehr als 16 Threads laufen haben.

Warum? Wie kommst du auf diese Zahl? In meinem Suche in der Delphi-PRAXiS

LUCKIEPING erzeuge ich 255 Threads auf einen Schlag.

Meine das mal als Empfehlung gelesen zu haben; aber da du so wehement dagegen hältst, bin ich mir schon nicht mehr so sicher...

Luckie hat folgendes geschrieben:

Nein, es ist ein Fehler in deinem Code. Du hast wahrschenlich da irgendwo ein Speicherleck.

Naja, wenn du das sagst... dann werde ich mich mal mit "Räucherwerk auf dem Klo einschließen und nachdenken", wie man so sagt.

reddevil hat folgendes geschrieben:

Ich habe mir dein neues Beispielprogramm angeschaut [...] Allerdings find ich das Programm auch relativ "sinnfrei", denn so wie du es dort umgesetzt hast, könnte man auch direkt syncron pingen.

Hmm, also von "sinnfrei" kann mal nicht wirklich die Rede sein.

Wenn du das synchron machst, dann bleibt die GUI "hängen", weil keine Ereignisverarbeitung mehr stattfindet (während der Ping-executes), das passiert mit dem PingListe-Beispiel nicht.

cu
Narses

reddevil · Beiträge: 23

Sorry, ich habe mich schlecht ausgedrückt.
Das syncrone Pingen müsste man natürlich in einen extra Thread auslagern, man würde sich dann aber das häufige Thread-erzeugen und beenden in deinem Programm ersparren.

Ich fände es sehr gut wenn du den Fehler finden würdest, also viel Erfolg auf dem Klo.

Narses · Verfasst: Mi 22.03.06 15:48

Moin!

reddevil hat folgendes geschrieben:

viel Erfolg auf dem Klo.

Danke, scheint genutzt zu haben!

Um das Ergebnis vorwegzunehmen: die Unit ist IMHO fehlerfrei, das ist kein Speicherleck.

Hier die Begründung:

Ich habe das im Anhang befindliche Testprogramm gestartet und den Speicherverbrauch nach jeweils einem Klick auf den Button aus dem Taskmanager abgeschrieben:

markieren

Quelltext

1:
2:
3:
4:

3616,3892,3948,3948,3972,3964,3968,4000,4180,4032,4248,4044,4048,
4140,4100 (nur gewartet),4224,4076,4268,4108,4144,4320,4160,4200,
4324,4144,4164,4284,4216,4376,4232,4412,4468,4340,4312,4524,4404,
4592,4408,4592,4472,4664,4536,4504,4696,4552,4760,4692,4828

Interpretation: Es ist zwar ein eindeutiger Aufwärtstrend sichtbar (durchschnittlich 127kb zunehmend, 116kb abnehmend), aber da auch im ersten markierten Fall 204kb freigegeben wurden, kann ich nicht an ein Speicherleck glauben. Ich denke vielmehr, dass es sich um die "normale" Fluktuation des Delphi-Speichermanagers handelt (besonders deshalb, weil im zweiten markierten Fall scheinbar eine garbage-collection stattgefunden hat).

Fazit: Ich schätze, meine Unit stellt im asynchronen Modus lediglich den Delphi-MemoryManager bloss...

Wenn jemand tatsächlich ein Speicherleck finden sollte (was ich nicht kategorisch ausschließen will!), dann bin ich über jede Info dankbar. Ich kann keinen Thread-basierten Fehler erkennen, IMHO ist das ExecuteAsync threadsave!

Hinweis: Da in meinem ersten Demoprogramm auch das Log-Memo mit Text gefüllt wird, wenn man Ping-Aufträge erstellt, könnte der zunehmende Speicherverbrauch auch an dieser Stelle Begründung finden... :?:

cu
Narses

Einloggen, um Attachments anzusehen!

reddevil · Beiträge: 23

Narses hat folgendes geschrieben:

Hinweis: Da in meinem ersten Demoprogramm auch das Log-Memo mit Text gefüllt wird, wenn man Ping-Aufträge erstellt, könnte der zunehmende Speicherverbrauch auch an dieser Stelle Begründung finden... :?:

Das kann ich ausschließen. Ich habe die Textausgabe auf das Log-Memo auskommentiert und der Speicherzuwachs war dennoch da.

An einen "Fehler" im MemoryManager will ich nicht glauben, allerdings weiss ich auch nicht woran es liegt.

Narses · Verfasst: Do 23.03.06 10:02

Moin!

reddevil hat folgendes geschrieben:

An einen "Fehler" im MemoryManager will ich nicht glauben, allerdings weiss ich auch nicht woran es liegt.

Von einem Fehler redet auch niemand, da aber in der Hostname-Variante Strings auf den (in den threadsave-mode geschalteten) Heap gelegt werden und die Threads nicht alle synchron dazu terminieren, wird es einfach ein "Schweizer-Käse"-Problem sein, schätze ich. Wenn du in Zeile 637 "Hostname" durch '' ersetzt, tritt der Speicher-Effekt auch nicht mehr (so) auf (in meinem 2. Test-Programm, dass nur den Call macht).

Fazit: IMHO ist da kein Speicherleck, das ist ein Thread-Heap-Problem mit den Strings (prinzipbedingt). Ich will das Speicherleck nicht ausschließen, aber in separaten Tests, in denen ich alle Elemente des TPingThread.Execute getestet habe, ist der Speicherzuwachs nach Terminieren der Threads wieder abgebaut worden. Sobald die Strings ins Spiel kamen, wurde der Speicher nicht mehr vollständig abgebaut, sondern nach dem im letzten Post beschriebenen Verhalten.

Also, ohne neue Erkenntnisse lasse ich das so und unterstelle keinen Fehler in der Unit.

cu
Narses

Zyklame · Verfasst: Mi 05.04.06 10:16

Vieleicht hat das Problem mit dem Delphi Speichermanager zu tun:

www.dsdt.info/inside.../speichermanager.php

Hendi48 · Beiträge: 271

Wo krieg ich denn dieses TPing her? Ich find das nur für Delphi 3 aber ich brauchs für D2007 =(

Narses · Verfasst: So 19.08.07 23:16

Moin!

Hendi48 hat folgendes geschrieben:

Wo krieg ich denn dieses TPing her?

Was für ein TPing? :gruebel:

Im ersten Beitrag (wie hier üblich... :roll:

) ist doch die komplette Unit und im Anhang eine Demo... :nixweiss:

cu
Narses

_________________
There are 10 types of people - those who understand binary and those who don´t.

Bookworm · Beiträge: 29 Win XP SP2 Delphi 2005 PE

Irgendwie komm ich damit nicht klar :oops:

Ich meine, die fertig kompilierte Demo zeigt mir schon, dass es eigentlich genau das ist, was ich suche. Aber meine bescheidenen Delphi-Kenntnisse beinhalten leider nicht, wie ich aus diesem Unit-Quelltext die DCU mache, die ich später bei uses einbinden kann. Und die eigentliche Ping-Funktion finde ich auch nicht :oops:

Asche auf mein Haupt
Bookworm

Narses · Verfasst: Do 30.08.07 21:25

Moin!

Speicher den Unit-Quelltext als Ping.pasim Verzeichnis deines Programms ab. Pack in die uses-Klausel am Anfang des Programms:

markieren

Delphi-Quelltext

1:
2:

uses
   ..., Ping;

dann kannst du die Unit benutzen.

cu
Narses

_________________
There are 10 types of people - those who understand binary and those who don´t.

	Mitgliederliste
	Gruppen
	Das Team
	Richtlinien
	Synonyme