{ +-------------------------------------------------------------+ }
{ |                                                             | }
{ |   GM-Software                                               | }
{ |   ===========                                               | }
{ |                                                             | }
{ |   Project: All Projects                                     | }
{ |                                                             | }
{ |   Description: Problem reports.                             | }
{ |                                                             | }
{ |                                                             | }
{ |   Copyright (C) - 2004 - Gerrit Moeller.                    | }
{ |                                                             | }
{ |   Source code distributed under MIT license.                | }
{ |                                                             | }
{ |   See: https://www.gm-software.de                           | }
{ |                                                             | }
{ +-------------------------------------------------------------+ }

{$INCLUDE GMCompilerSettings.inc}

{$IFDEF DEBUG}
  {.$DEFINE STORE_REPORT_XML}
{$ENDIF}

unit GMXmlRprt;

interface

uses {$IFNDEF JEDIAPI}Windows,{$ELSE}{$ENDIF}
     GMStrDef, GMCommon, GMIntf, GMXml;

const

  cStrXmlDBDErrReport = 'ProblemReport';

  cStrXmlId = 'Id';
  cStrXmlProduct = 'Product';
  cStrXmlCustomer = 'Customer';

  cStrXmlModuleRuntimes = 'ModuleRuntimes';
  cStrXmlModuleLoadTime = 'ModuleLoadTime';
  cStrXmlModuleRunDuration = 'ModuleRunDuration';

  cStrXmlProcesssModule = 'ProcessModule';
  cStrXmlModuleInfo = 'ModuleInfo';
  cStrXmlPath = 'Path';
  cStrXmlVersionText = 'VersionText';
  cStrXmlFileVersion = 'FileVersion';
  cStrXmlCompany = 'Company';
  cStrXmlCreated = 'Created';
  cStrXmlModified = 'Modified';
  cStrXmlAttributes = 'Attributes';
  cStrXmlSize = 'Size';
  //cStrXmlOutlookVersion = 'OutlookVersion';
  cStrXmlSystemLanguage = 'Language';

  cStrXmlOSInfo = 'OSInfo';
  cStrXmlOSVersion = 'OSVersion';
  cStrXmlOSName = 'OSName';
  cStrXmlSrvicePack = 'ServicePack';
  cStrXmlOSUpTime = 'UpTime';
  cStrXmlDisplay = 'Display';
  cStrXmlBitWidth = 'BitWidth';

  cStrXmlUserInfo = 'UserInfo';
  cStrXmlUserName = 'UserName';
  cStrXmlUserID = 'UserID';
  cStrXmlUserRegName = 'RegisteredUserName';
  cStrXmlCompanyName = 'CompanyName';
  cStrXmlUserLanguage = 'Language';
  cStrXmlUserPrivilegs = 'UserPrivilegs';

  cStrXmlComputerName = 'ComputerName';
  cStrXmlNetworkInfo = 'NetworkInfo';
  cStrXmlNetworkAdapter = 'NetworkAdapter';
  cStrXmlAdapterName = 'AdapterName';
  cStrXmlAdapterDesc = 'AdapterDesc';
  cStrXmlIPAddress = 'IPAddress';
  cStrXmlSubmask = 'Submask';
  cStrXmlGateway = 'Gateway';
  cStrXmlDSN1 = 'DNS1';
  cStrXmlDSN2 = 'DNS2';
  cStrXmlDHCP = 'DHCP';

  cStrXmlVirtualMemInfo = 'VirtualMemoryInfo';
  cStrXmlSysModules = 'SystemModules';

  cStrXmlRunningProcesses = 'RunningProcesses';
  cStrXmlRunningProcessCount = 'RunningProcessCount';
  cStrXmlRunningProcess = 'RunningProcess';

  cStrXmlProcessorInfo = 'ProcessorInfo';
  cStrXmlProcessorName = 'ProcessorName';
  cStrXmlProcessorFamily = 'ProcessorFamily';
  cStrXmlProcessorSpeed = 'ProcessorSpeed';

  cStrXmlMemoryLoad = 'PhysicalMemoryUsed';
  cStrXmlTotalPhysMem = 'TotalPhysicalMemory';
  cStrXmlAvailPhysMem = 'AvailablePhysicalMemory';
  cStrXmlTotalPageFile = 'TotalPageFileSize';
  cStrXmlAvailPageFile = 'AvailablePageFileSize';
  cStrXmlTotalVirtMem = 'TotalVirtualMemory';
  cStrXmlAvailVirtMem = 'AvailableVirtualMemory';

  cStrXmlProblemDesc = 'ProblemDesc';
  cStrXmlExceptionClassName = 'ExceptionClassName';
  cStrXmlExceptAddr = 'ExceptAddress';
  cStrXmlRaisorName = 'RaisorName';
  cStrXmlRaisorClassName = 'RaisorClassName';
  cStrXmlRoutineName = 'RoutineName';
  cStrXmlSeverity = 'SeverityLevel';
  cStrXmlMessage = 'Message';
  cStrXmlMainThreadID = 'MainThreadID';

  {$IFDEF CALLSTACK}
  cStrXmlCallStack = 'CallStack';
  cStrXmlStackCount = 'StackEntryCount';
  cStrXmlStackEntry = 'StackEntry';
  {$ENDIF}

  cStrXmlTrace = 'Trace';
  cStrXmlLine = 'Line';

  cStrTimeStampFmt = 'ddd dd"."mm"."yyyy hh":"nn":"ss"."zzz';
  cStrFileTimeFmt = 'ddd dd"."mm"."yyyy hh":"nn":"ss';
  cStrTimeDurationFmt = 'hh":"nn":"ss"."zzz';


procedure GMTraceReportLine(const ALine: TGMString);

function GMBuildReportXml(const AProductName, ACustomerName: TGMString;
                          const AExceptInfo: IGMExceptionInformation;
                          const AExceptCallStack: Boolean): IGMXmlTree;


type

  TGMTellTraceLineFunc = function(const ATraceLine: TGMString; const AData: Pointer = nil): Boolean;

procedure GMEnumTrace(const ATellTraceLineFunc: TGMTellTraceLineFunc; const AData: Pointer = nil);


var

  // Better use a grow delta boundary for vGMMaxTraceLines, otherwise the remaining entries will be wasted
  vGMMaxTraceLines: PtrInt = 5724; // 1111, 1333, 1599, 1918, 2301, 2761, 3313, 3975, 4770, 5724, 6748, 7772, 8796, 9820, 10844, 11868
  vGMMaxTraceLineLength: PtrInt = 4000;
  vAdditionalModulesXmlName: TGMString = '';
  vAdditionalModulesInReport: TGMStringArray = {$IFDEF DELPHI9}[]{$ELSE}nil{$ENDIF};
  //vGMOutlookVersion: TGMString = '';
  //vEnableTraceValId: Integer = -1;
  //vMaxTraceLinesValId: Integer = -1;


implementation                 

uses SysUtils, {$IFDEF JEDIAPI}jwaWinType, jwaWinBase, jwaWinReg, jwaWinNT, jwaWinUser, jwaWinGdi, jwaWinError,  jwaPsApi, jwaWinNLS,{$ENDIF}
     GMCollections{$IFDEF CALLSTACK}, GMCallStack, GMMapParser{$ENDIF}{$IFDEF STORE_REPORT_XML},GMActiveX{$ENDIF};

type

  RTraceEntry = record
   public
    ThreadId: DWORD;
    TimeStamp: TDateTime;
    TickCount: DWORD;
    LineId: Int64;
    Line: TGMString;

    function AsString: TGMString;
  end;


var

  vTraceList: IGMGenericArrayCollection<RTraceEntry> = nil;
  vTraceEnd: PtrInt = 0;
  //vLastMaxTraceLines: LongInt = 0;
  VTraceLineId: Int64 = 1;
  vModuleLoadTime: TDateTime = 0;


type

  PMemoryStatusEx = ^TMemoryStatusEx;
  TMemoryStatusEx = record
    dwLength: DWORD;
    dwMemoryLoad: DWORD;
    ullTotalPhys: Int64;
    ullAvailPhys: Int64;
    ullTotalPageFile: Int64;
    ullAvailPageFile: Int64;
    ullTotalVirtual: Int64;
    ullAvailVirtual: Int64;
    ullAvailExtendedVirtual: Int64;
  end;


{ --------------------- }
{ ---- RTraceEntry ---- }
{ --------------------- }

function BuildTraceEntry(const ALine: TGMString): RTraceEntry;
begin
  Result.ThreadId := GetCurrentThreadId;
  Result.TimeStamp := Now;
  Result.TickCount := GetTickCount;
  Result.LineId := vTraceLineId;
  if Length(ALine) > vGMMaxTraceLineLength then Result.Line := Copy(ALine, 1, vGMMaxTraceLineLength) + cStr_More else Result.Line := ALine;
  Inc(vTraceLineId);
end;

function RTraceEntry.AsString: TGMString;
const cMainThreadMark: array [Boolean] of TGMString = ('', '*');
begin
  Result := GMFormat('(%u:%u)[%u%s] %s: %s', [LineId, TickCount, ThreadId, cMainThreadMark[ThreadId = gGMMainThreadID], FormatDateTime(cStrTimeStampFmt, TimeStamp), Line]);
end;


{ ------------------------ }
{ ---- Trace Routines ---- }
{ ------------------------ }

function TraceList: IGMGenericArrayCollection<RTraceEntry>;
begin
  if vTraceList = nil then vTraceList := TGMGenericArrayCollection<RTraceEntry>.Create(True, False);
  Result := vTraceList;
end;

//function MaxTraceLines: PtrInt;
//begin
//  Result := vGMMaxTraceLines;
//end;

procedure GMTraceReportLine(const ALine: TGMString);
//var  // threadSync: RGMCriticalSectionLock; // maxLines: PtrInt;
begin
  //threadSync.Lock(TraceList);

  //
  // Thread serialization via Critical Section is done in GMDfltTrace
  //

  //maxLines := MaxTraceLines;
  if TraceList.Count < vGMMaxTraceLines then
   vTraceEnd := TraceList.AddIdx(BuildTraceEntry(ALine))
  else
   begin
    vTraceEnd := (vTraceEnd + 1) mod vGMMaxTraceLines;
    TraceList[vTraceEnd] := BuildTraceEntry(ALine);
   end;

  {$IFDEF DEBUG}
  OutputDebugString(PGMChar(ALine));
  {$ENDIF}
end;

procedure GMEnumTrace(const ATellTraceLineFunc: TGMTellTraceLineFunc; const AData: Pointer);
var threadSync: RGMCriticalSectionLock; traceStart, i: LongInt;
begin
  if not Assigned(ATellTraceLineFunc) then Exit;
  threadSync.Lock(TraceList);
  if not TraceList.IsEmpty then
   begin
    traceStart := (vTraceEnd + 1) mod vGMMaxTraceLines;
    for i:=traceStart to TraceList.Count-1 do if not ATellTraceLineFunc(TraceList[i].AsString, AData) then Exit;
    for i:=0 to traceStart-1 do if not ATellTraceLineFunc(TraceList[i].AsString, AData) then Exit;
   end;
end;


{ ------------------------- }
{ ---- Helper Routines ---- }
{ ------------------------- }

function AddXmlMsgLine(const ALine: TGMString; const ALastLine: Boolean; const AData: Pointer): Boolean;
var Node: IGMXmlNode;
begin
  Result := True;
  if (AData = nil) or not GMQueryInterface(IUnknown(Pointer(AData)), IGMXmlNode, node) then Exit;
//Node := IGMXmlNode(AData);
  GMCreateXmlNode(Node, cStrXmlLine, ALine);
end;

{$IFDEF CALLSTACK}
procedure GMTraceThreadExceptCallStack(var DestTrace: TGMStringArray; const ThreadId: LongWord);
var threadEntry: IGMThreadCallStack;
begin
  SetLength(DestTrace, 0);
  threadEntry := GMGetThreadCallStackData(GetCurrentThreadId);
  if threadEntry = nil then Exit;
  GMTraceCallStackNames(DestTrace, threadEntry.Obj.CallStack);
end;

procedure TraceCallStack(var DestTrace: TGMStringArray; const AExceptCallStack: Boolean);
var stackAddresses: TGMPtrIntArray;
begin
  if AExceptCallStack then GMTraceThreadExceptCallStack(DestTrace, GetCurrentThreadId) else
   begin
    GMCaptureCurrentThreadCallStack(stackAddresses);
    GMTraceCallStackNames(DestTrace, stackAddresses);
   end;
end;
{$ENDIF}

function MSIEPath: TGMString;
var regKey: IGMRegKey; i: Integer;
begin
  Result := '';
  regKey := TGMRegKey.Create;
  if not regKey.Obj.OpenKey(HKEY_CLASSES_ROOT, '\CLSID\{0002DF01-0000-0000-C000-000000000046}\LocalServer32') then Exit;
  Result := GMStrip(regKey.Obj.ReadString(''));
  if (Length(Result) > 0) and (Result[1] = '"') then
   begin
    for i:=2 to Length(Result) do if Result[i] = '"' then Break;
    Result := Copy(Result, 2, i-2);
   end;
end;

function MemSizeAsString(const Value: Int64): TGMString;
var DoubleValue: Double;
begin
  DoubleValue := Value;     
  Result := GMFileSizeAsString(Value) + GMFormat(' (%.0n Bytes)', [DoubleValue]);
end;

//function TestRegKey(const RootKey: HKey; const KeyPath: TGMString): Boolean;
//var regKey: IGMRegKey;
//begin
//regKey := TGMRegkey.Create;
//Result := regKey.Obj.OpenKey(RootKey, KeyPath);
//end;

function ReadRegStr(const ARootKey: HKey; const AKeyPath, AValueName: TGMString): TGMString;
var regKey: IGMRegKey;
begin
  regKey := TGMRegkey.Create;
  if regKey.Obj.OpenKey(ARootKey, AKeyPath) then Result := GMStrip(regKey.Obj.ReadString(AValueName, '')) else Result := '';
end;

function ReadRegInt(const ARootKey: HKey; const AKeyPath, AValueName: TGMString): LongInt;
var regKey: IGMRegKey;
begin
  regKey := TGMRegkey.Create;
  if regKey.Obj.OpenKey(ARootKey, AKeyPath) then Result := regKey.Obj.ReadInteger(AValueName, 0) else Result := 0;
end;

function TimeDurationAsString(const ADuration: TDateTime): TGMString;
begin
  Result := GMFormat('%u Day(s), %s', [Trunc(ADuration), FormatDateTime(cStrTimeDurationFmt, Frac(ADuration))]);
end;


{ ----------------------------------- }
{ ---- Simple Report Information ---- }
{ ----------------------------------- }

function WindowsMemoryStatus(AMemStatDataEx: PMemoryStatusEx): BOOL;
var vGlobalMemoryStatusEx: function (pMemStatDataEx: PMemoryStatusEx): BOOL; stdcall;
    memStatData: TMemoryStatus; hKernel32: THandle;
begin
  if AMemStatDataEx = nil then Begin Result := False; Exit; end;

  FillByte(AMemStatDataEx^, SizeOf(AMemStatDataEx^), 0);
  AMemStatDataEx^.dwLength := SizeOf(AMemStatDataEx^);

  vGlobalMemoryStatusEx := nil;
  hKernel32 := GetModuleHandle('kernel32.dll');
  if hKernel32 <> 0 then vGlobalMemoryStatusEx := GetProcAddress(hKernel32, 'GlobalMemoryStatusEx');

  if Assigned(vGlobalMemoryStatusEx) then Result := vGlobalMemoryStatusEx(AMemStatDataEx) else
   begin
    FillByte(memStatData, SizeOf(memStatData), 0);
    memStatData.dwLength := SizeOf(memStatData);
    GlobalMemoryStatus(memStatData);
    AMemStatDataEx.dwMemoryLoad := memStatData.dwMemoryLoad;
    AMemStatDataEx.ullTotalPhys := memStatData.dwTotalPhys;
    AMemStatDataEx.ullAvailPhys := memStatData.dwAvailPhys;
    AMemStatDataEx.ullTotalPageFile := memStatData.dwTotalPageFile;
    AMemStatDataEx.ullAvailPageFile := memStatData.dwAvailPageFile;
    AMemStatDataEx.ullTotalVirtual := memStatData.dwTotalVirtual;
    AMemStatDataEx.ullAvailVirtual := memStatData.dwAvailVirtual;
    Result := True;
   end;
end;

{function GetProcessorType: TGMString;
var SysInfo: TSystemInfo;
begin
  //Result := 'Unknown Processor Type';
  FillByte(SysInfo, SizeOf(SysInfo), 0);
  GetSystemInfo(SysInfo);

  case SysInfo.wProcessorArchitecture of
   0: begin
       Result := 'Intel,';
       case SysInfo.wProcessorLevel of
        3: Result := Result + ' 80386';
        4: Result := Result + ' 80486';
        5: Result := Result + ' Pentium';
        6: Result := Result + ' Pentium 2';
        15: Result := Result + ' Pentium 4';
        else
         begin
          if SysInfo.wProcessorLevel > 6 then Result := Result + ' higher than Pentium II,';
          Result := Result + ' Level (' + IntToStr(SysInfo.wProcessorLevel) + ')';
         end;
       end;
      end;

   1: Result := 'MIPS';
   2: Result := 'Alpha';
   3: Result := 'PPC';
   6: Result := 'Intel Itanium 64';
   9: Result := 'x64 (Intel or AMD)';
   $FFFF: Result := 'Unknown';
  end;
end;}

function GetOSName: TGMString;
var Is64bit: Boolean;
begin
  Result := 'Microsoft Windows ';
  case Win32Platform of
   VER_PLATFORM_WIN32_WINDOWS:
    case Win32MinorVersion of
     0..9: if GMStrip(Win32CSDVersion) = 'B' then Result := (Result + '95 OSR 2') else Result := (Result + '95');
     10..89: if GMStrip(Win32CSDVersion) = 'A' then Result := (Result + '98 SE') else Result := (Result + '98');
     90: Result := (Result + 'ME');
    end;
   VER_PLATFORM_WIN32_NT:
   begin
    //Is64bit := (TestRegKey(HKEY_LOCAL_MACHINE, '\Software\WOW6432') or TestRegKey(HKEY_LOCAL_MACHINE, '\Software\WOW6432Node'));
    try
     Is64bit := GMIs64BitOS;
    except
     Is64bit := False;
    end;
    case Win32MajorVersion of
     4: Result := (Result + 'NT 4.0');
     5: case Win32MinorVersion of
         0: Result := (Result + '2000');
         1: Result := (Result + 'XP');
         2: if (not Is64bit) then Result := (Result + 'Server 2003')
         else Result := Result + 'XP Platform (Unknown minor Version)';
       end;
     6: //Result := Result + 'Vista';
         case Win32MinorVersion of
          0: Result := Result + 'Vista / Server-2008';
          1: Result := Result + '7 / Server-2008-R2';
          else Result := Result + 'Vista Platform (Unknown minor Version)';
         end;
     else Result := Result + '(Unknown major Version)';
    end;
    //Result := GMStrJoin(Result, ' ', OSBitWidth);
    //if Is64bit then Result := Result + ' (64-Bit)' else Result := Result + ' (32-Bit)';
   end;
  end;
end;

function OsBitWidth: TGMString;
var Is64bit: Boolean;
begin
  try Is64bit := GMIs64BitOS; except Is64bit := False; end;
  if Is64bit then Result := '64-Bit' else Result := '32-Bit';
end;

function LangIDAsString(const ALang: LANGID): TGMString;
begin
  Result := GMFormat('0x%x, Major Language: 0x%x (Dez: %d), Minor Language: 0x%x (Dez: %d)', [ALang, ALang and $FF, ALang and $FF, (ALang and $FF00) shr 8, (ALang and $FF00) shr 8]);
end;

function GetOSBuildNo: TGMString;
begin
  if Win32Platform = VER_PLATFORM_WIN32_NT then
    Result := IntToStr(Win32BuildNumber)
  else
    Result := IntToStr((Win32BuildNumber and $0000FFFF));
end;

function UserRegName: TGMString;
begin
  Result := ReadRegStr(HKEY_LOCAL_MACHINE, '\SOFTWARE\MICROSOFT\WINDOWS NT\CURRENTVERSION', 'RegisteredOwner');
  if Result = '' then Result := ReadRegStr(HKEY_LOCAL_MACHINE, '\SOFTWARE\MICROSOFT\WINDOWS\CURRENTVERSION', 'RegisteredOwner');
  if Result = '' then Result := ReadRegStr(HKEY_LOCAL_MACHINE, '\SOFTWARE\MICROSOFT\MS SETUP (ACME)\USER INFO', 'DefName');
end;

function GetCompanyName: TGMString;
begin
  Result := ReadRegStr(HKEY_LOCAL_MACHINE, '\SOFTWARE\MICROSOFT\WINDOWS NT\CURRENTVERSION', 'RegisteredOrganization');
  if Result = '' then Result := ReadRegStr(HKEY_LOCAL_MACHINE, '\SOFTWARE\MICROSOFT\WINDOWS\CURRENTVERSION', 'RegisteredOrganization');
  if Result = '' then Result := ReadRegStr(HKEY_LOCAL_MACHINE, '\SOFTWARE\MICROSOFT\MS SETUP (ACME)\USER INFO', 'DefCompany');
end;

function OSUpTime: TGMString;
var tickCount: DWORD;
begin
  tickCount := GetTickCount;
  Result := GMStringJoin(TimeDurationAsString(tickCount / 86400000), ' ',  GMFormat('(TickCount: %u)', [tickCount]));
end;

function DisplayInfo: TGMString;
var ScreenDC: HDC;
begin
  ScreenDC := GetDC(0);
  if ScreenDC = 0 then Exit;
  try
   Result := GMFormat('%d x %d Pixel, %d-Bits per Pixel', [GetSystemMetrics(SM_CXSCREEN),
                                                           GetSystemMetrics(SM_CYSCREEN),
                                                           GetDeviceCaps(ScreenDC, BITSPIXEL)]);
  finally
   ReleaseDC(0, ScreenDC);
  end;
end;


{ ------------------------------------ }
{ ---- Complex Report Information ---- }
{ ------------------------------------ }

procedure AddCurrentUserPrivileges(const ANode: IGMXmlNode);
const cAttrStr: array [Boolean] of TGMString = ('No', 'Yes');
var ProcessToken: THandle; i: LongInt; Len, APICode: DWORD; Buffer: Pointer; PrivName: TGMString; 
begin
  if (ANode = nil) or not OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, ProcessToken) then Exit;
  try
   Len := 0;
   GetTokenInformation(ProcessToken, TokenPrivileges, nil, 0, Len);
   APICode := GetLasterror;
   if ((APICode <> 0) and (APICode <> ERROR_INSUFFICIENT_BUFFER)) or (Len = 0) then Exit;
   GetMem(Buffer, Len);
   try
    if (GetTokenInformation(ProcessToken, TokenPrivileges, Buffer, Len, Len)) then
     for i:=0 to PTokenPrivileges(Buffer).PrivilegeCount-1 do
      with PLUIDAndAttributes(GMAddPtr(@PTokenPrivileges(Buffer).Privileges, i * SizeOf(TLUIDAndAttributes)))^ do
       begin
        Len := 0;
        LookupPrivilegeName(nil, Luid, nil, Len);
        APICode := GetLastError;
        if ((APICode <> 0) and (APICode <> ERROR_INSUFFICIENT_BUFFER)) or (Len = 0) then Continue;
        SetLength(PrivName, Len-1);
        if not LookupPrivilegeName(nil, Luid, PGMChar(PrivName), Len) then Continue;
        GMCreateXmlNode(ANode, PrivName, cAttrStr[Attributes and SE_PRIVILEGE_ENABLED <> 0]);
       end;
   finally
    FreeMem(Buffer);
   end;
  finally
   CloseHandle(ProcessToken);
  end;
