rascomp32.~pas

DELIPHI编写的小程序

PROCEDURE TRAS.StateChanged;			 // Angus
BEGIN
	If ( fRASConn = 0 ) THEN Exit;
    If Assigned( fStateChanged ) THEN
    begin
        if (LastError <> 0) or (ConnectState <> SavedState) then
                                                fStateChanged( Self );
        if (LastError <> 0) then
            fSavedState := 0
        else
            fSavedState := fConnectState ;
    end ;
END;

PROCEDURE TRAS.AboutToOpenPort;
BEGIN
	If (fRASConn = 0) THEN Exit;
	If Assigned(fAboutToOpenPort) THEN fAboutToOpenPort (Self);
end;

procedure TRAS.PortOpened;
begin
	If (fRASConn = 0) THEN Exit;
//   	GetConnectStatus ; 				// Angus, get device type and device name
   	If Assigned(fPortOpened) THEN fPortOpened(Self);
end;

procedure TRAS.AboutToConnDev;
begin
	If (fRASConn = 0) THEN Exit;
	If Assigned(fAboutToConnDev) THEN fAboutToConnDev (Self);
end;

procedure TRAS.DevConnected;
begin
	If (fRASConn = 0) THEN Exit;
	If Assigned(fDevConnected) THEN fDevConnected(Self);
end;

procedure TRAS.AllDevsConnected;
begin
	If (fRASConn = 0) THEN Exit;
	If Assigned(fAllDevsConnected) THEN fAllDevsConnected(Self);
end;

procedure TRAS.Authenticate;
begin
	If (fRASConn = 0) THEN Exit;
	If Assigned(fAuthenticate) THEN fAuthenticate(Self);
end;

procedure TRAS.AuthNotify;
begin
	If (fRASConn = 0) THEN Exit;
	If Assigned(fAuthNotify) THEN fAuthNotify(Self);
end;

procedure TRAS.AuthRetry;
begin
	If (fRASConn = 0) THEN Exit;
	If Assigned(fAuthRetry) THEN fAuthRetry(Self);
end;

procedure TRAS.AuthCallBack;
begin
	If (fRASConn = 0) THEN Exit;
	If Assigned(fAuthCallBack) THEN fAuthCallBack(Self);
end;

procedure TRAS.AuthChangePassword;
begin
	If (fRASConn = 0) THEN Exit;
	If Assigned(fAuthChangePassword) THEN fAuthChangePassword(Self);
end;

procedure TRAS.AuthProject;
begin
	If (fRASConn = 0) THEN Exit;
	If Assigned(fAuthProject) THEN fAuthProject(Self);
end;

procedure TRAS.AuthLinkSpeed;
begin
	If (fRASConn = 0) THEN Exit;
	If Assigned(fAuthLinkSpeed) THEN fAuthLinkSpeed(Self);
end;

procedure TRAS.AuthAck;
begin
	If (fRASConn = 0) THEN Exit;
	If Assigned(fAuthAck) THEN fAuthAck(Self);
end;

procedure TRAS.ReAuthenticate;
begin
	If (fRASConn = 0) THEN Exit;
	If Assigned(fReAuthenticate) THEN fReAuthenticate(Self);
end;

procedure TRas.Authenticated;
begin
	If (fRASConn = 0) THEN Exit;
	If Assigned(fAuthenticated) THEN fAuthenticated(Self);
end;

procedure TRAS.PrepareforCallback;
begin
	if (fRASConn = 0) THEN Exit;
	If Assigned(fPrepareforCallback) THEN fPrepareforCallback(Self);
end;

procedure TRAS.WaitForModemReset;
begin
	If (fRASConn = 0) THEN Exit;
	If Assigned(fWaitForModemReset) THEN fWaitForModemReset(Self);
end;

procedure TRAS.InteractiveStarted;
begin
	If (fRASConn = 0) THEN Exit;
	If Assigned(fInteractiveStarted) THEN fInteractiveStarted(Self);
