i have sometting strange in my application. I wonder what I did wrong or what I did not understand.
The goal is to create 2 functions in the ServerMethodsUnit to modify a variable of the web module.
For that,
I used the Datasnap Rest Server wizard with the following parameters
Stand Alone VCL Gui application
No autorization,
from Tdatamodule
The server metjhods EchoString and ReverseString work well.
First I added in WebModuleUnit1 the variable var1:string;
TWebModule1 = class(TWebModule)
DSHTTPWebDispatcher1: TDSHTTPWebDispatcher;
DSServer1: TDSServer;
DSServerClass1: TDSServerClass;
ServerFunctionInvoker: TPageProducer;
ReverseString: TPageProducer;
WebFileDispatcher1: TWebFileDispatcher;
DSProxyGenerator1: TDSProxyGenerator;
DSServerMetaDataProvider1: TDSServerMetaDataProvider;
procedure DSServerClass1GetClass(DSServerClass: TDSServerClass;
var PersistentClass: TPersistentClass);
procedure ServerFunctionInvokerHTMLTag(Sender: TObject; Tag: TTag;
const TagString: string; TagParams: TStrings; var ReplaceText: string);
procedure WebModuleDefaultAction(Sender: TObject;
Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
procedure WebModuleBeforeDispatch(Sender: TObject;
Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
procedure WebFileDispatcher1BeforeDispatch(Sender: TObject;
const AFileName: string; Request: TWebRequest; Response: TWebResponse;
var Handled: Boolean);
procedure WebModuleCreate(Sender: TObject);
private
{ Déclarations privées }
FServerFunctionInvokerAction: TWebActionItem;
function AllowServerFunctionInvoker: Boolean;
public
{ Déclarations publiques }
var1:string;
end;
I added in ServerMethodsUnit1 2 functions in ServerMethodsUnit1
function SetVar1(astr:string):string;
function GetVar1():string;
and a uses of Datasnap.DSHTTPWebBroker (interface) and WebModuleUnit1(implementation)
function TServerMethods1.GetVar1: string;
var oweb : TWebModule1;
begin
oweb := TWebModule1(GetDataSnapWebModule);
result := oweb.var1;
end;
function TServerMethods1.SetVar1(astr: string): string;
var oweb : TWebModule1;
begin
oweb := TWebModule1(GetDataSnapWebModule);
oweb.var1 := astr;
result := oweb.var1;
end;
it all seemed ok !
I test my 2 function with http://localhost:xxxx/ServerFunctionInvoker
Everything works fine, when I have only one connection to my web server.
When I have multiple connections, it does not work anymore. I have the impression that the variable is shared by the different instances of the WebModule.
Example :
Instance 1 (Chrome) -> SetVar1('TOTO')
Instance 2 (Firefox) -> SetVar1('HELLO')
Instance 1 (Chrome) -> GetVar1 : return 'TOTO'
Instance 1 (Chrome) -> GetVar1 : return 'HELLO'
Instance 1 (Chrome) -> GetVar1 : return ''
If I run the same function 3 times , I do not have the same answer!!!
It's as if the GetDataSnapWebModule function did not return the correct webmodule.
What did I do wrong?
How to share a variable (or a TfdmemTable) between 2 calls of a function rest
thank you in advance for your help.
#+ Romuald
Related
In Embarcadero Delphi v10.1 I have both a DLL library with a record, and a VCL application containing a TStringGrid and a TEdit. The idea is to take the shortstring entered into the TEdit; save it to the record in the DLL and then use the data stored in the record to fill in one of the cells in the TStringGrid.
My problem is that after saving the shortstring to the record I can't seem to find a way to access the TStringGrid while inside the DLL procedure. So far I have tried using both classes and pointers to access the TStringGrid in the DLL but neither has worked:
type
pstringgrid = ^TStringGrid;
//or
type
pstringgrid = ^stringgrid1;
//or
type
istringgrid = class(TStringGrid);
I have even tried to import the TStringGrid into the procedure which is supposed to enter the shortstring from the record into the TStringGrid:
procedure AddElement (var grid : stringgrid1); stdcall;
//or
type
pstringgrid = ^TStringGrid;
procedure AddElement (var grid : ^pstringgrid); stdcall;
So far nothing has worked and all I am getting is the "undecleared identifier" error message from the debugger; please help! How can I access and edit a TStringGrid while in a DLL procedure?
Edit:
Here is the relevant code, sorry for the foreign variable names.
The DLL:
library BibliotekaDLL;
uses
System.SysUtils,
System.Classes;
type
StringGrid1 = class(TStringGrid);
plist = ^game;
game = record
nazwa: shortstring;
wydawca: shortstring;
rokwyd: integer;
gatunek1: shortstring;
gatunek2: shortstring;
pointer: plist;
end;
var
BazaDanych : file of game;
first, current: plist;
[...]
procedure WyswietlListe; stdcall;
var
row : integer;
begin
AssignFile(BazaDanych, 'c:\Baza_Danych_Gier.dat');
if not FileExists('c:\Baza_Danych_Gier.dat') then
ShowMessage ('Baza Danych Nie Instnieje' +E.Message)
else
begin
Reset(BazaDanych);
Read(BazaDanych, first);
Close(BazaDanych);
current := first;
row := 1;
while current^.pointer <> nil do
begin
current := first;
StringGrid1.Cells[0,row] := current^.nazwa;
StringGrid1.Cells[1,row] := current^.wydawca;
StringGrid1.Cells[2,row] := current^.rokwyd;
StringGrid1.Cells[3,row] := current^.gatunek1;
StringGrid1.Cells[4,row] := current^.gatunek2;
current := current^.pointer;
row = row +1;
StringGrid1.RowCount := row;
end;
if current^.pointer = nil do
begin
StringGrid1.Cells[0,row] := current^.nazwa;
StringGrid1.Cells[1,row] := current^.wydawca;
StringGrid1.Cells[2,row] := current^.rokwyd;
StringGrid1.Cells[3,row] := current^.gatunek1;
StringGrid1.Cells[4,row] := current^.gatunek2;
end;
end;
end;
[...]
And the VCL application code:
[...]
type
TForm1 = class(TForm)
Button2: TButton;
StringGrid1: TStringGrid;
procedure Button2Click(Sender: TObject);
end;
var
Form1: TForm1;
implementation
[...]
procedure TForm1.Button2Click(Sender: TObject);
var
Handle : THandle;
WyswietlListe : procedure;
begin
Handle := LoadLibrary('BibliotekaDLL.dll');
try
#WyswietlListe:= GetProcAddress(Handle, 'WyswietlListe');
if #WyswietlListe = nil then raise Exception.Create('Nie Można Znaleźć Procedury w Bibliotece!');
WyswietlListe;
finally
FreeLibrary(Handle);
end;
end;
[...]
My problem is that after saving the shortstring to the record I can't seem to find a way to access the TStringGrid while inside the DLL procedure.
Don't do that. It is bad design.
For one thing, it is not safe to access objects across the DLL boundary unless both app and DLL are compiled with Runtime Packages enabled so they share a single instance of the RTL and memory manager.
It is best if the DLL has no knowledge of your UI at all. If the DLL needs to communicate info to the app, the DLL should define a callback event that the app can assign a handler for, and then the DLL can call that event when needed. Let the app decide how to manage its own UI.
Also, your game record has a pointer member, but pointers cannot be persisted in files. You need to remove that member.
Try something more like this:
library BibliotekaDLL;
uses
System.SysUtils,
System.Classes,
Vcl.Dialogs;
type
game = packed record
nazwa: shortstring;
wydawca: shortstring;
rokwyd: integer;
gatunek1: shortstring;
gatunek2: shortstring;
end;
gameCallback = procedure(var g: game; userData: Pointer); stdcall;
procedure WyswietlListe(callback: gameCallback; userData: Pointer); stdcall;
var
BazaDanych : File of game;
current: game;
begin
AssignFile(BazaDanych, 'c:\Baza_Danych_Gier.dat');
Reset(BazaDanych);
if IOResult <> 0 then
ShowMessage ('Baza Danych Nie Instnieje')
else
try
repeat
Read(BazaDanych, current);
if IOResult <> 0 then Break;
if Assigned(callback) then callback(current, userData);
until False;
finally
Close(BazaDanych);
end;
end;
exports
WyswietlListe;
end.
interface
type
TForm1 = class(TForm)
Button2: TButton;
StringGrid1: TStringGrid;
procedure Button2Click(Sender: TObject);
end;
var
Form1: TForm1;
implementation
type
game = packed record
nazwa: shortstring;
wydawca: shortstring;
rokwyd: integer;
gatunek1: shortstring;
gatunek2: shortstring;
end;
gameCallback = procedure(var g: game; userData: Pointer); stdcall;
pmyCallbackInfo = ^myCallbackInfo;
myCallbackInfo = record
Grid: TStringGrid;
FirstTime: Boolean;
end;
procedure myCallback(var g: game; userData: Pointer); stdcall;
var
row: Integer;
begin
Grid := pmyCallbackInfo(userData).Grid;
// add a new row only if the initial non-fixed row is already filled...
if pmyCallbackInfo(userData).FirstTime then
pmyCallbackInfo(userData).FirstTime := False
else
Grid.RowCount := Grid.RowCount + 1;
row := Grid.RowCount - 1;
Grid.Cells[0, row] := g.nazwa;
Grid.Cells[1, row] := g.wydawca;
Grid.Cells[2, row] := IntToStr(g.rokwyd);
Grid.Cells[3, row] := g.gatunek1;
Grid.Cells[4, row] := g.gatunek2;
end;
procedure TForm1.Button2Click(Sender: TObject);
var
DLLHandle : THandle;
WyswietlListe : procedure(callback: gameCallback; userData: Pointer); stdcall;
info: myCallbackInfo;
begin
// clear the TStringGrid. However, it has an odd quirk
// that it requires at least 1 non-fixed row at all times...
//
StringGrid1.RowCount := StringGrid1.FixedRows + 1;
StringGrid1.Rows[StringGrid1.RowCount - 1].Clear;
DLLHandle := LoadLibrary('BibliotekaDLL.dll');
if DLLHandle = 0 then raise Exception.Create(...);
try
#WyswietlListe := GetProcAddress(DLLHandle, 'WyswietlListe');
if not Assigned(WyswietlListe) then raise Exception.Create('Nie Można Znaleźć Procedury w Bibliotece!');
info.Grid := StringGrid1;
info.FirstTime := True;
WyswietlListe(#myCallback, #info);
finally
FreeLibrary(DLLHandle);
end;
end;
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 try to fix up my activex project and i had errors , i have 2 forms in my activex project first form hold tmemo and button to call second form as parented form every thing works fine till now but i cannot set any record from second form to first form control always get access violation so i decided to show result before set tmemo.text control in the first form and actually result is showing but but cannot be set into the first form here is my project code
unit main1;
{$WARN SYMBOL_PLATFORM OFF}
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ActiveX, AxCtrls, embed_TLB, StdVcl, Vcl.StdCtrls;
type
Tform1 = class(TForm, Iform1)
Button1: TButton;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
protected
{ Protected declarations }
public
{ Public declarations }
procedure showEmo(L,T:Integer);
end;
var
Form1 : Tform1;
implementation
uses ComObj, ComServ, main2;
{$R *.DFM}
{ Tform1 }
procedure Tform1.Button1Click(Sender: TObject);
var
Rect: TRect;
begin
GetWindowRect(Self.button1.Handle, Rect);
showEmo(Rect.Left + 70,(Rect.Top - 290));
end;
procedure Tform1.FormCreate(Sender: TObject);
begin
Form2 := TForm2.Createparented(0);
end;
procedure TForm1.showEmo(L,T:Integer);
var
Rect: TRect;
begin
try
GetWindowRect(button1.Handle, Rect);
begin
Form2.FormStyle := fsStayOnTop;
end;
Form2.Left := L;//Rect.Left;
Form2.top := T;//Rect.Top - emo.Height;
finally
Form2.Visible := not (Form2.visible);
end;
end;
initialization
TActiveFormFactory.Create(
ComServer,
TActiveFormControl,
Tform1,
Class_form1,
0,
'',
OLEMISC_SIMPLEFRAME or OLEMISC_ACTSLIKELABEL,
tmApartment);
end.
Form 2
unit main2;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.OleCtrls, SHDocVw_EWB, EwbCore,
EmbeddedWB, MSHTML_EWB, Vcl.StdCtrls;
type
TForm2 = class(TForm)
ewbpage: TEmbeddedWB;
load: TMemo;
procedure FormCreate(Sender: TObject);
procedure ewbpageBeforeNavigate2(ASender: TObject; const pDisp: IDispatch;
var URL, Flags, TargetFrameName, PostData, Headers: OleVariant;
var Cancel: WordBool);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form2: TForm2;
implementation
uses main1;
{$R *.dfm}
procedure TForm2.ewbpageBeforeNavigate2(ASender: TObject; const pDisp: IDispatch;
var URL, Flags, TargetFrameName, PostData, Headers: OleVariant;
var Cancel: WordBool);
var
MousePos: TPoint;
HtmlElement: IHTMLElement;
iHTMLDoc: IHtmlDocument2;
begin
if Pos('#sm',URL)>0 then
begin
if Supports(ewbpage.Document, IHtmlDocument2, iHTMLDoc) then
begin
if GetCursorPos(MousePos) then
begin
MousePos := ewbpage.ScreenToClient(MousePos);
HtmlElement := iHTMLDoc.ElementFromPoint(MousePos.X, MousePos.Y);
if Assigned(HtmlElement) then
showmessage(HtmlElement.getAttribute('id', 0));
form1.Memo1.Text := HtmlElement.getAttribute('id', 0);
Cancel := True;
Self.Close;
end;
end;
end;
end;
procedure TForm2.FormCreate(Sender: TObject);
begin
ewbpage.LoadFromStrings(load.Lines);
end;
end.
and the question is why i get this error
Access violation at address 07C734FC in module 'EMBEDA~1.OCX'. Read of
address 000003B4.
at this line
form1.Memo1.Text := HtmlElement.getAttribute('id', 0);
why i cannot set result from second form to first form ? what i did wrong here is the full project for better understand
http://www.mediafire.com/download/zn7hzoxze2390a3/embeddedactivex.zip
You will see this issue once you start to format your code properly
procedure TForm2.ewbpageBeforeNavigate2(ASender: TObject; const pDisp: IDispatch;
var URL, Flags, TargetFrameName, PostData, Headers: OleVariant;
var Cancel: WordBool);
var
MousePos: TPoint;
HtmlElement: IHTMLElement;
iHTMLDoc: IHtmlDocument2;
begin
if Pos('#sm',URL)>0 then
begin
if Supports(ewbpage.Document, IHtmlDocument2, iHTMLDoc) then
begin
if GetCursorPos(MousePos) then
begin
MousePos := ewbpage.ScreenToClient(MousePos);
HtmlElement := iHTMLDoc.ElementFromPoint(MousePos.X, MousePos.Y);
// if we have a valid HtmlElement ...
if Assigned(HtmlElement)
then // show a message
showmessage(HtmlElement.getAttribute('id', 0));
// now we do not care about if HtmlElement is valid or not
form1.Memo1.Text := HtmlElement.getAttribute('id', 0);
Cancel := True;
Self.Close;
end;
end;
end;
end;
To only solve your current access violation you simply put a begin end block around all the lines that will use HtmlElement.
HtmlElement := iHTMLDoc.ElementFromPoint( MousePos.X, MousePos.Y );
if Assigned( HtmlElement )
then
begin
showmessage( HtmlElement.getAttribute( 'id', 0 ) );
form1.Memo1.Text := HtmlElement.getAttribute( 'id', 0 );
end;
But there are some more issues in your code. You should not use the global variables form1 and form2. Instead pass the form instance to the created TForm2 instance or even better a callback method.
I have a TObjectList, which I am trying to write to disk. Although I end up with a file (54 bytes), when I change the FNAME property value to something really long, the size of the file never changes, and I get nil when I try to read it. I am at a loss as to what is wrong. Sorry for the long code snippet. it is easy to understand what is going on, just I can't figure out why it's not doing what I want.
type
{ Declare a new object type. }
TNewObject = class(TComponent)
private
FName: String;
public
property BizName: String read FName write FName;
constructor Create(const AName: String);
destructor Destroy(); override;
end;
Declare a Global var for my TObjectList
var
Form1: TForm1;
List: TObjectList<TNewObject>;
Declare my constructors and destructors..
constructor TNewObject.Create(const AName: String);
begin
FName := AName;
end;
destructor TNewObject.Destroy;
begin
inherited;
end;
Now add a button to create my objects...
procedure TForm1.CreateButtonClick(Sender: TObject);
var
Obj: TNewObject;
begin
{ Create a new List. }
{ The OwnsObjects property is set by default to true -- the list will free the owned objects automatically. }
List := TObjectList<TNewObject>.Create();
{ Add some items to the List. }
List.Add(TNewObject.Create('One'));
List.Add(TNewObject.Create('Two'));
{ Add a new item, but keep the reference. }
Obj := TNewObject.Create('Three');
List.Add(Obj);
end;
Now add a SAVE Button
procedure TForm1.SaveButtonClick(Sender: TObject);
var
i: Integer;
fs: TfileStream;
begin
if SaveDialog1.Execute then
begin
fs := TfileStream.Create(SaveDialog1.FileName, fmCreate);
try
for i := 0 to List.Count - 1 do
begin
ShowMessage(List[i].BizName);
fs.WriteComponent(TNewObject(List[i]));
end;
finally
fs.Free;
end;
end;
end;
CAVEATS: I know that only PUBLIC properties will be saved... which should be BIZNAME. The 3 entries do show up in the SHOWMESSAGE when it is being saved....
I did remember my Class Registration.
Initialization
RegisterClass(TNewObject);
For completeness sake, here is my Load Routine as well...
procedure TForm1.LoadButtonClick(Sender: TObject);
var
i: Integer;
fs: TfileStream;
vRecord: TNewObject;
begin
if OpenDialog1.Execute then
begin
List.Clear; // clear list
fs := TfileStream.Create(OpenDialog1.FileName, fmopenRead);
try
while fs.Position < fs.size do
begin
vRecord := TNewObject(fs.ReadComponent(nil));
ShowMessage(vRecord.FName);
List.Add(vRecord);
end;
finally
fs.Free;
end;
ShowMessage(IntToStr(List.Count));
end;
end;
Thank you for your help.
Component streaming system only streams published properties, you need to publish 'BizName'.
Alternatively you can override DefineProperties to decide what else to stream.
type
TNewObject = class(TComponent)
private
FName: String;
procedure ReadName(Reader: TReader);
procedure WriteName(Writer: TWriter);
protected
procedure DefineProperties(Filer: TFiler); override;
public
property BizName: String read FName write FName;
...
procedure TNewObject.ReadName(Reader: TReader);
begin
FName := Reader.ReadString;
end;
procedure TNewObject.WriteName(Writer: TWriter);
begin
Writer.WriteString(FName);
end;
procedure TNewObject.DefineProperties(Filer: TFiler);
begin
inherited;
Filer.DefineProperty('bizname', ReadName, WriteName, FName <> '');
end;
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