end;

function AddTraceLineToXml(const ATraceLine: TGMString; const AData: Pointer): Boolean;
var xmlNode: IGMXmlNode;
begin
  if not GMQueryInterface(IUnknown(Pointer(AData)), IGMXmlNode, xmlNode) then begin Result := False; Exit; end;
  GMCreateXmlNode(xmlNode, cStrXmlLine, ATraceLine);
  Result := True;
end;

//procedure AddTraceLineToXml(const Node: IGMXmlNode; const TraceObj: TObject);
//begin
//if Node = nil then Exit;
//if not (TraceObj is RTraceEntry) then Exit;
//GMCreateXmlNode(Node, cStrXmlLine, (TraceObj as RTraceEntry).AsString);
//end;

procedure AddModuleInfo(ANode: IGMXmlNode; const AModulePath: TGMString; AXmlNodeName: TGMString = ''; const ABitWidth: Integer = -1);
var fileEntry: IGMFileProperties; n: Double;
begin
  if (ANode = nil) or (AModulePath = '') or not GMFileExists(AModulePath) then Exit;
  if AXmlNodeName = '' then AXmlNodeName := cStrXmlModuleInfo;
  fileEntry := GMFileSystemEntry(AModulePath);
  n := fileEntry.SizeInBytes;
  ANode := GMCreateXmlNode(ANode, AXmlNodeName);
  GMCreateXmlNode(ANode, cStrXmlPath, AModulePath);
  GMCreateXmlNode(ANode, cStrXmlVersionText, GMFileVersionInfo(AModulePath, viVersionText));
  GMCreateXmlNode(ANode, cStrXmlFileVersion, GMFileVersionInfo(AModulePath, viFileVersion));
  if ABitWidth > 0 then GMCreateXmlNode(ANode, cStrXmlBitWidth, GMIntToStr(ABitWidth) + '-Bit');
  GMCreateXmlNode(ANode, cStrXmlCompany, GMFileVersionInfo(AModulePath, viCompanyName));
  GMCreateXmlNode(ANode, cStrXmlCreated, FormatDateTime(cStrFileTimeFmt, fileEntry.CreationTime));
  GMCreateXmlNode(ANode, cStrXmlModified, FormatDateTime(cStrFileTimeFmt, fileEntry.LastWriteTime));
  GMCreateXmlNode(ANode, cStrXmlAttributes, GMFileAttrAsString(fileEntry));
  GMCreateXmlNode(ANode, cStrXmlSize, GMFormat('%.0n Byte(s) (%s)', [n, GMFileSizeAsString(fileEntry.SizeInBytes)]));