end;

procedure TRAS.RetryAuth;
begin
	If (fRASConn = 0) THEN Exit;
	If Assigned(fRetryAuth) THEN fRetryAuth(Self);
end;

procedure TRAS.PasswordExpired;
begin
	If (fRASConn = 0) THEN Exit;
	If Assigned(fPasswordExpired) THEN fPasswordExpired(Self);
end;

procedure TRAS.DisConnected;
var
	RasConnStatus : TRasConnStatus;
	ErrorStr : String;
begin
	If Assigned(fOnDisConnect) THEN
	begin
		fLastError := ERROR_DLL_NOT_FOUND ;
		if NOT LoadRASAPI then exit ;
		FillChar(RASConnStatus, SizeOf(RASConnStatus), #0);
		RASConnStatus.dwSize := Sizeof (RasConnStatus);
		fLastError := RasGetConnectStatus(RASConn, @RASConnStatus);
		ErrorStr := GetErrorString (fLastError);
		fOnDisConnect(Self,fLastError,ErrorStr);
	end;
end;

procedure TRAS.WaitingForCallBack;
begin
	If (fRASConn = 0) THEN Exit;
	If Assigned(fOnCallBack) THEN fOnCallBack(Self);
end;

procedure TRAS.ResetPerfStats ;
begin
	fStatsXmitCon := fStatsXmitTot ;	// tot counters are from IPL
	fStatsRecvCon := fStatsRecvTot ;
	fStatsXmitCur := 0 ;				// cur counters are current connection
	fStatsRecvCur := 0 ;
end ;

function TRAS.SearchDUA: boolean ;
var
	TempKey, Temp2Key: HKey;
	keyname, lockey: string ;
    flag: boolean ;
	NumSubKeys, NumValues, count: integer ;
    dwType, dwSize, Len: DWORD ;
begin
	result := false ;
	if NOT Win32Platform = VER_PLATFORM_WIN32_WINDOWS then exit ;
    DialUpAdaptors.Clear ;
    TempKey := 0;
    Temp2Key := 0;
	result := RegOpenKeyEx (HKEY_LOCAL_MACHINE, PChar(Reg_PerfStatEmum),
                                   0, KEY_READ, TempKey) = ERROR_SUCCESS ;
	if result then
        result := RegOpenKeyEx (HKEY_DYN_DATA, PChar(Reg_PerfStatStart),
                                   0, KEY_READ, Temp2Key) = ERROR_SUCCESS ;
	if result then
	begin
        NumSubKeys := 0 ;
        NumValues := 0 ;
        count := RegQueryInfoKey (TempKey, nil, nil, nil, @NumSubKeys,
                               nil, nil, @NumValues, nil, nil, nil, nil) ;
        if NumSubKeys <> 0 then
        begin
            SetString (lockey, nil, 33);
            for count := 0 to NumSubKeys - 1 do
            begin
                Len := 33 ;
                RegEnumKeyEx (TempKey, count, PChar(lockey), Len,
                                                    nil, nil, nil, nil);
                keyname := PChar (lockey) + '\' + fKeyDUNConn ;
  		        if RegQueryValueEx (Temp2Key, PChar(keyname), nil,
		  				@dwType, nil, @dwSize) = ERROR_SUCCESS then
                                     DialUpAdaptors.Add (PChar (lockey)) ;
            end ;
        end ;
    end ;
    if TempKey <> 0 then RegCloseKey (TempKey) ;
 	if Temp2Key <> 0 then RegCloseKey (Temp2Key) ;
    if DialUpAdaptors.Count <> 0 then DialUpAdaptors.Sort ;
end;


function TRAS.EnablePerfStats (start, search: boolean): boolean ;
var
	TempKey: HKey;
	keyname: string ;
	dwType, dwSize: DWORD ;
	TempData: Pointer ;

	function InitData (ValueName: string): boolean ;
	begin
		result := false ;
        ValueName := fKeyDUNAdap + '\' + ValueName ;
		if RegQueryValueEx (TempKey, PChar(ValueName), nil,
							@dwType, nil, @dwSize) = ERROR_SUCCESS then
		begin
		try		// read data but ignore it
			GetMem (TempData, dwSize) ;
			Result := RegQueryValueEx (TempKey, PChar(ValueName), nil,
							@dwType, TempData, @dwSize) = ERROR_SUCCESS ;
		finally
			FreeMem (TempData) ;
		    end ;
		end ;
	end ;

begin
	result := false ;
	if Win32Platform = VER_PLATFORM_WIN32s then exit ;
	result := true ;
	if Win32Platform = VER_PLATFORM_WIN32_WINDOWS then
	begin
        if search then
        begin
           SearchDUA ;
           if DialUpAdaptors.Count = 0 then
           begin
                result := false ;
                exit ;
           end ;
           fKeyDUNAdap := DialUpAdaptors [0] ; // set first
        end ;
		TempKey := 0;
		if start then
			keyname := Reg_PerfStatStart
		else
			keyname := Reg_PerfStatStop ;
		result := RegOpenKeyEx (HKEY_DYN_DATA, PChar(keyname), 0,
							  KEY_ALL_ACCESS, TempKey) = ERROR_SUCCESS ;
		if result then
		begin
			result := InitData (fKeyDUNXmit) ;
			if result then result := InitData (fKeyDUNRecv) ;
			if result then result := InitData (fKeyDUNConn) ;
			RegCloseKey (TempKey) ;
		end ;
	end ;
	if result then
	begin
		if start then result := GetPerfStats ;	// get counters
		ResetPerfStats ;			// set current
	end ;
end;

function TRAS.GetPerfStats: boolean ;
var
	TempKey: HKey;
	dwType,
    dwSize,
    connspd: DWORD ;
	perfdata: PPERF_DATA_BLOCK ;
	perfobj: PPERF_OBJECT_TYPE ;
	perfcdef: PPERF_COUNTER_DEFINITION ;
	perfmcdef: array [1..50] of PPERF_COUNTER_DEFINITION ;
	perfinst: PPERF_INSTANCE_DEFINITION ;
	perfcblk: PPERF_COUNTER_BLOCK ;
	regbuff,
    objptr,
    defptr,
    countptr: Pchar ;
	actualsize,
    DataType: Integer;
	objnr,
    instnr,
    countnr: integer ;
	datvalue: ^integer ;
	loopflag: boolean ;


 	function GetData (ValueName: string; var Info: DWORD): boolean ;
	begin
        ValueName := fKeyDUNAdap + '\' + ValueName ;
		dwSize := 4 ;	// data is four bytes of binary, aka a DWORD
		Result := RegQueryValueEx (TempKey, PChar(ValueName), nil,
							@dwType, @Info, @dwSize) = ERROR_SUCCESS;
	end ;

begin
	result := false ;
	if Win32Platform = VER_PLATFORM_WIN32s then exit ;
	if Win32Platform = VER_PLATFORM_WIN32_WINDOWS then  // Win95/98
	begin
		TempKey := 0;
		result := RegOpenKeyEx (HKEY_DYN_DATA, PChar(Reg_PerfStatData),
                                    0, KEY_READ, TempKey) = ERROR_SUCCESS ;
		if result then
        begin
            result := GetData (fKeyDUNXmit, fStatsXmitTot) ;
	    	if result then result := GetData (fKeyDUNRecv, fStatsRecvTot) ;
		    if result then result := GetData (fKeyDUNConn, connspd) ;
			RegCloseKey (TempKey) ;
    		if result then
	    	begin
    			if fStatsXmitTot < fStatsXmitCon then ResetPerfStats ;
	    		if fStatsRecvTot < fStatsRecvCon then ResetPerfStats ;
		    	fStatsConnSpd := connspd ;
    			fStatsXmitCur := fStatsXmitTot - fStatsXmitCon ;
    			fStatsRecvCur := fStatsRecvTot - fStatsRecvCon ;
            end ;
		end ;
	end
	else
	begin
		DataType := REG_NONE;        // Windows NT performance data
		try

// start with small buffer, it will be increased in size if necessary the
// first time, to that required for the returned performance data
			if datasize = 0 then datasize := TOTALBYTES ;
			GetMem (regbuff, datasize) ;
			actualsize := datasize ;
			while RegQueryValueEx (HKEY_PERFORMANCE_DATA,
				pchar(Pdata_RAS_Total), nil, @DataType, PByte(regbuff),
	 									@actualsize) = ERROR_MORE_DATA do
			begin
				Freemem (regbuff) ;
				inc (datasize,  BYTEINCREMENT) ;  // increase buffers size by 1K
				GetMem (regbuff, datasize) ;
				actualsize := datasize ;
			end ;

		// get performance data block
			if actualsize < 100 then exit ;     // forget it
			pointer (perfdata) := regbuff ;   // PERF_DATA_BLOCK

	// get performance object type blocks
			if perfdata.numobjecttypes = 0 then exit ;   // no objects to process
			objptr := regbuff + perfdata.HeaderLength ;
			for objnr := 1 to perfdata.numobjecttypes do
			begin
				Application.ProcessMessages;
				pointer (perfobj) := objptr ;  // PERF_OBJECT_TYPE
			//  perfobj.ObjectNameTitleIndex   // not needed
				defptr := objptr + perfobj.HeaderLength ;

			// get performance counter definitions
				if perfobj.numcounters > 0 then
				begin

			// read through definitions, really looking for length
				for countnr := 1 to perfobj.numcounters do
					begin
						pointer (perfmcdef [countnr]) := defptr ;  // keep each definitition
						pointer (perfcdef) := defptr ;  // PERF_COUNTER_DEFINITION
						inc (defptr, perfcdef.bytelength) ;
						if countnr > 50 then exit ;
						Application.ProcessMessages;
					end ;

			// now get counter data, perhaps from multiple instances
					loopflag := true ;
					instnr := 1 ;
					while loopflag do
					begin
						if perfobj.numinstances >= 1 then
						begin
							pointer (perfinst) := defptr ;  // PERF_INSTANCE_DEFINITON
					// Instance Name := WideCharToString
					//	(PWideChar(defptr + perfinst.nameoffset))) ;
							inc (defptr, perfinst.bytelength) ;
						end ;

					// get counter block, then read actual data values
						countptr := defptr ;  // after reading through blocks
						pointer (perfcblk) := countptr ;  // PERF_COUNTER_BLOCK

					// get counter data, currently only doublewords
						for countnr := 1 to perfobj.numcounters do
						begin
							if perfmcdef [countnr].CounterNameTitleIndex =
														Pdata_Bytes_Xmit then
							begin
								pointer (datvalue) := countptr +
									perfmcdef [countnr].counteroffset ;
								if Datvalue^ > fStatsXmitCur then
											fStatsXmitCur := Datvalue^ ;
							end ;
							if perfmcdef [countnr].CounterNameTitleIndex =
														Pdata_Bytes_Recv then
							begin
								pointer (datvalue) := countptr +
									perfmcdef [countnr].counteroffset ;
								if Datvalue^ > fStatsRecvCur then
												fStatsRecvCur := Datvalue^ ;
							end ;
						end ;
						inc (defptr, perfcblk.bytelength) ;

					// check for more instances of these counters
						if perfobj.numinstances >= 1 then
						begin
							inc (instnr) ;
							if instnr > perfobj.numinstances then loopflag := false ;
						end
						else
							loopflag := false ;
					end ;
				end ;
				objptr := objptr + perfobj.totalbytelength ;
			end ;
			result := true ;
		finally
			if regbuff <> nil then Freemem (regbuff) ;
		end ;
	end ;
end;

Initialization
finalization

end.