Delphi XE5 TRESTRequest getting ssl3_read_bytes:sslv3 alert handshake failure - rest

I'm getting the error
REST request failed! Error connecting with SSL. error:14094410:SSL
routines:ssl3_read_bytes:sslv3 alert handshake failure
using the TREST components, here is the example code -- full unit code below
seems to be specific to the url link e.g. other https: calls work fine
function Getcall_UsingRest : String;
var
fRstclnt1: TRESTClient;
fRstrqst1: TRESTRequest;
fRstrspns1: TRESTResponse;
begin
result := '';
try
fRstclnt1:= TRESTClient.Create('https://au-api.basiq.io');
fRstrqst1:= TRESTRequest.Create(nil);
fRstrspns1:= TRESTResponse.Create(nil);
try
fRstrqst1.Client := fRstclnt1;
fRstrqst1.Response := fRstrspns1;
fRstrqst1.Execute;
result := fRstrspns1.Content;
finally
fRstclnt1.Free;
fRstrqst1.Free;
fRstrspns1.Free;
end;
except
on E:Exception do begin
result := e.Message;
end;
end;
end;
I have been trying the following to try and fix but i haven't been able to get it to work
using TIdHTTP component i get the same error
function Getcall_UsingHTTP_WithSameIssue : String;
var
fIdHTTP1: TIdHTTP;
fIdSSLIOHandlerSocketOpenSSL1: TIdSSLIOHandlerSocketOpenSSL;
fresp: TMemoryStream;
fMySL : TStringList;
begin
result := '';
try
fIdHTTP1:= TIdHTTP.Create(nil);
try
fIdSSLIOHandlerSocketOpenSSL1 := TIdSSLIOHandlerSocketOpenSSL.Create(fIdHTTP1);
fIdHTTP1.IOHandler := fIdSSLIOHandlerSocketOpenSSL1;
fresp := TMemoryStream.Create;
fMySL := TStringList.Create;
try
fIdHTTP1.Get('https://au-api.basiq.io', fresp);
fresp.Position := 0;
fMySL.LoadFromStream( fresp );
result := fMySL.Text;
finally
fMySL.Free;
fresp.Free;
end;
finally
fIdHTTP1.Free;
end;
except
on E:Exception do begin
result := e.Message;
end;
end;
end;
there is a fix for this which is to put
procedure OnStatusInfoEx(ASender: TObject; const AsslSocket: PSSL;
const AWhere, Aret: TIdC_INT; const AType, AMsg: String);
begin
SSL_set_tlsext_host_name(AsslSocket, Request.Host);
end;
onto the fIdSSLIOHandlerSocketOpenSSL1.OnStatusInfoEx := OnStatusInfoEx;
the TIdSSLIOHandlerSocketOpenSSL component is buried deep in the TRESTClient and i haven't been able to find a way to see if i can apply the fix above to work on the TRESTClient
can someone help with how to get the TREST to be able to communicate
here is the full source code for the examples above
unit RestExample;
interface
uses
System.Generics.Collections
, REST.Types
, REST.Client
, sysutils
, IdHTTP
, IdSSLOpenSSL
, IdSSLOpenSSLHeaders, IdCTypes
, system.Classes
;
function Getcall_UsingRest : String;
function Getcall_UsingHTTP_WithSameIssue : String;
function Getcall_UsingHTTP_WithFix : String;
type
TCustomIdHTTP = class(TIdHTTP)
public
constructor Create(AOwner: TComponent);
private
procedure OnStatusInfoEx(ASender: TObject; const AsslSocket: PSSL; const AWhere, Aret: TIdC_INT; const AType, AMsg: String);
end;
implementation
function Getcall_UsingRest : String;
var
fRstclnt1: TRESTClient;
fRstrqst1: TRESTRequest;
fRstrspns1: TRESTResponse;
begin
result := '';
try
fRstclnt1:= TRESTClient.Create('https://au-api.basiq.io');
fRstrqst1:= TRESTRequest.Create(nil);
fRstrspns1:= TRESTResponse.Create(nil);
try
fRstrqst1.Client := fRstclnt1;
fRstrqst1.Response := fRstrspns1;
fRstrqst1.Execute;
result := fRstrspns1.Content;
finally
fRstclnt1.Free;
fRstrqst1.Free;
fRstrspns1.Free;
end;
except
on E:Exception do begin
result := e.Message;
end;
end;
end;
function Getcall_UsingHTTP_WithSameIssue : String;
var
fIdHTTP1: TIdHTTP;
fIdSSLIOHandlerSocketOpenSSL1: TIdSSLIOHandlerSocketOpenSSL;
fresp: TMemoryStream;
fMySL : TStringList;
begin
result := '';
try
fIdHTTP1:= TIdHTTP.Create(nil);
try
fIdSSLIOHandlerSocketOpenSSL1 := TIdSSLIOHandlerSocketOpenSSL.Create(fIdHTTP1);
fIdHTTP1.IOHandler := fIdSSLIOHandlerSocketOpenSSL1;
fresp := TMemoryStream.Create;
fMySL := TStringList.Create;
try
fIdHTTP1.Get('https://au-api.basiq.io', fresp);
fresp.Position := 0;
fMySL.LoadFromStream( fresp );
result := fMySL.Text;
finally
fMySL.Free;
fresp.Free;
end;
finally
fIdHTTP1.Free;
end;
except
on E:Exception do begin
result := e.Message;
end;
end;
end;
function Getcall_UsingHTTP_WithFix : String;
var
fTCustomIdHTTP: TCustomIdHTTP;
fresp: TMemoryStream;
fMySL : TStringList;
begin
result := '';
try
fTCustomIdHTTP:= TCustomIdHTTP.Create(nil);
try
fresp := TMemoryStream.Create;
fMySL := TStringList.Create;
try
fTCustomIdHTTP.Get('https://au-api.basiq.io', fresp);
fresp.Position := 0;
fMySL.LoadFromStream( fresp );
result := fMySL.Text;
finally
fMySL.Free;
fresp.Free;
end;
finally
fTCustomIdHTTP.Free;
end;
except
on E:Exception do begin
result := e.Message;
end;
end;
end;
{ TCustomIdHTTP }
constructor TCustomIdHTTP.Create(AOwner: TComponent);
begin
IOHandler := TIdSSLIOHandlerSocketOpenSSL.Create(nil);
with IOHandler as TIdSSLIOHandlerSocketOpenSSL do begin
OnStatusInfoEx := Self.OnStatusInfoEx;
end;
inherited Create(AOwner);
end;
procedure TCustomIdHTTP.OnStatusInfoEx(ASender: TObject; const AsslSocket: PSSL;
const AWhere, Aret: TIdC_INT; const AType, AMsg: String);
begin
SSL_set_tlsext_host_name(AsslSocket, Request.Host);
end;
end.

