Category Archives: Delphi

Working around Delphi’s default grid scrolling behaviour

Delphi’s T*Grid components have an annoying little feature whereby they will scroll the cell into view if you click on a partially visible cell at the right or the bottom of the window. Then, this couples with a timer that causes the scroll to continue as long as the mouse button is held down and the cell it is over is partially visible. This typically means that if a user clicks on a partially visible cell, they end up selecting a cell several rows or columns away from where they intended to click.

In my view, this is a bug that should be fixed in Delphi. I’m not the only person who thinks this. I’ve reported it to Embarcadero at RSP-18542.

In the meantime, here’s a little unit that works around the issue.

{
  Stop scroll on mousedown on bottom row of grid when bottom row
  is a partial cell: have to block both initial scroll and timer-
  based scroll.

  This code is pretty dependent on the implementation in Vcl.Grids.pas,
  so it should be checked if we upgrade to new version of Delphi.
}

{$IFNDEF VER320}
{$MESSAGE ERROR 'Check that this fix is still applicable for a new version of Delphi. Checked against Delphi 10.2' }
{$ENDIF}

unit ScrollFixedStringGrid;

interface

uses
  System.Classes,
  Vcl.Controls,
  Vcl.Grids,
  Winapi.Windows;

type
  TScrollFixedStringGrid = class(TStringGrid)
  private
    TimerStarted: Boolean;
    HackedMousedown: Boolean;
  protected
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer;
      Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override;
    function SelectCell(ACol, ARow: Longint): Boolean; override;
  end;

implementation

{ TScrollFixedStringGrid }

