dxcodetracer.pas

Well known and usefull component for delphi 7

unit DXCodeTracer;

interface

uses
   Windows,
   SyncObjs,
   Winsock,
   SysUtils,
   DB,
   Forms,
   Registry,
   Classes;

Type
{!}TDXPriType=(dxptStartTransaction, {0}
{!}            dxptEndTransaction,   {1}
{!}            dxptString,           {2}
{!}            dxptPointer,          {3}
{!}            dxptObject,           {4}
{!}            dxptActiveWindows,    {5}
{!}            dxptMyWindows,        {6}
{!}            dxptServicesList,     {7}
               dxptNonpersistent,    {8} // message is sent, but not saved to disk
{!}            dxptMemoryInfo,       {9}
{!}            dxptException,       {10}
{!}            dxptStringlist,      {11}
{!}            dxptFielddefs,       {12}
{!}            dxptRowFields,       {13}
{!}            dxptRegistry,        {14}
{!}            dxptComponentList,   {15}
{!}            dxptCPUUsage,        {16}
{!}            dxptStartRoutine,    {17}
{!}            dxptEndRoutine,      {18}
{!}            dxptStartTiming,     {19}
{!}            dxptStopTiming,      {20}
{!}            dxptComponentHierarchy); {21}

   TDXCatType=(dxctEmergency,
               dxctAlert,
               dxctCritical,
               dxctError,
               dxctWarning,
               dxctNotice,
               dxctInfo,
               dxctDebug);
   TServiceStatusList=(dxssStopped,
                       dxssStarting,
                       dxssStopping,
                       dxssStarted,
                       dxssRestarting,
                       dxssPausing,
                       dxssPaused);

type
  TDXCodeTracer = class(TComponent)
   private
     UUID_String:string;
     fCritical:TCriticalSection;
     fSocket:TSocket;
     fSendTo:TSockAddr;
     fSendToSize:Integer;
     fServerAddress:String;
     fServerPort:Integer;
     fApplication:TApplication;
     fTransaction:Integer;
     fApplicationName:String;
     fMsgID:Cardinal;
     Procedure LowlevelSend(Data:Pointer;DataLen:Integer);
     procedure AppException(Sender: TObject; E: Exception);
     Function GetNextMsgID:String;
   protected
   public
     constructor Create(AOwner:TComponent); override;
     destructor Destroy; override;
     Procedure StartTransaction(Description:String);
     Procedure EndTransaction;
     Procedure SendStringList(Category:TDXCatType;Strlist:TStrings);
     Procedure SendString(Category:TDXCatType;Str:String);
     Procedure SendInteger(Category:TDXCatType;Inte:Integer);
     Procedure SendMessage(Category:TDXCatType;Msg:String);
     Procedure SendBuffer(Category:TDXCatType;Data:Pointer;DataLen:Integer);
     Procedure SendPointer(Category:TDXCatType;Data:Pointer;DataLen:Integer);
     Procedure SendObject(Category:TDXCatType;Obj:TObject);
     Procedure SendFieldDefs(Category:TDXCatType;FieldDefs:TFieldDefs);
     Procedure SendFields(Category:TDXCatType;Fields:TFields);
     Procedure SendActiveWindows(Category:TDXCatType);
     Procedure SendMyWindows(Category:TDXCatType);
     Procedure SendCPUUsage(Category:TDXCatType);
     Procedure SendServices(Category:TDXCatType;ServiceStatus:TServiceStatusList);
     Procedure SendMemoryInformation(Category:TDXCatType);
     Procedure SendRegistry(Category:TDXCatType;Key:HKey;Path,Field:String);
     Procedure SendComponentList(Category:TDXCatType;Component:TComponent);
     Procedure SendComponentHierarchy(Category:TDXCatType;Component:TComponent);
     Procedure SendStartingRoutine(Category:TDXCatType;RoutineName:String);
     Procedure SendExitingRoutine(Category:TDXCatType;RoutineName:String);
     Procedure SendStartTiming(Category:TDXCatType;Comment:String);
     Procedure SendStopTiming(Category:TDXCatType);
     Procedure AssignExceptionLogging(Application:TApplication);
   published
     property ServerAddress:String read fServerAddress write fServerAddress;
     property ServerPort:Integer read fServerPort write fServerPort;
     property ApplicationName:String read fApplicationName write fApplicationName;
  end;

procedure Register;

{$IFDEF LINUX}
function CoCreateGuid(var GUID:TGUID):HResult;
{$ELSE}
{$IFDEF VER90}
function CoCreateGuid(var guid:Pointer):HResult;stdcall;
{$ELSE}
function CoCreateGuid(var guid:TGUID):HResult;stdcall;
{$ENDIF}
{$ENDIF}

implementation

Uses
   TypInfo,
   WinSvc,
   DXString,
   DXCodeTracerCPU;

procedure Register;
begin
  RegisterComponents('BPDX Code Tracer', [TDXCodeTracer]);
end;

Function GetTickString:String;
Var
   lpSystemTimeAsFileTime:TFileTime;
   X:Cardinal;

