excmagic.pas

一个异常处理的类

  end;
  GenerateFromAddr( Address, RegEBP, MaxSize, SuppressRecursion );
end;

procedure TExcCallStack.Dump( StrList: TStringList );
var
  S: String;
  i: Integer;
begin
  StrList.Clear;
  StrList.Add( 'Call stack:' );
  for i := 0 to Count-1 do
    with Items[i]^ do
      begin
        if NestingLevel > 1 then
          StrList.Add( Format( 'Recursive call (%d times):', [NestingLevel] ) );

        S := Format( ':%p [%s]', [CallAddress, ExtractFileName(DebugModule.ModuleName) ] );

        if ProcNameIndex <> -1 then
          S := S + Format( ' %s', [ ExceptionHook.UnMangle(DebugModule.GetName(ProcNameIndex), DebugModule.IsDelphiModule) ] );

        if FileLineNumber <> -1 then
          S := S + Format( ' (%s, line %d)', [ ExtractFileName(DebugModule.Names[FileNameIndex]),FileLineNumber ] );

        StrList.Add( S );
      end;
end;


// Dialog Procedure ----------------------------------------------------------

type
  TExceptionDlgParams = record
    Title:     PChar;
    Text:      PChar;
    CustomTab: PChar; // title of Additional Custom Tab
  end;
  PExceptionDlgParams = ^TExceptionDlgParams;

  TDialogInstanceData = record
    DlgFont: HFont;
    DlgIcon: HIcon;
    Details: Boolean;
  end;
  PDialogInstanceData = ^TDialogInstanceData;

{$IFDEF EXCMAGIC_GUI}
function TDSDialogProc( hwndDlg: HWND; uMsg: Word; wParam: Word; lParam: Longint ): LongBool; stdcall;
const
  DLG_OK        = 1000;
  DLG_DETAILS   = 1001;
  DLG_TERMINATE = 1002;
  DLG_TEXT      = 2000;
  DLG_STACK     = 3000;
  DLG_CONTEXT   = 4000;
  DLG_CUSTOM    = 5000;
  DLG_TABS      = 8000;
  DLG_ICON      = 9000;
const
  DetailTexts: array[Boolean] of PChar = ( 'Details >>', 'Compact <<' );
  Heights:  array[Boolean] of Integer = ( 500, 500 );
  Width:    Integer = 500;
var
  TC: TC_ITEM;
  R1,R2: TRect;
  CloseDlg: Boolean;

  procedure AllocDialogInstanceData;
  var
    pData: PDialogInstanceData;
  begin
    GetMem( pData, SizeOf(TDialogInstanceData) );
    FillChar( pData^, SizeOf(TDialogInstanceData), 0 );
    SetWindowLong( hwndDlg, GWL_USERDATA, Integer(pData) );
  end;

  procedure FreeDialogInstanceData;
  begin
    FreeMem( Pointer(GetWindowLong(hwndDlg,GWL_USERDATA)), SizeOf(TDialogInstanceData) );
  end;

  function DlgDataPtr: PDialogInstanceData; // pointer to dialog instance record
  begin
    Result := PDialogInstanceData( GetWindowLong( hwndDlg, GWL_USERDATA ) );
  end;

  procedure ShowTab( ActiveTabIndex: Integer );
  var
    i,N: Integer;
  begin
    // get total number of
    N := SendDlgItemMessage( hwndDlg, DLG_TABS, TCM_GETITEMCOUNT, 0, 0 );
    // hide all text controls attached to tabs
    ShowWindow( GetDlgItem(hwndDlg,DLG_STACK),   SW_HIDE );
    ShowWindow( GetDlgItem(hwndDlg,DLG_CONTEXT), SW_HIDE );
    ShowWindow( GetDlgItem(hwndDlg,DLG_CUSTOM),  SW_HIDE );
    // show text control attached to active tab
    for i := 0 to N-1 do
      begin
        TC.mask := TCIF_PARAM;
        SendDlgItemMessage( hwndDlg, DLG_TABS, TCM_GETITEM, i, Longint(@TC) );
        if i = ActiveTabIndex then
          begin
            ShowWindow( GetDlgItem(hwndDlg,TC.lParam), SW_SHOW );
            SendDlgItemMessage( hwndDlg, TC.lParam, EM_SETSEL, -1, 0 ); // remove selection
            SendDlgItemMessage( hwndDlg, DLG_TABS, TCM_SETCURSEL, ActiveTabIndex, 0 );
          end
      end;
    // set focus to 'OK' button
    SetFocus( GetDlgItem(hwndDlg, DLG_OK) );
  end;

  procedure InsertTab( Name: String; ID: Integer; Text: PChar );
  begin
    ZeroMemory( @TC, SizeOf(TC) );
    TC.mask    := TCIF_TEXT or TCIF_PARAM;
    TC.pszText := PChar(Name);
    TC.lParam  := ID;
    SendDlgItemMessage( hwndDlg, DLG_TABS, TCM_INSERTITEM, 0, Longint(@TC) );
    SendDlgItemMessage( hwndDlg, ID, WM_SETTEXT, 0, Longint(Text) );
    SendDlgItemMessage( hwndDlg, ID, WM_SETFONT, DlgDataPtr^.DlgFont, 0 );
  end;

  procedure ShowDetails;
  begin
    SetWindowPos( hwndDlg, 0, 0, 0, Width, Heights[DlgDataPtr^.Details], SWP_NOMOVE + SWP_NOOWNERZORDER );
    SetDlgItemText( hwndDlg, DLG_DETAILS, DetailTexts[DlgDataPtr^.Details] );
  end;