Related

In Delphi, how can I modify cells in a TStringGrid using a DLL procedure?

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;

Cannot receive contentType "application/pdf" using RestResponse

My application sends data(personal info) using "application/json". If data is valid, then, server sends me back a PDF File through "application/pdf". But when RestResponse arrives, an exception pops out: "No mapping for the unicode character exists in the target multibyte code page". I don't know whats happening. I'm working on this in the past 4 days and I can't fix this. Exception pops out at line: "RRequest.Execute;". Here's my code guys:
procedure TThreadBoleto.Execute;
var
RCtx : TRttiContext;
RType : TRttiType;
RProp : TRttiProperty;
I : integer;
PDF : TFile;
begin
try
try
RClient := TRESTClient.Create('');
with RClient do begin
AcceptEncoding := 'identity';
FallbackCharsetEncoding := 'UTF-8';
Accept := 'application/json;text/plain;application/pdf;';
AcceptCharset := 'UTF-8';
BaseURL := 'https://sandbox.boletocloud.com/api/v1/boletos';
ContentType := 'application/x-www-form-urlencoded';
HandleRedirects := true;
RCtx := TRttiContext.Create;
RType := RCtx.GetType(THRBoleto.ClassType);
I := 0;
for RProp in RType.GetProperties do
begin
Params.AddItem;
Params.Items[I].name := LowerCase(RProp.Name.Replace('_','.'));
Params.Items[I].Value := RProp.GetValue(THRBoleto).AsString;
I := I + 1;
end;
end;
RRequest := TRESTRequest.Create(RRequest);
with RRequest do begin
Accept := 'application/json;text/plain;application/pdf;';
Client := RClient;
Method := rmPost;
SynchronizedEvents := false;
AcceptCharset := 'UTF-8';
end;
RResponse := TRESTResponse.Create(RResponse);
RResponse.ContentType := 'application/pdf;*/*;';
RResponse.ContentEncoding := 'UTF-8';
RAuth := THTTPBasicAuthenticator.Create('','');
with RAuth do begin
Username := 'anAPItokenAccess';
Password := 'token';
end;
RClient.Authenticator := RAuth;
RRequest.Response := RResponse;
RRequest.Execute;
PDF.WriteAllBytes(ExtractFilePath(Application.ExeName)+'boleto.pdf',RResponse.RawBytes);
OutputStrings.Add(RResponse.Content);
OutputStrings.Add('');
OutputStrings.Add('');
OutputStrings.AddStrings(RResponse.Headers);
except on E:Exception do
ShowMessage('Error: '+E.Message);
end;
finally
THRBoleto.Free;
end;
end;
Are you sure the error is happening on the RRequest.Execute() call? You are trying to receive the PDF data as a String when you read the RResponse.Content property, so I would expect a Unicode error on that call instead. A PDF file is not textual data, it is binary data, so the only safe way to receive it is with the RResponse.RawBytes property.
Also, you should not be setting the RResponse.ContentType or RResponse.ContentEncoding properties at all (not to mention that you are setting them to invalid values anyway). They will be filled in according to the actual response that is received.
Since you are setting the RRequest.Accept property to include 3 different media types that you are willing to accept in a response, you need to look at the RResponse.ContentType property value to make sure you are actually receiving a PDF file before saving the RawBytes to a .pdf file. If you receive a text or JSON response instead, you can't process them as a PDF.
Personally, I find the REST components to be quite buggy. You might have better luck using Indy's TIdHTTP instead, eg:
uses
..., IdGlobal, IdGlobalProtocols, IdHTTP, IdSSLOpenSSL;
procedure TThreadBoleto.Execute;
var
RCtx : TRttiContext;
RType : TRttiType;
RProp : TRttiProperty;
Client: TIdHTTP;
Params: TStringList;
Response: TMemoryStream;
begin
Client := TIdHTTP.Create;
try
with Client.Request do begin
AcceptEncoding := 'identity';
Accept := 'application/json;text/plain;application/pdf';
AcceptCharset := 'UTF-8';
ContentType := 'application/x-www-form-urlencoded';
BasicAuthentication := True;
Username := 'anAPItokenAccess';
Password := 'token';
end;
Client.HandleRedirects := true;
RCtx := TRttiContext.Create;
RType := RCtx.GetType(THRBoleto.ClassType);
Response := TMemoryStream.Create;
try
Params := TStringList.Create;
try
for RProp in RType.GetProperties do
Params.Add(LowerCase(RProp.Name.Replace('_','.')) + '=' + RProp.GetValue(THRBoleto).AsString);
Client.Post('https://sandbox.boletocloud.com/api/v1/boletos', Params, Response);
finally
Params.Free;
end;
Response.Position := 0;
case PosInStrArray(ExtractHeaderMediaType(Client.Response.ContentType), ['application/pdf', 'application/json', 'text/plain'], False) of
0: begin
// save PDF
Response.SaveToFile(ExtractFilePath(Application.ExeName)+'boleto.pdf');
OutputStrings.Add('[PDF file]');
end;
1: begin
// process JSON as needed
OutputStrings.Add(ReadStringAsCharset(Response, Client.Response.Charset));
end;
2: begin
// process Text as needed
OutputStrings.Add(ReadStringAsCharset(Response, Client.Response.Charset));
end;
else
// something else!
OutputStrings.Add('[Unexpected!]');
end;
finally
Response.Free;
end;
OutputStrings.Add('');
OutputStrings.Add('');
OutputStrings.AddStrings(Client.Response.RawHeaders);
finally
Client.Free;
end;
end;
procedure TThreadBoleto.DoTerminate;
begin
if FatalException <> nil then
begin
// Note: ShowMessage() is NOT thread-safe!
ShowMessage('Error: ' + Exception(FatalException).Message);
end;
THRBoleto.Free;
inherited;
end;

