diff --git a/packages/fcl-web/src/base/fphtml.pp b/packages/fcl-web/src/base/fphtml.pp index 008a7a58b9..7f977b2b4b 100644 --- a/packages/fcl-web/src/base/fphtml.pp +++ b/packages/fcl-web/src/base/fphtml.pp @@ -57,6 +57,7 @@ type procedure RedrawContentProducer(AContentProducer: THTMLContentProducer); virtual; procedure CallServerEvent(AHTMLContentProducer: THTMLContentProducer; AEvent: Integer; APostVariable: string = ''); virtual; procedure Clear; virtual; + procedure Redirect(AUrl: string); virtual; function ScriptIsEmpty: Boolean; virtual; function GetScript: String; virtual; property WebController: TWebController read GetWebController; @@ -66,6 +67,7 @@ type TWebController = class(TComponent) private + FAddRelURLPrefix: boolean; FBaseURL: string; FMessageBoxHandler: TMessageBoxHandler; FScriptName: string; @@ -95,6 +97,7 @@ type function MessageBox(AText: String; Buttons: TWebButtons; ALoaded: string = ''): string; virtual; function DefaultMessageBoxHandler(Sender: TObject; AText: String; Buttons: TWebButtons; ALoaded: string = ''): string; virtual; abstract; function CreateNewScript: TStringList; virtual; abstract; + function AddrelativeLinkPrefix(AnURL: string): string; procedure FreeScript(var AScript: TStringList); virtual; abstract; property ScriptFileReferences: TStringList read GetScriptFileReferences; property Scripts: TFPObjectList read GetScripts; @@ -103,6 +106,7 @@ type published property BaseURL: string read FBaseURL write SetBaseURL; property ScriptName: string read FScriptName write SetScriptName; + property AddRelURLPrefix: boolean read FAddRelURLPrefix write FAddRelURLPrefix; end; { TAjaxResponse } @@ -205,7 +209,7 @@ type property AcceptChildsAtDesignTime: boolean read FAcceptChildsAtDesignTime; property parent: TComponent read FParent write SetParent; end; - THTMLContentProducerClas = class of THTMLContentProducer; + THTMLContentProducerClass = class of THTMLContentProducer; TWriterElementEvent = procedure (Sender:THTMLContentProducer; aWriter : THTMLWriter; var anElement : THTMLCustomElement) of object; @@ -491,6 +495,11 @@ begin FScript.Clear; end; +procedure TJavaScriptStack.Redirect(AUrl: string); +begin + AddScriptLine('window.location = "'+AUrl+'";'); +end; + function TJavaScriptStack.ScriptIsEmpty: Boolean; begin result := FScript.Count=0; @@ -1241,6 +1250,16 @@ begin result := DefaultMessageBoxHandler(self,AText,Buttons,ALoaded); end; +function TWebController.AddrelativeLinkPrefix(AnURL: string): string; +var + i: Integer; +begin + if FAddRelURLPrefix and (AnURL<>'') and (copy(AnURL,1,1)<>'/') and assigned(Owner) and (owner is TWebPage) and assigned(TWebPage(Owner).Request) then + result := TWebPage(Owner).Request.LocalPathPrefix + AnURL + else + result := AnURL; +end; + function TWebController.GetRequest: TRequest; begin if assigned(Owner) and (owner is TWebPage) then