{ ******************************************************************************
  *
  * AV Catcher
  *
  * Description
  *      Log the Access violation to a log file and allow the user to copy
  *      the information into an email if needed.
  *
  *
  *
  *
  * ****************************************************************************** }

unit U_AVCatcher;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
  SHFolder, ShellAPI, Vcl.StdCtrls, Vcl.Imaging.pngimage, Vcl.ExtCtrls,
  Vcl.ImgList, ComObj;

type

  TAppExcept = class(TForm)
    ImageList1: TImageList;
    pnlBottom: TPanel;
    btnLogFile: TButton;
    btnLogEMail: TButton;
    pnlTop: TPanel;
    imgAV: TImage;
    lblAVHeading: TLabel;
    lblAVText: TLabel;
    PnlDetailsMsg: TPanel;
    lblDeatailTxt1: TLabel;
    lblDeatailTxt2: TLabel;
    pnlDetails: TPanel;
    LogDetails: TMemo;
    btnClose: TButton;
    pnlBtns: TGridPanel;
    btnCustom: TButton;
    procedure lblDeatailTxt1Click(Sender: TObject); // Shows the details panel
  private
  public
  end;

  TAppException = procedure(Sender: TObject; E: Exception) of object;


  IExceptionInterface = interface(IInterface)
    ['{72A771EF-0DDF-4D73-8F4E-FDEB86683F1E}']
    function GetLogFileName(): String;
    function GetDaysToPurge(): Integer;
    procedure SetDaysToPurge(aValue: Integer);
    function GetEmailTo(): TStringList;
    procedure SetEmailTo(aValue: TStringList);
    function GetEnabled(): Boolean;
    procedure SetEnabled(aValue: Boolean);
    function GetAppException(): TAppException;
    procedure SetAppException(aValue: TAppException);
    function GetCustomMethod(): TNotifyEvent;
    procedure SetCustomMethod(aValue: TNotifyEvent);
    function GetTerminateApp(): Boolean;
    procedure SetTerminateApp(aValue: Boolean);
    function GetVisible(): Boolean;
    procedure SetVisible(aValue: Boolean);
    Procedure SetCustomBtn(aValue: string);

    Property AVLogFile: String read GetLogFileName;
    property DaysToPurge: Integer read GetDaysToPurge write SetDaysToPurge;
    Property EmailTo: TStringList read GetEmailTo write SetEmailTo;
    property Enabled: Boolean read GetEnabled write SetEnabled;
    property OnAppException: TAppException read GetAppException
      write SetAppException;
    property OnCustomMethod: TNotifyEvent read GetCustomMethod
      write SetCustomMethod;
    Property TerminateApp: Boolean read GetTerminateApp write SetTerminateApp;
    Property Visible: Boolean read GetVisible write SetVisible;
    Property CustomButtonCaption: string write SetCustomBtn;
  end;

  TExceptionLogger = class(TInterfacedObject, IExceptionInterface)
  private
    fAppException: TAppException;
    fCustomAction: TNotifyEvent;
    fAV_LogFileName: string; // Log file for the AV info
    fCustomBtnCap: String;
    fEmailTo: TStringList;
    fEnabled: Boolean;
    fExceptionForm: TAppExcept;
    fDaysToPurge: Integer;
    fVisible: Boolean;
    fTerminateApp: Boolean;
    procedure AppException(Sender: TObject; E: Exception);
    // Inital way to call code
    procedure CatchException(Sender: TObject; E: Exception);
    // Creates blank email with log information in body
    procedure EmailError(LogMessage: String);
    // Sets up the log file for the AppData folder
    function GetLogFileName(): String;
    function GetDaysToPurge(): Integer;
    procedure SetDaysToPurge(aValue: Integer);
    function GetEmailTo(): TStringList;
    procedure SetEmailTo(aValue: TStringList);
    function GetEnabled(): Boolean;
    procedure SetEnabled(aValue: Boolean);
    function GetAppException(): TAppException;
    procedure SetAppException(aValue: TAppException);
    function GetCustomMethod(): TNotifyEvent;
    procedure SetCustomMethod(aValue: TNotifyEvent);
    function GetTerminateApp(): Boolean;
    procedure SetTerminateApp(aValue: Boolean);
    function GetVisible(): Boolean;
    procedure SetVisible(aValue: Boolean);
    Procedure SetCustomBtn(aValue: string);
    // function LeftPad(S: string; ch: char; Len: Integer): string;
    // Writes error to log file (creates new files if needed)
    procedure LogError(LogMessage: string);
    function RightPad(S: string; ch: char; Len: Integer): string;
    // Purges log files based on DaysToPurge const
    Function ThePurge(): String;
  public
    constructor Create();
    destructor Destroy(); override;
    Property CustomButtonCaption: string write SetCustomBtn;
    Property AVLogFile: String read GetLogFileName write fAV_LogFileName;
  end;