delphi Activex and parented forms error

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.

Pascal Overriding class methods during runtime

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

Blob to String : How to convert Blob to string from StoredProcedure Parameter in PostgreSQL?

I have stored procedure (function in Postgres) with type of parameter like this :
Params[0] : result = ftBlob // postgresql function = text
Params[1] : 1 = ftString
Params[2] : 2 = ftInteger
Params[3] : 3 = ftInteger
my code is like this :
procedure TForm1.Button1Click(Sender: TObject);
var
ResultStr: TResultStr;
BlobField: TBlobField;
bStream: TStream;
DataSet: TDataSet;
StoredProc: TSQLStoredProc;
begin
sp01.Close;
sp01.Params[1].AsString := '2010/2011';
sp01.Params[2].AsInteger := 2;
sp01.Params[3].AsInteger := 1;
sp01.ExecProc;
if sp01.ParamByName('result').Value.IsBlob then
begin
BlobField := StoredProc.ParamByName('result') as TBlobField;
bStream := sp01.CreateBlobStream(BlobField, bmRead);
try
bStream.Read(ResultStr,sizeof(TResultStr));
finally
bStream.Free;
end;
end;
ShowMessage(ResultStr.Hasil);
end;
the question is, how do I want to get the result (Blob) become string ?
I don't know what TResultString is, but you can do it with a string:
var
BlobResult: string; // Changed to make clearer where changes were below
begin
// Your other code here
if sp01.ParamByName('result').Value.IsBlob then
begin
BlobField := StoredProc.ParamByName('result') as TBlobField;
bStream := sp01.CreateBlobStream(BlobField, bmRead);
try
SetLength(BlobResult, bStream.Size); // Note changes here
bStream.Read(BlobResult[1], bStream.Size); // and here
finally
bStream.Free;
end;
end;
This is an old post but if anyone needs in the future.
ShowMessage(BlobField.AsString);