I'm trying to get and set some property values on VCL components. Some are DevExpress and some are not.
I have wrtiten a small helper class:
type
RttiHelper = class
strict private
public
class function GetPropertyValue(const aObject: TObject; const aPropertyName, aSecondLevel: string): TValue; inline;
class function GetPropertyValue2(const aObject: TObject; const aPropertyName, aSecondLevel: string): TValue; inline;
class procedure GetProperty(const aObject: TObject; const aPropertyName, aSecondLevel: string; var aRttiProperty: TRttiProperty); inline;
end;
{ TRttiHelper }
class procedure RttiHelper.GetProperty(const aObject: TObject; const aPropertyName, aSecondLevel: string; var aRttiProperty: TRttiProperty);
var
NextLevel: TObject;
begin
aRttiProperty := TRttiContext.Create.GetType(aObject.ClassType).GetProperty(aPropertyName);
if aRttiProperty = nil then // Try harder: Look after the property in next level
begin
aRttiProperty := TRttiContext.Create.GetType(aObject.ClassType).GetProperty(aSecondLevel);
if aRttiProperty <> nil then
begin
NextLevel := aRttiProperty.GetValue(aObject).AsObject;
if NextLevel = nil then
exit;
aRttiProperty := TRttiContext.Create.GetType(NextLevel.ClassType).GetProperty(aPropertyName);
end;
end;
end;
class function RttiHelper.GetPropertyValue(const aObject: TObject; const aPropertyName, aSecondLevel: string): TValue;
var
RttiProperty: TRttiProperty;
aInstance, Properties: TObject;
begin
RttiProperty := TRttiContext.Create.GetType(aObject.ClassType).GetProperty(aPropertyName);
aInstance := aObject;
if RttiProperty = nil then // Try harder: Look after the property in next level
begin
RttiProperty := TRttiContext.Create.GetType(aObject.ClassType).GetProperty(aSecondLevel);
if RttiProperty <> nil then
begin
Properties := RttiProperty.GetValue(aObject).AsObject;
aInstance := Properties;
if Properties = nil then
exit(nil);
RttiProperty := TRttiContext.Create.GetType(Properties.ClassType).GetProperty(aPropertyName);
end;
end;
if RttiProperty = nil then // Nothing found
exit(nil);
Result := RttiProperty.GetValue(aInstance);
end;
class function RttiHelper.GetPropertyValue2(const aObject: TObject; const aPropertyName, aSecondLevel: string): TValue;
var
RttiProperty: TRttiProperty;
begin
RttiHelper.GetProperty(aObject, aPropertyName, aSecondLevel, RttiProperty);
if RttiProperty <> nil then
Result := RttiProperty.GetValue(aObject)
else
Result := nil;
end;
Preferable I would like to call the GetProperty method and then get or set the value but on DevExpress Components i dont get the correct result.
Here is how to reproduce:
Place a TEdit and TcxTextEdit on a form, and then write the following code:
Edit1.Text := RttiHelper.GetPropertyValue2(Edit1, 'Color', 'Style').AsVariant;
cxTextEdit1.Text := RttiHelper.GetPropertyValue2(cxTextEdit1, 'Color', 'Style').AsVariant;
While if I use this code it wotrks very well:
Edit1.Text := RttiHelper.GetPropertyValue(Edit1, 'Color', 'Style').AsVariant;
cxTextEdit1.Text := RttiHelper.GetPropertyValue(cxTextEdit1, 'Color', 'Style').AsVariant
Can anyone tell me what I'm doing wrong?
The problem is in this line : RttiProperty.GetValue(aObject) I call GetValue on the the Original object, but it's not certainly that the property is placed on that object.
the property Color e.g is a very good example: On a TEdit it is placed on the "Main Object". You can write Edit1.Color := clBlue; but in a TcxTextEdit the Color property is placed on a style object, so you'll have to write: cxTextEdit1.Style.Color := clBlue. There for I need to call RttiProperty.GetValue(aObject) on the correct object.
In order for doing that I've cahanged the declaration of GetProperty from
class procedure GetProperty(const aObject: TObject; const aPropertyName, aSecondLevel: string; var aRttiProperty: TRttiProperty);
To:
class procedure GetProperty(var aObject: TObject; const aPropertyName, aSecondLevel: string; var aRttiProperty: TRttiProperty);
An the implementation changed to:
class procedure RttiHelper.GetProperty(var aObject: TObject; const aPropertyName, aSecondLevel: string; var aRttiProperty: TRttiProperty);
var
NextLevel: TObject;
begin
aRttiProperty := ctx.GetType(aObject.ClassType).GetProperty(aPropertyName);
if aRttiProperty = nil then // Try harder: Look after the property in next level
begin
aRttiProperty := ctx.GetType(aObject.ClassType).GetProperty(aSecondLevel);
if aRttiProperty <> nil then
begin
NextLevel := aRttiProperty.GetValue(aObject).AsObject;
if NextLevel = nil then
exit;
aObject := NextLevel;
aRttiProperty := ctx.GetType(NextLevel.ClassType).GetProperty(aPropertyName);
end;
end;
end;
Then it works.
After a bit of cleanup this is my complpete helper:
unit RttiHelperU;
interface
uses
RTTI;
type
RttiHelper = class
strict private
class var ctx: TRttiContext;
public
class function GetProperty(var aObject: TObject; const aPropertyName, aSecondLevel: string): TRttiProperty;
class function GetPropertyValue(aObject: TObject; const aPropertyName, aSecondLevel: string): TValue;
class function SetPropertyValue(aObject: TObject; const aPropertyName, aSecondLevel: string; const aValue: TValue): boolean;
end;
implementation
class function RttiHelper.GetProperty(var aObject: TObject; const aPropertyName, aSecondLevel: string): TRttiProperty;
var
NextLevel: TObject;
begin
Result := ctx.GetType(aObject.ClassType).GetProperty(aPropertyName);
if Result = nil then // Try harder: Look after the property in next level
begin
Result := ctx.GetType(aObject.ClassType).GetProperty(aSecondLevel);
if Result <> nil then
begin
NextLevel := Result.GetValue(aObject).AsObject;
if NextLevel = nil then
exit(nil);
aObject := NextLevel;
Result := ctx.GetType(NextLevel.ClassType).GetProperty(aPropertyName);
end;
end;
end;
class function RttiHelper.GetPropertyValue(aObject: TObject; const aPropertyName, aSecondLevel: string): TValue;
var
RttiProperty: TRttiProperty;
begin
RttiProperty := GetProperty(aObject, aPropertyName, aSecondLevel);
if RttiProperty <> nil then
Result := RttiProperty.GetValue(aObject)
else
Result := nil;
end;
class function RttiHelper.SetPropertyValue(aObject: TObject; const aPropertyName, aSecondLevel: string; const aValue: TValue): boolean;
var
RttiProperty: TRttiProperty;
begin
Result := False;
RttiProperty := GetProperty(aObject, aPropertyName, aSecondLevel);
if RttiProperty = nil then
exit;
try
RttiProperty.SetValue(aObject, aValue);
Result := true;
except
end;
end;
end.
Related
I am trying to create a linked list implementation in Delphi, but can't create a node because I need to check if the head pointer is empty or not. The code I'm using right now looks like this:
procedure LinkedList.addNode(newNode: Node);
var lastNode: Node;
begin
if pHead = nil then
pHead := #newNode
else
lastNode := peekLastNode(pHead^);
lastNode.pNext := #newNode;
end;
The program freezes up after just adding one element, so the nil part is the issue indefinitely.
Here is the entire program:
program LinkedListImplementation;
{$APPTYPE CONSOLE}
{$R *.res}
uses
System.SysUtils;
type
Node = record
data: string;
pNext: ^Node;
end;
type
LinkedList = class
pHead: ^Node;
function peekLastNode (currentNode: Node) : Node;
function listToString(currentNode: Node) : String;
procedure addNode (newNode: Node);
end;
//the initial parameter for this function is LinkedList.pHead^
function LinkedList.peekLastNode (currentNode: Node) : Node;
begin
if currentNode.pNext = nil then
result := currentNode
else
result := peekLastNode(currentNode.pNext^);
end;
//produces string in form 'abc -> def -> ghi' from linked list
function LinkedList.listToString(currentNode: Node) : String;
begin
if currentNode.pNext = nil then
result := currentNode.data
else
result := currentNode.data + ' -> ' + listToString(currentNode.pNext^)
end;
//this uses helper method 'peekLastNode'
procedure LinkedList.addNode(newNode: Node);
var lastNode: Node;
begin
if pHead = nil then
pHead := #newNode
else
lastNode := peekLastNode(pHead^);
lastNode.pNext := #newNode;
end;
var
Strings: LinkedList;
String1: Node;
String2: Node;
begin
try
String1.data := 'abc';
String2.data := 'def';
Strings.Create();
Strings.addNode(String1);
Strings.addNode(String2);
WriteLn(Strings.listToString(Strings.pHead^));
ReadLn;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.
In addNode(), if pHead is nil then you are setting it to point at a local variable, and if it is not nil then you set lastNode.pNext instead to point at another local variable. Those local variables go out of scope when addNode() exits, thus leaving pHead/pNext dangling so they are pointing at invalid memory for the next time you try to use them.
You need to use heap allocation when adding Node instances to your list, and you need to pass ^Node pointers around rather than Node instances directly.
Also, addNode() has a logic error in that it sets lastNode.pNext unconditionally whether pHead is nil or not. If pHead is nil then lastNode is not assigned anything. The else block is missing begin..end statements around its operations.
Also, you are not even constructing the LinkedList object correctly. Strings.Create(); needs to be Strings := LinkedList.Create(); instead.
With that said, try something more like this:
program LinkedListImplementation;
{$APPTYPE CONSOLE}
{$R *.res}
uses
System.SysUtils;
type
PNode = ^Node;
Node = record
data: string;
pNext: PNode;
end;
type
LinkedList = class
private
pHead: PNode;
public
destructor Destroy; override;
function peekLastNode(currentNode: PNode = nil): PNode;
function listToString(currentNode: PNode = nil): String;
function addNode(const data: String): PNode;
procedure clear;
end;
destructor LinkedList.Destroy;
begin
clear;
end;
//the initial parameter for this function is LinkedList.pHead
function LinkedList.peekLastNode(currentNode: PNode) : PNode;
begin
if currentNode = nil then currentNode := pHead;
if (currentNode = nil) or (currentNode.pNext = nil) then
Result := currentNode
else
Result := peekLastNode(currentNode.pNext);
end;
{ Alternatively:
function LinkedList.peekLastNode(currentNode: PNode): PNode;
begin
if currentNode = nil then currentNode := pHead;
Result := currentNode;
if Result <> nil then
begin
while Result.pNext <> nil do
Result := Result.pNext;
end;
end;
}
//produces string in form 'abc -> def -> ghi' from linked list
function LinkedList.listToString(currentNode: PNode): String;
begin
if currentNode = nil then currentNode := pHead;
if currentNode = nil then
Result := ''
else if currentNode.pNext = nil then
Result := currentNode.data
else
Result := currentNode.data + ' -> ' + listToString(currentNode.pNext);
end;
{ Alternatively:
function LinkedList.listToString(currentNode: PNode): String;
begin
Result := '';
if currentNode = nil then currentNode := pHead;
if currentNode <> nil then
begin
Result := currentNode.data;
while currentNode.pNext <> nil do
begin
currentNode := currentNode.pNext;
Result := Result + ' -> ' + currentNode.data;
end;
end;
end;
}
//this uses helper method 'peekLastNode'
function LinkedList.addNode(const data: String): PNode;
begin
New(Result);
Result.data := data;
Result.pNext := nil;
if pHead = nil then
pHead := Result
else
peekLastNode(pHead).pNext := Result;
end;
{ Alternatively:
function LinkedList.addNode(const data: String): PNode;
var
currentNode: ^PNode;
begin
currentNode := #pHead;
while currentNode^ <> nil do
currentNode := #((currentNode^).pNext);
New(currentNode^);
(currentNode^).data := data;
(currentNode^).pNext := nil;
Result := currentNode^;
end;
}
procedure LinkedList.clear;
var
currentNode, nextNode: PNode;
begin
currentNode := pHead;
while currentNode <> nil do
begin
nextNode := currentNode.pNext;
Dispose(currentNode);
currentNode := nextNode;
end;
end;
var
Strings: LinkedList;
begin
try
Strings := LinkedList.Create();
try
Strings.addNode('abc');
Strings.addNode('def');
WriteLn(Strings.listToString());
finally
Strings.Free();
end;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
ReadLn;
end.
I need a container with different TProc indexed by String.
Something like TDictionary.
TMessageBus = class
private
fContainer: TDictionary<String, TProc<T>>; // ERROR !!
public
procedure Send<T>(aName: String; aData: T); // producer
procedure Subscribe<T>(aName: String; aProc: TProc<T>); // consumer
end;
Please help.
If you have a field dependent on the generic type T you have to make the complete class generic and not the methods:
type
TMessageBus<T> = class
private
fContainer: TDictionary<String, TProc<T>>; // ERROR !!
public
procedure Send(aName: String; aData: T); // producer
procedure Subscribe(aName: String; aProc: TProc<T>); // consumer
end;
Knowing that TProc<T> is implemented as interface you can write this code:
type
TMessageBus = class
private
fContainer: TDictionary<string, IInterface>;
public
constructor Create;
destructor Destroy; override;
procedure Send<T>(const aName: string; const aData: T);
procedure Subscribe<T>(const aName: string; const aProc: TProc<T>);
end;
constructor TMessageBus.Create;
begin
fContainer := TDictionary<string, IInterface>.Create;
end;
destructor TMessageBus.Destroy;
begin
fContainer.Free;
inherited;
end;
procedure TMessageBus.Send<T>(const aName: string; const aData: T);
begin
TProc<T>(fContainer[aName])(aData);
end;
procedure TMessageBus.Subscribe<T>(const aName: string; const aProc: TProc<T>);
begin
fContainer.AddOrSetValue(aName, IInterface(PPointer(#aProc)^));
end;
However apart from leaving out any validation code this can easily blow up if you do send a different data type than you subscribed. So I would use the TValue type here to wrap the passed TProc<T> inside a TProc<TValue> (from System.Rtti). Keep in mind however that TValue itself only allows type conversions that also the compiler allows, so it won't convert string to Integer and alike - but if required you can then add this yourself:
type
TMessageBus = class
private
fContainer: TDictionary<string, TProc<TValue>>;
public
constructor Create;
destructor Destroy; override;
procedure Send<T>(const aName: string; const aData: T);
procedure Subscribe<T>(const aName: string; const aProc: TProc<T>);
end;
constructor TMessageBus.Create;
begin
fContainer := TDictionary<string, TProc<TValue>>.Create;
end;
destructor TMessageBus.Destroy;
begin
fContainer.Free;
inherited;
end;
procedure TMessageBus.Send<T>(const aName: string; const aData: T);
var
proc: TProc<TValue>;
begin
if fContainer.TryGetValue(aName, proc) then
proc(TValue.From<T>(aData));
end;
procedure TMessageBus.Subscribe<T>(const aName: string; const aProc: TProc<T>);
begin
fContainer.AddOrSetValue(aName,
procedure(aValue: TValue)
begin
aProc(aValue.AsType<T>);
end);
end;
If you now call mb.Send('somestring', 42); for example it will raise an EInvalidCast exception in TValue.AsType because as mentioned before it can't convert the passed 42 to string which is what you specified when you called Subscribe.
We have to include SNI (Server_Name_Indication) in our rest requests because the server will hosts several virtual domains in the near future. We are using a standard THTTPClient component created at runtime.
As soon as we add a new domain with new certificate we receive an exception
"Server certificate invalid or does not exist"
(translated from the german error text)
Is there a special header value to archive SNI this like for the basic authentication?
Below is a simplified version of our code (no logging, no proxy, fake URL). I apologize that I can not provide the real URL we are using.
We would expect that we must augment the GetRequest method, but did not find any example or hint.
unit Unit1;
interface
uses
Winapi.Windows, WinApi.WinHTTP, System.Classes,
Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls,
System.Net.HTTPClient;
type
TForm1 = class(TForm)
Button1: TButton;
Edit1: TEdit;
procedure Button1Click(Sender: TObject);
private
function PostRequest(const cRequest, cBody: string): string;
public
{ Public declarations }
end;
type
TMyRestClient = class(TObject)
private
fHTTPClient: THTTPClient;
fSysUrl: string;
fUserID: string;
fPassWD: string;
//...
function GetRequest(const cMethod, cUrl: string): IHTTPRequest;
public
constructor Create(const cUrl: string);
destructor Destroy; override;
function Post(const cRequest, cBody: string): string;
//...
property SystemUrl: string read fSysUrl write fSysUrl;
property Username: string read fUserID write fUserID;
property Password: string read fPassWD write fPassWD ;
end;
var
Form1: TForm1;
implementation
uses
System.SysUtils, System.Variants, System.NetEncoding;
{$R *.dfm}
constructor TMyRestClient.Create(const cUrl: string);
begin
fHTTPClient := THTTPClient.Create;
SystemUrl := cUrl;
end;
destructor TMyRestClient.Destroy;
begin
FreeAndNil(fHTTPClient);
inherited Destroy;
end;
function TMyRestClient.GetRequest(const cMethod, cUrl: string): IHTTPRequest;
begin
Result := fHTTPClient.GetRequest(cMethod, cUrl);
Result.AddHeader('content-type', 'appplication/json');
if (Password <> '') then
Result.AddHeader('Authorization', 'Basic ' + TNetEncoding.Base64.Encode(Username + ':' + Password));
end;
function TMyRestClient.Post(const cRequest, cBody: string): string;
var
iRequest: IHTTPRequest;
iResponse: IHTTPResponse;
aBody: TStringStream;
begin
iRequest := GetRequest('POST', Format('%s/%s', [SystemUrl, cRequest]));
aBody := TStringStream.Create(UTF8String(cBody));
try
iRequest.SourceStream := aBody;
iResponse := fHTTPClient.Execute(iRequest);
finally
aBody.DisposeOf;
end;
if (iResponse.StatusCode <> HTTP_STATUS_OK) then
raise Exception.CreateFmt('Post: %s failed (Code %d) %', [cRequest, iResponse.StatusCode, iResponse.StatusText]);
Result := iResponse.ContentAsString;
end;
function TForm1.PostRequest(const cRequest, cBody: string): string;
var
xClient: TMyRestClient;
begin
xClient := TMyRestClient.Create('www.myserver.com/demo');
try
// Basic authentification (not used)
xClient.Username := '';
xClient.Password := '';
Result := xClient.Post(cRequest, cBody);
finally
xClient.DisposeOf
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Edit1.Text := PostRequest('retrieve/paramvalue', '{''PARAM'':''VERSION''}' );
end;
The problem is that when I press the login button I get this in the memo: "Your session has expired. You can log in again from this page or go to the login page". I'm using XE3. Thanks for your help
var
tslPost1: TStringList;
sResult1: String;
idhHttp1: TIdHTTP;
procedure TForm1.Button1Click(Sender: TObject);
begin
tslPost1 := TStringList.Create;
idhHttp1 := TIdHTTP.Create;
idhHttp1.HandleRedirects := True;
idhHttp1.AllowCookies := True;
idHttp1.CookieManager := Form1.IdCookieManager1;
idhHttp1.Request.UserAgent := 'Mozilla/5.0 (Windows NT 6.1; WOW64; rv:12.0) Gecko/20100101 Firefox/12.0';
try
tslPost1.Add('log=' + Edit1.Text);
tslPost1.Add('pwd=' + Edit2.Text);
tslPost1.Add('rememberme=forever');
tslPost1.Add('wp-submit=Login');
tslPost1.Add('redirect_to=' + Edit3.Text + '/wp-admin/');
tslPost1.Add('testcookie=1');
idhHttp1.Get(Edit3.Text + '/wp-login.php');
idhHttp1.Post(Edit3.Text + '/wp-login.php', tslPost1);
sResult1 := idhHttp1.Get(Edit3.Text + '/wp-admin/');
Memo1.Lines.Add(sResult1);
finally
FreeAndNil(tslPost1);
FreeAndNil(idhHttp1);
end;
end;
pls try adding the cookie manually:
CookieManager.AddServerCookie('wordpress_test_cookie=WP+Cookie+check',
TIdURI.Create(Website));
or a complete login function:
function TWordPress.Login(AIdHTTPHelper: TIdHTTPHelper): Boolean;
var
Params: TStringList;
Enc: TEncoding;
ResponseStr: string;
begin
Result := False;
with AIdHTTPHelper do
begin
AddCookie('wordpress_test_cookie=WP+Cookie+check', Website);
Params := TStringList.Create;
try
with Params do
begin
Add('log=' + AccountName);
Add('pwd=' + AccountPassword);
Add('rememberme=forever');
Add('wp-submit=');
Add('testcookie=1');
end;
Request.CharSet := 'UTF-8';
Enc := CharsetToEncoding(Request.CharSet);
try
try
ResponseStr := Post(Website + 'wp-login.php', Params, Enc);
except
on E: Exception do
begin
ErrorMsg := E.message;
Exit;
end;
end;
finally
Enc.Free;
end;
finally
Params.Free;
end;
if (Pos('action=logout', ResponseStr) = 0) then
begin
with TRegExpr.Create do
begin
try
InputString := ResponseStr;
Expression := 'error">(.*?)<\/div>';
if Exec(InputString) then
begin
Self.ErrorMsg := HTML2Text(Match[1]);
Exit;
end;
finally
Free;
end;
end;
end;
end;
Result := True;
end;
here is my uIdHTTPHelper unit.
unit uIdHTTPHelper;
interface
uses
// Delphi
SysUtils, Classes, Dialogs, StrUtils,
// Indy
IdGlobal, IdURI, IdCharsets, IdHTTP, IdCookieManager, IdCookie, IdZLib, IdCompressorZLib, IdSSLOpenSSL, IdSocks, IdMultipartFormData,
// Plugin System
uPlugInInterface, uPlugInConst;
type
TIdHTTPHelper = class(TIdHTTP)
private
FLastRedirect: string;
function GetCookieList: string;
procedure SetCookieList(ACookies: string);
function GetResponseRefresh: string;
procedure Redirect(Sender: TObject; var dest: string; var NumRedirect: Integer; var Handled: boolean; var VMethod: TIdHTTPMethod);
protected
FIdCookieManager: TIdCookieManager;
FIdCompressorZLib: TIdCompressorZLib;
FIdSSLIOHandlerSocketOpenSSL: TIdSSLIOHandlerSocketOpenSSL;
FIdSocksInfo: TIdSocksInfo;
public
constructor Create; overload;
constructor Create(const APlugIn: IPlugIn); overload;
property LastRedirect: string read FLastRedirect;
procedure AddCookie(ACookie, AWebsite: string);
procedure Get(AURL: string; AResponseContent: TStream); overload;
function Post(AURL: string; ASource: TStrings; AByteEncoding: TIdTextEncoding = nil): string; overload;
procedure Post(AURL: string; ASource, AResponseContent: TStream); overload;
procedure Post(AURL: string; ASource: TIdMultiPartFormDataStream; AResponseContent: TStream); overload;
property CookieList: string read GetCookieList write SetCookieList;
property Response_Refresh: string read GetResponseRefresh;
class function Charsets: string;
destructor Destroy; override;
end;
implementation
function TIdHTTPHelper.GetCookieList: string;
var
I: Integer;
begin
with TStringList.Create do
try
for I := 0 to CookieManager.CookieCollection.Count - 1 do
Add(CookieManager.CookieCollection.Cookies[I].ServerCookie);
Result := Text;
finally
Free;
end;
end;
procedure TIdHTTPHelper.SetCookieList(ACookies: string);
function ExtractUrl(const AURL: string): string;
var
I: Integer;
begin
I := PosEx('/', AURL, Pos('://', AURL) + 3);
if I > 0 then
Result := copy(AURL, 1, I)
else
Result := AURL;
end;
var
I: Integer;
begin
with TStringList.Create do
try
Text := ACookies;
for I := 0 to Count - 1 do
AddCookie(Strings[I], ExtractUrl(Request.Referer));
finally
Free;
end;
end;
function TIdHTTPHelper.GetResponseRefresh: string;
// Ähnlich dem "Location" Header
const
url = 'url=';
var
_RefreshHeader: string;
begin
_RefreshHeader := LowerCase(Response.RawHeaders.Values['Refresh']);
Result := '';
if (Pos(url, _RefreshHeader) > 0) then
Result := copy(_RefreshHeader, Pos(url, _RefreshHeader) + length(url));
end;
procedure TIdHTTPHelper.Redirect(Sender: TObject; var dest: string; var NumRedirect: Integer; var Handled: boolean; var VMethod: TIdHTTPMethod);
begin
FLastRedirect := dest;
end;
constructor TIdHTTPHelper.Create();
begin
inherited Create(nil);
FIdCookieManager := TIdCookieManager.Create(nil);
FIdCompressorZLib := TIdCompressorZLib.Create(nil);
FIdSSLIOHandlerSocketOpenSSL := TIdSSLIOHandlerSocketOpenSSL.Create(nil);
FIdSocksInfo := TIdSocksInfo.Create(nil);
OnRedirect := Redirect;
end;
constructor TIdHTTPHelper.Create(const APlugIn: IPlugIn);
var
_ICMSPlugin: ICMSPlugIn;
begin
Create();
with APlugIn do
if Proxy.Active then
if not(Proxy.ServerType = ptHTTP) then
with FIdSocksInfo do
begin
Host := Proxy.Server;
Port := Proxy.Port;
if (Proxy.ServerType = ptSOCKS4) then
Version := svSocks4
else
Version := svSocks5;
Username := Proxy.AccountName;
Password := Proxy.AccountPassword;
Enabled := True;
end
else
with ProxyParams do
begin
ProxyServer := Proxy.Server;
ProxyPort := Proxy.Port;
ProxyUsername := Proxy.AccountName;
ProxyPassword := Proxy.AccountPassword;
end;
FIdSSLIOHandlerSocketOpenSSL.TransparentProxy := FIdSocksInfo;
CookieManager := FIdCookieManager;
Compressor := FIdCompressorZLib;
IOHandler := FIdSSLIOHandlerSocketOpenSSL;
AllowCookies := True;
HandleRedirects := True;
ConnectTimeout := APlugIn.ConnectTimeout;
ReadTimeout := APlugIn.ReadTimeout;
ProtocolVersion := pv1_1;
HTTPOptions := HTTPOptions + [hoKeepOrigProtocol];
Request.Accept := 'text/html, application/xml;q=0.9, application/xhtml+xml, image/png, image/jpeg, image/gif, image/x-xbitmap, */*;q=0.1';
Request.AcceptCharSet := 'iso-8859-1, utf-8, utf-16, *;q=0.1';
Request.AcceptEncoding := 'deflate, gzip, identity, *;q=0';
Request.AcceptLanguage := 'de-DE,de;q=0.9,en;q=0.8';
Request.Connection := 'Keep-Alive';
Request.ContentType := 'application/x-www-form-urlencoded';
if Supports(APlugIn, ICMSPlugIn) then
begin
if APlugIn.QueryInterface(ICMSPlugIn, _ICMSPlugin) = 0 then
try
Request.Referer := _ICMSPlugin.Website;
finally
_ICMSPlugin := nil;
end;
end;
Request.UserAgent := 'Opera/9.80 (Windows NT 6.1; U; de) Presto/2.9.168 Version/11.51';
ReuseSocket := rsTrue;
end;
procedure TIdHTTPHelper.AddCookie(ACookie: string; AWebsite: string);
var
IdURI: TIdURI;
begin
IdURI := TIdURI.Create(AWebsite);
try
CookieManager.AddServerCookie(ACookie, IdURI);
finally
IdURI.Free;
end;
end;
procedure TIdHTTPHelper.Get(AURL: string; AResponseContent: TStream);
begin
try
inherited Get(AURL, AResponseContent);
except
on E: EDecompressionError do
;
on E: EIdHTTPProtocolException do
begin
if not(Pos('<body', LowerCase(E.ErrorMessage)) = 0) then
begin
if AResponseContent.InheritsFrom(TStringStream) then
TStringStream(AResponseContent).WriteString(E.ErrorMessage);
end
else
raise ;
end;
end;
end;
function TIdHTTPHelper.Post(AURL: string; ASource: TStrings; AByteEncoding: TIdTextEncoding = nil): string;
begin
try
Result := inherited Post(AURL, ASource, AByteEncoding);
except
on E: EDecompressionError do
;
on E: EIdHTTPProtocolException do
begin
if not(Pos('<body', LowerCase(E.ErrorMessage)) = 0) then
Result := E.ErrorMessage
else
raise ;
end;
end;
if SameStr('', Result) then
begin
if not(Response.Location = '') then
Result := Get(Response.Location)
else if not(Response_Refresh = '') then
Result := Get(Response_Refresh);
end;
end;
procedure TIdHTTPHelper.Post(AURL: string; ASource, AResponseContent: TStream);
begin
try
inherited Post(AURL, ASource, AResponseContent);
except
on E: EDecompressionError do
;
on E: EIdHTTPProtocolException do
begin
if not(Pos('<body', LowerCase(E.ErrorMessage)) = 0) then
begin
if AResponseContent.InheritsFrom(TStringStream) then
TStringStream(AResponseContent).WriteString(E.ErrorMessage);
end
else
raise ;
end;
end;
if AResponseContent.InheritsFrom(TStringStream) and (TStringStream(AResponseContent).DataString = '') then
begin
if not(Response.Location = '') then
Get(Response.Location, AResponseContent)
else if not(Response_Refresh = '') then
Get(Response_Refresh, AResponseContent);
end;
end;
procedure TIdHTTPHelper.Post(AURL: string; ASource: TIdMultiPartFormDataStream; AResponseContent: TStream);
begin
Assert(ASource <> nil);
Request.ContentType := ASource.RequestContentType;
Post(AURL, TStream(ASource), AResponseContent);
end;
class function TIdHTTPHelper.Charsets: string;
var
Lcset: TIdCharset;
begin
with TStringList.Create do
try
for Lcset := TIdCharset(1) to high(TIdCharset) do
Add(IdCharsetNames[Lcset]);
Result := Text;
finally
Free;
end;
end;
destructor TIdHTTPHelper.Destroy;
begin
FIdSocksInfo.Free;
FIdSSLIOHandlerSocketOpenSSL.Free;
FIdCompressorZLib.Free;
FIdCookieManager.Free;
inherited Destroy;
end;
end.
I have been using Synapse for some time now, to send e-mails mainly. Today I am creating a simple installer, and trying to download the application exe file through HTTP. The file is about 9 MB in size, so I´d like to add a progress status to user, but I do not understand the examples I found. Here is what I got so far:
type
THookSocketStatus = Procedure(Sender: TObject; Reason: THookSocketReason; const Value: String) of Object;
CallBack = class
Class Procedure Status(Sender: TObject; Reason: THookSocketReason; const Value: String);
end;
Class Procedure CallBack.Status(Sender: TObject; Reason: THookSocketReason; const Value: String);
var
V: String;
Begin
V := GetEnumName(TypeInfo(THookSocketReason), Integer(Reason)) + ' ' + Value;
Form1.mem1.Lines.Add(V);
application.ProcessMessages;
end;
procedure TForm1.btn1Click(Sender: TObject);
var
HTTP: THTTPSend;
MSTM: TMemoryStream;
begin
Screen.Cursor := crHourGlass;
HTTP := THTTPSend.Create;
MSTM := TMemoryStream.Create;
Try
Try
HTTP.Sock.OnStatus := CallBack.Status;
If HTTP.HTTPMethod('GET', edt1.Text) Then
Begin
MSTM.Seek(0, soFromBeginning);
MSTM.CopyFrom(HTTP.Document, 0);
MSTM.SaveToFile(ExtractFilePath(Application.ExeName) + 'test.exe');
end;
Except
end;
Finally
MSTM.Free;
HTTP.Free;
Screen.Cursor := crDefault;
end;
end;
In this simple test I got this result:
HR_SocketClose
HR_ResolvingBegin www.website.com:80
HR_ResolvingEnd 176.102.295.18:80
HR_SocketCreate IPv4
HR_Connect www.website.com:80
HR_WriteCount 158
HR_CanRead
HR_ReadCount 288
HR_CanRead
HR_ReadCount 8192
HR_ReadCount 8192
HR_ReadCount 8192
HR_ReadCount 6720
HR_CanRead
HR_ReadCount 3299
.
.
.
HR_ReadCount 8192
HR_ReadCount 8192
HR_ReadCount 7828
HR_SocketClose
HR_SocketClose
Please, what means WriteCount and ReadCount? How can I get total file size to set the progress bar before start the download?
Thank you guys!
I had the same problem and found a solution by extending the code above. The file length was available as suggested above by using the Header information.
Here is my code:
unit uhttpdownloader;
{$mode Delphi}{$H+}
interface
uses
Classes, SysUtils, httpsend, blcksock, typinfo;
//Interface for notifications about the progress
type
IProgress = interface
procedure ProgressNotification(Text: String; CurrentProgress : integer; MaxProgress : integer);
end;
type
{ THttpDownloader }
THttpDownloader = class
public
function DownloadHTTP(URL, TargetFile: string; ProgressMonitor : IProgress): Boolean;
private
Bytes : Integer;
MaxBytes : Integer;
HTTPSender: THTTPSend;
ProgressMonitor : IProgress;
procedure Status(Sender: TObject; Reason: THookSocketReason; const Value: String);
function GetSizeFromHeader(Header: String):integer;
end;
implementation
function THttpDownloader.DownloadHTTP(URL, TargetFile: string; ProgressMonitor : IProgress): Boolean;
var
HTTPGetResult: Boolean;
begin
Result := False;
Bytes:= 0;
MaxBytes:= -1;
Self.ProgressMonitor:= ProgressMonitor;
HTTPSender := THTTPSend.Create;
try
//add callback function for status updates
HTTPSender.Sock.OnStatus:= Status;
HTTPGetResult := HTTPSender.HTTPMethod('GET', URL);
if (HTTPSender.ResultCode >= 100) and (HTTPSender.ResultCode<=299) then begin
HTTPSender.Document.SaveToFile(TargetFile);
Result := True;
end;
finally
HTTPSender.Free;
end;
end;
//Callback function for status events
procedure THttpDownloader.Status(Sender: TObject; Reason: THookSocketReason; const Value: String);
var
V, currentHeader: String;
i: integer;
begin
//try to get filesize from headers
if (MaxBytes = -1) then
begin
for i:= 0 to HTTPSender.Headers.Count - 1 do
begin
currentHeader:= HTTPSender.Headers[i];
MaxBytes:= GetSizeFromHeader(currentHeader);
if MaxBytes <> -1 then break;
end;
end;
V := GetEnumName(TypeInfo(THookSocketReason), Integer(Reason)) + ' ' + Value;
//HR_ReadCount contains the number of bytes since the last event
if Reason = THookSocketReason.HR_ReadCount then
begin
Bytes:= Bytes + StrToInt(Value);
ProgressMonitor.ProgressNotification(V, Bytes, MaxBytes);
end;
end;
function THttpDownloader.GetSizeFromHeader(Header: String): integer;
var
item : TStringList;
begin
//the download size is contained in the header (e.g.: Content-Length: 3737722)
Result:= -1;
if Pos('Content-Length:', Header) <> 0 then
begin
item:= TStringList.Create();
item.Delimiter:= ':';
item.StrictDelimiter:=true;
item.DelimitedText:=Header;
if item.Count = 2 then
begin
Result:= StrToInt(Trim(item[1]));
end;
end;
end;
end.
The complete source code and example can be downloaded here as well:
http://andydunkel.net/lazarus/delphi/2015/09/09/lazarus_synapse_progress.html
Andy