I would like to extend a FB but i need to call the code of the basis FB.
example Code
FB_Basis
FUNCTION_BLOCK FB_Basis
VAR_INPUT
bInTest : BOOL;
END_VAR
VAR_OUTPUT
nOutTest : INT;
END_VAR
IF bInTest THEN
nOutTest := nOutTest + 1;
END_IF
FB_Test
FUNCTION_BLOCK FB_Test EXTENDS FB_Basis
VAR_INPUT
bInTest2 : BOOL;
END_VAR
VAR_OUTPUT
nOutTest2 : INT;
END_VAR
IF bInTest2 THEN
nOutTest2 := nOutTest2 + 1;
END_IF
The Call:
FB_Test( bInTest:=
, nOutTest=>
, bInTest2:=
, nOutTest2=>
);
If I set bInTest at TRUE I want the Output nOutTest count up but it doesn't.
I can't find information how to handle code from the FB_basis in the InfoSys from Beckhoff the just explain the behavior of methods.
I don't know how to call the code, would be thankful for answers.
You can use SUPER^() to call the body of the parent function block. You need to add this to the body of FB_Test:
FUNCTION_BLOCK FB_Test EXTENDS FB_Basis
VAR_INPUT
bInTest2 : BOOL;
END_VAR
VAR_OUTPUT
nOutTest2 : INT;
END_VAR
SUPER^(); // Call the body of FB_Basis
IF bInTest2 THEN
nOutTest2 := nOutTest2 + 1;
END_IF
Related
i am trying to get into the beckhoff/twincat universe, therefore is was following along with some twincat tutorials. While programming a simple event-logger I encountered the following problem:
After executing FB_FileOpen, it´s bBusy variable stays True - therefore my statemachine won´t execute any further and is stuck in FILE_OPEN. Any idea, what I did wrong? Here is my code:
VAR
FileOpen : FB_FileOpen := (sPathName := 'C:\Events-log.txt', nMode := FOPEN_MODEAPPEND OR FOPEN_MODETEXT);
FileClose :FB_FileClose;
FilePuts : FB_FilePuts;
stEventWrittenToFile : ST_Event;
CsvString : T_MaxString;
eWriteState :(TRIGGER_FILE_OPEN, FILE_OPEN, WAIT_FOR_EVENT,TRIGGER_WRITE_EVENT, WRITE_EVENT, FILE_CLOSE, ERROR);
END_VAR
CASE eWriteState OF
TRIGGER_FILE_OPEN :
FileOpen(bExecute := TRUE);
eWriteState := FILE_OPEN;
FILE_OPEN :
FileOpen(bExecute := FALSE);
IF FileOpen.bError THEN
eWriteState := ERROR;
ELSIF NOT FileOpen.bBusy AND FileOpen.hFile <> 0 THEN
eWriteState := WAIT_FOR_EVENT;
END_IF
WAIT_FOR_EVENT :
//Do nothing, triggered externally by method
TRIGGER_WRITE_EVENT :
CsvString := ConvertStructureToString(stEvent := stEventWrittenToFile);
FilePuts( sLine:= CsvString,
hFile := FileOpen.hFile,
bExecute := TRUE,);
eWriteState := WRITE_EVENT;
WRITE_EVENT :
FilePuts(bExecute := FALSE);
IF FilePuts.bError THEN
eWriteState := ERROR;
ELSIF NOT FilePuts.bBusy THEN
eWriteState := FILE_CLOSE;
END_IF
FILE_CLOSE :
FileClose( hFile := FileOpen.hFile,
bExecute := TRUE);
IF FileClose.bError = TRUE THEN
FileClose.bExecute := FALSE;
eWriteState := ERROR;
ELSIF NOT FileClose.bBusy THEN
FileClose.bExecute := FALSE;
eWriteState := TRIGGER_FILE_OPEN;
END_IF
ERROR : // Do nothing
END_CASE
The issue probably lies in how you call the function block. You need to make sure to call the function block with the input bExecute := FALSE and only after that calling it with bExecute := TRUE will trigger the function block execution. Caliing the fb with its "exectue" input to false after it has had the input triggered, will always work so just invert your order of TRUE and FALSE executes for all your states.
TRIGGER_FILE_OPEN:
fileOpen(bExecute := FALSE);
eWriteState := FILE_OPEN;
FILE_OPEN:
fileOpen(bExecute := TRUE);
...
You could also follow the Beckhoff example provided on their website, not a fan of this, but calling the function block twice, back to back in a single PLC cycle :
(* Open source file *)
fbFileOpen( bExecute := FALSE );
fbFileOpen( sNetId := sSrcNetId,
sPathName := sSrcPathName,
nMode := FOPEN_MODEREAD OR FOPEN_MODEBINARY,
ePath := PATH_GENERIC,
tTimeout := tTimeOut,
bExecute := TRUE );
Full example can be found here : https://infosys.beckhoff.com/english.php?content=../content/1033/tcplclib_tc2_system/30977547.html&id=
I found the error.
My mistake was, that I started the state machine with a positive edge from a start variable. Since I am running the task in a 1ms cycle, the whole thing would´ve needed to complete within 1ms then.
this is my first question here on stackoverflow and im hoping someone might be able to help me out.
I'm trying to get the local AmsNetId of my TwinCat PLC system. The Code is running on the TwinCat System locally.
The function is working properly, no problems compiling. But the functionblock FB_GetLocalAmsNetId never seems to return the Ams Net Id. fbGetAmsNetId.bBusy is always busy.
I dont know what i'm doing wrong.
Variables:
FUNCTION_BLOCK FB_GetAmsNetId
VAR_INPUT
END_VAR
VAR_OUTPUT
END_VAR
VAR
fbGetAmsNetId : FB_GetLocalAmsNetId;
bRequestStarted : BOOL := FALSE;
sAmsNetId : T_AmsNetId;
END_VAR
Programcode:
IF(bRequestStarted = FALSE) THEN
fbGetAmsNetId(bExecute := TRUE, tTimeOut := T#2S);
bRequestStarted := TRUE;
ELSE
IF(NOT fbGetAmsNetId.bBusy) THEN
sAmsNetId := fbGetAmsNetId.AddrString;
fbGetAmsNetId.bExecute := FALSE;
bRequestStarted := FALSE;
END_IF
END_IF
You need to cyclically call fbGetAmsNetId in your code, otherwise FB_GetLocalAmsNetId will not be able to finish it's internal operations beeing executed for only one plc cycle.
For example:
fbGetAmsNetId();
IF(bRequestStarted = FALSE) THEN
fbGetAmsNetId(bExecute := TRUE, tTimeOut := T#2S);
bRequestStarted := TRUE;
ELSE
IF(NOT fbGetAmsNetId.bBusy) THEN
sAmsNetId := fbGetAmsNetId.AddrString;
fbGetAmsNetId.bExecute := FALSE;
bRequestStarted := FALSE;
END_IF
END_IF
Is there a timer function or variable in Codesys as in arduino millis() ?
If not, how can I create a timer?
Thanks!
In CoDeSys function TIME() return time in milliseconds from PLC start. If you want to start the count on the event you can use triggers to create a time point.
VAR
tStarted, tElapsed : TIME;
END_VAR
fbR_TRIG(CLK := xStart);
IF (fbR_TRIG.Q) THEN
tStarted := TIME();
END_IF;
tElapsed := TIME() - tStarted;
And rest follows like reset the timer, pause counting, etc.
You can build one yourself.
Here an example:
Declaration part:
FUNCTION_BLOCK FB_Millis
VAR_INPUT
timer : TON := (IN:=TRUE,PT:=maxTime);
END_VAR
VAR_OUTPUT
tElapsedTime : TIME;
END_VAR
VAR
maxTime : TIME := UDINT_TO_TIME(4294967295);
//timer : TON := (IN:=TRUE,PT:=maxTime);
END_VAR
Implementation part:
timer();
tElapsedTime := timer.ET;
You call it cyclically like this:
fbMillis();
And retrieve the result like this:
tElapasedTime := fbMillis.tElapsedTime;
FB_Millis overflows after 49days 17hours 2minutes 47seconds and 295ms.
If you want to compare the elapsed time from fbMillis.tElapsedTime with another variable you do like this:
IF fbMillis.tElapsedTime < tAnotherTimeVar
THEN
; //Do something
ELSE
; //Do something else
END_IF
If you instead just want a simple timer you need the TON Function Block:
Declaration part:
//2 seconds timer
mySimpleTimer : TON := (PT:=T#2s);
Implementation part:
mySimpleTimer();
// your code here
//Start timer
mySimpleTimer.IN := TRUE;
//Check if timer has reached desired time
IF mySimpleTime.Q
THEN
//Do something here
mySimpleTimer.IN := FALSE;
END_IF
My Inno Setup GUI is frozen during unzip operations.
I've a procedure DoUnzip(source: String; targetdir: String) with the core
unzipTool := ExpandConstant('{tmp}\7za.exe');
Exec(unzipTool, ' x "' + source + '" -o"' + targetdir + '" -y',
'', SW_HIDE, ewWaitUntilTerminated, ReturnCode);
This procedure is called multiple times and the Exec operation blocks the user interface. There is only a very short moment between the executions, where the Inno GUI is dragable/moveable.
I know that there are other options for TExecWait instead of ewWaitUntilTerminated, like ewNoWait and ewWaitUntilIdle, but unfortunately they are not helpful in this case. Using ewNoWait would result in the execution of multiple unzip operations at the same time.
I'm looking for a way to execute an external unzip operation and wait for it to finish, but without blocking the user interface. How can i implement that?
Here are my notes and ideas:
Waiting for a process to finish, is blocking, unless you'll be waiting in a thread different from the main one. I think some kind of callback is needed, which is executed, when the unzip operation finishes.
I'm aware that Inno Setup doesn't provide this feature out of the box, see https://github.com/jrsoftware/issrc/issues/149
While searching for related issues on Stack Overflow, I came up with the question Using callback to display filenames from external decompression dll in Inno Setup, where I found Mirals's answer. It's using InnoCallback combined with another DLL.
I think, in my case this could be 7zxa.dll for the unzip operation. But it doesn't accept a callback. So, the following code is just a concept / idea draft. One problem is, that 7zxa.dll doesn't accept a callback.
Another problem is that the 7zxa API is not really inviting to work with.
[Code]
type
TMyCallback = procedure(Filename: PChar);
{ wrapper to tell callback function to InnoCallback }
function WrapMyCallback(Callback: TMyCallback; ParamCount: Integer): LongWord;
external 'WrapCallback#files:innocallback.dll stdcall';
{ the call to the unzip dll }
{ P!: the 7zxa.dll doesn't accept a callback }
procedure DoUnzipDll(Blah: Integer; Foo: String; ...; Callback: LongWord);
external 'DoUnzipDll#files:7zxa.dll stdcall';
{ the actual callback action }
procedure MyCallback(Filename: PChar);
begin
{ refresh the GUI }
end;
{ ----- }
var Callback : LongWord;
{ tell innocallback the callback procedure as 1 parameter }
Callback := WrapMyCallback(#MyCallback, 1);
{ pass the wrapped callback to the unzip DLL }
DoUnzipDll(source, target, ..., Callback);
procedure DoUnzip(src, target : String);
begin
DoUnzipDll(ExpandConstant(src), ExpandConstant(target));
end;
Update: #Rik suggested to combine the WinAPI function ShellExecuteEx() with INFINITE WaitForSingleObject.
I've implemented and tested this approach. The code is below.
The unzipping works, but the Inno Setup window is only moveable/dragable for a short moment between the individual unzip operations. During a long running unzip the GUI is fully unresponsive - no dragging/no cancel button.
I've added BringToFrontAndRestore(), but it seems the new process has the focus.
const
WAIT_OBJECT_0 = $0;
WAIT_TIMEOUT = $00000102;
SEE_MASK_NOCLOSEPROCESS = $00000040;
INFINITE = $FFFFFFFF; { Infinite timeout }
type
TShellExecuteInfo = record
cbSize: DWORD;
fMask: Cardinal;
Wnd: HWND;
lpVerb: string;
lpFile: string;
lpParameters: string;
lpDirectory: string;
nShow: Integer;
hInstApp: THandle;
lpIDList: DWORD;
lpClass: string;
hkeyClass: THandle;
dwHotKey: DWORD;
hMonitor: THandle;
hProcess: THandle;
end;
function ShellExecuteEx(var lpExecInfo: TShellExecuteInfo): BOOL;
external 'ShellExecuteEx{#AW}#shell32.dll stdcall';
function WaitForSingleObject(hHandle: THandle; dwMilliseconds: DWORD): DWORD;
external 'WaitForSingleObject#kernel32.dll stdcall';
function CloseHandle(hObject: THandle): BOOL; external 'CloseHandle#kernel32.dll stdcall';
procedure DoUnzip(source: String; targetdir: String);
var
unzipTool, unzipParams : String; { path to unzip util }
ReturnCode : Integer; { errorcode }
ExecInfo: TShellExecuteInfo;
begin
{ source might contain {tmp} or {app} constant, so expand/resolve it to path name }
source := ExpandConstant(source);
unzipTool := ExpandConstant('{tmp}\7za.exe');
unzipParams := ' x "' + source + '" -o"' + targetdir + '" -y';
ExecInfo.cbSize := SizeOf(ExecInfo);
ExecInfo.fMask := SEE_MASK_NOCLOSEPROCESS;
ExecInfo.Wnd := 0;
ExecInfo.lpFile := unzipTool;
ExecInfo.lpParameters := unzipParams;
ExecInfo.nShow := SW_HIDE;
if not FileExists(unzipTool)
then MsgBox('UnzipTool not found: ' + unzipTool, mbError, MB_OK)
else if not FileExists(source)
then MsgBox('File was not found while trying to unzip: ' + source, mbError, MB_OK)
else begin
{ ShellExecuteEx combined with INFINITE WaitForSingleObject }
if ShellExecuteEx(ExecInfo) then
begin
while WaitForSingleObject(ExecInfo.hProcess, INFINITE) <> WAIT_OBJECT_0
do begin
InstallPage.Surface.Update;
{ BringToFrontAndRestore; }
WizardForm.Refresh();
end;
CloseHandle(ExecInfo.hProcess);
end;
end;
end;
Like I suspected using INFINITE with WaitForSingleObject still blocks the main-thread. Next I thought using a smaller timeout with WaitForSingleObject. But the problem is still that the main-thread stays in the while loop of WaitForSingleObject and doesn't respond to moving. WizardForm.Refresh does not make it movable. It just refreshes the form but doesn't process other messages (like WM_MOVE). You need something like Application.ProcessMessages to allow the windows to move. Since Inno Setup doesn't have a ProcessMessages we could create one ourselves.
Below is your code with a ProcessMessage implemented. It does a 100 millisecond wait for WaitForSingleObject and if it's still in the wait-state it executes the ProcessMessage and Refresh. This will allow you to move the window. You can play a little with the value 100.
Another way could be that you save the ExecInfo and go on with some other install-part. In the final page you could check if the process is finished. If it's not loop with the AppProcessMessage until it is.
[Code]
#ifdef UNICODE
#define AW "W"
#else
#define AW "A"
#endif
const
WAIT_OBJECT_0 = $0;
WAIT_TIMEOUT = $00000102;
SEE_MASK_NOCLOSEPROCESS = $00000040;
INFINITE = $FFFFFFFF; { Infinite timeout }
type
TShellExecuteInfo = record
cbSize: DWORD;
fMask: Cardinal;
Wnd: HWND;
lpVerb: string;
lpFile: string;
lpParameters: string;
lpDirectory: string;
nShow: Integer;
hInstApp: THandle;
lpIDList: DWORD;
lpClass: string;
hkeyClass: THandle;
dwHotKey: DWORD;
hMonitor: THandle;
hProcess: THandle;
end;
function ShellExecuteEx(var lpExecInfo: TShellExecuteInfo): BOOL;
external 'ShellExecuteEx{#AW}#shell32.dll stdcall';
function WaitForSingleObject(hHandle: THandle; dwMilliseconds: DWORD): DWORD;
external 'WaitForSingleObject#kernel32.dll stdcall';
function CloseHandle(hObject: THandle): BOOL; external 'CloseHandle#kernel32.dll stdcall';
{ ----------------------- }
{ "Generic" code, some old "Application.ProcessMessages"-ish procedure }
{ ----------------------- }
type
TMsg = record
hwnd: HWND;
message: UINT;
wParam: Longint;
lParam: Longint;
time: DWORD;
pt: TPoint;
end;
const
PM_REMOVE = 1;
function PeekMessage(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax, wRemoveMsg: UINT): BOOL; external 'PeekMessageA#user32.dll stdcall';
function TranslateMessage(const lpMsg: TMsg): BOOL; external 'TranslateMessage#user32.dll stdcall';
function DispatchMessage(const lpMsg: TMsg): Longint; external 'DispatchMessageA#user32.dll stdcall';
procedure AppProcessMessage;
var
Msg: TMsg;
begin
while PeekMessage(Msg, WizardForm.Handle, 0, 0, PM_REMOVE) do begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end;
{ ----------------------- }
{ ----------------------- }
procedure DoUnzip(source: String; targetdir: String);
var
unzipTool, unzipParams : String; // path to unzip util
ReturnCode : Integer; // errorcode
ExecInfo: TShellExecuteInfo;
begin
{ source might contain {tmp} or {app} constant, so expand/resolve it to path name }
source := ExpandConstant(source);
unzipTool := ExpandConstant('{tmp}\7za.exe');
unzipParams := ' x "' + source + '" -o"' + targetdir + '" -y';
ExecInfo.cbSize := SizeOf(ExecInfo);
ExecInfo.fMask := SEE_MASK_NOCLOSEPROCESS;
ExecInfo.Wnd := 0;
ExecInfo.lpFile := unzipTool;
ExecInfo.lpParameters := unzipParams;
ExecInfo.nShow := SW_HIDE;
if not FileExists(unzipTool)
then MsgBox('UnzipTool not found: ' + unzipTool, mbError, MB_OK)
else if not FileExists(source)
then MsgBox('File was not found while trying to unzip: ' + source, mbError, MB_OK)
else begin
{ ShellExecuteEx combined with INFINITE WaitForSingleObject }
if ShellExecuteEx(ExecInfo) then
begin
while WaitForSingleObject(ExecInfo.hProcess, 100) = WAIT_TIMEOUT { WAIT_OBJECT_0 }
do begin
AppProcessMessage;
{ InstallPage.Surface.Update; }
{ BringToFrontAndRestore; }
WizardForm.Refresh();
end;
CloseHandle(ExecInfo.hProcess);
end;
end;
end;
(This code is tested and works for me)
I am trying to overwrite an object method during runtime.
I managed to get the addr of the method and I can be sure it is corrct (see read-only usage).
My problem is that I can only get read-only access to methods code address
Therefor I either need a way:
- to force write into a Ram-Area that is protected
- to copy the whole class type into a non-protected area and modify it there. (this would be even more useful, because I would still have the original version to hand)
program DynClass;
uses
System.SysUtils,
System.Rtti,
System.TypInfo;
type
TObjectMethod = procedure of Object;
TObjectTest = class(TObject)
public
fieldVar: integer;
procedure ov1; virtual; // <-- virtual does not help
procedure ov2; virtual; // <-- the method I an trying to override
end;
{ TObjectTest }
procedure TObjectTest.ov1; begin writeLn('TObjectTest.ov1'); end;
procedure TObjectTest.ov2; begin writeLn('TObjectTest.opasv2'); end;
// the Method thats supposed to replace it
procedure Override_ov1(self: TObject);
begin writeLn('TOverrideSrc.ov1'); writeLn(TObjectTest(self).fieldVar); end;
var obj: TObjectTest;
var fMethod: TMethod;
var C: TRttiContext;
var T: TRttiType;
var M: TRttiMethod;
var VTMEntry: PVmtMethodEntry;
begin try
obj := TObjectTest.Create;
obj.fieldVar := 21;
T := C.GetType(TypeInfo(TObjectTest));
M := T.GetMethod('ov2');
VTMEntry := PVmtMethodExEntry(m.Handle).Entry;
writeln('address(API): 0x',IntToHex(Integer(M.CodeAddress),8));
writeln('address(Container): 0x',IntToHex(Integer(VTMEntry^.CodeAddress),8));
// ^ note: The address in the container matches the address the Rtti API offers
// --> I really have the virtual method table entry
// vvv This both works (meaning that all addresses are correct)
fMethod.Data := obj;
fMethod.Code := VTMEntry^.CodeAddress;
TObjectMethod(fMethod)(); // call the method in the VTMEntry
fMethod.Code := addr(Override_ov1);
TObjectMethod(fMethod)(); // call the method I want to use in overriding
// ^^^
VTMEntry^.CodeAddress := addr(Override_ov1);
// ^ access violation here
obj.ov2; // if all works, this should do the same as the call above
except on E: Exception do begin
writeLn(E.ClassName+':'+E.Message);
end; end;
readLn;
end.
Ok I finally figured out how to do this thing.
Pascal vmts are kind of confusing.
It uses 4 kinds of vmts:
* One only used for published methods
* One only used by Rtti, containing additional data for all methods
* One used by message and dynamic methods
* And the one that is used, when you just call an ObjectMethod
It took a lot of backwards engeneering, but now it work.
For those of you wondering how its done, I have this:
program DynClass;
uses windows;
type
// ***
// * Most of these types I got from "http://hallvards.blogspot.de/2006/04/hack-9-dynamic-method-table-structure.html"
// ***
PClass = ^TClass;
TDMTIndex = Smallint;
PDmtIndices = ^TDmtIndices;
TDmtIndices = array[0..High(Word)-1] of TDMTIndex;
PDmtMethods = ^TDmtMethods;
TDmtMethods = array[0..High(Word)-1] of Pointer;
PDmt = ^TDmt;
TDmt = packed record
Count: word;
Indicies: TDmtIndices; // really [0..Count-1]
Methods : TDmtMethods; // really [0..Count-1]
end;
PVmtMethodEntry = ^TVmtMethodEntry;
TVmtMethodEntry = packed record
Len: Word;
CodeAddress: Pointer;
Name: ShortString;
{Tail: TVmtMethodEntryTail;} // only exists if Len indicates data here
end;
PVmtMethodEntryEx = ^TVmtMethodEntryEx;
TVmtMethodEntryEx = packed record
Entry: PVmtMethodEntry;
Flags: Word;
VirtualIndex: Smallint; // signed word
end;
PEquals = function (Self,Obj: TObject): Boolean;
PGetHashCode = function (Self: TObject): Integer;
PToString = function (Self: TObject): string;
PSafeCallException = function (Self: TObject; ExceptObject: TObject; ExceptAddr: Pointer): HResult;
PAfterConstruction = procedure (Self: TObject);
PBeforeDestruction = procedure (Self: TObject);
PDispatch = procedure (Self: TObject; var Message);
PDefaultHandler = procedure (Self: TObject; var Message);
PNewInstance = function (Self: TClass) : TObject;
PFreeInstance = procedure (Self: TObject);
PDestroy = procedure (Self: TObject; OuterMost: ShortInt);
PVmt = ^TVmt;
TVmt = packed record
SelfPtr : TClass;
IntfTable : Pointer;
AutoTable : Pointer;
InitTable : Pointer;
TypeInfo : Pointer;
FieldTable : Pointer;
MethodTable : Pointer;
DynamicTable : PDmt;
ClassName : PShortString;
InstanceSize : PLongint;
Parent : PClass;
Equals : PEquals; // these I had to add they might
GetHashCode : PGetHashCode; // be incorrect for older delphi
ToString : PToString; // versions (this works for XE2)
SafeCallException : PSafeCallException;
AfterConstruction : PAfterConstruction;
BeforeDestruction : PBeforeDestruction;
Dispatch : PDispatch;
DefaultHandler : PDefaultHandler;
NewInstance : PNewInstance;
FreeInstance : PFreeInstance;
Destroy : PDestroy;
{UserDefinedVirtuals: array[0..999] of procedure;}
end;
// v taked from System.Rtti
function GetBitField(Value, Shift, Bits: Integer): Integer;
begin Result := (Value shr Shift) and ((1 shl Bits) - 1); end;
// v substituted from System.Rtti
function GetIsDynamic(handle: PVmtMethodEntryEx): boolean;
begin case GetBitField(Handle.Flags,3,2) of
2,3: result := true;
else result := false; end; end;
// a method that can be used to write data into protected RAM
function hackWrite(const addr: PPointer; const value: Pointer): boolean;
var RestoreProtection, Ignore: DWORD; begin
if VirtualProtect(addr,SizeOf(addr^),PAGE_EXECUTE_READWRITE,RestoreProtection) then begin
addr^ := Value; result := true;
VirtualProtect(addr,SizeOf(addr^),RestoreProtection,Ignore);
FlushInstructionCache(GetCurrentProcess,addr,SizeOf(addr^)); // flush cache
end else result := false; end;
// the Vmt is located infront of a Class
function GetVmt(AClass: TClass): PVmt;
begin Result := PVmt(AClass); Dec(PVmt(Result)); end;
// seares the vmt for
function getVirtualIndex(vmt: PVmt; aMeth: shortString; out isDynamic: boolean): SmallInt;
var P: PByte;
procedure readClassic;
var count: PWord; meth: PVmtMethodEntry; next: PByte; I: integer; begin
Count := PWord(P); inc(PWord(P));
for I := 0 to pred(Count^) do begin
meth := PVmtMethodEntry(P);
if meth.Name=aMeth then
begin result := I; break; end;
inc(p,meth.Len);
end; end;
procedure readExtendedMethods;
var Count: PWord; I: integer; meth: PVmtMethodEntryEx; begin
Count := PWord(P); inc(PWord(P));
for i := 0 to pred(count^) do begin
meth := PVmtMethodEntryEx(P);
if meth.Entry.Name=aMeth then begin
result := meth.VirtualIndex;
isDynamic := GetIsDynamic(meth);
exit; end;
inc(PVmtMethodEntryEx(P));
end; end;
begin isDynamic := false;
P := vmt.MethodTable; result := low(SmallInt);
readClassic; // classic method are method declared in a published area
if result=low(SmallInt)
then readExtendedMethods; // extended methods were added in D2010, when Rtti was introduced
end;
procedure overwriteMethod(vmt: PVmt; vmtID: smallInt; isDynamic: boolean; meth: Pointer); overload;
var loc: PByte; dynIndex: word; i: smallInt;
begin if vmtID<>low(SmallInt) then begin
if isDynamic then begin
loc := #vmt.DynamicTable.Indicies[0]; // goto first index entry
for i := 0 to vmt.DynamicTable.Count-1 do begin
if vmt.DynamicTable.Indicies[i] = vmtId
then begin vmtId := i; break; end; end;
// ^ find the vmt id in the dynamic table
inc(loc,
(vmt.DynamicTable.Count*sizeOf(TDMTIndex))+ // end of indices
(vmtID*sizeOf(Pointer))); // desired method entry
end else begin
loc := PByte(vmt);
inc(PVmt(loc)); // skip to the end of the vmt (thats where all the methods are stored)
inc(loc,vmtID*sizeOf(Pointer)); // skip to the exact position of the method
end; end;
hackWrite(PPointer(loc),meth); // overwrite it
end;
procedure overwriteMethod(c: TClass; methName: shortString; meth: Pointer); overload;
var vmtID: smallInt; isDynamic: boolean; vmt: PVmt; begin
vmt := GetVmt(c);
vmtID := getVirtualIndex(vmt,methName,isDynamic);
overwriteMethod(vmt,vmtID,isDynamic,meth);
end;
// ** everything on needs for dynPascal is now defined
type TBaseTestClass = class(TObject)
public
procedure updateA; virtual; abstract;
procedure updateB; virtual; abstract;
end;
type TTestClass = class(TBaseTestClass)
public
procedure foobar; dynamic;
procedure updateA; override;
procedure updateB; override;
end;
type TTestClass2 = class(TTestClass)
public
procedure updateA; override;
procedure updateB; override;
end;
{ TTestClass }
procedure TTestClass.foobar; begin writeLn('foobar'); end;
procedure TTestClass.updateA; begin writeLn('TTestClass.updateA'); end;
procedure TTestClass.updateB; begin writeLn('TTestClass.updateB'); end;
{ TTestClass2 }
procedure TTestClass2.updateA; begin writeLn('TTestClass2.updateA'); end;
procedure TTestClass2.updateB; begin writeLn('TTestClass2.updateB'); end;
procedure testMeth(self: TObject);
begin writeLn('!!!!!!!!!!!!Overwritten method called!!!!!!!!!!!!'); end;
var fTable: PVmt;
var a,b: TObject;
var vmt: PVmt;
var I: integer; begin
fTable := GetVmt(TTestClass);
a := TTestClass.Create;
b := TTestClass2.Create;
// ** demonstration calls, to show that the types work normal at first
TBaseTestClass(a).updateA;
TBaseTestClass(b).updateA;
TBaseTestClass(a).updateB;
TBaseTestClass(b).updateB;
writeLn('');
// ** overwrite a few methods with testMeth and repeat the calling process
overwriteMethod(TTestClass,'foobar',addr(testMeth));
// ^ dynamic methods like foobar work differently but I included handles for those, too
overwriteMethod(TTestClass,'updateA',addr(testMeth));
overwriteMethod(TTestClass2,'updateA',addr(testMeth));
TTestClass(a).foobar;
TBaseTestClass(a).updateA;
TBaseTestClass(b).updateA;
TBaseTestClass(a).updateB; // These 2 methods I didn't overwrite
TBaseTestClass(b).updateB; // ...
readLn;
end.
Basically it is writing self-modifying code. You need to set the attributes of the related page.
See e.g. http://support.microsoft.com/kb/127904