end;

procedure AddAdditionalModules(const ANode: IGMXmlNode);
var i: Integer;
begin
  for i:=Low(vAdditionalModulesInReport) to High(vAdditionalModulesInReport) do
   //if GMFileExists(vAdditionalModulesInReport[i]) then
      AddModuleInfo(ANode, vAdditionalModulesInReport[i], vAdditionalModulesXmlName, GMPointerSizeInBits);
end;

procedure AddProcessorInfo(const ANode: IGMXmlNode);
const cStrPrcssRegPath = '\HARDWARE\DESCRIPTION\System\CentralProcessor\0';
begin
  if ANode = nil then Exit;
  GMCreateXmlNode(ANode, cStrXmlProcessorName, ReadRegStr(HKEY_LOCAL_MACHINE, cStrPrcssRegPath, 'ProcessorNameString'));
  GMCreateXmlNode(ANode, cStrXmlProcessorFamily, ReadRegStr(HKEY_LOCAL_MACHINE, cStrPrcssRegPath, 'Identifier'));
  GMCreateXmlNode(ANode, cStrXmlProcessorSpeed, GMFormat('~%u MHz', [ReadRegInt(HKEY_LOCAL_MACHINE, cStrPrcssRegPath, '~MHz')]));
end;

procedure AddRunningProcesses(ANode: IGMXmlNode);
const cPMax = 2048; cBufSize = cPMax * SizeOf(DWORD);
type TEnumProcesses = function (lpidProcess: Pointer; cb: DWORD; pcbNeeded: PDWORD): BOOL; stdcall;
     //TGetModuleFileNameEx = function (hProcess: THandle; hModule: HMODULE; lpFilename: PAnsiChar; nSize: DWORD): DWORD; stdcall;