procedure TScrollFixedStringGrid.MouseDown(Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  // When we first mouse-down, we know the grid has
  // no active scroll timer
  TimerStarted := False;

  // Call the inherited event, blocking the default MoveCurrent
  // behaviour that scrolls the cell into view
  HackedMouseDown := True;
  try
    inherited;
  finally
    HackedMouseDown := False;
  end;

  // Cancel scrolling timer started by the mousedown event for selecting
  if FGridState = gsSelecting then
    KillTimer(Handle, 1);
end;

procedure TScrollFixedStringGrid.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
  // Start the scroll timer if we are selecting and mouse
  // button is down, on our first movement with mouse down
  if not TimerStarted and (FGridState = gsSelecting) then
  begin
    SetTimer(Handle, 1, 60, nil);
    TimerStarted := True;
  end;
  inherited;
end;


function TScrollFixedStringGrid.SelectCell(ACol, ARow: Longint): Boolean;
begin
  Result := inherited;
  if Result and HackedMousedown then
  begin
    // MoveColRow calls MoveCurrent, which
    // calls SelectCell. If SelectCell returns False, then
    // movement is blocked. But we fake it by re-calling with Show=False
    // to get the behaviour we want
    HackedMouseDown := False;
    try
      MoveColRow(ACol, ARow, True, False);
    finally
      HackedMouseDown := True;
    end;
    Result := False;
  end;
end;

end.

 

Don’t forget to navigate to about:blank when embedding IWebBrowser2

Today I spent several hours trying to figure out why an embedded web browser component (in this case TEmbeddedWB) in a Delphi test app never received the appropriate IHttpSecurity and IWindowForBindingUI QueryService requests.

I was doing this in order to provide more nuanced handling of self-signed certificates in an intranet context. We all do this, right? Here the term “nuanced” means “Of course I trust self signed certificates on my intranet, don’t you?” Feel free to rant and rave on this. 😉

But no matter what I did, what incantations I tried, or what StackOverflow posts I perused, I was unable to find an answer. Until finally I stumbled on a side comment in a thread from 2010. Igor Tandetnik notes that:

Right after creating the control, navigate it to about:blank. Right after that, navigate it to the page you wanted to go to. It’s a known problem that IServiceProvider doesn’t work for the very first navigation.

And this was something that I kinda knew in the back of my head, but of course had forgotten. Thank you Igor.

This post would not be complete without some splendiferous code. Just for reference, it’s so simple if you don’t blank out and forget about:blank.

unit InsecureBrowser;

interface

uses
  Winapi.Windows,
  Winapi.Messages,
  Winapi.Urlmon,
  Winapi.WinInet,
  System.SysUtils,
  System.Variants,
  System.Classes,
  Vcl.Graphics,
  Vcl.Controls,
  Vcl.Forms,
  Vcl.Dialogs,
  Vcl.OleCtrls,
  Vcl.StdCtrls,
  SHDocVw_EWB,
  EwbCore,
  EmbeddedWB;

type
  TInsecureBrowserForm = class(TForm, IHttpSecurity, IWindowForBindingUI)
    web: TEmbeddedWB;
    cmdGoInsecure: TButton;
    procedure webQueryService(Sender: TObject; const [Ref] rsid,
      iid: TGUID; var Obj: IInterface);
    procedure FormCreate(Sender: TObject);
    procedure cmdGoInsecureClick(Sender: TObject);
  private
    { IWindowForBindingUI }
    function GetWindow(const guidReason: TGUID; out hwnd): HRESULT; stdcall;

    { IHttpSecurity }
    function OnSecurityProblem(dwProblem: Cardinal): HRESULT; stdcall;
  end;

var
  InsecureBrowserForm: TInsecureBrowserForm;

implementation

{$R *.dfm}

function TInsecureBrowserForm.GetWindow(const guidReason: TGUID;
  out hwnd): HRESULT;
begin
  Result := S_FALSE;
end;

function TInsecureBrowserForm.OnSecurityProblem(dwProblem: Cardinal): HRESULT;
begin
  if (dwProblem = ERROR_INTERNET_INVALID_CA) or
     (dwProblem = ERROR_INTERNET_SEC_CERT_CN_INVALID)
    then Result := S_OK
    else Result := E_ABORT;
end;

procedure TInsecureBrowserForm.webQueryService(Sender: TObject;
  const [Ref] rsid, iid: TGUID; var Obj: IInterface);
begin
  if IsEqualGUID(IID_IWindowForBindingUI, iid) then
    Obj := Self as IWindowForBindingUI
  else if IsEqualGUID(IID_IHttpSecurity, iid) then
    Obj := Self as IHttpSecurity;
end;

procedure TInsecureBrowserForm.cmdGoInsecureClick(Sender: TObject);
begin
  web.Navigate('https://evil.intranet.site/');
end;

procedure TInsecureBrowserForm.FormCreate(Sender: TObject);
begin
  web.Navigate('about:blank');
end;

end.

 

More windbg tricks with Delphi – how to ignore specific exceptions

This is a really quick post, just noting more flexible ways of handling exceptions in WinDBG, for example ignoring EIdConnClosedGracefully or EAbort by default.

There are two parts to this:

  1. Use script files to build complex breakpoint or exception statements. While you could technically embed it all in one line, it becomes increasingly unwieldy. It’s still painful in a script file but slightly less so.
  2. Use as to create aliases for specific memory addresses in the script, making string comparisons much simpler.

To tell WinDbg to use a script file when a Delphi exception occurs:

sxe -c "$$><C:\\scripts\\windbg_delphi_exception.txt" 0EEDFADE

Then, the script file itself:

$$
$$ Report on Delphi exceptions: setup aliases
$$

.block {
    as ${/v:exception_cleanup} ad /q ${/v:exception_message}; ad /q ${/v:exception_name}; ad /q ${/v:exception_address}
}
.block {
    exception_cleanup
}
.block {
    aS /mu ${/v:exception_message} poi(poi(ebp+1c)+4)
    aS /ma ${/v:exception_name} poi(poi(poi(ebp+1c))-38)+1
    aS /x ${/v:exception_address} poi(ebp+4)
}

$$
$$ Do everything in this block, no matter what the exception is. This way we 
$$ get reports on exceptions without interrupting program execution. You may want to
$$ add extra reporting, e.g. stack traces, other variables.
$$

.block {
    .echo Delphi exception exception_name at ${exception_address}: exception_message
}

$$
$$ In this block, we add conditionals for exception types we want to ignore, or even
$$ specific addresses or other conditions as you need.
$$
$$ Don't include anything below this block, not even comments, because that breaks the 
$$ "gc" command
$$

.block {
    .if ($scmp( "${exception_name}", "EIdConnClosedGracefully") == 0) { exception_cleanup; gc }
    .elsif ($scmp( "${exception_name}", "EAbort") == 0) { exception_cleanup; gc }
        .else {
      .echo
      exception_cleanup
    }
}

Yes, this file has a bit of complexity in it. The WinDbg script interpreter is excessively pernickity. Important things to note are:

  • aliases are not expanded until the block is started (hence usage of the aliases is in a separate block to the definition)
  • you can’t have any additional statements after a block containing a gc or t or similar command, otherwise the script interpreter has a little hissy fit
  • the exception_cleanup alias is pretty essential to avoid leaving aliases about that then get expanded at the wrong time (leading to premature expansion of aliases from a previous exception).
  • the exception_name alias is not 100% reliable. This is because it is referencing a Delphi short string, which is not null-terminated, leading to garbage characters displayed at the end in some cases. Sadface. There is probably a way to work around this but I haven’t found it yet.
  • You’ll see sometimes I use the ${alias_name} expansion and other times I use just alias_name. Use ${alias_name} where non-whitespace characters may be immediately after the alias, as they will be interpreted as part of the alias.
  • The ${/v:alias_name} version prevents expansion of the alias, which is useful for referring to the name of the alias if it is already defined, for example to delete it.

Useful knowledge on WinDbg scripts from other sources:

Update 12 Oct 2020: Fixed up final block to use .elsif and .else to avoid script execution past gc

Windbg and Delphi – a quick reference

This is a list of my blog posts on using WinDBG with Delphi apps, mostly for my reference. Internally, I use a version of tds2dbg with some private modifications, but you should have reasonable results with the public version.

WinDBG and Delphi exceptions

WinDBG and Delphi exceptions in x64

Locating Delphi exceptions in a live session or dump using WinDbg

Debugging a stalled Delphi process with Windbg and memory searches

Finding class instances in a Delphi process using WinDbg

More windbg tricks with Delphi – how to ignore specific exceptions (Jan 2016)

I also have some other posts that talk about WinDBG and/or Delphi which can be helpful for illustrative purposes:

Another partial malware diagnosis

Detecting the Citadel Trojan with an Application Failure

When characters go astray: diagnosing missing characters when printing with IE9

WaitForSingleObject. Why you should never use it.

IE11, Windbg, JavaScript = joy

 

 

 

 

GUI Info Utility for Windows

A very quick one today. GUIInfo is a tiny little utility that has a narrow purpose: it shows, in realtime, the current active, focus, foreground and capture window information for Windows.

Why this utility? Debugging focus issues is always frustrating. Attempting to observe current window focus information in a debugger results in the focus changing (to the debugger, of course). You can work around this – use remote debugging, or add logging in the debugger – but it’s a hassle.

Debugging focus issues would make Werner Heisenberg feel right at home.

Screenshot

GUIInfo Screenshot

Features

  • Updates 10 times a second so changes are reflected promptly.
  • Changes are highlighted in green, and slowly fade back to black.
  • Hovering over bold window labels will highlight the relevant window on the screen.
  • Topmost, so you can see the information without needing to try and keep the window visible.
  • Open Source – written in Delphi, MIT license.

Download and Source

An update for EncodeURIComponent

Way way back in the dark ages of Delphi XE2, I wrote a function to encode components of a URI. Now, this function has been updated for use on mobile platforms, by Nicolas Dusart, and I quote Nicolas:

I had to make some modifications on it to compile for the mobile platforms, as the strings are 0-based on these platforms.

I also modified it to escape non-ASCII characters using their UTF-8 encoding as the standards advices. For multi-bytes characters, each byte is percent-encoded as usual.

Here’s the code, maybe it could interests you and the future readers of that article 🙂

And here’s Nicolas’s updated function in all its glory:

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;

Many thanks, Nicolas 🙂

Fixing the incorrect client size for Delphi VCL Forms that use styles

Delphi XE2 and later versions have a robust theming system that has a frustrating flaw: the client width and height are not reliably preserved when the theme changes the border widths for dialog boxes.

For forms that are sizeable this is not typically a problem, but for dialogs laid out statically this can look really ugly, as shown in this Stack Overflow question.

The problem in pictures

Here’s a little form, shown in the Delphi form designer. I’ve placed 4 buttons right in the corners of the form. I’m going to populate the Memo with notes on the form size at runtime.

Design time form with four buttons at corners

When I have no custom style set to the project (i.e. “Windows” style), I can run on a variety of platforms and see the buttons are where they should be. Shown here on Windows 10, Windows 7 and Windows XP (just because):
Windows theme form on Windows 10Windows theme form on Windows 7

Windows theme form on Windows XP

But when I apply a custom style to the project — I chose “Glossy” — then my dialog appears like so, instead:

Glow theme form on Windows 7

You’ll note that the vertical is adjusted but the horizontal is not: Button2 and Button4 are now chopped off on the right. Because we are using themes, the form looks identical on all platforms.

This problem has not been addressed as of Delphi XE8.

The workaround

For my needs, I found a workaround using a class helper, which can be applied to the forms which need to maintain their design-time ClientWidth and ClientHeight. This is typically the case for dialog boxes.

This workaround should be used with care as it has been designed to address a single issue and may have side effects.

  • It will trigger resize events at load time
  • Setting AutoScroll = true means that ClientWidth and ClientHeight are not stored in the form .dfm, and so this does not work.
  • It may not address other layout issues such as scaled elements scaling wrongly (I haven’t tested this).
type
  TFormHelper = class helper for Vcl.Forms.TCustomForm
  private
    procedure RestoreDesignClientSize;
  end;

procedure TfrmTestSize.FormCreate(Sender: TObject);
begin
  RestoreDesignClientSize;
end;

{ TFormHelper }

procedure TFormHelper.RestoreDesignClientSize;
begin
  if BorderStyle in [bsSingle, bsDialog] then
  begin
    if Self.FClientWidth > 0 then ClientWidth := Self.FClientWidth;
    if Self.FClientHeight > 0 then ClientHeight := Self.FClientHeight;
  end;
end;

After adding in this little snippet, the form is now restored to its design-time size, like thus:

Fixed glow theme form on Windows 7

Success 🙂

A workaround for a record.property getter bug in the Delphi XE2 compiler

We recently ran into a nasty little bug in the Delphi XE2 compiler, that arises with a complex set of conditions:

  1. A record with a string property that has a get function;
  2. A call to this getter that has a constant string appended to the result;
  3. This result passed directly to another arbitrary function.

When these conditions are met (see code below for examples), the compiler generates code that crashes.

Reproducing the bug

The following program is enough to reproduce the bug.

program ustrcatbug;

type
  TWrappedString = record
  private
    FValue: string;
    function GetValue: string;
  public
    property Value: string read GetValue;
  end;

{ TWrappedString }

function TWrappedString.GetValue: string;
begin
  Result := FValue;
end;

function GetWrappedString: TWrappedString;
begin
  Result.FValue := 'Something';
end;

begin
  writeln(GetWrappedString.Value + ' Else');
end.

Looking at the last line of code from that sample in the disassembler, we see the following code:

ustrcatbug.dpr.28: writeln(GetWrappedString.Value + ' Else');
0040712A 8D45EC           lea eax,[ebp-$14]
0040712D E816E9FFFF       call GetWrappedString
00407132 8D55EC           lea edx,[ebp-$14]
00407135 B8C0BB4000       mov eax,$0040bbc0
0040713A 8B0DE8594000     mov ecx,[$004059e8]
00407140 E883D8FFFF       call @CopyRecord
00407145 8D55E8           lea edx,[ebp-$18]
00407148 B8C0BB4000       mov eax,$0040bbc0
0040714D E8D6E8FFFF       call TWrappedString.GetValue
00407152 8D45E8           lea eax,[ebp-$18]
00407155 BAB4714000       mov edx,$004071b4
0040715A E899D6FFFF       call @UStrCat
0040715F 8B10             mov edx,[eax]
00407161 A12C884000       mov eax,[$0040882c]
00407166 E86DC6FFFF       call @Write0UString
0040716B E868C7FFFF       call @WriteLn
00407170 E867BCFFFF       call @_IOTest
ustrcatbug.dpr.29: end.
00407175 33C0             xor eax,eax

The problem arises with these two lines:

0040715A E899D6FFFF       call @UStrCat
0040715F 8B10             mov edx,[eax]

The problem is that eax is not preserved through function calls with Delphi’s default register calling convention. And, as _UStrCat is a procedure, we can make no assumptions about the return value (which is passed in eax):

procedure _UStrCat(var Dest: UnicodeString; const Source: UnicodeString);

The issue does not arise if we avoid using the property:

  writeln(GetWrappedString.GetValue + ' Else');

From this, the compiler generates:

ustrcatbug.dpr.28: writeln(GetWrappedString.GetValue + ' Else');
0040712A 8D45E8           lea eax,[ebp-$18]
0040712D E816E9FFFF       call GetWrappedString
00407132 8D55E8           lea edx,[ebp-$18]
00407135 B8C0BB4000       mov eax,$0040bbc0
0040713A 8B0DE8594000     mov ecx,[$004059e8]
00407140 E883D8FFFF       call @CopyRecord
00407145 B8C0BB4000       mov eax,$0040bbc0
0040714A 8D55EC           lea edx,[ebp-$14]
0040714D E8D6E8FFFF       call TWrappedString.GetValue
00407152 8D45EC           lea eax,[ebp-$14]
00407155 BAB4714000       mov edx,$004071b4
0040715A E899D6FFFF       call @UStrCat
0040715F 8B55EC           mov edx,[ebp-$14]
00407162 A12C884000       mov eax,[$0040882c]
00407167 E86CC6FFFF       call @Write0UString
0040716C E867C7FFFF       call @WriteLn
00407171 E866BCFFFF       call @_IOTest
ustrcatbug.dpr.29: end.
00407176 33C0             xor eax,eax

Where we now see that edx is reloaded from the stack, as it should be:

0040715A E899D6FFFF       call @UStrCat
0040715F 8B55EC           mov edx,[ebp-$14]

Workarounds

There are a number of possible workarounds:

  1. Upgrade to Delphi XE7 – this problem appears to be resolved, though I could not find a QC or RSP report relating to the bug when I searched. Moving to XE7 is not an option for us in the short term: too many code changes, too many unknowns.
  2. Don’t use properties in records. This means changing code to call functions instead: no big deal for the Get, but annoying for the Set half of the function pair.
  3. Patch around the problem by modifying UStrCat to return the address of the Dest parameter.

In the end, I wrote option (3) but we went with option (2) in our code base.

Because UStrCat is implemented in System.pas, it’s difficult to build your own version of the unit. One way to skin the option 3 UStrCat is to copy the implementation of UStrCat and its dependencies (a bunch of memory and string manipulation functions), and monkeypatch at runtime.

In the copied functions, we need to preserve eax through the function calls. This results in the addition of 4 lines of assembly to the UStrCat and UStrAsg functions, pushing the eax register onto the stack and popping it before exit. I haven’t reproduced the code here because the original is copyrighted to Embarcadero, but here are the changes required:

  1. In UStrCat, Add push eax just after the conditional jump to UStrAsg, and pop eax just before the ret instruction.
  2. In UStrAsg, wrap the call to FreeMem with a push eax and pop eax.

The patch function is also pretty straightforward:

procedure MonkeyPatch(OldProc, NewProc: PBYTE);
var
  pBase, p: PBYTE;
  oldProtect: Cardinal;
begin
  p := OldProc;
  pBase := p;

  // Allow writes to this small bit of the code section
  VirtualProtect(pBase, 5, PAGE_EXECUTE_WRITECOPY, oldProtect);

  // First write the long jmp instruction.
  p := pBase;
  p^ := $E9;  // long jmp opcode
  Inc(p);
  PDWord(p)^ := DWORD(NewProc) - DWORD(p) - 4;  // address to jump to, relative to EIP

  // Finally, protect that memory again now that we are finished with it
  VirtualProtect(pBase, 5, oldProtect, oldProtect);
end;

function GetUStrCatAddr: Pointer; assembler;
asm
  lea  eax,System.@UStrCat
end;

initialization
  MonkeyPatch(GetUStrCatAddr, @_UStrCatMonkey);
end.

This solution does give me the heebie jeebies, because we are patching the symptoms of the problem as we’ve seen them arise, without being able to either understand or address the root cause within the compiler. It’s not really possible to guarantee that there won’t be some other code path that causes this solution to come unstuck without really digging deep into the compiler’s code generation.

As noted, this problem appears to be resolved in Delphi XE5 or possibly earlier; however it is unclear if the root cause of the problem has been addressed, or we just got lucky. The issue has been reported as RSP-10255.

IE11, Windbg, JavaScript = joy

I was trying to debug a web application today, which is running in an Internet Explorer MSHTML window embedded in a thick client application. Weirdly, the app would fail, silently, without any script errors, on the sixth refresh — pressing F5 six times in a row would crash it each and every time.  Ctrl+F5 or F5, either would do it.

I was going slightly mad trying to trace this, with no obvious solutions. Finally I loaded the process up in Windbg, not expecting much, and found that three (handled) C++ exceptions were thrown for each of the first 6 loads (initial load, + 5 refreshes):

(958.17ac): C++ EH exception - code e06d7363 (first chance)
(958.17ac): C++ EH exception - code e06d7363 (first chance)
(958.17ac): C++ EH exception - code e06d7363 (first chance)

However, on the sixth refresh, this exception was happening four times:

(958.17ac): C++ EH exception - code e06d7363 (first chance)
(958.17ac): C++ EH exception - code e06d7363 (first chance)
(958.17ac): C++ EH exception - code e06d7363 (first chance)
(958.17ac): C++ EH exception - code e06d7363 (first chance)

This gave me something to look at! At the very least there was an observable difference between the refreshes within the debugger. A little more spelunking revealed that the very last exception thrown was the relevant one, and it returned the following trace (snipped):

(958.17ac): C++ EH exception - code e06d7363 (first chance)
ChildEBP RetAddr  
001875e8 75d3359c KERNELBASE!RaiseException+0x58
00187620 72ba1df2 msvcrt!_CxxThrowException+0x48
00187664 72d659cb jscript9!Js::JavascriptExceptionOperators::ThrowExceptionObjectInternal+0xb4
0018767c 72ba1cda jscript9!Js::JavascriptExceptionOperators::ThrowExceptionObject+0x15
001876a8 72bb5175 jscript9!Js::JavascriptExceptionOperators::Throw+0x6e
001876f4 6e9acd03 jscript9!CJavascriptOperations::ThrowException+0x9c
0018771c 6f3029f5 MSHTML!CFastDOM::ThrowDOMError+0x70
00187750 72b68e9d MSHTML!CFastDOM::CWebSocket::DefaultEntryPoint+0xe2
001877b8 72cff6a2 jscript9!Js::JavascriptExternalFunction::ExternalFunctionThunk+0x165
00187810 72bb849c jscript9!Js::JavascriptFunction::CallAsConstructor+0xc7
00187830 72bb8537 jscript9!Js::InterpreterStackFrame::NewScObject_Helper+0x39
0018784c 72bb858c jscript9!Js::InterpreterStackFrame::ProfiledNewScObject_Helper+0x53
0018786c 72bb855e jscript9!Js::InterpreterStackFrame::OP_NewScObject_Impl<Js::OpLayoutCallI_OneByte,1>+0x24
00187ba8 72b66548 jscript9!Js::InterpreterStackFrame::Process+0x3c44
00187dbc 132f1ae1 jscript9!Js::InterpreterStackFrame::InterpreterThunk<1>+0x1e8
WARNING: Frame IP not in any known module. Following frames may be wrong.
00187dc8 72c372dd 0x132f1ae1
00187ed0 138be456 jscript9!Js::JavascriptFunction::EntryApply+0x265
00187f38 72b6669e 0x138be456
00188288 72b66548 jscript9!Js::InterpreterStackFrame::Process+0xbd7
001883bc 132f0681 jscript9!Js::InterpreterStackFrame::InterpreterThunk<1>+0x1e8
001883c8 72b6669e 0x132f0681
00188718 72b66548 jscript9!Js::InterpreterStackFrame::Process+0xbd7
0018887c 132f1b41 jscript9!Js::InterpreterStackFrame::InterpreterThunk<1>+0x1e8
00188888 72b6669e 0x132f1b41
00188bd8 72b66548 jscript9!Js::InterpreterStackFrame::Process+0xbd7
00188d1c 132f1c21 jscript9!Js::InterpreterStackFrame::InterpreterThunk<1>+0x1e8
00188d28 72bb7642 0x132f1c21
00189080 72bd501f jscript9!Js::InterpreterStackFrame::Process+0x2175
001890b8 72bd507e jscript9!Js::InterpreterStackFrame::OP_TryCatch+0x49
001893f8 72b66548 jscript9!Js::InterpreterStackFrame::Process+0x4e84
00189594 132f0081 jscript9!Js::InterpreterStackFrame::InterpreterThunk<1>+0x1e8
00189624 72d0134c 0x132f0081
00189650 72bf3de5 jscript9!Js::JavascriptOperators::GetProperty_Internal<0>+0x48
00189678 72b677a7 jscript9!Js::InterpreterStackFrame::OP_ProfiledLoopBodyStart<0,1>+0xa2
001899b8 72b66548 jscript9!Js::InterpreterStackFrame::Process+0x24f7
00189b34 132f0089 jscript9!Js::InterpreterStackFrame::InterpreterThunk<1>+0x1e8
00189b40 72b6669e 0x132f0089
00189e98 72b66548 jscript9!Js::InterpreterStackFrame::Process+0xbd7
0018a004 132f0099 jscript9!Js::InterpreterStackFrame::InterpreterThunk<1>+0x1e8
0018a010 72b6669e 0x132f0099
0018a368 72b66548 jscript9!Js::InterpreterStackFrame::Process+0xbd7
0018a4bc 132f1c69 jscript9!Js::InterpreterStackFrame::InterpreterThunk<1>+0x1e8
0018a4c8 72b6669e 0x132f1c69
0018a818 72b66548 jscript9!Js::InterpreterStackFrame::Process+0xbd7
0018a95c 132f1c71 jscript9!Js::InterpreterStackFrame::InterpreterThunk<1>+0x1e8
0018a968 72b6669e 0x132f1c71
0018acb8 72b66548 jscript9!Js::InterpreterStackFrame::Process+0xbd7
0018ade4 132f1fb1 jscript9!Js::InterpreterStackFrame::InterpreterThunk<1>+0x1e8
0018adf0 72c372dd 0x132f1fb1
0018ae90 72b60685 jscript9!Js::JavascriptFunction::EntryApply+0x265
0018aee0 72bd4fcc jscript9!Js::JavascriptFunction::CallFunction<1>+0x88
0018b220 72bd501f jscript9!Js::InterpreterStackFrame::Process+0x442e
0018b258 72bd507e jscript9!Js::InterpreterStackFrame::OP_TryCatch+0x49
0018b598 72b66548 jscript9!Js::InterpreterStackFrame::Process+0x4e84
0018b71c 132f1ed9 jscript9!Js::InterpreterStackFrame::InterpreterThunk<1>+0x1e8
0018b728 72b6669e 0x132f1ed9
0018ba78 72b66548 jscript9!Js::InterpreterStackFrame::Process+0xbd7
0018bbac 132f1ca1 jscript9!Js::InterpreterStackFrame::InterpreterThunk<1>+0x1e8
0018bbb8 72bb7642 0x132f1ca1
0018bf00 72bd501f jscript9!Js::InterpreterStackFrame::Process+0x2175
0018bf38 72bd507e jscript9!Js::InterpreterStackFrame::OP_TryCatch+0x49
0018c278 72b66548 jscript9!Js::InterpreterStackFrame::Process+0x4e84
0018c3ac 132f1e21 jscript9!Js::InterpreterStackFrame::InterpreterThunk<1>+0x1e8
0018c3b8 72bb7642 0x132f1e21
0018c700 72bd501f jscript9!Js::InterpreterStackFrame::Process+0x2175
0018c738 72bd507e jscript9!Js::InterpreterStackFrame::OP_TryCatch+0x49
0018ca78 72b66548 jscript9!Js::InterpreterStackFrame::Process+0x4e84
0018cbb4 132f1e21 jscript9!Js::InterpreterStackFrame::InterpreterThunk<1>+0x1e8
0018cbc0 72b6669e 0x132f1e21
0018cf08 72b66548 jscript9!Js::InterpreterStackFrame::Process+0xbd7
0018d03c 132f1e51 jscript9!Js::InterpreterStackFrame::InterpreterThunk<1>+0x1e8
0018d048 72b6669e 0x132f1e51
0018d398 72b66548 jscript9!Js::InterpreterStackFrame::Process+0xbd7
0018d4bc 132f0341 jscript9!Js::InterpreterStackFrame::InterpreterThunk<1>+0x1e8
0018d4c8 72bb7642 0x132f0341
0018d810 72bd501f jscript9!Js::InterpreterStackFrame::Process+0x2175
0018d848 72bd507e jscript9!Js::InterpreterStackFrame::OP_TryCatch+0x49
0018db88 72b66548 jscript9!Js::InterpreterStackFrame::Process+0x4e84
0018dd44 132f1f99 jscript9!Js::InterpreterStackFrame::InterpreterThunk<1>+0x1e8
0018dd50 72b60685 0x132f1f99
0018dd98 72bd4fcc jscript9!Js::JavascriptFunction::CallFunction<1>+0x88
0018e0d8 72bd501f jscript9!Js::InterpreterStackFrame::Process+0x442e
0018e110 72bd507e jscript9!Js::InterpreterStackFrame::OP_TryCatch+0x49
0018e450 72c5bfce jscript9!Js::InterpreterStackFrame::Process+0x4e84
0018e488 72c5bf0f jscript9!Js::InterpreterStackFrame::OP_TryFinally+0xb1
0018e7c8 72b66548 jscript9!Js::InterpreterStackFrame::Process+0x68eb
0018e8f4 132f0351 jscript9!Js::InterpreterStackFrame::InterpreterThunk<1>+0x1e8
0018e900 72b6669e 0x132f0351
0018ec48 72b66548 jscript9!Js::InterpreterStackFrame::Process+0xbd7
0018ed94 132f1cf9 jscript9!Js::InterpreterStackFrame::InterpreterThunk<1>+0x1e8
0018eda0 72b66ce9 0x132f1cf9
0018f0f8 72b66548 jscript9!Js::InterpreterStackFrame::Process+0x1cd7
0018f264 132f1d01 jscript9!Js::InterpreterStackFrame::InterpreterThunk<1>+0x1e8
0018f270 72b66ce9 0x132f1d01
0018f5c8 72b66548 jscript9!Js::InterpreterStackFrame::Process+0x1cd7
0018f70c 132f1d49 jscript9!Js::InterpreterStackFrame::InterpreterThunk<1>+0x1e8
0018f718 72b60685 0x132f1d49
0018f760 72b6100e jscript9!Js::JavascriptFunction::CallFunction<1>+0x88
0018f7cc 72b60f60 jscript9!Js::JavascriptFunction::CallRootFunction+0x93
0018f814 72b60ee7 jscript9!ScriptSite::CallRootFunction+0x42
0018f83c 72b6993c jscript9!ScriptSite::Execute+0x6c
0018f898 72b69878 jscript9!ScriptEngineBase::ExecuteInternal<0>+0xbb
0018f8b0 6eaab78f jscript9!ScriptEngineBase::Execute+0x1c
0018f964 6eaab67c MSHTML!CListenerDispatch::InvokeVar+0x102
0018f990 6eaab21e MSHTML!CListenerDispatch::Invoke+0x61
0018fa28 6eaab385 MSHTML!CEventMgr::_InvokeListeners+0x1a2
0018fb98 6e8a98bb MSHTML!CEventMgr::Dispatch+0x35a
0018fbc0 6e92d0c0 MSHTML!CEventMgr::DispatchEvent+0x8c
0018fd18 6e92da30 MSHTML!CXMLHttpRequest::Fire_onreadystatechange+0x8b
0018fd2c 6e9343ea MSHTML!CXMLHttpRequest::DeferredFire_onreadystatechange+0x52
0018fd5c 6e8a9472 MSHTML!CXMLHttpRequest::DeferredFire_progressEvent+0x10
0018fdac 773f62fa MSHTML!GlobalWndProc+0x1cd
0018fdd8 773f6d3a USER32!InternalCallWinProc+0x23
0018fe50 773f77c4 USER32!UserCallWinProcCheckWow+0x109
0018feb0 773f788a USER32!DispatchMessageWorker+0x3bc

So now I knew that somewhere deep in my Javascript code there was something happening that was bad. Okay… I guess that helps, maybe?

But then, after some more googling, I discovered the following blog post, published a mere 9 days ago: Finally… JavaScript source line info in a dump. Magic! (In fact, I’m just writing this blog post for my future self, so I remember where to find this info in the future.)

After following the specific incantations outlined within that post, I was able to get the exact line of Javascript that was causing my weird error. All of a sudden, things made sense.

0:000> k
ChildEBP RetAddr  
00186520 76bd22b4 KERNELBASE!RaiseException+0x48
00186558 5900775d msvcrt!_CxxThrowException+0x59
00186588 590076a3 jscript9!Js::JavascriptExceptionOperators::ThrowExceptionObjectInternal+0xb7
001865b8 5901503d jscript9!Js::JavascriptExceptionOperators::Throw+0x77
00186604 6365e79b jscript9!CJavascriptOperations::ThrowException+0x9c
0018662c 63e609aa mshtml!CFastDOM::ThrowDOMError+0x70
00186660 58f1f9a3 mshtml!CFastDOM::CWebSocket::DefaultEntryPoint+0xe2
001866c8 58f29994 jscript9!Js::JavascriptExternalFunction::ExternalFunctionThunk+0x165
00186724 58f2988c jscript9!Js::JavascriptFunction::CallAsConstructor+0xc7
00186744 58f29a4a jscript9!Js::InterpreterStackFrame::NewScObject_Helper+0x39
00186760 58f29a7a jscript9!Js::InterpreterStackFrame::ProfiledNewScObject_Helper+0x53
00186780 58f29aa9 jscript9!Js::InterpreterStackFrame::OP_NewScObject_Impl<Js::OpLayoutCallI_OneByte,1>+0x24
00186b58 58f26510 jscript9!Js::InterpreterStackFrame::Process+0x402b
00186d6c 14ea1ae1 jscript9!Js::InterpreterStackFrame::InterpreterThunk<1>+0x1e8
WARNING: Frame IP not in any known module. Following frames may be wrong.
00186d78 58faa407 js!Anonymous function [http://marcdev2010:4131/app/main/main-controller.js @ 251,7]
00186e70 15511455 jscript9!Js::JavascriptFunction::EntryApply+0x267
00186ed8 58f268e6 js!d [http://marcdev2010:4131/lib/angular/angular.min.js @ 34,479]
001872c8 58f26510 jscript9!Js::InterpreterStackFrame::Process+0x899
001873f4 14ea0681 jscript9!Js::InterpreterStackFrame::InterpreterThunk<1>+0x1e8
00187400 58f268e6 js!instantiate [http://marcdev2010:4131/lib/angular/angular.min.js @ 35,101]
001877e8 58f26510 jscript9!Js::InterpreterStackFrame::Process+0x899
00187944 14ea1b41 jscript9!Js::InterpreterStackFrame::InterpreterThunk<1>+0x1e8
00187950 58f268e6 js!Anonymous function [http://marcdev2010:4131/lib/angular/angular.min.js @ 67,280]
00187d38 58f26510 jscript9!Js::InterpreterStackFrame::Process+0x899
00187e74 14ea1c21 jscript9!Js::InterpreterStackFrame::InterpreterThunk<1>+0x1e8
...

When I looked at the line in question, line 251 of main-controller.js, I found:

// TODO: We need to handle the web socket connection going down -- it really should be wrappered
//  try {
      $scope.watcher = new WebSocket("ws://"+location.host+"/");
//  } catch(e) {
//    $scope.watcher = null;
//  }
    
    $scope.$on('$destroy', function() {
      if($scope.watcher) {
        $scope.watcher.close();
        $scope.watcher = null;
      }
    });

It turns out that if I press F5, or call browser.navigate from the container app, the $destroy event was never called, and what’s worse, MSHTML wasn’t shutting down the web socket, either.  And by default, Internet Explorer has a maximum of six concurrent WebSocket connections. So six page loads and we’re done. The connection error is not triggering a script error in the MSHTML host, sadly, which is why it was so hard to track down.

Yeah, if I had already written the error handling for the WebSocket connection in the JavaScript code, this issue wouldn’t have been so hard to trace. But at least I’ve learned a useful new debugging technique!

Speculation and further investigation:

  • I’m still working on why the web socket is staying open between page loads when embedded.  It’s not straightforward, and while onbeforeunload is a workaround that, well, works, I hate workarounds when I don’t have a clear answer as to why they are needed.
  • It is possible that there is a circular reference leak or similar, but I did kinda think MS had sorted most of those with recent releases of IE.
  • This problem is only reproducible within the MSHTML embedded browser, and not within Internet Explorer itself. Changing $scope.watcher to window.watcher made no difference.
  • TWebBrowser (Delphi) and TEmbeddedWB (Delphi) both exhibited the same symptoms.
  • A far simpler document with a web socket call did not cause the problem.

Updated a few minutes later:

Yes, I have found the cause. It’s a classic Internet Explorer leak: a function within a closure that references the DOM. Simplified, it looks something like:

  window.addEventListener( "load", function(event) {
    var aa = document.getElementById('aa');
    var watcher = new WebSocket("ws://"+location.host+"/");
    watcher.onmessage = function() {
      aa.innerHTML = 'message received';
    }
    aa.innerHTML = 'WebSocket started';
  }, false);

This will persist the connection between  page loads, and quickly eat up your available WebSocket connections.  But it still only happens in the embedded web browser. Why that is, I am still exploring.

Updated 30 Nov 2015:

The reason this happens only in the embedded web browser is that by default, the embedded web browser runs in an emulation mode for IE7. Even with the X-UA-Compatible meta tag, you still need to add your executable to the FEATURE_BROWSER_EMULATION registry key.

Using Delphi attributes to unify source, test and documentation

Updated 28 May 2014: Removed extraneous unit reference from AttributeValidation.pas. Sorry…

What problem was I trying to solve?

Recently, while using the Indy Internet components in Delphi XE2, I was struggling to track the thread contexts in which certain code paths ran, to ensure that resource contention and deadlocks were correctly catered for.

Indy components are reasonably robust, but use a multithreaded model which it turns out is difficult to get 100% correct.  Component callbacks can occur on many different threads:

  • The thread that constructed the component
  • The VCL thread
  • The server listener thread
  • The connection’s thread
  • Some, e.g. exceptions, can occur on any thread

Disentangling this, especially when in conjunction with third party solutions that are based on Indy and may add several layers of indirection, quickly becomes an unenjoyable task.

I started adding thread validation assertions to each function to ensure that I was (a) understanding which thread context the function was actually running in, and (b) to ensure that I didn’t call the function in the wrong context myself.  However, when browsing the code, it was still very difficult to get a big picture view of thread usage.

Introducing attributes

Enter attributes.  Delphi 2010 introduced support for attributes in Win32, and a nice API to query them with extended Run Time Type Information (RTTI).  This is nice, except for one thing: it’s difficult at runtime to find the RTTI associated with the current method.

In this unit, I have tried to tick a number of boxes:

  • Create a simple framework for extending runtime testing of classes with attributes
  • Use attributes to annotate methods, in this case about thread safety, to optimise self-documentation
  • Keep a single, consistent function call in each member method, to test any attributes associated with that method.
  • Sensible preprocessor use to enable and disable both the testing and full RTTI in one place.

One gotcha is that by default, RTTI for Delphi methods is only available for public and published member methods.  This can be changed with the $RTTI compiler directive but you have to remember to do it in each unit!  I have used a unit-based $I include in order to push the correct RTTI settings consistently.

I’ve made use of Delphi’s class helper model to give direct access to any object at compile time.  This is a clean way of injecting this support into all classes which are touched by the RTTI, but does create larger executables.  I believe this to be a worthwhile tradeoff.

Example code

The code sample below demonstrates how to use the attribute tests in a multi-threaded context. In this example, an assertion will be raised soon after cmdDoSomeHardWorkClick is called. Why is this? It happens because the HardWorkCallback function on the main thread is annotated with [MainThread] attribute, but it will be called from TSomeThread‘s thread context, not the main thread.

In order for the program run without an assertion, you could change the annotation of HardWorkCallback to [NotMainThread]. Making this serves as an immediate prompt that you should not be accessing VCL properties, because you are no longer running on the main thread. In fact, unless you can prove that the lifetime of the form will exceed that of TSomeThread, you shouldn’t even be referring to the form. The HardWorkCallback function here violates these principles by referring to the Handle property of TForm. However, because we can show that the form is destroyed after the thread exits, it’s safe to make the callback to the TAttrValForm object itself.

You can download the full source for this project from the link at the bottom of this post in order to compile it and run it yourself.

Exercise: How could you restructure this to make HardWorkCallback thread-safe? There’s more than one way to skin this cat.

unit AttrValSample;

interface

uses
  System.Classes,
  System.SyncObjs,
  System.SysUtils,
  System.Variants,
  Vcl.Controls,
  Vcl.Dialogs,
  Vcl.Forms,
  Vcl.Graphics,
  Vcl.StdCtrls,
  Winapi.Messages,
  Winapi.Windows,

  {$I AttributeValidation.inc};

type
  TSomeThread = class;

  TAttrValForm = class(TForm)
    cmdStartThread: TButton;
    cmdDoSomeHardWork: TButton;
    cmdStopThread: TButton;
    procedure cmdStartThreadClick(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure cmdStopThreadClick(Sender: TObject);
    procedure cmdDoSomeHardWorkClick(Sender: TObject);
  private
    FThread: TSomeThread;
  public
    [MainThread] procedure HardWorkCallback;
  end;

  TSomeThread = class(TThread)
  private
    FOwner: TAttrValForm;
    FEvent: TEvent;
    [NotMainThread] procedure HardWork;
  protected
    [NotMainThread] procedure Execute; override;
  public
    [MainThread] constructor Create(AOwner: TAttrValForm);
    [MainThread] destructor Destroy; override;
    [MainThread] procedure DoSomeHardWork;
  end;

var
  AttrValForm: TAttrValForm;

implementation

{$R *.dfm}

procedure TAttrValForm.cmdStartThreadClick(Sender: TObject);
begin
  FThread := TSomeThread.Create(Self);

  cmdDoSomeHardWork.Enabled := True;
  cmdStopThread.Enabled := True;
  cmdStartThread.Enabled := False;
end;

procedure TAttrValForm.cmdDoSomeHardWorkClick(Sender: TObject);
begin
  FThread.DoSomeHardWork;
end;

procedure TAttrValForm.cmdStopThreadClick(Sender: TObject);
begin
  FreeAndNil(FThread);
  cmdDoSomeHardWork.Enabled := False;
  cmdStopThread.Enabled := False;
  cmdStartThread.Enabled := True;
end;

procedure TAttrValForm.FormDestroy(Sender: TObject);
begin
  FreeAndNil(FThread);
end;

procedure TAttrValForm.HardWorkCallback;
begin
  ValidateAttributes;
  SetWindowText(Handle, 'Hard work done');
end;

{ TSomeThread }

constructor TSomeThread.Create(AOwner: TAttrValForm);
begin
  ValidateAttributes;
  FEvent := TEvent.Create(nil, False, False, '');
  FOwner := AOwner;
  inherited Create(False);
end;

destructor TSomeThread.Destroy;
begin
  ValidateAttributes;
  if not Terminated then
  begin
    Terminate;
    FEvent.SetEvent;
    WaitFor;
  end;
  FreeAndNil(FEvent);
  inherited Destroy;
end;

procedure TSomeThread.DoSomeHardWork;
begin
  ValidateAttributes;
  FEvent.SetEvent;
end;

procedure TSomeThread.Execute;
begin
  ValidateAttributes;
  while not Terminated do
  begin
    if FEvent.WaitFor = wrSignaled then
      if not Terminated then
        HardWork;
  end;
end;

procedure TSomeThread.HardWork;
begin
  ValidateAttributes;
  FOwner.HardWorkCallback;
end;

end.

The AttributeValidation.inc file referenced in the uses clause above controls RTTI and debug settings, in one line. This pattern makes it easy to use the unit without forgetting to set the appropriate RTTI flags in one unit.

// Disable the following $DEFINE to remove all validation from the project
// You may want to do this with {$IFDEF DEBUG} ... {$ENDIF}
{$DEFINE ATTRIBUTE_DEBUG}

// Shouldn't need to touch anything below here
{$IFDEF ATTRIBUTE_DEBUG}
{$RTTI EXPLICIT METHODS([vcPrivate,vcProtected,vcPublic,vcPublished])}
{$ENDIF}

// This .inc file is also included from AttributeValidation.pas, so
// don't use it again in that context.
{$IFNDEF ATTRIBUTE_DEBUG_UNIT}
AttributeValidation
{$ENDIF}

Finally, the AttributeValidation.pas file itself contains the assembly stub to capture the return address for the caller, and the search through the RTTI for the appropriate method to test in each case. This will have a performance cost so should really only be present in Debug builds.

unit AttributeValidation;

interface

{$DEFINE ATTRIBUTE_DEBUG_UNIT}
{$I AttributeValidation.inc}

uses
  System.Rtti;

type
  // Base class for all validation attributes
  ValidationAttribute = class(TCustomAttribute)
    function Execute(Method: TRTTIMethod): Boolean; virtual;
  end;

  // Will log to the debug console whenever a deprecated
  // function is called
  DeprecatedAttribute = class(ValidationAttribute)
    function Execute(Method: TRTTIMethod): Boolean; override;
  end;

  // Base class for all thread-related attributes
  ThreadAttribute = class(ValidationAttribute);

  // This indicates that the procedure can be called from
  // any thread.  No test to pass, just a bare attribute
  ThreadSafeAttribute = class(ThreadAttribute);

  // This indicates that the procedure must only be called
  // in the context of the main thread
  MainThreadAttribute = class(ThreadAttribute)
    function Execute(Method: TRTTIMethod): Boolean; override;
  end;

  // This indicates that the procedure must only be called
  // in another thread context.
  NotMainThreadAttribute = class(ThreadAttribute)
    function Execute(Method: TRTTIMethod): Boolean; override;
  end;

  TAttributeValidation = class helper for TObject
{$IFDEF ATTRIBUTE_DEBUG}
  private
    procedure IntValidateAttributes(FReturnAddress: UIntPtr);
{$ENDIF}
  protected
    procedure ValidateAttributes;
  end;

implementation

uses
  Winapi.Windows,

  classes;

{ TAttributeValidation }

{
 Function:    TAttributeValidation.ValidateAttributes

 Description: Save the return address to an accessible variable
              on the stack.  We could do this with pure Delphi and
              some pointer jiggery-pokery, but this is cleaner.
}
{$IFNDEF ATTRIBUTE_DEBUG}
procedure TAttributeValidation.ValidateAttributes;
begin
end;
{$ELSE}
{$IFDEF CPUX64}
procedure TAttributeValidation.ValidateAttributes;
asm
  push rbp
  sub  rsp, $20
  mov  rbp, rsp
                          // rcx = param 1; will already be pointing to Self.
  mov  rdx, [rbp+$28]     // rdx = param 2; rbp+$28 is return address on stack
  call TAttributeValidation.IntValidateAttributes;

  lea  rsp, [rbp+$20]
  pop  rbp
end;
{$ELSE}
procedure TAttributeValidation.ValidateAttributes;
asm
                            // eax = Self
  mov edx, dword ptr [esp]  // edx = parameter 1
  call TAttributeValidation.IntValidateAttributes
end;
{$ENDIF}

{
 Function:    TAttributeValidation.IntValidateAttributes

 Description: Find the closest function to the return address,
              and test the attributes in that function.  Assumes
              that the closest function is the correct one, so
              if RTTI is missing then you'll be in a spot of
              bother.
}
procedure TAttributeValidation.IntValidateAttributes(FReturnAddress: UIntPtr);
var
  FRttiType: TRttiType;
  FClosestRttiMethod, FRttiMethod: TRTTIMethod;
  FAttribute: TCustomAttribute;
begin
  with TRttiContext.Create do
  try
    FRttiType := GetType(ClassType);
    if not Assigned(FRttiType) then Exit;

    FClosestRttiMethod := nil;

    // Find nearest function for the return address
    for FRttiMethod in FRttiType.GetMethods do
    begin
      if (UIntPtr(FRttiMethod.CodeAddress) <= FReturnAddress) then
      begin
        if not Assigned(FClosestRttiMethod) or
            (UIntPtr(FRttiMethod.CodeAddress) > UIntPtr(FClosestRttiMethod.CodeAddress)) then
          FClosestRttiMethod := FRttiMethod;
      end;
    end;

    // Check attributes for the function
    if Assigned(FClosestRttiMethod) then
    begin
      for FAttribute in FClosestRttiMethod.GetAttributes do
      begin
        if FAttribute is ValidationAttribute then
        begin
          if not (FAttribute as ValidationAttribute).Execute(FClosestRttiMethod) then
          begin
            Assert(False, 'Attribute '+FAttribute.ClassName+' did not validate on '+FClosestRttiMethod.Name);
          end;
        end;
      end;
    end;
  finally
    Free;
  end;
end;
{$ENDIF}

{ ValidationAttribute }

function ValidationAttribute.Execute(Method: TRTTIMethod): Boolean;
begin
  Result := True;
end;

{ MainThreadAttribute }

function MainThreadAttribute.Execute(Method: TRTTIMethod): Boolean;
begin
  Result := GetCurrentThreadID = MainThreadID;
end;

{ NotMainThreadAttribute }

function NotMainThreadAttribute.Execute(Method: TRTTIMethod): Boolean;
begin
  Result := GetCurrentThreadID <> MainThreadID;
end;

{ DeprecatedAttribute }

function DeprecatedAttribute.Execute(Method: TRTTIMethod): Boolean;
begin
  OutputDebugString(PChar(Method.Name + ' was called.'#13#10));
  Result := True;
end;

end.

There you have it — a “real” use case for attributes in Delphi. The key advantages I see to this approach, as opposed to, say function-level assertions, is that a birds-eye view of your class will help you to understand the preconditions for each member function, and these preconditions can be consistently and simply tested.

Using a class helper makes it easy to inject the additional functionality into every class that is touched by attribute validation, without polluting the class hierarchy. This means that attribute tests can be seamlessly added to existing infrastructure and Delphi child classes such as TForm.

Full source: AttrVal.zip. License: MPL 2.0. YMMV and use at your own risk.