Delphi：基于jcl的Bugsplat Crash收集单元

//BugSplat Crash模拟.net数据封装

unit uBugSplat;

interface

uses
  Windows, SysUtils, Classes, StrUtils, ShellAPI, JclDebug;

type
  TBugSplat = class
  class var
    Instance: TBugSplat;
  private
    FBSPath: string;
    FDBName: string;
    FAppName: string;
    FVersion: string;
    FQuietMode: Boolean;
    FUser: string;
    FEMail: string;
    FUserDescription: string;
    FLogPath: string;
    FAdditionalFiles: TStrings;

    //生成Crash报告
    procedure CreateReport(E: Exception);
    procedure WriteStack(sw: TStreamWriter; E: Exception);
    function GetTempPath: string;
    function ExecProcess(AppName, Params: string): Boolean;
    procedure AddAdditionalFileFromFolder(const AFolder: string);
  public
    constructor Create(const ADBName, AAppName, AVersion: string);

    //Exception事件接管
    procedure AppException(Sender: TObject; E: Exception);
    procedure AddAdditionalFile(const AFileName: string);

    property User: string read FUser write FUser;
    property EMail: string read FEmail write FEmail;
    property UserDescription: string read FUserDescription write FUserDescription;
    property QuietMode: Boolean read FQuietMode write FQuietMode;
    property LogPath: string read FLogPath write FLogPath;
    property AdditionalFiles: TStrings read FAdditionalFiles write FAdditionalFiles;
  end;

implementation

{ TBugSplat }

constructor TBugSplat.Create(const ADBName, AAppName, AVersion: string);
begin
  FDBName := ADBName;
  FAppName := AAppName;
  FVersion := AVersion;
  //FUserDescription := 'Crash of ' + FAppName;
  FQuietMode := True;
  FBSPath := ExtractFilePath(ParamStr(0)) + 'BsSndRpt.exe';

  FAdditionalFiles := TStringList.Create;
  if Instance = nil then Instance := Self;
end;

procedure TBugSplat.AddAdditionalFile(const AFileName: string);
begin
  if FileExists(AFileName) then
    FAdditionalFiles.Append(AFileName);
end;

procedure TBugSplat.WriteStack(sw: TStreamWriter; E: Exception);
  function RPos(const substr, str: RawByteString): Integer;
  begin
     Result := Length(str) - Pos(ReverseString(substr), ReverseString(str)) + 1;
  end;

var
  i: Integer;
  s, sFileName, sLineNumber: string;
  sl: TStrings;
begin
  sl := TStringList.Create;
  try
    sl.Text := E.StackTrace;
    //Stack头
    sw.WriteLine('<report>');
    sw.WriteLine('  <process>');
    sw.WriteLine('    <exception>');
    sw.WriteLine('      <func><![CDATA[' + sl[0] + ']]></func>');
    sw.WriteLine('      <code><![CDATA[' + E.ClassName + ': ' + E.Message + ']]></code>');
    sw.WriteLine('      <explanation><![CDATA[' + FAppName + ']]></explanation>');
    sw.WriteLine('      <file><![CDATA[]]></file>');
    sw.WriteLine('      <line><![CDATA[]]></line>');
    sw.WriteLine('      <registers></registers>');
    sw.WriteLine('    </exception>');
    sw.WriteLine('    <modules numloaded="0"></modules>');
    sw.WriteLine('    <threads count="1">');
    sw.WriteLine('      <thread id="' + IntToStr(GetCurrentThreadId()) + '" current="yes" event="yes" framecount="1">');

    //StackTrace
    //[004560E8] Controls.TWinControl.MainWndProc (Line 9065, "Controls.pas")
    for i := 0 to sl.Count - 1 do
    begin
      sFileName := '';
      sLineNumber := '';
      s := sl[i];
      if Pos('"', s) <> 0 then
        sFileName := Copy(s, Pos('"', s) + Length('"'), RPos('"', s) - Pos('"', s) - Length('"'));
      if Pos('Line', s) <> 0 then
        sLineNumber := Copy(s, Pos('Line ', s) + Length('Line '), Pos(',', s) - Pos('Line ', s) - Length('Line '));

      sw.WriteLine('        <frame>');
      sw.WriteLine('          <symbol><![CDATA[' + s + ']]></symbol>');
      sw.WriteLine('          <arguments></arguments>');
      sw.WriteLine('          <locals></locals>');
      sw.WriteLine('          <file>' + sFileName + '</file>');
      sw.WriteLine('          <line>' + sLineNumber + '</line>');
      sw.WriteLine('        </frame>');
    end;
    sw.WriteLine('      </thread>');
    sw.WriteLine('    </threads>');
    sw.WriteLine('  </process>');
    sw.WriteLine('</report>');
  finally
    sl.Free;
  end;
end;

procedure TBugSplat.AddAdditionalFileFromFolder(const AFolder: string);
var
  sr: TSearchRec;
  s: string;
begin
  //取其中文件入附加文件列表
  if FindFirst(AFolder + '*.*', faAnyFile, sr) = 0 then
  begin
    try
      repeat
        if (sr.Name = '.') or (sr.Name = '..') then Continue;

        s := IncludeTrailingPathDelimiter(AFolder) + sr.Name;
        if sr.Attr and faDirectory = 0 then
          FAdditionalFiles.Append(s)
        else if DirectoryExists(s) then
          AddAdditionalFileFromFolder(s);
      until FindNext(sr) <> 0;
    finally
      FindClose(sr);
    end;
  end;
end;

procedure TBugSplat.AppException(Sender: TObject; E: Exception);
begin
  if not FileExists(FBSPath) then
    raise Exception.Create('BsSndRpt.exe does not exists!');

  CreateReport(E);
