blob: c9b92c778f6fa4be805e76bb9cbd513a1eef5153 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
|
program WebmoduleCrash;
{$mode objfpc}
uses
Classes, SysUtils;
type
TGetActionEvent = Procedure (Sender : TObject) of object;
TGetMethodProc=function(): TMethod of object;
type
{ TTestObject }
TTestObject = class(TObject)
function GetOnGetAction: TGetActionEvent;
procedure DataModuleGetAction(Sender: TObject);
end;
function TTestObject.GetOnGetAction: TGetActionEvent;
begin
Result := @DataModuleGetAction;
end;
procedure TTestObject.DataModuleGetAction(Sender: TObject);
begin
writeln('is');
end;
var AMethod : TMethod;
ATestObject : TTestObject;
begin
ATestObject := TTestObject.create;
// uncomment the next line and the exception wil occur on the line after the 'this' writeln,
// else the crash will occur in TTestObject.GetOnGetAction
ATestObject.GetOnGetAction;
AMethod := TGetMethodProc(@ATestObject.GetOnGetAction)();
WriteLn('this');
TGetActionEvent(AMethod)(nil);
WriteLn('a test');
ATestObject.Free;
end.
|