var HPSAPI, HProcess: THandle; ModulePath: TGMString; i: LongInt; N: DWORD; Buffer: Pointer;
    EnumProcesses: TEnumProcesses; {$IFNDEF JEDIAPI}GetModuleFileNameEx: TGetModuleFileNameEx;{$ENDIF}
begin
  if ANode = nil then Exit;
  HPSAPI := LoadLibrary('PSAPI.dll');
  if HPSAPI = 0 then Exit;
  try
   EnumProcesses := GetProcAddress(HPSAPI, 'EnumProcesses');
   if not Assigned(EnumProcesses) then Exit;
   {$IFNDEF JEDIAPI}
   GetModuleFileNameEx := GetProcAddress(HPSAPI, 'GetModuleFileNameExA');
   if not Assigned(GetModuleFileNameEx) then Exit;
   {$ENDIF}
   GetMem(Buffer, cBufSize);
   try
    if not EnumProcesses(Buffer, cBufSize, @N) then Exit;
    N := N div SizeOf(DWORD);
    if N = 0 then Exit;
    ANode := GMCreateXmlNode(ANode, cStrXmlRunningProcesses);
    GMCreateXmlNode(ANode, cStrXmlRunningProcessCount, IntToStr(N));
    for i:=0 to N-1 do
     begin
      HProcess := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False, PDWORD(GMAddPtr(Buffer, i * SizeOf(DWORD)))^);
      if HProcess = 0 then Continue;
      try
       SetLength(ModulePath, 2048);
       SetLength(ModulePath, GetModuleFileNameEx(HProcess, 0, PGMChar(ModulePath), Length(ModulePath)));
       if Length(ModulePath) = 0 then Continue;
       //ModulePath := GMFullPathName(ModulePath);
       GMCreateXmlNode(ANode, cStrXmlRunningProcess, GMStringJoin(ModulePath, ', Version ',
           GMStringJoin(GMFileVersionInfo(ModulePath, viFileVersion), ', ', GMFileVersionInfo(ModulePath, viCompanyName))));
      finally
       CloseHandle(HProcess);
      end;
     end;
   finally
    FreeMem(Buffer);
   end;
  finally
   FreeLibrary(HPSAPI);
  end;