function ExceptionLog: IExceptionInterface;

var
  fExceptionLog: IExceptionInterface;
  // ExceptionLog: TExceptionLogger;

implementation

{$R *.dfm}

Uses
  JclDebug;

function ExceptionLog: IExceptionInterface;
begin
  fExceptionLog.QueryInterface(IExceptionInterface, Result);
end;

{$REGION' TExceptionLogger'}

// ==============================================================================
// DaysToPurge defines how long a log file can exist on the system. If/when a
// new exception happens all files older than the purge days will be deleted.
// ==============================================================================
constructor TExceptionLogger.Create();
begin
  inherited;
  fDaysToPurge := 60;
  fEnabled := True;
  fEmailTo := TStringList.Create;
  fVisible := true;
  fTerminateApp := false;
  Application.OnException := AppException;
end;

destructor TExceptionLogger.Destroy();
begin
  FreeAndNil(fEmailTo);
  inherited;
end;

procedure TExceptionLogger.AppException(Sender: TObject; E: Exception);
begin
  if Assigned(fAppException) then
    fAppException(Sender, E);

  if fEnabled then
    CatchException(Sender, E)
  else
    Application.ShowException(E);

  if fTerminateApp and (not Application.Terminated) then
    Application.Terminate;

end;

procedure TExceptionLogger.CatchException(Sender: TObject; E: Exception);
// Inital way to call code
var
  ErrLogString: TStringList;

  function GetAppVersionStr: string;
  var
    Exe: string;
    Size, Handle: DWORD;
    Buffer: TBytes;
    FixedPtr: PVSFixedFileInfo;
  begin
    Exe := ParamStr(0);
    Size := GetFileVersionInfoSize(PChar(Exe), Handle);
    if Size = 0 then
      RaiseLastOSError;
    SetLength(Buffer, Size);
    if not GetFileVersionInfo(PChar(Exe), Handle, Size, Buffer) then
      RaiseLastOSError;
    if not VerQueryValue(Buffer, '\', Pointer(FixedPtr), Size) then
      RaiseLastOSError;
    Result := Format('%d.%d.%d.%d', [LongRec(FixedPtr.dwFileVersionMS).Hi,
      // major
      LongRec(FixedPtr.dwFileVersionMS).Lo, // minor
      LongRec(FixedPtr.dwFileVersionLS).Hi, // release
      LongRec(FixedPtr.dwFileVersionLS).Lo]) // build
  end;

  procedure GatherStackInfo(var OutList: TStringList);
  begin
    if not Assigned(OutList) then
      exit;
    OutList.Add(StringOfChar(' ', 15) + 'Application Information');
    OutList.Add(RightPad('', '=', 50));
    OutList.Add(RightPad('Name', ' ', 10) + ': ' +
      ExtractFileName(Application.ExeName));
    OutList.Add(RightPad('Version', ' ', 10) + ': ' + GetAppVersionStr);
    OutList.Add('');
    OutList.Add(StringOfChar(' ', 15) + 'Exception Information');
    OutList.Add(RightPad('', '=', 50));
    OutList.Add(RightPad('Date/Time', ' ', 10) + ': ' +
      FormatDateTime('mm/dd/yyyy hh:mm:ss', now()));
    OutList.Add(RightPad('Unit', ' ', 10) + ': ' + E.UnitName);
    OutList.Add(RightPad('Class', ' ', 10) + ': ' + E.ClassName);
    OutList.Add(RightPad('Message', ' ', 10) + ': ' + E.Message);
    if E.ToString <> E.Message then
      OutList.Add(RightPad('Text', ' ', 10) + ': ' + E.ToString);
    OutList.Add('');
    OutList.Add(StringOfChar(' ', 15) + 'Exception Trace');
    OutList.Add(RightPad('', '=', 50));
    JclLastExceptStackListToStrings(OutList, False, True, True, True);
    OutList.Add('');
    OutList.Add('');
  end;

begin
  try
    ErrLogString := TStringList.Create();
    try
      GatherStackInfo(ErrLogString);
      if fVisible then
      begin
        if not Application.Terminated then
        begin
        fExceptionForm := TAppExcept.Create(Application);
        try
          if fEmailTo.Count = 0 then
            fExceptionForm.pnlBtns.ColumnCollection[2].Value := 0
          else
            fExceptionForm.pnlBtns.ColumnCollection[2].Value := 25;

          if Assigned(fCustomAction) then
          begin
            fExceptionForm.pnlBtns.ColumnCollection[3].Value := 25;
            fExceptionForm.btnCustom.Caption := fCustomBtnCap;
            fExceptionForm.btnCustom.OnClick := fCustomAction;
          end else
           fExceptionForm.pnlBtns.ColumnCollection[3].Value := 0;

          fExceptionForm.lblAVText.Caption := E.Message;
          fExceptionForm.LogDetails.Lines.Clear;
          fExceptionForm.LogDetails.Lines.text := ErrLogString.text;

          fExceptionForm.ShowModal;
          Screen.Cursor := crHourGlass;
          try
            LogError(ErrLogString.text);

            // Log to email
            if fExceptionForm.ModalResult = mrNo then
            begin
              EmailError(ErrLogString.text);
            end;
          finally
            Screen.Cursor := crDefault;
          end;

        finally
          fExceptionForm.Free;
        end;
        end else
          LogError(ErrLogString.text);
      end else
       LogError(ErrLogString.text);
    finally
      ErrLogString.Free;
    end;
  except
    // swallow
  end;
end;

function TExceptionLogger.GetLogFileName(): String;
Var
  OurLogFile, LocalOnly, AppDir, AppName: string;

  // Finds the users special directory
  function LocalAppDataPath: string;
  const
    SHGFP_TYPE_CURRENT = 0;
  var
    path: array [0 .. MaxChar] of char;
  begin
    SHGetFolderPath(0, CSIDL_LOCAL_APPDATA, 0, SHGFP_TYPE_CURRENT, @path[0]);
    Result := StrPas(path);
  end;

begin
  if Trim(fAV_LogFileName) <> '' then
    Result := fAV_LogFileName
  else
  begin
    OurLogFile := LocalAppDataPath;
    if (Copy(OurLogFile, Length(OurLogFile), 1) <> '\') then
      OurLogFile := OurLogFile + '\';

    LocalOnly := OurLogFile;

    // Now set the application level
    OurLogFile := OurLogFile + ExtractFileName(Application.ExeName);
    if (Copy(OurLogFile, Length(OurLogFile), 1) <> '\') then
      OurLogFile := OurLogFile + '\';
    AppDir := OurLogFile;

    // try to create or use base direcrtory
    if not DirectoryExists(AppDir) then
      if not ForceDirectories(AppDir) then
        OurLogFile := LocalOnly;

    // Get the application name
    AppName := ExtractFileName(Application.ExeName);
    AppName := Copy(AppName, 0, Pos('.', AppName) - 1);

    OurLogFile := OurLogFile + AppName + '_' + IntToStr(GetCurrentProcessID) +
      '_' + FormatDateTime('mm_dd_yy_hh_mm', now) + '_LOG.TXT';

    fAV_LogFileName := OurLogFile;
    Result := OurLogFile;
  end;
end;

function TExceptionLogger.GetDaysToPurge(): Integer;
begin
  Result := fDaysToPurge;
end;

procedure TExceptionLogger.SetDaysToPurge(aValue: Integer);
begin
  fDaysToPurge := aValue;
end;

function TExceptionLogger.GetEmailTo(): TStringList;
begin
  Result := fEmailTo;
end;

procedure TExceptionLogger.SetEmailTo(aValue: TStringList);
begin
  fEmailTo := aValue;
end;

function TExceptionLogger.GetEnabled(): Boolean;
begin
  Result := fEnabled;
end;

procedure TExceptionLogger.SetEnabled(aValue: Boolean);
begin
  fEnabled := aValue;
end;

function TExceptionLogger.GetAppException(): TAppException;
begin
  Result := fAppException;
end;

procedure TExceptionLogger.SetAppException(aValue: TAppException);
begin
  fAppException := aValue;
end;

function TExceptionLogger.GetCustomMethod(): TNotifyEvent;
begin
 Result := fCustomAction;
end;

procedure TExceptionLogger.SetCustomMethod(aValue: TNotifyEvent);
begin
  fCustomAction := aValue;
end;

function TExceptionLogger.GetTerminateApp(): Boolean;
begin
  Result := fTerminateApp;
end;

procedure TExceptionLogger.SetTerminateApp(aValue: Boolean);
begin
  fTerminateApp := aValue;
end;

function TExceptionLogger.GetVisible(): Boolean;
begin
  Result := fVisible;
end;

procedure TExceptionLogger.SetVisible(aValue: Boolean);
begin
  fVisible := aValue;
end;

Procedure TExceptionLogger.SetCustomBtn(aValue: string);
begin
  fCustomBtnCap := aValue;
end;

Function TExceptionLogger.ThePurge(): String;
const
  aFileMask = '*_LOG.txt';
var
  searchResult: TSearchRec;
  iDelCnt, iErrorCnt, iFile: Integer;
  dtFileDate, dtNow: TDateTime;
  sFilePath: string;
begin
  // Init variables
  iDelCnt := 0;
  iErrorCnt := 0;
  dtNow := Date;
  sFilePath := ExtractFilePath(AVLogFile);

  // Loop through dir looking for the files
  iFile := FindFirst(sFilePath + aFileMask, faAnyFile, searchResult);
  while iFile = 0 do
  begin
    // Make sure we are on a file and not a directory
    if (searchResult.Name <> '.') and (searchResult.Name <> '..') and
      ((searchResult.Attr and faDirectory) <> faDirectory) then
    begin
      // Check the date of the file
      dtFileDate := searchResult.TimeStamp;
      if trunc(dtNow - dtFileDate) + 1 > fDaysToPurge then
      begin
        // Try to delete and update the count as needed
        if not DeleteFile(sFilePath + searchResult.Name) then
          Inc(iErrorCnt)
        else
          Inc(iDelCnt);
      end;
    end;
    // Grab the next file
    iFile := FindNext(searchResult);
  end;
  // Free up memory allocation
  FindClose(searchResult);

  // If any files were purged or errored then add this to the return message
  if (iErrorCnt > 0) or (iDelCnt > 0) then
  begin
    Result := (StringOfChar(' ', 15) + 'Log Purge Information');
    Result := Result + #13#10 + (RightPad('', '=', 50));
    Result := Result + #13#10 + (RightPad('Days:', ' ', 10) + ': ' +
      IntToStr(fDaysToPurge));
    Result := Result + #13#10 + (RightPad('Purged', ' ', 10) + ': ' +
      IntToStr(iDelCnt));
    Result := Result + #13#10 + (RightPad('NA', ' ', 10) + ': ' +
      IntToStr(iErrorCnt));
    Result := Result + #13#10 + #13#10;
  end
  else
    Result := '';
