dxcodetracer.pas

Well known and usefull component for delphi 7

   Ws:='';
   Loop:=0;
   While Loop<Strlist.Count do begin
      Ws:=Ws+StrList[Loop]+#13#10;
      Inc(loop);
   End;
   Ws:=GetNextMsgID+'<'+IntegerToString(GetSLType(dxptActiveWindows,Category))+'>['+
      IntegerToString(GetCurrentThreadID)+'.'+IntegerToString(fTransaction)+':'+UUID_String+
      ']{'+GetTickString+'}'+Ws;
   LowlevelSend(@Ws[1],Length(Ws));
   StrList.Free;
End;

// Enumerate Thread Windows CallBack Function
function EnumThreadWindowsProc(Window:HWnd;LPARAM:Pointer):bool stdcall;
const
   MaxWTextLength=1024;

var
   WindowText:String;

begin
   SetLength(WindowText,MaxWTextLength);
   SetLength(WindowText,GetWindowText(Window,PChar(WindowText),MaxWTextLength));
   if Length(Trim(WindowText))>0 then
      TStringList(LParam^).Add('[$'+IntToHex(Window,8)+']'+#9+WindowText); // Add Hex & String Value
   Result:=True;
end;

Procedure TDXCodeTracer.SendMyWindows(Category:TDXCatType);
Var
   StrList:TStringList;
   Ws:String;
   Loop:Integer;

Begin
   StrList:=TStringList.Create;
   EnumThreadWindows(GetCurrentThreadID,@EnumThreadWindowsProc, LongInt(@StrList)); // Enumerate Windows (and Log them)
   StrList.Sort;
   Ws:='';
   Loop:=0;
   While Loop<Strlist.Count do begin
      Ws:=Ws+StrList[Loop]+#13#10;
      Inc(loop);
   End;
   Strlist.Sort;
   Ws:=GetNextMsgID+'<'+IntegerToString(GetSLType(dxptMyWindows,Category))+'>['+
      IntegerToString(GetCurrentThreadID)+'.'+IntegerToString(fTransaction)+':'+UUID_String+
      ']{'+GetTickString+'}'+Ws;
   LowlevelSend(@Ws[1],Length(Ws));
   StrList.Free;
End;

(*// Enumerate WindowStaions CallBack Function
function EnumWindowStationsCallBack(WindowStation:PChar;LPARAM:Pointer):bool stdcall;
begin
   TStringList(LParam^).Add('EnumWindowStations: '+WindowStation); // Add Hex & String Value
   Result:=True;
end;

Procedure TDXCodeTracer.SendActiveWindowStations(Category:TDXCatType);
Var
   StrList:TStringList;
   Ws:String;

Begin
   StrList:=TStringList.Create;
   EnumWindowStations(@EnumWindowStationsCallBack,Longint(@StrList));
   StrList.Sort;
   Ws:='';
   While StrList.Count>0 do Begin
      Ws:=StrList[0]+#13#10;
      StrList.Delete(0);
   End;
   Ws:=GetNextMsgID+'<'+IntegerToString(GetSLType(dxptActiveStations,Category))+'>['+
      IntegerToString(GetCurrentThreadID)+'.'+IntegerToString(fTransaction)+':'+UUID_String+
      ']{'+GetTickString+'}'+Ws;
   LowlevelSend(@Ws[1],Length(Ws));
   StrList.Free;
End; *)

Function GetServicesList(ServiceStatusTxt:String):String;
var
  hscManager : THandle;
  EnumServiceStatus : pointer;
  BytesNeeded, ServicesReturned, ResumeHandle : DWORD;
  BytesAllocated : DWORD;

  procedure ShowServices;
  type
    TArrayEnumServicesStatus = array of TEnumServiceStatus;
  const
    StatusText : array [SERVICE_STOPPED..SERVICE_PAUSED] of string =
                       ('Stopped', 'Starting', 'Stopping', 'Started',
                        'Restarting', 'Pausing', 'Paused');
  var
    i : Integer;
  begin
    for i := 0 to ServicesReturned - 1 do
      with TArrayEnumServicesStatus ((@EnumServiceStatus)^) [i] do
        begin
          If Statustext [ServiceStatus.dwCurrentState]=ServiceStatusTxt then
          Result:=Result+(Format ('%s'+#9+'%s', [lpServiceName, lpDisplayName]))+#13;
        end;
  end;

  procedure CallEnumServices;
  begin
    if WinSvc.EnumServicesStatus (hScManager,
                                 SERVICE_TYPE_ALL,
                                 SERVICE_STATE_ALL,
                                 TEnumServiceStatus (EnumServiceStatus^),
                                 BytesAllocated,
                                 BytesNeeded, ServicesReturned, ResumeHandle)
      then begin
        ShowServices;
      end
      else
      case GetLastError of
        ERROR_ACCESS_DENIED : Result:='The specified handle was not opened with SC_MANAGER_ENUMERATE_SERVICE access';
        ERROR_INVALID_HANDLE : Result:='The specified handle is invalid';
        ERROR_INVALID_PARAMETER : Result:='A parameter that was specified is invalid';
        ERROR_MORE_DATA :
          begin
            ShowServices;
            ReallocMem (EnumServiceStatus, BytesNeeded);
            BytesAllocated := BytesNeeded;
            Result:='';
            CallEnumServices;
          end;
        else Result:='Unknown Error';
      end
  end;

begin
   Result:='';
   ResumeHandle := 0;
   hScManager := OpenSCManager (nil, nil, GENERIC_READ or GENERIC_EXECUTE);
try
    if hscManager <> 0 then begin
        BytesAllocated := 3072;
        GetMem (EnumServiceStatus, BytesAllocated);
        try
          CallEnumServices;
        finally
          FreeMem (EnumServiceStatus, BytesAllocated);
        end;
    end
    else
      case GetLastError of
        ERROR_ACCESS_DENIED : Result:='Acces Denied';
        ERROR_DATABASE_DOES_NOT_EXIST : Result:='Database doesn''t exists';
        ERROR_INVALID_PARAMETER : Result:='Invalid Parameter';
        else Result:='Unknown Error';
      end;
  finally
    if hscManager <> 0
      then CloseServiceHandle (hscManager);
  end;
end;

Procedure TDXCodeTracer.SendServices(Category:TDXCatType;ServiceStatus:TServiceStatusList);
Const
    StatusText : array [0..6] of string =
                       ('Stopped', 'Starting', 'Stopping', 'Started',
                        'Restarting', 'Pausing', 'Paused');
Var
   StrList:TStringList;
   Ws:String;

Begin
   StrList:=TStringList.Create;
   Ws:=GetNextMsgID+'<'+IntegerToString(GetSLType(dxptServicesList,Category))+'>['+
      IntegerToString(GetCurrentThreadID)+'.'+IntegerToString(fTransaction)+':'+UUID_String+
      ']{'+GetTickString+'}'+StatusText[Ord(ServiceStatus)]+#13+
      GetServicesList(StatusText[Ord(ServiceStatus)]);
   LowlevelSend(@Ws[1],Length(Ws));
   StrList.Free;
End;


Procedure TDXCodeTracer.SendMemoryInformation(Category:TDXCatType);
Var
   MemoryStatus:TMemoryStatus;
   Ws:String;

function SizeStampPrefix(CPS:Cardinal):String;
Begin
   If CPS<1024 then Result:=IntegerToString(CPS)+'b'
   Else If CPS<1024000 then Result:=FormatFloat('0.00',CPS / 1024)+'kb'
   Else If CPS<1024000000 then Result:=FormatFloat('0.00',CPS / 1024000)+'mb'
   Else Result:=FormatFloat('0.00',CPS / 1024000000)+'gb';
End;

Begin
   MemoryStatus.dwLength:=Sizeof(MemoryStatus);
   GlobalMemoryStatus(MemoryStatus);
   Ws:='Memory Information Snapshot'+#13+
      'Memory Load '+IntegerToString(MemoryStatus.dwMemoryLoad)+'%'+#13+
      'Total Physical Memory '+SizeStampPrefix(MemoryStatus.dwTotalPhys)+#13+
      'Total Page File Memory '+SizeStampPrefix(MemoryStatus.dwTotalPageFile)+#13+
      'Total Virtual Memory '+SizeStampPrefix(MemoryStatus.dwTotalVirtual)+#13+
      'Free Physical Memory '+SizeStampPrefix(MemoryStatus.dwAvailPhys)+#13+
      'Free Page File Memory '+SizeStampPrefix(MemoryStatus.dwAvailPageFile)+#13+
      'Free Virtual Memory '+SizeStampPrefix(MemoryStatus.dwAvailVirtual);
   Ws:=GetNextMsgID+'<'+IntegerToString(GetSLType(dxptMemoryInfo,Category))+'>['+
      IntegerToString(GetCurrentThreadID)+'.'+IntegerToString(fTransaction)+':'+UUID_String+
      ']{'+GetTickString+'}'+Ws;
   LowlevelSend(@Ws[1],Length(Ws));
End;

Procedure TDXCodeTracer.SendFieldDefs(Category:TDXCatType;FieldDefs:TFieldDefs);
Const
  FieldType:Array[0..37] of String = ('ftUnknown', 'ftString', 'ftSmallint',
     'ftInteger', 'ftWord', 'ftBoolean', 'ftFloat', 'ftCurrency', 'ftBCD',
     'ftDate', 'ftTime', 'ftDateTime', 'ftBytes', 'ftVarBytes', 'ftAutoInc',
     'ftBlob', 'ftMemo', 'ftGraphic', 'ftFmtMemo', 'ftParadoxOle',
     'ftDBaseOle', 'ftTypedBinary', 'ftCursor', 'ftFixedChar',
     'ftWideString', 'ftLargeint', 'ftADT', 'ftArray', 'ftReference',
     'ftDataSet', 'ftOraBlob', 'ftOraClob', 'ftVariant', 'ftInterface',
     'ftIDispatch', 'ftGuid', 'ftTimeStamp', 'ftFMTBcd');

Var
   Ws:String;
   Loop:Integer;
   X:Integer;

Begin
   If Not Assigned(FieldDefs) then Exit;
   Ws:=FieldDefs.DataSet.Name+#13;
   For Loop:=1 to FieldDefs.Count do Begin
      X:=Ord(FieldDefs[Loop-1].DataType);
      Ws:=Ws+'<'+IntegerToString(FieldDefs[Loop-1].FieldNo)+'>'+
         FieldDefs[Loop-1].Name+'^'+FieldType[X]+':'+
         IntegerToString(FieldDefs[Loop-1].Size)+#13;
   End;
   Ws:=GetNextMsgID+'<'+IntegerToString(GetSLType(dxptFieldDefs,Category))+'>['+
      IntegerToString(GetCurrentThreadID)+'.'+IntegerToString(fTransaction)+':'+UUID_String+
      ']{'+GetTickString+'}'+Ws;
   LowlevelSend(@Ws[1],Length(Ws));
End;

Procedure TDXCodeTracer.SendFields(Category:TDXCatType;Fields:TFields);
Var
   Loop:Integer;
   Ws:String;

Begin
   Ws:=Fields.DataSet.Name+#13;
   For Loop:=1 to Fields.Count do Begin
try
      Ws:=Ws+Fields[Loop-1].DisplayName+':'+Fields[Loop-1].AsString+#13;
except
end;
   End;
   Ws:=GetNextMsgID+'<'+IntegerToString(GetSLType(dxptRowFields,Category))+'>['+
      IntegerToString(GetCurrentThreadID)+'.'+IntegerToString(fTransaction)+':'+UUID_String+
      ']{'+GetTickString+'}'+Ws;
   LowlevelSend(@Ws[1],Length(Ws));
End;

Procedure TDXCodeTracer.SendRegistry(Category:TDXCatType;Key:HKey;Path,Field:String);
Var
   Ws:String;
   Reg:TRegistry;
   Info: TRegDataInfo;

Begin
   Case Key of
      HKEY_CLASSES_ROOT:Ws:='HKEY_CLASSES_ROOT';
      HKEY_CURRENT_USER:Ws:='HKEY_CURRENT_USER';
      HKEY_LOCAL_MACHINE:Ws:='HKEY_LOCAL_MACHINE';
      HKEY_USERS:Ws:='HKEY_USERS';
      HKEY_PERFORMANCE_DATA:Ws:='HKEY_PERFORMANCE_DATA';
      HKEY_CURRENT_CONFIG:Ws:='HKEY_CURRENT_CONFIG';
      HKEY_DYN_DATA:Ws:='HKEY_DYN_DATA';
      Else Ws:='*INVALID HKEY*';
   End;
   Reg:=TRegistry.Create;
   Reg.RootKey:=Key;
   Ws:=Ws+#13+Path+#13+Field+#13;
   If Reg.OpenKey(Path,False) then Begin
      if Reg.GetDataInfo(Field, Info) then Begin
         Case Info.RegData of
            rdUnknown:Ws:=Ws+'UNKNOWN';
            rdString:Ws:=Ws+'REG_SZ';
            rdExpandString:Ws:=Ws+'REG_EXPAND_SZ';
            rdInteger:Ws:=Ws+'REG_DWORD';
            rdBinary:Ws:=Ws+'REG_BINARY';
         End;
         Ws:=Ws+#13+IntegerToString(Info.DataSize)+#13+Reg.ReadString(Field);
      End;
   End;
   Reg.CloseKey;
   Reg.Free;
   Ws:=GetNextMsgID+'<'+IntegerToString(GetSLType(dxptRegistry,Category))+'>['+
      IntegerToString(GetCurrentThreadID)+'.'+IntegerToString(fTransaction)+':'+UUID_String+
      ']{'+GetTickString+'}'+Ws;
   LowlevelSend(@Ws[1],Length(Ws));
End;

Function GetClassTypeName(obj:TObject):String;
Var
   pti: PTypeInfo;

Begin
   Result:='';
   pti := obj.ClassType.ClassInfo;
   if pti = nil then Exit;
   Result:=':'+pti.Name;
End;

Procedure TDXCodeTracer.SendComponentList(Category:TDXCatType;Component:TComponent);
Var
   Loop:Integer;
   Ws:String;

Begin
   If Not Assigned(Component) then Exit;
   Ws:=Component.Name+GetClassTypeName(Component)+#13;
   For Loop:=1 to Component.ComponentCount do Begin
      Ws:=Ws+Component.Components[Loop-1].Name+GetClassTypeName(Component.Components[Loop-1])+#13;
   End;
   Ws:=GetNextMsgID+'<'+IntegerToString(GetSLType(dxptComponentList,Category))+'>['+
      IntegerToString(GetCurrentThreadID)+'.'+IntegerToString(fTransaction)+':'+UUID_String+
      ']{'+GetTickString+'}'+Ws;
   LowlevelSend(@Ws[1],Length(Ws));
End;

Procedure TDXCodeTracer.SendComponentHierarchy(Category:TDXCatType;Component:TComponent);
Var
   Ws:String;
   RefClass:TClass;

Begin
   If Not Assigned(Component) then Exit;
   Ws:=Component.Name+GetClassTypeName(Component)+#13;
   RefClass:=Component.ClassParent;
   While RefClass<>Nil do Begin
      Ws:=Ws+RefClass.ClassName+#13;
      RefClass:=RefClass.ClassParent;
   End;
   Ws:=GetNextMsgID+'<'+IntegerToString(GetSLType(dxptComponentHierarchy,Category))+'>['+
      IntegerToString(GetCurrentThreadID)+'.'+IntegerToString(fTransaction)+':'+UUID_String+
      ']{'+GetTickString+'}'+Ws;
   LowlevelSend(@Ws[1],Length(Ws));
End;

Procedure TDXCodeTracer.SendStartingRoutine(Category:TDXCatType;RoutineName:String);
Var
   Ws:String;

Begin
   Ws:=GetNextMsgID+'<'+IntegerToString(GetSLType(dxptStartRoutine,Category))+'>['+
      IntegerToString(GetCurrentThreadID)+'.'+IntegerToString(fTransaction)+':'+UUID_String+
      ']{'+GetTickString+'}'+RoutineName;
   LowlevelSend(@Ws[1],Length(Ws));
End;

Procedure TDXCodeTracer.SendExitingRoutine(Category:TDXCatType;RoutineName:String);
Var
   Ws:String;
   
Begin
   Ws:=GetNextMsgID+'<'+IntegerToString(GetSLType(dxptEndRoutine,Category))+'>['+
      IntegerToString(GetCurrentThreadID)+'.'+IntegerToString(fTransaction)+':'+UUID_String+
      ']{'+GetTickString+'}'+RoutineName;
   LowlevelSend(@Ws[1],Length(Ws));
End;

Procedure TDXCodeTracer.SendStartTiming(Category:TDXCatType;Comment:String);
Var
   Ws:String;

Begin
   Ws:=GetNextMsgID+'<'+IntegerToString(GetSLType(dxptStartTiming,Category))+'>['+
      IntegerToString(GetCurrentThreadID)+'.'+IntegerToString(fTransaction)+':'+UUID_String+
      ']{'+GetTickString+'}'+Comment;
   LowlevelSend(@Ws[1],Length(Ws));
End;

Procedure TDXCodeTracer.SendStopTiming(Category:TDXCatType);
Var
   Ws:String;

Begin
   Ws:=GetNextMsgID+'<'+IntegerToString(GetSLType(dxptStopTiming,Category))+'>['+
      IntegerToString(GetCurrentThreadID)+'.'+IntegerToString(fTransaction)+':'+UUID_String+
      ']{'+GetTickString+'}';
   LowlevelSend(@Ws[1],Length(Ws));
End;

Procedure TDXCodeTracer.SendCPUUsage(Category:TDXCatType);
Var
   Ws:String;
   Loop:Integer;

Begin
   Ws:=IntegerToString(GetCPUCount-1)+' CPUs'+#13;
   For Loop:=1 to GetCPUCount-1 do
      Ws:=Ws+IntegerToString(Trunc(GetCPUUsage(Loop)))+'%'+#13;
   Ws:=GetNextMsgID+'<'+IntegerToString(GetSLType(dxptCPUUsage,Category))+'>['+
      IntegerToString(GetCurrentThreadID)+'.'+IntegerToString(fTransaction)+':'+UUID_String+
      ']{'+GetTickString+'}'+Ws;
   LowlevelSend(@Ws[1],Length(Ws));
End;

procedure TDXCodeTracer.AppException(Sender: TObject; E: Exception);
Var
   Ws:String;

begin
   Ws:=GetNextMsgID+'<'+IntegerToString(GetSLType(dxptException,dxctCritical))+'>['+
      IntegerToString(GetCurrentThreadID)+'.'+IntegerToString(fTransaction)+':'+UUID_String+
      ']{'+GetTickString+'}'+E.Message;
   LowlevelSend(@Ws[1],Length(Ws));
end;

Procedure TDXCodeTracer.AssignExceptionLogging(Application:TApplication);
Begin
  Application.OnException := AppException;
End;

Procedure TDXCodeTracer.EndTransaction;
Var
   Msg:String;

Begin
   ProcessWindowsMessageQueue;
   SleepEx(1,False);
   Msg:=GetNextMsgID+'<'+IntegerToString(GetSLType(dxptEndTransaction,dxctInfo))+'>['+
      IntegerToString(GetCurrentThreadID)+'.'+
      IntegerToString(fTransaction)+':'+UUID_String+']{'+GetTickString+'}End of this Transaction';
   LowlevelSend(@Msg[1],Length(Msg));
   Inc(fTransaction);
   SleepEx(0,False);
End;

function MakeBytesToWord(Const A,B:Byte):Word;
Begin
   Result:=(A shl 8) + B;
End;

{$IFNDEF LINUX}
Var
   DLLData:TWSAData;
{$ENDIF}

initialization
{$IFDEF LINUX}
{$ELSE}
   WSAStartup(MAKEBytesToWORD(2,2),DLLData);
{$ENDIF}

finalization
{$IFNDEF LINUX}
   WSACleanup;
{$ENDIF}

end.