end;

procedure AddNetworkData(const ANode: IGMXmlNode);
type
  IP_ADDRESS_STRING = record
    S: array[0..15] of AnsiChar;
  end;

  PIP_ADDR_STRING = ^IP_ADDR_STRING;
  IP_ADDR_STRING = record
    Next: PIP_ADDR_STRING;
    IpAddress: IP_ADDRESS_STRING;
    IpMask: IP_ADDRESS_STRING;
    Context: DWord;
  end;

  PIP_ADAPTER_INFO = ^IP_ADAPTER_INFO;
  IP_ADAPTER_INFO = record
    Next: PIP_ADAPTER_INFO;
    ComboIndex: DWORD; //Unused0: array[0..407] of Byte;
    AdapterName: array [0..259] of AnsiChar;
    Description: array [0..131] of AnsiChar;
    AddressLength: UINT;
    Address: array [0..7] of Byte;
    Index: DWord;
    Type_: DWord;
    DhcpEnabled: DWord;
    CurrentIpAddress: PIP_ADDR_STRING;
    IpAddressList: IP_ADDR_STRING;
    GatewayList: IP_ADDR_STRING;
    DhcpServer: IP_ADDR_STRING;
    Unused1: array[0..19] of Byte;
  end;

  PIP_PER_ADAPTER_INFO = ^IP_PER_ADAPTER_INFO;
  IP_PER_ADAPTER_INFO = record
    Unused: array[0..7] of Byte;
    CurrentDnsServer: PIP_ADDR_STRING;
    DnsServerList: IP_ADDR_STRING;
  end;