end;

procedure TExceptionLogger.LogError(LogMessage: string);
var
  myFile: TextFile;
begin
  // Clean the old dir on first run
  if Trim(fAV_LogFileName) = '' then
    LogMessage := ThePurge + LogMessage;

  // Asign our file
  AssignFile(myFile, AVLogFile);
  if FileExists(AVLogFile) then
    Append(myFile)
  else
    ReWrite(myFile);

  // Write this final line
  WriteLn(myFile, LogMessage);

  CloseFile(myFile);

  // Old code that would open file explorer to the log directory
  { if MessageDlg('Error logged, do you wish to navigate to the file?',
    mtInformation, [mbYes, mbNo], -1) = mrYes then
    ShellExecute(0, nil, 'explorer.exe', PChar('/select,' + CPRS_LogFileName),
    nil, SW_SHOWNORMAL); }
end;

Procedure TExceptionLogger.EmailError(LogMessage: string);
const
  CannedBdy =
    'An access violation has occured. Log file as follows (also attached to the email)';
var
  EmailUsrs, TmpStr: string;

  function EncodeURIComponent(const ASrc: string): string;
  const
    HexMap: string = '0123456789ABCDEF';

    function IsSafeChar(ch: Byte): Boolean;
    begin
      if (ch >= 48) and (ch <= 57) then
        Result := True // 0-9
      else if (ch >= 65) and (ch <= 90) then
        Result := True // A-Z
      else if (ch >= 97) and (ch <= 122) then
        Result := True // a-z
      else if (ch = 33) then
        Result := True // !
      else if (ch >= 39) and (ch <= 42) then
        Result := True // '()*
      else if (ch >= 45) and (ch <= 46) then
        Result := True // -.
      else if (ch = 95) then
        Result := True // _
      else if (ch = 126) then
        Result := True // ~
      else
        Result := False;
    end;

  var
    I, J: Integer;
    Bytes: TBytes;
  begin
    Result := '';

    Bytes := TEncoding.UTF8.GetBytes(ASrc);

    I := 0;
    J := Low(Result);

    SetLength(Result, Length(Bytes) * 3); // space to %xx encode every byte

    while I < Length(Bytes) do
    begin
      if IsSafeChar(Bytes[I]) then
      begin
        Result[J] := char(Bytes[I]);
        Inc(J);
      end
      else
      begin
        Result[J] := '%';
        Result[J + 1] := HexMap[(Bytes[I] shr 4) + Low(ASrc)];
        Result[J + 2] := HexMap[(Bytes[I] and 15) + Low(ASrc)];
        Inc(J, 3);
      end;
      Inc(I);
    end;

    SetLength(Result, J - Low(ASrc));
  end;

  procedure SendMail(Subject, Body, RecvAddress, Attachs: string);
  const
    olMailItem = 0;
  var
    Outlook: OLEVariant;
    MailItem: Variant;
    MailInspector: Variant;
    stringlist: TStringList;
  begin
    try
      Outlook := GetActiveOleObject('Outlook.Application');
    except
      Outlook := CreateOleObject('Outlook.Application');
    end;
    stringlist := TStringList.Create;
    try
      MailItem := Outlook.CreateItem(olMailItem);
      MailItem.Subject := Subject;
      MailItem.Recipients.Add(RecvAddress);
      MailItem.Attachments.Add(Attachs);
      stringlist := TStringList.Create;
      stringlist.Add(Body);
      MailItem.Body := stringlist.text;
      MailInspector := MailItem.GetInspector;
      MailInspector.display(True); // true means modal
    finally
      Outlook := Unassigned;
      stringlist.Free;
    end;
  end;