Begin
   GetSystemTimeAsFileTime(lpSystemTimeAsFileTime);
   If lpSystemTimeAsFileTime.dwLowDateTime<0 then X:=lpSystemTimeAsFileTime.dwLowDateTime shr 1
   Else X:=lpSystemTimeAsFileTime.dwLowDateTime;
   Result:=IntegerToString(((lpSystemTimeAsFileTime.dwHighDateTime mod 1000)*1000000)+
         X div 10000);
End;

{$IFNDEF VER90}
const
   ole32='ole32.dll';
{$ENDIF}

{$IFNDEF LINUX}
function CoCreateGuid; external ole32 name'CoCreateGuid';
{$ENDIF}

function MakeUUID:string;
var
   UUIDVar:TGUID;
   k:Integer;

begin
   CoCreateGuid(UUIDVar);
   Result:=IntToHex(UUIDVar.D1,8)+'-'+
      IntToHex(UUIDVar.D2,4)+'-'+
      IntToHex(UUIDVar.D3,4)+'-';
   for k:=0 to 1 do
      Result:=Result+IntToHex(UUIDVar.D4[k],2);
   Result:=Result+'-';
   for k:=2 to 7 do
      Result:=Result+IntToHex(UUIDVar.D4[k],2);
end;

constructor TDXCodeTracer.Create(AOwner:TComponent);
Begin
   inherited Create(AOwner);
   UUID_String:=MakeUUID;
   fApplicationName:='Your App Name';
   fCritical:=TCriticalSection.Create;
   fSocket:={$IFDEF LINUX}Libc.
            {$ELSE}Winsock.
            {$ENDIF}Socket(AF_INET,SOCK_DGRAM,IPPROTO_UDP);
   fSendToSize:=SizeOf(TSockAddr);
   fSendTo.sin_family:=AF_INET;
   fServerPort:=514;
   fServerAddress:='127.0.0.1';
   fTransaction:=1;
   fMsgID:=0;
End;

destructor TDXCodeTracer.Destroy;
Begin
   if fSocket<>Invalid_Socket then Begin
      ShutDown(fSocket,2);
{$IFDEF LINUX}
      Libc.__close(fSocket);
{$ELSE}
      CloseSocket(fSocket);
{$ENDIF}
   End;
   fCritical.Free;
   inherited Destroy;
End;

procedure ProcessWindowsMessageQueue;
{$IFDEF LINUX}
begin
   Application.ProcessMessages;
end;
{$ELSE}
var
   MsgRec:TMsg;

begin
   if not IsConsole then
      while PeekMessage(MsgRec,0,0,0,PM_REMOVE) do begin
         TranslateMessage(MsgRec);
         DispatchMessage(MsgRec)
      end;
end;
{$ENDIF}

Procedure TDXCodeTracer.LowlevelSend(Data:Pointer;DataLen:Integer);
Var
   Result:Integer;

Begin
   fSendTo.sin_port:=htons(fServerPort);
   fSendTo.sin_addr.S_addr:=Inet_Addr(Pchar(fServerAddress));
   fCritical.Acquire;
   Result:={$IFDEF LINUX}Libc.
           {$ELSE}Winsock.
           {$ENDIF}SendTo(fSocket,Data^,DataLen,0,fSendTo,fSendToSize);
   fCritical.Release;
   ProcessWindowsMessageQueue;
End;

Function GetSLType(Priority:TDXPriType;Category:TDXCatType):Integer;
Begin
   Result:=(Ord(Category)) + (Ord(Priority)*8);
End;

function GetUserName: String;
var
 N: DWord;
 Buf: array[0..1023] of AnsiChar;
begin
 N:=SizeOf(Buf)-1;
 Windows.GetUserName(Buf, N);
 Result:=PChar(@Buf[0]);
end;

function GetComputerName: String;
var
 N: DWORD;
 Buf: array [0..16] of AnsiChar;
begin
 N:=SizeOf(Buf)-1;
 Windows.GetComputerName(Buf, N);
 Result:=PChar(@Buf[0]);
end;

Function TDXCodeTracer.GetNextMsgID:String;
Begin
   Inc(fMsgID);
   Result:=IntegerToString(fMsgID);
End;

Procedure TDXCodeTracer.StartTransaction(Description:String);
Var
   Msg:String;

Begin
   Inc(fTransaction);
   Msg:=GetNextMsgID+'<'+IntegerToString(GetSLType(dxptStartTransaction,dxctInfo))+'>['+
      IntegerToString(GetCurrentThreadID)+'.'+IntegerToString(fTransaction)+':'+UUID_String+']{'+
      GetTickString+'}Start of Transaction'+#13+
      fApplicationName+#13+
      GetComputerName+#13+
      GetUserName+#0+Description;
   LowlevelSend(@Msg[1],Length(Msg));
   SleepEx(0,False);
End;

Procedure TDXCodeTracer.SendStringList(Category:TDXCatType;Strlist:TStrings);
Var
   Msg:String;

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

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