begin
  // default result
  Result := False;
  case uMsg of
    WM_COMMAND:
        case wParam of
          DLG_OK:
            begin
              EndDialog( hwndDlg, 0 );
              Result := True;
            end;
          DLG_DETAILS:
            begin
              DlgDataPtr^.Details := not DlgDataPtr^.Details;
              ShowDetails;
            end;
          DLG_TERMINATE:
            begin
              if Assigned(ExceptionHook.FOnTerminate) then
                begin
                  CloseDlg := True;
                  ExceptionHook.FOnTerminate( CloseDlg );
                  if CloseDlg then
                    begin
                      EndDialog( hwndDlg, 0 );
                      Result := True;
                    end;
                end
              else
                TerminateProcess( GetCurrentProcess, 0 );
            end;
        end;

    WM_NOTIFY:
        if wParam = DLG_TABS then
          if PNMHDR(lParam)^.code = TCN_SELCHANGE then
            ShowTab( SendDlgItemMessage( hwndDlg, DLG_TABS, TCM_GETCURSEL, 0, 0 ) );

    WM_DESTROY:
        begin
          with DlgDataPtr^ do
            begin
              if DlgFont <> 0 then DeleteObject( DlgFont );
              if DlgIcon <> 0 then DeleteObject( DlgIcon );
            end;
          FreeDialogInstanceData;
          Result := False;
        end;

    WM_INITDIALOG:
        begin
          // allocate record with unique data for each dialog instance
          AllocDialogInstanceData;

          // load custom icon
          if Assigned(ExceptionHook.Icon) then
            begin
              // default Windows icon ?
              if Dword(ExceptionHook.Icon) and $FFFF0000 = 0 then
                DlgDataPtr^.DlgIcon := LoadIcon( 0, ExceptionHook.Icon )
              else
                DlgDataPtr^.DlgIcon := LoadImage( hInstance, ExceptionHook.Icon, IMAGE_ICON, 0, 0, 0 );
              SendDlgItemMessage( hwndDlg,
                                  DLG_ICON,
                                  STM_SETIMAGE,
                                  IMAGE_ICON,
                                  DlgDataPtr^.DlgIcon );
            end;
          // create & set fixed font
          DlgDataPtr^.DlgFont := CreateFont( 14, 0, 0, 0,
                                  FW_NORMAL, 0, 0, 0,
                                  DEFAULT_CHARSET,
                                  OUT_DEFAULT_PRECIS,
                                  CLIP_DEFAULT_PRECIS,
                                  DEFAULT_QUALITY,
                                  FIXED_PITCH,
                                  'Courier' );
          // what is initial state of dialog ?
          DlgDataPtr^.Details := excDlgDetailed in ExceptionHook.Options;

          // Check options. If no tabs - disable DETAILS button
          if [] = ExceptionHook.Options * [excDlgCallStack,excDlgRegisters,excDlgCustomInfo] then
            begin
              //EnableWindow( GetDlgItem(hwndDlg,DLG_DETAILS), False );
              ShowWindow( GetDlgItem(hwndDlg,DLG_DETAILS), SW_HIDE );
              DlgDataPtr^.Details := False;
            end
          else
            begin  // Add tabs
              if excDlgCustomInfo in ExceptionHook.Options then
                InsertTab( PExceptionDlgParams(lParam).CustomTab,
                           DLG_CUSTOM, PChar(ExceptionHook.FCustomInfoStrings.Text) );
              if excDlgRegisters in ExceptionHook.Options then
                InsertTab( 'Registers',  DLG_CONTEXT, PChar(ExceptionHook.FContextStrings.Text) );
              if excDlgCallStack in ExceptionHook.Options then
                InsertTab( 'Call Stack', DLG_STACK, PChar(ExceptionHook.FCallStackStrings.Text) );
              ShowTab( 0 );
            end;

          // Get MIN & MAX heights of dialog
          GetWindowRect( hwndDlg, R1 );
          Heights[True] := R1.Bottom - R1.Top;
          Width := R1.Right - R1.Left;
          GetWindowRect( GetDlgItem(hwndDlg, DLG_TABS), R2 );
          Heights[False] := R2.Top - R1.Top;

          // show/hide TERMINATE button
          if excDlgTerminate in ExceptionHook.Options then
            ShowWindow( GetDlgItem(hwndDlg,DLG_TERMINATE), SW_SHOW )
          else
            ShowWindow( GetDlgItem(hwndDlg,DLG_TERMINATE), SW_HIDE );

          // lParam = ptr to TExceptionDlgParams record
          SetWindowText( hwndDlg, PExceptionDlgParams(lParam).Title );
          SendDlgItemMessage( hwndDlg, DLG_TEXT, WM_SETTEXT, 0,
                              Longint(PExceptionDlgParams(lParam).Text) );
          ShowDetails;

          Result := False;
        end;
  end;
