opports.dpr

像windows的netstat一样查看本机开放端口的程序源码

   CopyMemory(@LBuf,LAnsiString.Buffer,LAnsiString.Length);
   PByte(Cardinal(@LBuf)+LAnsiString.Length)^:=0;
   Result:=LBuf;
   RtlFreeAnsiString(@LAnsiString);
  end;
 end else Result:='Idle';
end;

function EnableDebugPrivilege:Boolean;
var
 TokenHandle:THandle;
 DebugNameValue:TLargeInteger;
 Privileges:TOKEN_PRIVILEGES;
 RetLen:Cardinal;
begin
 Result:=False;
 if not OpenProcessToken(GetCurrentProcess,TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY,TokenHandle) then Exit;
 if not LookupPrivilegeValue(nil,'SeDebugPrivilege',DebugNameValue) then
 begin
  CloseHandle(TokenHandle);
  Exit;
 end;
 Privileges.PrivilegeCount:=1;
 Privileges.Privileges[0].Luid:=DebugNameValue;
 Privileges.Privileges[0].Attributes:=SE_PRIVILEGE_ENABLED;
 Result:=AdjustTokenPrivileges(TokenHandle,False,Privileges,SizeOf(Privileges),nil,RetLen);
 CloseHandle(TokenHandle);
end;

procedure InstallAndStartDriver;
var
 LPName,LPDisplayName,LPArgs:PChar;
 LSCMHandle,LHandle:SC_HANDLE;
 LType,LStart,LResSize,LBytesWritten:Cardinal;
 LRes,LGlobalRes,LFile:THandle;
 LResPtr:Pointer;
 LSysDir:array[0..MAX_PATH-1] of Char;