begin

  // Need to figure out the ole object method
  // fEmailTo.Delimiter := ';';
  EmailUsrs := '';
  for TmpStr in fEmailTo do
  begin
    if (EmailUsrs <> '') then
      EmailUsrs := EmailUsrs + ';';
    EmailUsrs := EmailUsrs + TmpStr;
  end;
  SendMail('Error logged in ' + ExtractFileName(Application.ExeName),
    CannedBdy + #13#10 + #13#10 + LogMessage, EmailUsrs, AVLogFile);

end;

function TExceptionLogger.RightPad(S: string; ch: char; Len: Integer): string;
var
  RestLen: Integer;
begin
  Result := S;
  RestLen := Len - Length(S);
  if RestLen < 1 then
    exit;
  Result := S + StringOfChar(ch, RestLen);
end;
{
  function TExceptionLogger.LeftPad(S: string; ch: char; Len: Integer): string;
  var
  RestLen: Integer;
  begin
  Result := S;
  RestLen := Len - Length(S);
  if RestLen < 1 then
  Exit;
  Result := StringOfChar(ch, RestLen) + S;
  end;
}
{$ENDREGION}
{$REGION 'TAppExcept'}

procedure TAppExcept.lblDeatailTxt1Click(Sender: TObject);
begin
  pnlDetails.Visible := True;
end;

{$ENDREGION 'Private'}

INITIALIZATION

// ExceptionLog := TExceptionLogger.Create(nil);
TExceptionLogger.Create.GetInterface(IExceptionInterface, fExceptionLog);

// Enable raw mode (default mode uses stack frames which aren't always generated by the compiler)
Include(JclStackTrackingOptions, stRawMode);

// Disable stack tracking in dynamically loaded modules (it makes stack tracking code a bit faster)
Include(JclStackTrackingOptions, stStaticModuleList);

// Initialize Exception tracking
JclStartExceptionTracking;

FINALIZATION

// Uninitialize Exception tracking
JclStopExceptionTracking;

end.