Procedure TDXCodeTracer.SendString(Category:TDXCatType;Str:String);
Begin
   SendMessage(Category,Str);
End;

Procedure TDXCodeTracer.SendInteger(Category:TDXCatType;Inte:Integer);
Begin
   SendMessage(Category,IntegerToString(Inte));
End;

Procedure TDXCodeTracer.SendBuffer(Category:TDXCatType;Data:Pointer;DataLen:Integer);
Var
   Buf:Pointer;
   Ws:String;

Begin
   Ws:=GetNextMsgID+'<'+IntegerToString(GetSLType(dxptPointer,Category))+'>['+
      IntegerToString(GetCurrentThreadID)+'.'+IntegerToString(fTransaction)+':'+UUID_String+
      ']{'+GetTickString+'}';
   Buf:=GetMem(Datalen+Length(Ws));
   If Buf<>Nil then Begin
      Buf:=StrPCopy(Buf,Ws);
      Buf:=StrCat(Buf,Data);
      LowlevelSend(Buf,DataLen+Length(Ws));
      FreeMem(Buf);
   End;
End;

Procedure TDXCodeTracer.SendPointer(Category:TDXCatType;Data:Pointer;DataLen:Integer);
Begin
   SendBuffer(Category,Data,DataLen);
End;

function GetPublishedProperties(Obj:TObject): TStringList;
var
   pti: PTypeInfo;
   ptd: PTypeData;
   I, nProps: Integer;
   pProps: PPropList;
   ppi: PPropInfo;
   S: String;
   WorkMethod:TMethod;

begin
   result := TStringList.Create;
   pti := obj.ClassType.ClassInfo;
   if pti = nil then Exit;
   ptd := GetTypeData(pti);
   nProps := ptd^.PropCount;
   if nProps > 0 then begin
      GetMem(pProps, SizeOf(PPropInfo) * nProps);
      GetPropInfos(pti, pProps);
   end
   else pProps := nil; // v 2.0 12/01/2002
   for I:=0 to nProps - 1 do begin
      ppi:=pProps[I];
      S:=ppi^.Name+'^'+ppi^.PropType^.Name+'(';
      case ppi^.PropType^.Kind of
         tkInteger
         {$IFNDEF VER100}
            ,tkInt64
         {$ENDIF}
            :begin
            S:=S+IntegerToString(GetOrdProp(Obj, ppi));
         end;
         {$IFNDEF VER100}
         tkSet:Begin
            S:=S+GetSetProp(Obj,ppi);
         End;
         {$ENDIF}
         tkChar:Begin
            S:=S+Char(GetOrdProp(Obj, ppi));
         End;
         tkString, tkLString, tkWString:Begin
            S:=S+GetStrProp(Obj, ppi);
         end;
         tkClass:Begin
            S:=S+'TClass';
         End;
         tkVariant: // 12/01/2002
             S:= S+GetVariantProp(Obj, ppi);
         tkMethod:Begin // we do not send events!
            WorkMethod:=GetMethodProp(Obj,ppi);
            If Assigned(WorkMethod.Code) or
               Assigned(WorkMethod.Data) then Begin
               S:=S+'$'+IntToHex(LongInt(WorkMethod.Code),8)+':'+
                  IntToHex(LongInt(WorkMethod.Data),8);
            End
            Else Begin
               S:=S+'Nil';
            End;
            S:=#1+S;
         End;
         Else Begin
            if ppi^.PropType^.Kind=tkEnumeration then Begin
{$IFNDEF VER100}
               S:=S+GetEnumProp(Obj,ppi);
{$ENDIF}
            End
            Else Begin
               S:=S+'*UNKNOWN*';
               if ppi^.PropType^.Kind=tkEnumeration then Begin
                  S:=S+'?';
               End;
            End;
         End;
      end;
      If S<>'' then result.Add(S+')');
   end;
   if nProps > 0 then
      FreeMem(pProps, SizeOf(PPropInfo) * nProps);
end;

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

Begin
   If Not Assigned(Obj) then Exit;
   Strlist:=GetPublishedProperties(Obj);
   If StrList.Count>0 then begin
      Ws:=Obj.ClassName+':';
      Loop:=0;
      While Loop<Strlist.Count do begin
         Ws:=Ws+StrList[Loop]+#13#10;
         Inc(loop);
      End;
      Ws:=GetNextMsgID+'<'+IntegerToString(GetSLType(dxptObject,Category))+'>['+
         IntegerToString(GetCurrentThreadID)+'.'+IntegerToString(fTransaction)+':'+UUID_String+
         ']{'+GetTickString+'}'+Ws;
      LowlevelSend(@Ws[1],Length(Ws));
   End;
   Strlist.Free;
End;

// Enumerate Windows CallBack Function
function EnumWindowsCallBack(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.SendActiveWindows(Category:TDXCatType);
Var
   StrList:TStringList;
   Ws:String;
   Loop:Integer;

Begin
   StrList:=TStringList.Create;
   EnumWindows(@EnumWindowsCallBack, LongInt(@StrList)); // Enumerate Windows (and Log them)
   StrList.Sort;