var
  GetAdaptersInfo: function(pAdapterInfo: PIP_ADAPTER_INFO; var pOutBufLen: DWord): DWord; stdcall;
  GetPerAdapterInfo: function(IfIndex: DWord; pPerAdapterInfo: PIP_PER_ADAPTER_INFO; var pOutBufLen: DWord): DWord; stdcall;

  Adapters, Adapters_Start: PIP_ADAPTER_INFO;
  HIPHlpApiDll: THandle; Size: DWord; AdapterNode: IGMXmlNode;
  IP, Submask, Gateway, DNS1, DNS2, DHCP: TGMString;

  procedure GetAdapterInfo(Adapter: PIP_ADAPTER_INFO);
  var
    IpAddrString: PIp_Addr_String;
    GatewayString: PIp_Addr_String;
    DnsServerString: PIp_Addr_String;
    pPerAdapterInfo: PIP_PER_ADAPTER_INFO;
    n: Integer;
    Size2: DWord;

    function PaddIP(const IPAddr: TGMString): TGMString;
    var Token: TGMString; ChPos: PtrInt;
    begin
      if IPAddr = '' then begin Result := '000.000.000.000'; Exit; end;
      ChPos := 1; Result := '';
      repeat
       Token := GMStrip(GMNextWord(ChPos, IPAddr, '.'), '.' + cWhiteSpace);
       if Token = '' then Continue;
       while Length(Token) < 3  do Insert('0', Token, 1);
       Result := GMStringJoin(Result, '.', Token);
      until Token = '';
    end;

  begin
    if (Adapter^.DhcpEnabled = 1) then DHCP := 'ON' else DHCP := 'OFF';

    IpAddrString := @Adapter^.IpAddressList;
    if (IpAddrString <> nil) then
     begin
      IP := PaddIP(IpAddrString^.IpAddress.S);
      Submask := PaddIP(IpAddrString^.IpMask.S);
     end;

    GatewayString := @Adapter^.GatewayList;
    if (GatewayString <> nil) then Gateway := PaddIP(GatewayString^.IpAddress.S);

    Size2 := 0;
    if (GetPerAdapterInfo(Adapter^.Index, nil, Size2) = ERROR_BUFFER_OVERFLOW) then
     begin
      pPerAdapterInfo := AllocMem(Size2);
      try
       GetPerAdapterInfo(Adapter^.Index, pPerAdapterInfo, Size2);

       n := 1;
       DnsServerString := @pPerAdapterInfo^.DnsServerList;
       while ((DnsServerString <> nil) and (n <= 2)) do
        begin
         if n = 1 then
          DNS1 := PaddIP(DnsServerString^.IpAddress.S)
         else
          DNS2 := PaddIP(DnsServerString^.IpAddress.S);

         Inc(n);
         DnsServerString := DnsServerString^.Next;
        end;
       if n = 2 then DNS2 := PaddIP('');
      finally
       FreeMem(pPerAdapterInfo);
      end;
     end;
  end;

