diff --git a/packages/fcl-web/src/base/fphtml.pp b/packages/fcl-web/src/base/fphtml.pp
index a6645732c1..6ceedb84bf 100644
--- a/packages/fcl-web/src/base/fphtml.pp
+++ b/packages/fcl-web/src/base/fphtml.pp
@@ -39,6 +39,7 @@ type
TWebButtons = array of TWebButton;
TMessageBoxHandler = function(Sender: TObject; AText: String; Buttons: TWebButtons; Loaded: string = ''): string of object;
+ TOnGetUrlProc = procedure(ParamNames, ParamValues, KeepParams: array of string; Action: string; var URL: string) of object;
TWebController = class;
THTMLContentProducer = class;
@@ -125,6 +126,7 @@ type
FAddRelURLPrefix: boolean;
FBaseURL: string;
FMessageBoxHandler: TMessageBoxHandler;
+ FOnGetURL: TOnGetUrlProc;
FScriptName: string;
FScriptStack: TFPObjectList;
FIterationIDs: array of string;
@@ -139,6 +141,7 @@ type
function GetStyleSheetReferences: TContainerStylesheets; virtual; abstract;
function GetScripts: TFPObjectList; virtual; abstract;
function GetRequest: TRequest;
+ property OnGetURL: TOnGetUrlProc read FOnGetURL write FOnGetURL;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
@@ -164,6 +167,7 @@ type
procedure ShowRegisteredScript(ScriptID: integer); virtual; abstract;
function IncrementIterationLevel: integer; virtual;
+ function ResetIterationLevel: integer; virtual;
procedure SetIterationIDSuffix(AIterationLevel: integer; IDSuffix: string); virtual;
function GetIterationIDSuffix: string; virtual;
procedure DecrementIterationLevel; virtual;
@@ -247,6 +251,7 @@ type
procedure SetParent(const AValue: TComponent);
Protected
function CreateWriter (Doc : THTMLDocument) : THTMLWriter; virtual;
+ function GetIdentification: string; virtual;
function GetIDSuffix: string; virtual;
procedure SetIDSuffix(const AValue: string); virtual;
protected
@@ -284,6 +289,7 @@ type
function MoveContentProducer(MoveElement, MoveBeforeElement: THTMLContentProducer) : boolean;
procedure HandleAjaxRequest(ARequest: TRequest; AnAjaxResponse: TAjaxResponse); virtual;
procedure ForeachContentProducer(AForeachChildsProc: TForeachContentProducerProc; Recursive: boolean);
+ property Identification: string read GetIdentification;
property Childs[Index: integer]: THTMLContentProducer read GetContentProducers;
property AcceptChildsAtDesignTime: boolean read FAcceptChildsAtDesignTime;
property parent: TComponent read FParent write SetParent;
@@ -676,6 +682,11 @@ begin
Result := FChilds;
end;
+function THTMLContentProducer.GetIdentification: string;
+begin
+ result := '';
+end;
+
function THTMLContentProducer.ProduceContent: String;
var WCreated, created : boolean;
el : THtmlCustomElement;
@@ -1440,6 +1451,11 @@ begin
SetLength(FIterationIDs,Result);
end;
+function TWebController.ResetIterationLevel: integer;
+begin
+ SetLength(FIterationIDs,0);
+end;
+
procedure TWebController.SetIterationIDSuffix(AIterationLevel: integer; IDSuffix: string);
begin
FIterationIDs[AIterationLevel-1]:=IDSuffix;
diff --git a/packages/fcl-web/src/base/webpage.pp b/packages/fcl-web/src/base/webpage.pp
index c644c57bf8..65ce24ad2d 100644
--- a/packages/fcl-web/src/base/webpage.pp
+++ b/packages/fcl-web/src/base/webpage.pp
@@ -61,6 +61,8 @@ type
function CreateNewScript: TStringList; override;
procedure ShowRegisteredScript(ScriptID: integer); override;
procedure FreeScript(var AScript: TStringList); override;
+ published
+ property OnGetURL;
end;
{ TWebPage }
@@ -89,7 +91,6 @@ type
procedure DoHandleAjaxRequest(ARequest: TRequest; AnAjaxResponse: TAjaxResponse; var Handled: boolean); virtual;
procedure DoBeforeRequest(ARequest: TRequest); virtual;
procedure DoBeforeShowPage(ARequest: TRequest); virtual;
- property WebModule: TFPWebModule read FWebModule;
procedure DoCleanupAfterRequest(const AContentProducer: THTMLContentProducer);
procedure SetRequest(ARequest: TRequest); virtual;
procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
@@ -114,6 +115,7 @@ type
property ContentProducers[Index: integer]: THTMLContentProducer read GetContentProducer;
property HasWebController: boolean read GetHasWebController;
property WebController: TWebController read GetWebController write FWebController;
+ property WebModule: TFPWebModule read FWebModule;
published
property BeforeRequest: TRequestEvent read FBeforeRequest write FBeforeRequest;
property BeforeShowPage: TRequestEvent read FBeforeShowPage write FBeforeShowPage;
@@ -263,7 +265,7 @@ begin
AComponent:=self;
while (i > 0) and (assigned(AComponent)) do
begin
- AComponent := FindComponent(copy(CompName,1,i-1));
+ AComponent := AComponent.FindComponent(copy(CompName,1,i-1));
CompName := copy(compname,i+1,length(compname)-i);
i := pos('$',CompName);
end;
@@ -277,6 +279,7 @@ begin
if ASuffixID<>'' then
begin
SetIdSuffixes(THTMLContentProducer(AComponent));
+ webcontroller.ResetIterationLevel;
end;
THTMLContentProducer(AComponent).HandleAjaxRequest(ARequest, AnAjaxResponse);
end;
@@ -611,7 +614,9 @@ begin
p := copy(qs,1,length(qs)-1);
if p <> '' then
- result := result + ConnectChar + p
+ result := result + ConnectChar + p;
+ if assigned(OnGetURL) then
+ OnGetURL(ParamNames, ParamValues, KeepParams, Action, Result);
end;
procedure TStandardWebController.BindJavascriptCallstackToElement(AComponent: TComponent; AnElement: THtmlCustomElement; AnEvent: string);