mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-11-18 11:59:25 +01:00
153 lines
3.8 KiB
ObjectPascal
153 lines
3.8 KiB
ObjectPascal
{
|
|
$Id: header,v 1.1 2000/07/13 06:33:45 michael Exp $
|
|
This file is part of the Free Component Library (FCL)
|
|
Copyright (c) 1999-2000 by the Free Pascal development team
|
|
|
|
See the file COPYING.FPC, included in this distribution,
|
|
for details about the copyright.
|
|
|
|
This program is distributed in the hope that it will be useful,
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
|
|
|
**********************************************************************}
|
|
{$mode objfpc}
|
|
{$H+}
|
|
unit fpcgi;
|
|
|
|
interface
|
|
|
|
uses SysUtils,Classes,CustCgi,httpDefs,fpHTTP;
|
|
|
|
Type
|
|
|
|
{ TCGIApplication }
|
|
TGetModuleEvent = Procedure (Sender : TObject; ARequest : TRequest;
|
|
Var ModuleClass : TCustomHTTPModuleClass) of object;
|
|
|
|
TCGIApplication = Class(TCustomCGIApplication)
|
|
private
|
|
FModuleVar: String;
|
|
FOnGetModule: TGetModuleEvent;
|
|
FAllowDefaultModule: Boolean;
|
|
Protected
|
|
Function GetModuleName(Arequest : TRequest) : string;
|
|
function FindModule(ModuleClass : TCustomHTTPModuleClass): TCustomHTTPModule;
|
|
Public
|
|
Constructor Create(AOwner : TComponent); override;
|
|
Procedure CreateForm(AClass : TComponentClass; Var Reference : TComponent);
|
|
Procedure handleRequest(ARequest : TRequest; AResponse : TResponse); override;
|
|
Property OnGetModule : TGetModuleEvent Read FOnGetModule Write FOnGetModule;
|
|
Property ModuleVariable : String Read FModuleVar Write FModuleVar;
|
|
Property AllowDefaultModule : Boolean Read FAllowDefaultModule Write FAllowDefaultModule;
|
|
end;
|
|
|
|
EFPCGIError = Class(Exception);
|
|
|
|
Var
|
|
Application : TCGIApplication;
|
|
ShowCleanUpErrors : Boolean = False;
|
|
|
|
Implementation
|
|
|
|
resourcestring
|
|
SErrNoModuleNameForRequest = 'Could not determine HTTP module name for request';
|
|
SErrNoModuleForRequest = 'Could not determine HTTP module for request "%s"';
|
|
|
|
Procedure InitCGI;
|
|
|
|
begin
|
|
Application:=TCGIApplication.Create(Nil);
|
|
end;
|
|
|
|
Procedure DoneCGI;
|
|
|
|
begin
|
|
Try
|
|
FreeAndNil(Application);
|
|
except
|
|
if ShowCleanUpErrors then
|
|
Raise;
|
|
end;
|
|
end;
|
|
|
|
{ TCGIApplication }
|
|
|
|
function TCGIApplication.GetModuleName(Arequest: TRequest): string;
|
|
|
|
|
|
begin
|
|
If (FModuleVar<>'') then
|
|
Result:=ARequest.QueryFields.Values[FModuleVar];
|
|
If (Result='') then
|
|
Result:=ARequest.GetNextPathInfo;
|
|
end;
|
|
|
|
function TCGIApplication.FindModule(ModuleClass : TCustomHTTPModuleClass): TCustomHTTPModule;
|
|
|
|
Var
|
|
I : Integer;
|
|
|
|
begin
|
|
I:=ComponentCount-1;
|
|
While (I>=0) and (Not (Components[i] is ModuleClass)) do
|
|
Dec(i);
|
|
if (I>=0) then
|
|
Result:=Components[i] as TCustomHTTPModule
|
|
else
|
|
Result:=Nil;
|
|
end;
|
|
|
|
constructor TCGIApplication.Create(AOwner: TComponent);
|
|
begin
|
|
inherited Create(AOwner);
|
|
FModuleVar:='Module'; // Do not localize
|
|
FAllowDefaultModule:=True;
|
|
end;
|
|
|
|
procedure TCGIApplication.CreateForm(AClass: TComponentClass;
|
|
var Reference: TComponent);
|
|
begin
|
|
Reference:=AClass.Create(Self);
|
|
end;
|
|
|
|
procedure TCGIApplication.HandleRequest(ARequest: TRequest; AResponse: TResponse);
|
|
|
|
Var
|
|
MC : TCustomHTTPModuleClass;
|
|
M : TCustomHTTPModule;
|
|
MN : String;
|
|
MI : TModuleItem;
|
|
|
|
begin
|
|
MC:=Nil;
|
|
If (OnGetModule<>Nil) then
|
|
OnGetModule(Self,ARequest,MC);
|
|
If (MC=Nil) then
|
|
begin
|
|
MN:=GetModuleName(ARequest);
|
|
If (MN='') and Not AllowDefaultModule then
|
|
Raise EFPCGIError.Create(SErrNoModuleNameForRequest);
|
|
MI:=ModuleFactory.FindModule(MN);
|
|
If (MI=Nil) and (ModuleFactory.Count=1) then
|
|
MI:=ModuleFactory[0];
|
|
if (MI=Nil) then
|
|
begin
|
|
Raise EFPCGIError.CreateFmt(SErrNoModuleForRequest,[MN]);
|
|
end;
|
|
MC:=MI.ModuleClass;
|
|
M:=FindModule(MC); // Check if a module exists already
|
|
end;
|
|
If (M=Nil) then
|
|
M:=MC.Create(Self);
|
|
M.HandleRequest(ARequest,AResponse);
|
|
end;
|
|
|
|
Initialization
|
|
InitCGI;
|
|
|
|
Finalization
|
|
DoneCGI;
|
|
|
|
end.
|