begin
  if ANode = nil then Exit;
  HIPHlpApiDll := LoadLibrary('iphlpapi.dll');
  if (HIPHlpApiDll <> 0) then
  try
   @GetAdaptersInfo := GetProcAddress(HIPHlpApiDll, 'GetAdaptersInfo');
   @GetPerAdapterInfo := GetProcAddress(HIPHlpApiDll, 'GetPerAdapterInfo');
   if (Assigned(GetAdaptersInfo)) and (Assigned(GetPerAdapterInfo)) then
    begin
     Size := 0;
     if (GetAdaptersInfo(nil, Size) = ERROR_BUFFER_OVERFLOW) then
      begin
       Adapters_Start := AllocMem(Size);
       Adapters := Adapters_Start;
       try
        if (GetAdaptersInfo(Adapters, Size) = NO_ERROR) then
         begin
          while (Adapters <> nil) do
           begin
            IP := ''; Submask := ''; Gateway := ''; DNS1 := ''; DNS2 := ''; Dhcp := '';
            GetAdapterInfo(Adapters);
            AdapterNode := GMCreateXmlNode(ANode, cStrXmlNetworkAdapter);
            GMCreateXmlNode(AdapterNode, cStrXmlAdapterName, Adapters.AdapterName);
            GMCreateXmlNode(AdapterNode, cStrXmlAdapterDesc, Adapters.Description);
            if IP <> '' then GMCreateXmlNode(AdapterNode, cStrXmlIPAddress, IP);
            if Submask <> '' then GMCreateXmlNode(AdapterNode, cStrXmlSubmask, Submask);
            if Gateway <> '' then GMCreateXmlNode(AdapterNode, cStrXmlGateway, Gateway);
            if DNS1 <> '' then GMCreateXmlNode(AdapterNode, cStrXmlDSN1, DNS1);
            if DNS2 <> '' then GMCreateXmlNode(AdapterNode, cStrXmlDSN2, DNS2);
            if Dhcp <> '' then GMCreateXmlNode(AdapterNode, cStrXmlDHCP, Dhcp);
            Adapters := (Adapters^.Next);
           end;
         end;
        finally
         FreeMem(Adapters_Start);
        end;
      end;
    end;
  finally
    FreeLibrary(HIPHlpApiDll);
  end;
end;


{ ---------------------- }
{ ---- Build Report ---- }
{ ---------------------- }

{$IFDEF STORE_REPORT_XML}
procedure StoreXmlToFile(const AXml: IGMXmlTree);
var FileStrm: IStream;
begin
  vfGMMessageBox('GMWinVersion (ordinal): ' + IntToStr(Ord(GMWinVersion)));
  if AXml = nil then Exit;
  FileStrm := TGMFileIStream.CreateOverwrite(GMTempFileName('', CGMTempFilePrefix, 'xml'));
  AXml.Obj.StoreToStream(FileStrm);
end;
{$ENDIF}

function GMBuildReportXml(const AProductName, ACustomerName: TGMString;
                          const AExceptInfo: IGMExceptionInformation;
                          const AExceptCallStack: Boolean): IGMXmlTree;
const cModuleXmlName: array [Boolean] of TGMString = (cStrXmlProcesssModule, '');
var rprtNode, xmlNode: IGMXmlNode; VersionInfo: TOSVersionInfo; MemStatus: TMemoryStatusEx; // Xml: IGMXmlTree;
    //traceLock: IUnknown;
    {$IFDEF CALLSTACK}i: LongInt; StackTrace: TGMStringArray;{$ENDIF} // StackAsString: TGMString;