end;
{$ENDIF}

{$STACKFRAMES ON}
function TDSExceptionErrorMessage(ExceptObject: TObject; Address: Pointer;
                                  Buffer: PChar; Size: Integer): Integer; register;
const
  DEFAULT_EXCEPTION_MSG: PChar =
    'Exception ''%s'' in module %s at %p'#13#10 +
    '%s'#13#10#13#10 +
    'Source file: %s, Line %s';
  UNKNOWN: String = 'UNKNOWN';
var
  MsgSrcFile: String;
  MsgSrcLine: String;
  MsgInfo: TExceptionMessageInfo;

begin
{$IFDEF EXCMAGIC_DEBUG}
    DebugMsg( '--> SysUtils.ExceptionErrorMessage' );
{$ENDIF}

  try
    EnterCriticalSection(ExcMagicLock);
    { make local copy of _ExcMsgInfo. workaround for D3,D4 compiler bug }
    MsgInfo := _ExcMsgInfo;

    with MsgInfo do
      begin
        miDebugModule := ExceptionHook.FindDebugModule( Address );
        // if no module contains this address then use main module (always exists)
        if miDebugModule = nil then
          miDebugModule := ExceptionHook.FindDebugModule( Addr(TDSExceptionErrorMessage) );

        miDebugModule.GetModuleName( Address, miModuleName, SizeOf(miModuleName) );
        miVirtualAddress := Address;
        miModuleAddress  := miDebugModule.GetConvertedAddress( Address );

        miMessage := '';
        if ExceptObject is Exception then
          miMessage := Exception(ExceptObject).Message;

        // ATTENTION ! Decrement Address by 1 because initial Address points to
        // instruction just AFTER the one that raised exception
        miDebugModule.GetSourceLine( Pointer(Longword(miModuleAddress)-1), miSrcNameIndex, miSrcLineNum );
        miDebugModule.GetProcName( miModuleAddress, miModuleNameIndex, miProcNameIndex );

        if miSrcNameIndex <> -1 then MsgSrcFile := ExtractFileName(miDebugModule.Names[miSrcNameIndex])
                                else MsgSrcFile := UNKNOWN;
        if miSrcLineNum   <> -1 then MsgSrcLine := IntToStr(miSrcLineNum)
                                else MsgSrcLine := UNKNOWN;

        // do not load from resource - it's failed when compiled with runtime packages
        //LoadString( FindResourceHInstance(HInstance), PResStringRec(@SException).Identifier, Format, SizeOf(Format));
        //LoadString( FindHInstance(@SException), PResStringRec(@SException).Identifier, Fmt, SizeOf(Fmt));
        StrLFmt( Buffer, Size, DEFAULT_EXCEPTION_MSG,
          [ ExceptObject.ClassName,
            miModuleName,
            miModuleAddress,
            miMessage,
            MsgSrcFile,
            MsgSrcLine ] );

        _ExcMsgInfo := MsgInfo; // copy local var back

        if Assigned(ExceptionHook.FOnExceptionMsg) then
          ExceptionHook.FOnExceptionMsg( ExceptObject, MsgInfo, Buffer, Size );

        Result := StrLen(Buffer);
      end;
  finally
    LeaveCriticalSection(ExcMagicLock);
  end;