end;

procedure TBugSplat.CreateReport(E: Exception);
var
  i: Integer;
  xmlName, iniName, args: string;
  sw: TStreamWriter;
begin
  //写.net stack解析文件
  if Trim(E.StackTrace) <> '' then
  begin
    xmlName := IncludeTrailingPathDelimiter(GetTempPath()) + 'stack.net';
    if FileExists(xmlName) then DeleteFile(xmlName);
    sw := TStreamWriter.Create(xmlName);
    try
      WriteStack(sw, E);
    finally
      sw.Close;
    end;
  end;

  //写ini配置文件
  iniName := IncludeTrailingPathDelimiter(GetTempPath()) + 'bs.ini';
  if FileExists(iniName) then DeleteFile(iniName);
  sw := TStreamWriter.Create(iniName);
  try
    sw.WriteLine('[BugSplat]');
    sw.WriteLine('Vendor=' + FDBName);
    sw.WriteLine('Application=' + FAppName);
    sw.WriteLine('Version=' + FVersion);
    if FileExists(xmlName) then
      sw.WriteLine('DotNet=' + xmlName);
    if FUser <> '' then
      sw.WriteLine('User=' + FUser);
    if FEMail <> '' then
      sw.WriteLine('Email=' + FEMail);
    if FUserDescription <> '' then
      sw.WriteLine('UserDescription=' + FUserDescription);

    //附加文件
    if DirectoryExists(FLogPath) then AddAdditionalFileFromFolder(FLogPath);
    for i := 0 to FAdditionalFiles.Count - 1 do
    begin
      if FileExists(FAdditionalFiles[i]) then
        sw.WriteLine('AdditionalFile' + IntToStr(i) + '=' + FAdditionalFiles[i]);
    end;
  finally
    sw.Close;
  end;

  //发送
  args := '/i ' + '"' + iniName + '"';
  if FQuietMode then
    args := args + ' /q';
  ExecProcess(FBSPath, args);
end;

function TBugSplat.ExecProcess(AppName, Params: string): Boolean;
var
  // Structure containing and receiving info about application to start
  ShellExInfo: TShellExecuteInfo;
begin
  FillChar(ShellExInfo, SizeOf(ShellExInfo), 0);
  with ShellExInfo do
  begin
    cbSize := SizeOf(ShellExInfo);
    fMask := see_Mask_NoCloseProcess;
    Wnd := 0;
    lpFile := PChar(AppName);
    lpParameters := PChar(Params);
    nShow := SW_SHOWNORMAL;
  end;

  Result := ShellExecuteEx(@ShellExInfo);
end;

function TBugSplat.GetTempPath: string;
var
  p: array[0..MAX_PATH] of Char;
begin
  Windows.GetTempPath(MAX_PATH, p);
  Result := StrPas(p);
end;

//Exception事件挂接...用此其取为空，其下面的可以
//function GetExceptionStackInfoProc(P: PExceptionRecord): Pointer;
//var
//  LLines: TStringList;
//  LText: String;
//  LResult: PChar;
//begin
//  LLines := TStringList.Create;
//  try
//    JclLastExceptStackListToStrings(LLines, True, True, True, True);
//    LText := LLines.Text;
//    LResult := StrAlloc(Length(LText));
//    StrCopy(LResult, PChar(LText));
//    Result := LResult;
//  finally
//    LLines.Free;
//  end;
//end;

function GetExceptionStackInfoProc(P: PExceptionRecord): Pointer;
var
  LLines: TStringList;
  LText: String;
  LResult: PChar;
  jcl_sil: TJclStackInfoList;
begin
  LLines := TStringList.Create;
  try
    jcl_sil := TJclStackInfoList.Create(False, 7, p.ExceptAddr, False, nil, nil);
    try
      jcl_sil.AddToStrings(LLines); //, true, true, true, true);
    finally
      FreeAndNil(jcl_sil);
    end;
    LText := LLines.Text;
    LResult := StrAlloc(Length(LText));
    StrCopy(LResult, PChar(LText));
    Result := LResult;
  finally
    LLines.Free;
  end;
end;

function GetStackInfoStringProc(Info: Pointer): string;
begin
  Result := string(PChar(Info));
end;

procedure CleanUpStackInfoProc(Info: Pointer);
begin
  StrDispose(PChar(Info));
end;

initialization
// Start the Jcl exception tracking and register our Exception
// stack trace provider.
if JclStartExceptionTracking then
begin
  Exception.GetExceptionStackInfoProc := GetExceptionStackInfoProc;
  Exception.GetStackInfoStringProc := GetStackInfoStringProc;
  Exception.CleanUpStackInfoProc := CleanUpStackInfoProc;
end;

finalization
// Stop Jcl exception tracking and unregister our provider.
if JclExceptionTrackingActive then
begin
  Exception.GetExceptionStackInfoProc := nil;
  Exception.GetStackInfoStringProc := nil;
  Exception.CleanUpStackInfoProc := nil;
  JclStopExceptionTracking;
end;

end.

调用方法：

procedure InitBugSplat();
var
  sVersion: string;
begin
  sVersion := GetFileVersion(Application.ExeName);
  if TBugSplat.Instance = nil then
    TBugSplat.Create('XXX_DSB', SDefaultProductName, sVersion);

  Application.OnException := TBugSplat.Instance.AppException;
  TBugSplat.Instance.LogPath := IncludeTrailingBackslash(g_DocumentPath) + 'Log';
  TBugSplat.Instance.EMail := 'xx@xx.com';
  TBugSplat.Instance.UserDescription := 'DSB_' + sVersion;
end;

以做备忘