icmpdll.pas

IP地址查询,可以在互联网上搜索不同的IP地址为网络编程提供个接例程

    RequestOptions: TIPOptions;
    RoundTime: longint;
    i: integer;
begin
     inherited Go;
     case ICMP_state of
          ICMP_dll:         //the only one implemented here
     else
         raise EICMPError.Create('No ICMP.DLL found - Cannot Perform PING');
     end;
     //initailise stats
     RequestData:=nil;
     ReplyBuffer:=nil;
     fNoOfPacketsRec:=0;
     RoundTime:=0;
     fRoundTimeMax:=-1;
     fRoundTimeMin:=maxint;
     fRoundTimeMed:=-1;
     //do the stuff
     try
        GetMem(RequestData,fBlockSize);
        fillchar(RequestData^,fBlockSize,#$a7);
        GetMem(ReplyBuffer,fReplySize);

        RequestOptions.TTL:=fTTL; //a ping should live near infinity, apparently - allowing it to travel through as many routers as it takes..
        RequestOptions.tos:=0;
        RequestOptions.flags:=0;
        RequestOptions.OptionsSize:=0;
        RequestOptions.OptionsData:=nil;

        for i:=1 to fNoOfPackets do
            begin
                 if fTerminated then break;
                 //This is the PING
                 if ICMPSendEcho(ICMPHandle,fAddress,
                                 RequestData,fBlockSize,
                                 @RequestOptions,
                                 Replybuffer,fReplySize,
                                 fTimeout) = 1 then
                    begin
                         pReply:=pICMPEchoReply(replybuffer);
                         //update the internal statistics
                         if (pReply^.status=ipSuccess) and
                              (pReply^.address=fAddress) then
                            begin
                                 inc(fNoOfPacketsRec);
                                 RoundTime:=RoundTime+pReply^.rttime;
                                 if fRoundTimeMin>pReply^.rttime then
                                    fRoundTimeMin:=pReply^.rttime;
                                 if fRoundTimeMax<pReply^.rttime then
                                    fRoundTimeMax:=pReply^.rttime;
                                 fRoundTimeMed:=RoundTime/fNoOfPacketsRec;
                            end;
                         //raise an event
                         if assigned(fOnPing) then
                            fOnPing(self,pReply^.status,pReply^.address,pReply^.rttime,false);
                    end
                   else
                    begin //No Packets, but still raise an event but with BadEcho Flag
                         if assigned(fOnPing) then
                            fOnPing(self,-1,0,-1,true);
                    end;
            end;
        //finalise the internal stats
        if fNoOfPacketsRec>0 then
           fRoundTimeMed:=RoundTime/fNoOfPacketsRec
          else
           fRoundTimeMed:=-1;
        if fRoundTimeMin=fTimeout+1 then
           fRoundTimeMin:=-1;
     finally
        if RequestData<>nil then
           FreeMem(RequestData,fBlockSize);
        if ReplyBuffer<>nil then
           FreeMem(ReplyBuffer,fReplySize);
     end;
end;

function TPing.GetRoundTimeMin:longint;
begin
     if fRoundTimeMin=maxint then
        result:=-1
       else
        result:=fRoundTimeMin;
end;

//------------------------------------------
//TTraceRoute
constructor TTraceRoute.Create(Aowner:TComponent);
begin
     inherited create(AOwner);
     fBlockSize:=64;
end;

procedure TTraceRoute.Go;
var RequestData,ReplyBuffer: pointer;
    pReply: pICMPEchoReply;
    RequestOptions: TIPOptions;
    i: integer;
begin
     inherited Go;
     case ICMP_state of
          ICMP_dll:         //the only one implemented here
     else
         raise EICMPError.Create('No ICMP.DLL found - Cannot Perform TraceRoute');
     end;
     requestdata:=nil;
     replybuffer:=nil;
     try
        GetMem(RequestData,fBlockSize);
        fillchar(RequestData^,fBlockSize,#$a7);
        GetMem(ReplyBuffer,fReplySize);

        i:=0;
        while (i<fTTL) do
              begin
                   if fTerminated then break;
                   //Set up for this round..
                   RequestOptions.TTL:=i+1;
                   RequestOptions.tos:=0;
                   RequestOptions.flags:=0;
                   RequestOptions.optionssize:=0;
                   RequestOptions.optionsdata:=nil;
                   //PING for this round
                   if ICMPSendEcho(ICMPHandle,fAddress,
                                   RequestData,fBlockSize,
                                   @RequestOptions,
                                   ReplyBuffer,fReplySize,
                                   fTimeout) = 1 then
                      begin
                           pReply:=pICMPEchoReply(ReplyBuffer);
                           if (pReply^.status=ipSuccess) and
                                (pReply^.address=fAddress) then
                              begin
                                   //We've found it!! Don't do any more
                                   fTerminated:=true;
                                   inc(i);
                              end
                             else
                              //Packet didn't last long enough..
                              if (pReply^.status=ipTTLExpiredTransmit) then
                                 inc(i)
                                else
                                 {Trip not completed, and Packet lived.. Don't really know what to do!};
                           //Raise event if: Assigned
                           //                Successful trip OR Packet died
                           if assigned(fOnRoute) and
                                ((pReply^.status=ipSuccess) or (pReply^.status=ipTTLExpiredTransmit)) then
                              fOnRoute(self,i,pReply^.address,pReply^.rttime,false);
                      end
                     else
                      begin //Nothing Returned, but show an event with a BadEcho flag
                            //This allows for a prog to Terminate as required, before TTL is reached
                            inc(i); //increase the Hops
                            if assigned(fOnRoute) then
                               fOnRoute(self,i,0,-1,true);
                      end;
              end;
     finally
        if requestdata<>nil then
           FreeMem(RequestData,fBlockSize);
        if replybuffer<>nil then
           FreeMem(ReplyBuffer,fReplySize);
     end;
end;

//------------------------------------------
//These could be used as components
//  But I have left them as classes for
//      easier use with threads

{procedure Register;
begin
     RegisterComponents('ICMP', [TPing]);
     RegisterComponents('ICMP', [TTraceRoute]);
end;}

//------------------------------------------
//Initialisation and Finalisation procedures
//   Load and free the ICMP.dll as required

procedure Setup;
var f_socket: TSocket;
begin
     hDll:=LoadLibrary('ICMP.DLL');
     if hdll<>0 then
        begin
             @ICMPCreateFile:=GetProcAddress(hdll,'IcmpCreateFile');
             @ICMPCloseHandle:=GetProcAddress(hdll,'IcmpCloseHandle');
             @ICMPSendEcho:=GetProcAddress(hdll,'IcmpSendEcho');
             ICMP_state:=ICMP_dll; //We'll use this!
        end
       else
        begin
             f_socket:=Winsock.Socket(PF_INET,SOCK_RAW,IPPROTO_IP);
             if f_socket=INVALID_SOCKET then
                ICMP_state:=no_ICMP        //no ICMP possible
               else
                ICMP_state:=ICMP_winsock;  //ICMP via winsock, not implemented here
             closesocket(f_socket);
        end;
end;

procedure Shutdown;
begin
     if hDll<>0 then FreeLibrary(hDll);
end;

initialization
begin
     SetUp;
end;

finalization
begin
     Shutdown;
end;

end.