end;

procedure TDSShowException( ExceptObject: TObject; Address: Pointer ); register;
var
  {$IFDEF EXCMAGIC_GUI}
    DlgParams: TExceptionDlgParams;
  {$ENDIF}
  Title:   array[0..63] of Char;
  Buffer:  array[0..1023] of Char;
  BufLen:  Integer;
begin
  try
    EnterCriticalSection(ExcMagicLock);

  {$IFDEF EXCMAGIC_DEBUG}
    DebugMsg( '--> SysUtils.ShowException' );
  {$ENDIF}

    Buffer[0] := #0;
    BufLen := TDSExceptionErrorMessage(ExceptObject, Address, Buffer, SizeOf(Buffer) );

    ExceptionHook.DumpAll;

    ExceptionHook.FCustomInfoStrings.Clear;
    if Assigned(ExceptionHook.FOnCustomInfo) then
      ExceptionHook.FOnCustomInfo( ExceptionHook.FCustomInfoStrings );

    if not ExceptionHook.LogHandled then
      ExceptionHook.LogExceptionData( Buffer, BufLen );

    if excShowDialog in ExceptionHook.FOptions then
      begin
        //LoadString(FindResourceHInstance(HInstance), PResStringRec(@SExceptTitle).Identifier, Title, SizeOf(Title));
        LoadString( FindHInstance(@SExceptTitle), PResStringRec(@SExceptTitle).Identifier, Title, SizeOf(Title));

        if Assigned(ExceptionHook.FOnExceptionShow) then
          ExceptionHook.FOnExceptionShow( String(Title), String(Buffer),
                                          ExceptionHook.FCallStackStrings,
                                          ExceptionHook.FContextStrings,
                                          ExceptionHook.FCustomInfoStrings )
        else
          begin
          {$IFDEF EXCMAGIC_CON}
            WriteLn( Buffer  );
            WriteLn( ExceptionHook.FCallStackStrings.Text );
            WriteLn( ExceptionHook.FContextStrings.Text );
          {$ENDIF}
          {$IFDEF EXCMAGIC_GUI}
            DlgParams.Title     := Title;
            DlgParams.Text      := Buffer;
            DlgParams.CustomTab := PChar(ExceptionHook.CustomTab);
            //DlgParams.Stack   := PChar(ExceptionHook.FCallStackStrings.Text);
            //DlgParams.Context := PChar(ExceptionHook.FContextStrings.Text);