begin
  Result := TGMXmlTree.CreateWrite(ccUtf8, True);
  rprtNode := GMCreateXmlNode(Result.Obj.RootNode, cStrXmlDBDErrReport);

  GMCreateXmlNode(rprtNode, cStrXmlId, GMGuidToString(GMCreateGuid));

  if AProductName <> '' then GMCreateXmlNode(rprtNode, cStrXmlProduct, AProductName);
  if ACustomerName <> '' then GMCreateXmlNode(rprtNode, cStrXmlCustomer, ACustomerName);
  GMCreateXmlNode(rprtNode, cStrXmlCreated, FormatDateTime(cStrFileTimeFmt, Now));

  if vModuleLoadTime <> 0 then
   begin
    xmlNode := GMCreateXmlNode(rprtNode, cStrXmlModuleRuntimes);
    GMCreateXmlNode(xmlNode, cStrXmlModuleLoadTime, FormatDateTime(cStrTimeStampFmt, vModuleLoadTime));
    GMCreateXmlNode(xmlNode, cStrXmlModuleRunDuration, TimeDurationAsString(Now - vModuleLoadTime));
   end;

  //if vGMOutlookVersion <> '' then GMCreateXmlNode(rprtNode, cStrXmlOutlookVersion, vGMOutlookVersion);

  if IsLibrary then AddModuleInfo(rprtNode, GMModuleFileName(0), cStrXmlProcesssModule, GMPointerSizeInBits);
  AddModuleInfo(rprtNode, GMThisModuleFileName, cModuleXmlName[IsLibrary], GMPointerSizeInBits);

  if Length(vAdditionalModulesInReport) > 0 then AddAdditionalModules(rprtNode);

  xmlNode := GMCreateXmlNode(rprtNode, cStrXmlOSInfo);
  GMCreateXmlNode(xmlNode, cStrXmlOSName, GMFormat('%s, Build: %s', [GetOSName, GetOSBuildNo]));
  FillByte(VersionInfo, SizeOf(VersionInfo), 0);
  VersionInfo.dwOSVersionInfoSize := SizeOf(VersionInfo);
  if GetVersionEx(VersionInfo) then
   begin
    GMCreateXmlNode(xmlNode, cStrXmlOSVersion, GMFormat('Version: %d.%d  Platform: %d  Build: %d', [VersionInfo.dwMajorVersion, VersionInfo.dwMinorVersion, VersionInfo.dwPlatformId, VersionInfo.dwBuildNumber]));
    if Length(PGMChar(@VersionInfo.szCSDVersion)) > 0 then GMCreateXmlNode(xmlNode, cStrXmlSrvicePack, VersionInfo.szCSDVersion);
   end;
  GMCreateXmlNode(xmlNode, cStrXmlBitWidth, OsBitWidth);
  GMCreateXmlNode(xmlNode, cStrXmlOSUpTime, OSUpTime);
  GMCreateXmlNode(xmlNode, cStrXmlDisplay, DisplayInfo);
  GMCreateXmlNode(xmlNode, cStrXmlSystemLanguage, LangIDAsString(GetSystemDefaultLangID));

  xmlNode := GMCreateXmlNode(rprtNode, cStrXmlUserInfo);
  GMCreateXmlNode(xmlNode, cStrXmlUserName, GMThisUserName);
  GMCreateXmlNode(xmlNode, cStrXmlUserID, GMThisUserSid);
  GMCreateXmlNode(xmlNode, cStrXmlUserRegName, UserRegName);
  GMCreateXmlNode(xmlNode, cStrXmlCompanyName, GetCompanyName);
  GMCreateXmlNode(xmlNode, cStrXmlUserLanguage, LangIDAsString(GetUserDefaultLangID));
  xmlNode := GMCreateXmlNode(xmlNode, cStrXmlUserPrivilegs);
  AddCurrentUserPrivileges(xmlNode);

  xmlNode := GMCreateXmlNode(rprtNode, cStrXmlNetworkInfo);
  GMCreateXmlNode(xmlNode, cStrXmlComputerName, GMThisComputerName);
  AddNetworkData(xmlNode);

  xmlNode := GMCreateXmlNode(rprtNode, cStrXmlProcessorInfo);
  AddProcessorInfo(xmlNode);

  if WindowsMemoryStatus(@MemStatus) then
   begin
    xmlNode := GMCreateXmlNode(rprtNode, cStrXmlVirtualMemInfo);
    GMCreateXmlNode(xmlNode, cStrXmlMemoryLoad, IntToStr(MemStatus.dwMemoryLoad) + ' %');
    GMCreateXmlNode(xmlNode, cStrXmlTotalPhysMem, MemSizeAsString(MemStatus.ullTotalPhys));
    GMCreateXmlNode(xmlNode, cStrXmlAvailPhysMem, MemSizeAsString(MemStatus.ullAvailPhys));
    GMCreateXmlNode(xmlNode, cStrXmlTotalPageFile, MemSizeAsString(MemStatus.ullTotalPageFile));
    GMCreateXmlNode(xmlNode, cStrXmlAvailPageFile, MemSizeAsString(MemStatus.ullAvailPageFile));
    GMCreateXmlNode(xmlNode, cStrXmlTotalVirtMem, MemSizeAsString(MemStatus.ullTotalVirtual));
    GMCreateXmlNode(xmlNode, cStrXmlAvailVirtMem, MemSizeAsString(MemStatus.ullAvailVirtual));
   end;

  xmlNode := GMCreateXmlNode(rprtNode, cStrXmlSysModules);
  AddModuleInfo(xmlNode, GMAppendPath(GMWinSystemDir, 'ComCtl32.dll'));
  AddModuleInfo(xmlNode, GMAppendPath(GMWinSystemDir, 'WinINet.dll'));
  AddModuleInfo(xmlNode, MSIEPath);

  AddRunningProcesses(rprtNode);

  {$IFDEF CALLSTACK}
  TraceCallStack(StackTrace, AExceptCallStack);
  if Length(StackTrace) > 0 then
   begin
    xmlNode := GMCreateXmlNode(RprtNode, cStrXmlCallStack);
    GMCreateXmlNode(xmlNode, cStrXmlStackCount, IntToStr(Length(StackTrace)));
    for i:=Low(StackTrace) to High(StackTrace) do GMCreateXmlNode(xmlNode, cStrXmlStackEntry, StackTrace[i]);
    //for i:=Low(StackTrace) to High(StackTrace) do StackAsString := GMStringJoin(StackAsString, cNewLine, StackTrace[i]);
    //vfGMMessageBox(StackAsString);
   end;
  {$ENDIF}

  if AExceptInfo <> nil then
   begin
    xmlNode := GMCreateXmlNode(rprtNode, cStrXmlProblemDesc);
    GMCreateXmlNode(xmlNode, cStrXmlExceptionClassName, AExceptInfo.ExceptionClassName);
    GMCreateXmlNode(xmlNode, cStrXmlExceptAddr, GMFormat('$%p', [AExceptInfo.ExceptAddress]));
    GMCreateXmlNode(xmlNode, cStrXmlRaisorName, AExceptInfo.RaisorName);
    GMCreateXmlNode(xmlNode, cStrXmlRaisorClassName, AExceptInfo.RaisorClassName);
    GMCreateXmlNode(xmlNode, cStrXmlRoutineName, AExceptInfo.RoutineName);
    GMCreateXmlNode(xmlNode, cStrXmlSeverity, GMFormat('%s (%d)', [GMSeverityName(AExceptInfo.SeverityLevel), Ord(AExceptInfo.SeverityLevel)]));
    xmlNode := GMCreateXmlNode(xmlNode, cStrXmlMessage);
//  GMIterateLines(AExceptInfo.Message, AddXmlMsgLine, xmlNode);
    GMParseLines(AExceptInfo.GMMessage, AddXmlMsgLine, Pointer(xmlNode));
   end;

  GMCreateXmlNode(rprtNode, cStrXmlMainThreadID, '['+IntToStr(gGMMainThreadID)+']');

  //SyncLock := TGMCriticalSectionLock.Create(TraceList);
  //try

  if not TraceList.IsEmpty then
   begin
    xmlNode := GMCreateXmlNode(rprtNode, cStrXmlTrace);
    GMEnumTrace(AddTraceLineToXml, Pointer(xmlNode));
   end;
//traceLock := TGMCriticalSectionLock.Create(TraceList);
//if not TraceList.IsEmpty then
// begin
//  xmlNode := GMCreateXmlNode(rprtNode, cStrXmlTrace);
//  TraceStart := (vTraceEnd + 1) mod MaxTraceLines;
//  for i:=TraceStart to TraceList.Count-1 do AddTraceLineToXml(xmlNode, TraceList[i]);
//  for i:=0 to TraceStart-1 do AddTraceLineToXml(xmlNode, TraceList[i]);
// end;
  //finally
   //SyncLock := nil;
  //end;
  {$IFDEF STORE_REPORT_XML}
  StoreXmlToFile(Result);
  {$ENDIF}
end;


initialization

  vModuleLoadTime := now;

end.