begin
 LPName:=PChar(DriverName);
 LPDisplayName:=PChar(DriverName);

 LRes:=FindResource(0,PChar(1),RT_RCDATA);
 LGlobalRes:=LoadResource(0,LRes);
 LResPtr:=LockResource(LGlobalRes);
 LResSize:=SizeofResource(0,LRes);
 GetSystemDirectory(LSysDir,SizeOf(LSysDir));
 DriverBin:=LSysDir;
 if not ((Length(DriverBin)=0) or (DriverBin[Length(DriverBin)]='\')) then DriverBin:=DriverBin+'\';
 DriverBin:=DriverBin+'drivers\'+DriverFileName;

 UninstallDriver;

 DeleteFile(DriverBin);
 LFile:=CreateFile(PChar(DriverBin),GENERIC_WRITE,0,nil,CREATE_ALWAYS,
                   FILE_ATTRIBUTE_READONLY,0);
 if (LFile=INVALID_HANDLE_VALUE) or (LFile=0)
  or (not WriteFile(LFile,LResPtr^,LResSize,LBytesWritten,nil))
   or (not (LBytesWritten=LResSize)) then Exit;
 CloseHandle(LFile);
 LType:=SERVICE_KERNEL_DRIVER;
 LStart:=SERVICE_DEMAND_START;

 LSCMHandle:=OpenSCManager(nil,nil,SC_MANAGER_ALL_ACCESS);
 if LSCMHandle=0 then Exit;
 LHandle:=CreateService(LSCMHandle,LPName,LPDisplayName,SERVICE_ALL_ACCESS,LType,LStart,
                        SERVICE_ERROR_IGNORE,PChar(DriverBin),nil,nil,nil,nil,nil);
 LPArgs:=nil;
 if LHandle<>0 then
 begin
  StartService(LHandle,0,LPArgs);
  CloseServiceHandle(LHandle);
 end;
 CloseServiceHandle(LSCMHandle);
end;

procedure OpenDriver;
begin
 DrvHandle:=CreateFile('\\.\'+DriverName,GENERIC_ALL,0,nil,OPEN_EXISTING,0,0);
 if DrvHandle=INVALID_HANDLE_VALUE then FatalError('unable to load driver');
end;

procedure UninstallDriver;
var
 LSCMHandle,LHandle:SC_HANDLE;
 LSvcStatus:TServiceStatus;
begin
 LSCMHandle:=OpenSCManager(nil,nil,SC_MANAGER_ALL_ACCESS);
 if LSCMHandle<>0 then
 begin
  LHandle:=OpenService(LSCMHandle,PChar(DriverName),SERVICE_ALL_ACCESS);
  if LHandle<>0 then
  begin
   ControlService(LHandle,SERVICE_CONTROL_STOP,LSvcStatus);
   DeleteService(LHandle);
   CloseServiceHandle(LHandle);
  end;
  CloseServiceHandle(LSCMHandle);
 end;
end;

function DeleteFile(AFile:string):Boolean;
begin
 SetFileAttributes(PChar(AFile),0);
 Result:=Windows.DeleteFile(PChar(AFile));
end;

function GetProcessPathByPID(APID:Cardinal):string;
var
 LProcHandle:THandle;
 LInfo:TProcessBasicInformation;
 LProcessParametres:Pointer;
 LImagePathName:TUnicodeString;
 LPathBuf:array[0..MAX_PATH*2-1] of Char;
 LBytes:Cardinal;
 LAnsiPath:TAnsiString;
begin
 Result:='';
 ZeroMemory(@LImagePathName,SizeOf(LImagePathName));
 LProcHandle:=OpenProcess(PROCESS_VM_READ or PROCESS_QUERY_INFORMATION,False,APID);
 if (LProcHandle<>0) and (LProcHandle<>INVALID_HANDLE_VALUE) then
 begin
  if NtQueryInformationProcess(LProcHandle,ProcessBasicInformation,@LInfo,SizeOf(LInfo),nil)=0 then
  begin
   if ReadProcessMemory(LProcHandle,Pointer(Cardinal(LInfo.PebBaseAddress)+$10),@LProcessParametres,4,LBytes)
    and ReadProcessMemory(LProcHandle,Pointer(Cardinal(LProcessParametres)+$38),@LImagePathName,8,LBytes)
    and ReadProcessMemory(LProcHandle,LImagePathName.Buffer,@LPathBuf,LImagePathName.Length,LBytes) then
    begin
     LImagePathName.Buffer:=@LPathBuf;
     RtlUnicodeStringToAnsiString(@LAnsiPath,@LImagePathName,True);
     SetLength(Result,LAnsiPath.Length);
     CopyMemory(@Result[1],LAnsiPath.Buffer,LAnsiPath.Length);
     RtlFreeAnsiString(@LAnsiPath);
    end; 
  end;
 end;
end;

function IntToStr(AInt:Integer):string;
begin
 Str(AInt,Result);
end;

function UpCase(AStr:string):string;
var
 LI:Integer;
begin
 Result:=AStr;
 for LI:=1 to Length(Result) do Result[LI]:=System.UpCase(Result[LI]);
end;

function Name2PID(AName:string):Cardinal;
var
 LPProcess:PSystemProcesses;
 LAnsiString:TAnsiString;
 LRes:Cardinal;

begin
 LRes:=$FFFFFFFF;
 AName:=UpCase(AName);
 if AName<>'IDLE' then
 begin
  LPProcess:=ProcessInfoTable;
  while (LPProcess^.NextEntryDelta>0) and (LRes=$FFFFFFFF) do
  begin
   LPProcess:=Pointer(Cardinal(LPProcess)+LPProcess^.NextEntryDelta);

   RtlUnicodeStringToAnsiString(@LAnsiString,@LPProcess^.ProcessName,True);
   if UpCase(PChar(LAnsiString.Buffer))=AName then LRes:=LPProcess^.ProcessId;
   RtlFreeAnsiString(@LAnsiString);
  end;
  Result:=LRes;
 end else Result:=0;
end;

procedure AddPort(AInfo:TSystemHandleInformation;APort:Word;AProto:Byte);
var
 LI:Integer;
 LChange:Boolean;
 LNewObj:Pointer;
 LSystemPID:Cardinal;
 LPObj:PSystemHandleInformation;
begin
 if AInfo.ProcessId=GetCurrentProcessId then Exit;
 LSystemPID:=Name2PID('System');
 with ResultPorts[AProto,APort] do
 begin
  Active:=True;
  LChange:=True;
  LPObj:=Objects;
  for LI:=0 to Count-1 do
  begin
   if (LPObj^.ProcessId=AInfo.ProcessId)
    or ((LPObj^.ObjectPtr<>nil) and (AInfo.ProcessId=LSystemPID) and (LPObj^.ObjectPtr=AInfo.ObjectPtr)) then
    begin
     LChange:=False;
     Break;
    end;
   if (LPObj^.ObjectPtr<>nil) and (LPObj^.ProcessId=LSystemPID) then
   begin
    LPObj^:=AInfo;
    LChange:=False;
    Break;
   end; 
   Inc(LPObj);
  end;
  if LChange then
  begin
   Inc(Count);
   LNewObj:=Pointer(LocalAlloc(LMEM_FIXED,Count*SizeOf(TSystemHandleInformation)));
   if Count>1 then
   begin
    CopyMemory(LNewObj,Objects,(Count-1)*SizeOf(TSystemHandleInformation));
    LocalFree(Cardinal(Objects));
   end;
   PSystemHandleInformation(Cardinal(LNewObj)+Cardinal(Count-1)*SizeOf(TSystemHandleInformation))^:=AInfo;     //sorry for this :)
   Objects:=LNewObj;
  end;
 end;
end;

begin
 About;
 if not LoadAPI then FatalError('Unable to load API.');
 if not IpHlpSupport then
 begin
  InstallAndStartDriver;
  OpenDriver;
  GetHandleTableAndSocketType;
 end;
 EnableDebugPrivilege;
 ZeroMemory(@ResultPorts,SizeOf(ResultPorts));

 ProcessInfoTable:=nil;
 ProcessInfoTableSize:=$10000;
 while ProcessInfoTable=nil do
 begin
  ProcessInfoTable:=Pointer(LocalAlloc(LMEM_FIXED,ProcessInfoTableSize));
  Status:=NtQuerySystemInformation(SystemProcessesAndThreadsInformation,ProcessInfoTable,ProcessInfoTableSize,nil);
  if Status=STATUS_INFO_LENGTH_MISMATCH then
  begin
   LocalFree(Cardinal(ProcessInfoTable));
   ProcessInfoTable:=nil;
   ProcessInfoTableSize:=2*ProcessInfoTableSize;
  end else if Status<>0 then FatalError('Unable to get system process information table.',True);
 end;

 if IpHlpSupport then
 begin
  if AllocateAndGetTcpExTableFromStack(@TCPPortsTable,True,GetProcessHeap,0,2)=0 then
  begin
   TCPRow:=@TCPPortsTable^.Table;
   for I:=0 to TCPPortsTable^.NumEntries-1 do
   begin
    ZeroMemory(@HandleInfo,SizeOf(HandleInfo));
    HandleInfo.ProcessId:=TCPRow^.ProcessId;
    AddPort(HandleInfo,ntohs(TCPRow^.LocalPort),0);
    Inc(TCPRow);
   end;
  end;
  if AllocateAndGetUdpExTableFromStack(@UDPPortsTable,False,GetProcessHeap,0,2)=0 then
  begin
   UDPRow:=@UDPPortsTable^.Table;
   for I:=0 to UDPPortsTable^.NumEntries-1 do
   begin
    ZeroMemory(@HandleInfo,SizeOf(HandleInfo));
    HandleInfo.ProcessId:=UDPRow^.ProcessId;
    AddPort(HandleInfo,ntohs(UDPRow^.LocalPort),1);
    Inc(UDPRow);
   end;
  end;
 end else
 begin
  LocPID:=GetCurrentProcessId;
  ZeroMemory(@LastObj,SizeOf(LastObj));
  LastObj.ProcessId:=$FFFFFFFF;
  ProcessHandle:=INVALID_HANDLE_VALUE;
  PHandleInfo:=@HandleTable^.Handles;
  for I:=0 to HandleTable^.NumberOfEntries-1 do
  begin
   if PHandleInfo^.ObjectTypeNumber=SockHandleType then
   begin
    if LastObj.ProcessId<>PHandleInfo^.ProcessId then
    begin
     if ProcessHandle<>INVALID_HANDLE_VALUE then CloseHandle(ProcessHandle);
     ProcessHandle:=OpenProcess(PROCESS_DUP_HANDLE,False,PHandleInfo^.ProcessId);
     LastObj:=PHandleInfo^;
     if ProcessHandle=0 then ProcessHandle:=INVALID_HANDLE_VALUE;
    end;
    if (ProcessHandle<>INVALID_HANDLE_VALUE) and (PHandleInfo^.ProcessId<>LocPID) then
    begin
     if DuplicateHandle(ProcessHandle,PHandleInfo^.Handle,GetCurrentProcess,@DupHandle,0,False,DUPLICATE_SAME_ACCESS) then
     begin
      ObjInfo:=GetObjInfo(PHandleInfo^,Str1);

      Proto:=0;
      if (ObjInfo.Flags=1) or (ObjInfo.Flags=2) then
       if ObjInfo.Ptr1=SockObjInfoTCP.Ptr1 then Proto:=1
       else if ObjInfo.Ptr1=SockObjInfoUDP.Ptr1 then Proto:=2;

      if Proto>0 then
      begin
       ZeroMemory(@TdiConnIn,SizeOf(TdiConnIn));
       ZeroMemory(@TdiConnOut,SizeOf(TdiConnOut));
       if ObjInfo.Flags=2 then
       begin
        TdiConnIn.RemoteAddressLength:=4;
        if DeviceIoControl(DupHandle,$00210012,@TdiConnIn,SizeOf(TdiConnIn),@TdiConnOut,SizeOf(TdiConnOut)-$16,BytesRet,nil) then
        begin
         TdiConnIn.RemoteAddressLength:=3;
         if DeviceIoControl(DupHandle,$00210012,@TdiConnIn,SizeOf(TdiConnIn),@TdiConnOut,SizeOf(TdiConnOut),BytesRet,nil) then
         begin
          Port:=ntohs(TdiConnOut.ReceivedTsdus);
          AddPort(LastObj,Port,Proto-1);
         end;
        end;
       end else
       begin
        TdiConnIn.RemoteAddressLength:=3;
        if DeviceIoControl(DupHandle,$00210012,@TdiConnIn,SizeOf(TdiConnIn),@TdiConnOut,SizeOf(TdiConnOut),BytesRet,nil) then
        begin
         Port:=ntohs(TdiConnOut.ReceivedTsdus);
         AddPort(LastObj,Port,Proto-1);
        end;
       end;
      end;
      CloseHandle(DupHandle);
     end;
    end;
   end;
   Inc(PHandleInfo);
  end;
  CloseHandle(ProcessHandle);
  LocalFree(Cardinal(HandleTable));
  CloseHandle(DrvHandle);
  UninstallDriver;
  DeleteFile(DriverBin);
 end;
 WriteLn('PID   Process name       Port  Proto  Process image path');
 for I:=0 to 65535 do
 with ResultPorts[0,I] do
 if Active then
 begin
  PObj:=Objects;
  for J:=0 to Count-1 do
  begin
   ResLn:=StringOfChar(' ',31)+'TCP    '+GetProcessPathByPID(PObj^.ProcessId);
   Str1:=GetProcessNameByPID(PObj^.ProcessId);
   if Length(Str1)=0 then
   begin
    Str1:='System';
    PObj^.ProcessId:=Name2PID(Str1);
   end;
   CopyMemory(@ResLn[7],@Str1[1],Length(Str1));

   Str1:=IntToStr(PObj^.ProcessId);
   CopyMemory(@ResLn[1],@Str1[1],Length(Str1));
   Str1:=IntToStr(I);
   CopyMemory(@ResLn[26],@Str1[1],Length(Str1));
   WriteLn(ResLn);
   Inc(PObj);
  end;
  if Objects<>nil then LocalFree(Cardinal(Objects));
 end;
 WriteLn;
 for I:=0 to 65535 do
 with ResultPorts[1,I] do
 if Active then
 begin
  PObj:=Objects;
  for J:=0 to Count-1 do
  begin
   ResLn:=StringOfChar(' ',31)+'UDP    '+GetProcessPathByPID(PObj^.ProcessId);
   Str1:=GetProcessNameByPID(PObj^.ProcessId);
   if Length(Str1)=0 then
   begin
    Str1:='System';
    PObj^.ProcessId:=Name2PID(Str1);
   end;
   CopyMemory(@ResLn[7],@Str1[1],Length(Str1));

   Str1:=IntToStr(PObj^.ProcessId);
   CopyMemory(@ResLn[1],@Str1[1],Length(Str1));
   Str1:=IntToStr(I);
   CopyMemory(@ResLn[26],@Str1[1],Length(Str1));
   WriteLn(ResLn);
   Inc(PObj);
  end;
  if Objects<>nil then LocalFree(Cardinal(Objects));
 end;
 LocalFree(Cardinal(ProcessInfoTable));
end.