paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-11-23 12:09:39 +01:00
Code Issues Packages Projects Releases Wiki Activity

* Fixed never-ending CGI scripts

Browse Source 
git-svn-id: trunk@15698 -
This commit is contained in:
michael 2010-08-03 08:39:55 +00:00
parent 62adc74dc4
commit ea72abc6a5
1 changed files with 22 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
packages/fcl-web/src/base/custweb.pp
View File

@ -96,6 +96,7 @@ Type
FRedirectOnError : Boolean; FRedirectOnError : Boolean;
FRedirectOnErrorURL : String; FRedirectOnErrorURL : String;
FTitle: string; FTitle: string;
FOnTerminate : TNotifyEvent;
protected protected
procedure Terminate; procedure Terminate;
Function GetModuleName(Arequest : TRequest) : string; Function GetModuleName(Arequest : TRequest) : string;
@ -152,6 +153,7 @@ Type
procedure SetOnShowRequestException(const AValue: TOnShowRequestException); procedure SetOnShowRequestException(const AValue: TOnShowRequestException);
procedure SetRedirectOnError(const AValue: boolean); procedure SetRedirectOnError(const AValue: boolean);
procedure SetRedirectOnErrorURL(const AValue: string); procedure SetRedirectOnErrorURL(const AValue: string);
procedure DoOnTerminate(Sender : TObject);
protected protected
Procedure DoRun; override; Procedure DoRun; override;
function InitializeWebHandler: TWebHandler; virtual; abstract; function InitializeWebHandler: TWebHandler; virtual; abstract;
@ -163,7 +165,7 @@ Type
Procedure CreateForm(AClass : TComponentClass; out Reference); Procedure CreateForm(AClass : TComponentClass; out Reference);
Procedure Initialize; override; Procedure Initialize; override;
Procedure Log(EventType: TEventType; const Msg: String); override; Procedure Log(EventType: TEventType; const Msg: String); override;
procedure Terminate; override;
Property HandleGetOnPost : Boolean Read GetHandleGetOnPost Write SetHandleGetOnPost; Property HandleGetOnPost : Boolean Read GetHandleGetOnPost Write SetHandleGetOnPost;
Property RedirectOnError : boolean Read GetRedirectOnError Write SetRedirectOnError; Property RedirectOnError : boolean Read GetRedirectOnError Write SetRedirectOnError;
Property RedirectOnErrorURL : string Read GetRedirectOnErrorURL Write SetRedirectOnErrorURL; Property RedirectOnErrorURL : string Read GetRedirectOnErrorURL Write SetRedirectOnErrorURL;
@ -339,6 +341,8 @@ end;
procedure TWebHandler.Terminate; procedure TWebHandler.Terminate;
begin begin
FTerminated := true; FTerminated := true;
If Assigned(FOnTerminate) then
FOnTerminate(Self);
end; end;
function TWebHandler.GetModuleName(Arequest: TRequest): string; function TWebHandler.GetModuleName(Arequest: TRequest): string;
@ -553,6 +557,13 @@ end;
constructor TCustomWebApplication.Create(AOwner: TComponent); constructor TCustomWebApplication.Create(AOwner: TComponent);
begin begin
FWebHandler := InitializeWebHandler; FWebHandler := InitializeWebHandler;
FWebHandler.FOnTerminate:=@DoOnTerminate;
end;
procedure TCustomWebApplication.DoOnTerminate(Sender : TObject);
begin
If Not Terminated then
Terminate;
end; end;
destructor TCustomWebApplication.Destroy; destructor TCustomWebApplication.Destroy;
@ -578,4 +589,14 @@ begin
EventLog.log(EventType,Msg); EventLog.log(EventType,Msg);
end; end;
Procedure TCustomWebApplication.Terminate;
begin
Inherited;
If Not Webhandler.FTerminated then
WebHandler.Terminate;
end;
end. end.