* Added BaseURL, and support for additional encodings. Implemented CGI testbed application

git-svn-id: trunk@15322 -

.gitattributes

@@ -2188,6 +2188,8 @@ packages/fcl-web/src/httpdefs.pp svneol=native#text/plain
 packages/fcl-web/src/webpage.pp svneol=native#text/plain
 packages/fcl-web/src/websession.pp svneol=native#text/plain
 packages/fcl-web/src/webutil.pp svneol=native#text/plain
+packages/fcl-web/tests/testcgiapp.lpi svneol=native#text/plain
+packages/fcl-web/tests/testcgiapp.pp svneol=native#text/plain
 packages/fcl-xml/Makefile svneol=native#text/plain
 packages/fcl-xml/Makefile.fpc svneol=native#text/plain
 packages/fcl-xml/fpmake.pp svneol=native#text/plain

packages/fcl-web/src/custcgi.pp

@@ -374,13 +374,20 @@ Function TCGIRequest.GetFieldValue(Index : Integer) : String;
 
 begin
   Case Index of
-    25 : Result:=Decodevar(5); // Property PathInfo
+    21,
+    34 : Result:=DecodeVar(14); // Property ServerName and Host
+    25 : begin
+         Result:=Decodevar(5); // Property PathInfo
+         If (Result='') then
+           Result:=Decodevar(34); // Property Request URI
+         end;
     26 : Result:=DecodeVar(6); // Property PathTranslated
     27 : Result:=DecodeVar(8); // Property RemoteAddress
     28 : Result:=DecodeVar(9); // Property RemoteHost
     29 : Result:=DecodeVar(13); // Property ScriptName
     30 : Result:=DecodeVar(15); // Property ServerPort
     31 : Result:=DecodeVar(12); // Property RequestMethod
+    32 : Result:=DecodeVar(34); // Property URI
     33 : Result:=DecodeVar(7); // Property QueryString
     36 : Result:=DecodeVar(36); // Property XRequestedWith
   else

packages/fcl-web/src/custweb.pp

@@ -80,6 +80,7 @@ Type
   Private
     FAdministrator: String;
     FAllowDefaultModule: Boolean;
+    FApplicationURL: String;
     FEmail: String;
     FModuleVar: String;
     FOnGetModule: TGetModuleEvent;
@@ -95,6 +96,8 @@ Type
     function WaitForRequest(out ARequest : TRequest; out AResponse : TResponse) : boolean; virtual; abstract;
     procedure EndRequest(ARequest : TRequest;AResponse : TResponse); virtual;
     function FindModule(ModuleClass : TCustomHTTPModuleClass): TCustomHTTPModule;
+    Procedure SetBaseURL(AModule : TCustomHTTPModule; Const AModuleName : String; ARequest : TRequest); virtual;
+    function GetApplicationURL(ARequest : TRequest): String; virtual;
     Procedure DoRun; override;
     procedure ShowRequestException(R: TResponse; E: Exception); virtual;
     Function GetEmail : String; virtual;
@@ -111,6 +114,7 @@ Type
     Property HandleGetOnPost : Boolean Read FHandleGetOnPost Write FHandleGetOnPost;
     Property RedirectOnError : boolean Read FRedirectOnError Write FRedirectOnError;
     Property RedirectOnErrorURL : string Read FRedirectOnErrorURL Write FRedirectOnErrorURL;
+    Property ApplicationURL : String Read FApplicationURL Write FApplicationURL;
     Property Request : TRequest read FRequest;
     Property AllowDefaultModule : Boolean Read FAllowDefaultModule Write FAllowDefaultModule;
     Property ModuleVariable : String Read FModuleVar Write FModuleVar;
@@ -253,20 +257,15 @@ begin
     If (MC=Nil) then
       begin
       MN:=GetModuleName(ARequest);
-      If (MN='') and Not AllowDefaultModule then
-        Raise EFPWebError.Create(SErrNoModuleNameForRequest);
       MI:=ModuleFactory.FindModule(MN);
-      If (MI=Nil) and (ModuleFactory.Count=1) then
-        MI:=ModuleFactory[0];
       if (MI=Nil) then
-        begin
         Raise EFPWebError.CreateFmt(SErrNoModuleForRequest,[MN]);
-        end;
       MC:=MI.ModuleClass;
       end;
     M:=FindModule(MC); // Check if a module exists already
     If (M=Nil) then
       M:=MC.Create(Self);
+    SetBaseURL(M,MN,ARequest);
     if M.Kind=wkOneShot then
       begin
       try
@@ -302,19 +301,43 @@ begin
   Result := FEventLog;
 end;
 
+function TCustomWebApplication.GetApplicationURL(ARequest: TRequest): String;
+begin
+  Result:=FApplicationURL;
+  If (Result='') then
+    Result:=ARequest.ScriptName;
+end;
+
 function TCustomWebApplication.GetModuleName(Arequest: TRequest): string;
+
+   Function GetDefaultModuleName : String;
+
+   begin
+      If (ModuleFactory.Count=1) then
+        Result:=ModuleFactory[0].ModuleName;
+   end;
+
 var
   S : String;
+  I : Integer;
+
 begin
   If (FModuleVar<>'') then
     Result:=ARequest.QueryFields.Values[FModuleVar];//Module name from query parameter using the FModuleVar as parameter name (default is 'Module')
   If (Result='') then
     begin
     S:=ARequest.PathInfo;
-    Delete(S,1,1);
-    if (Pos('/',S) <= 0) and AllowDefaultModule then
-      Exit;//There is only 1 '/' in ARequest.PathInfo -> only ActionName is there -> use default module
-    Result:=ARequest.GetNextPathInfo;
+    If (Length(S)>0) and (S[1]='/') then
+      Delete(S,1,1);
+    I:=Pos('/',S);
+    if (I>0) then
+      Result:=ARequest.GetNextPathInfo;
+    end;
+  If (Result='') then
+    begin
+    if Not AllowDefaultModule then
+      Raise EFPWebError.Create(SErrNoModuleNameForRequest);
+    Result:=GetDefaultModuleName
     end;
 end;
 
@@ -337,6 +360,25 @@ begin
     Result:=Nil;
 end;
 
+procedure TCustomWebApplication.SetBaseURL(AModule: TCustomHTTPModule;
+  Const AModuleName : String; ARequest: TRequest);
+
+Var
+  S,P : String;
+
+begin
+  S:=IncludeHTTPPathDelimiter(GetApplicationURL(ARequest));
+  P:=IncludeHTTPPathDelimiter(ARequest.ProcessedPathinfo);
+  If (P='') or (P='/') then
+    P:=IncludeHTTPPathDelimiter(AModuleName);
+  if (Length(P)>0) and (P[1]='/') then
+    Delete(P,1,1);
+{$ifdef CGIDEBUG}
+  senddebug(Format('SetBaseURL : "%s" "%s"',[S,P]));
+{$endif CGIDEBUG}
+  AModule.BaseURL:=S+P;
+end;
+
 procedure TCustomWebApplication.DoHandleRequest(ARequest: TRequest; AResponse: TResponse);
 begin
   HandleRequest(ARequest,AResponse);

packages/fcl-web/src/fpapache.pp

@@ -83,6 +83,7 @@ Type
     Procedure DoRun; override;
     function WaitForRequest(out ARequest : TRequest; out AResponse : TResponse) : boolean; override;
     Function AllowRequest(P : PRequest_Rec) : Boolean; virtual;
+    function GetApplicationURL(ARequest : TRequest): String; override;
   Public
     Constructor Create(AOwner : TComponent); override;
     Destructor Destroy; override;
@@ -247,6 +248,14 @@ begin
     FBeforeRequest(Self,HN,Result);
 end;
 
+function TCustomApacheApplication.GetApplicationURL(ARequest: TRequest
+  ): String;
+begin
+  Result:=inherited GetApplicationURL(ARequest);
+  If (Result='') then
+    Result:=BaseLocation;
+end;
+
 constructor TCustomApacheApplication.Create(AOwner: TComponent);
 begin
   inherited Create(AOwner);
@@ -493,7 +502,7 @@ Constructor TApacheRequest.CreateReq(App : TCustomApacheApplication; ARequest :
 begin
   FApache:=App;
   FRequest:=Arequest;
-  ReturnedPathInfo:=App.BaseLocation;
+  ProcessedPathInfo:=App.BaseLocation;
   Inherited Create;
   InitFromRequest;
 end;

packages/fcl-web/src/fphttp.pp

@@ -34,6 +34,7 @@ Type
     FAfterResponse: TResponseEvent;
     FBeforeRequest: TRequestEvent;
     FRequest      : TRequest;
+    FResponse: TResponse;
   Protected
     Procedure DoHandleRequest(ARequest : TRequest; AResponse : TResponse; Var Handled : Boolean); virtual;
     Procedure DoGetContent(ARequest : TRequest; Content : TStream; Var Handled : Boolean); virtual;
@@ -48,6 +49,7 @@ Type
     Function  HaveContent : Boolean; virtual;
     function ContentToStream(Stream : TStream) : boolean; virtual;
     Property Request : TRequest Read FRequest;
+    Property Response : TResponse Read FResponse;
   end;
   
   { TCustomWebAction }
@@ -102,10 +104,12 @@ Type
 
   TCustomHTTPModule = Class(TDataModule)
   private
+    FBaseURL: String;
     FWebModuleKind: TWebModuleKind;
   public
     Procedure HandleRequest(ARequest : TRequest; AResponse : TResponse); virtual; abstract;
     property Kind: TWebModuleKind read FWebModuleKind write FWebModuleKind default wkPooled;
+    Property BaseURL : String Read FBaseURL Write FBaseURL;
   end;
   
   TCustomHTTPModuleClass = Class of TCustomHTTPModule;
@@ -250,6 +254,7 @@ Var
   M : TMemoryStream;
   
 begin
+  FResponse:=AResponse;
   M:=TMemoryStream.Create;
   DoGetContent(ARequest,M,Handled);
   AResponse.ContentStream:=M;

packages/fcl-web/src/httpdefs.pp

@@ -267,7 +267,7 @@ type
     FHandleGetOnPost: Boolean;
     FURI: String;
     FFiles : TUploadedFiles;
-    FReturnedPathInfo : String;
+    FProcessedPathInfo : String;
     procedure ParseFirstHeaderLine(const line: String);override;
     function GetFirstHeaderLine: String;
   Protected
@@ -282,11 +282,11 @@ type
     Procedure InitRequestVars; virtual;
     Procedure InitPostVars; virtual;
     Procedure InitGetVars; virtual;
-    Property ReturnedPathInfo : String Read FReturnedPathInfo Write FReturnedPathInfo;
   public
     constructor Create; override;
     destructor destroy; override;
     Function  GetNextPathInfo : String;
+    Property  ProcessedPathInfo : String Read FProcessedPathInfo Write FProcessedPathInfo;
     Property  CommandLine : String Read FCommandLine;
     Property  Command : String read FCommand;
     Property  URI : String read FURI;                // Uniform Resource Identifier
@@ -377,6 +377,7 @@ type
 
 Function HTTPDecode(const AStr: String): String;
 Function HTTPEncode(const AStr: String): String;
+Function IncludeHTTPPathDelimiter(const AStr: String): String;
 
 implementation
 
@@ -503,6 +504,18 @@ begin
   SetLength(Result,R-PChar(Result));
 end;
 
+function IncludeHTTPPathDelimiter(const AStr: String): String;
+
+Var
+  l : Integer;
+
+begin
+  Result:=AStr;
+  L:=Length(Result);
+  If (L>0) and (Result[L]<>'/') then
+    Result:=Result+'/';
+end;
+
 
 { ---------------------------------------------------------------------
   THTTPHeader
@@ -921,20 +934,19 @@ Var
   
 begin
   P:=PathInfo;
+{$ifdef CGIDEBUG}SendDebug(Format('Pathinfo: "%s" "%s"',[P,FProcessedPathInfo]));{$ENDIF}
   if (P <> '') and (P[length(P)] = '/') then
     Delete(P, length(P), 1);//last char is '/'
   If (P<>'') and (P[1]='/') then
     Delete(P,1,1);
+  Delete(P,1,Length(IncludeHTTPPathDelimiter(FProcessedPathInfo)));
+ {$ifdef CGIDEBUG}SendDebug(Format('Pathinfo: "%s" "%s"',[P,FProcessedPathInfo]));{$ENDIF}
   I:=Pos('/',P);
-  If (I>0) then
-  begin//only if there was a module name, otherwise only the action name is there
-    Delete(P,1,Length(FReturnedPathInfo));
-    I:=Pos('/',P);
-  end;
   If (I=0) then
     I:=Length(P)+1;
   Result:=Copy(P,1,I-1);
-  FReturnedPathInfo:=FReturnedPathInfo+'/'+Result;
+  FProcessedPathInfo:=IncludeHTTPPathDelimiter(FProcessedPathInfo)+Result;
+ {$ifdef CGIDEBUG}SendDebug(Format('Pathinfo: "%s" "%s" : %s',[P,FProcessedPathInfo,Result]));{$ENDIF}
 end;
 
 procedure TRequest.ParseFirstHeaderLine(const line: String);
@@ -1157,29 +1169,25 @@ begin
   SendMethodEnter('InitPostVars');
 {$endif}
   CL:=ContentLength;
-  M:=TCapacityStream.Create;
-  Try
-    if CL<>0 then
-      begin
-      M.Capacity:=Cl;
-      M.WriteBuffer(Content[1], Cl);
-      end;
-    M.Position:=0;
-    CT:=ContentType;
-    if Pos('MULTIPART/FORM-DATA',Uppercase(CT))<>0 then
-      ProcessMultiPart(M,CT, ContentFields)
-    else if Pos('APPLICATION/X-WWW-FORM-URLENCODED',Uppercase(CT))<>0 then
-      ProcessUrlEncoded(M, ContentFields)
-    else if CL<>0 then
-      begin
-{$ifdef CGIDEBUG}
-      SendDebug('InitPostVars: unsupported content type:'+CT);
-{$endif}
-      Raise Exception.CreateFmt(SErrUnsupportedContentType,[CT]);
-      end;
-  finally
-    M.Free;
-  end;
+  if CL<>0 then
+    begin
+    M:=TCapacityStream.Create;
+    Try
+      if CL<>0 then
+        begin
+        M.Capacity:=Cl;
+        M.WriteBuffer(Content[1], Cl);
+        end;
+      M.Position:=0;
+      CT:=ContentType;
+      if Pos('MULTIPART/FORM-DATA',Uppercase(CT))<>0 then
+        ProcessMultiPart(M,CT, ContentFields)
+      else if Pos('APPLICATION/X-WWW-FORM-URLENCODED',Uppercase(CT))<>0 then
+        ProcessUrlEncoded(M, ContentFields)
+    finally
+     M.Free;
+    end;
+    end;
 {$ifdef CGIDEBUG}
   SendMethodExit('InitPostVars');
 {$endif}

packages/fcl-web/src/webutil.pp

@@ -20,13 +20,13 @@ interface
 uses
   Classes, SysUtils, httpdefs;
 
-procedure DumpRequest (ARequest : TRequest; Dump : TStrings);
+procedure DumpRequest (ARequest : TRequest; Dump : TStrings; Environment : Boolean = False);
 
 implementation
 
 
 
-procedure DumpRequest (ARequest : TRequest; Dump : TStrings);
+procedure DumpRequest (ARequest : TRequest; Dump : TStrings; Environment : Boolean = False);
 
   Procedure AddNV(Const N,V : String);
   
@@ -35,7 +35,7 @@ procedure DumpRequest (ARequest : TRequest; Dump : TStrings);
   end;
 
 Var
-  I   : integer;
+  I,J   : integer;
   N,V : String;
 begin
   With ARequest, Dump do
@@ -88,6 +88,23 @@ begin
         end;
       Add('</TABLE><P>');
       end;
+    If Environment then
+      begin
+      Add('<H1>Environment variables: ('+IntToStr(GetEnvironmentVariableCount)+') </H1>');
+      Add('<TABLE BORDER="1"><TR><TD>Name</TD><TD>Value</TD></TR>');
+      For I:=1 to GetEnvironmentVariableCount do
+        begin
+        V:=GetEnvironmentString(i);
+        j:=Pos('=',V);
+        If (J>0) then
+          begin
+          N:=Copy(V,1,J-1);
+          system.Delete(V,1,J);
+          AddNV(N,V);
+          end;
+        end;
+      Add('</TABLE><P>');
+      end;
     If (Files.Count>0) then
       begin
       Add('<H1>Uploaded files: ('+IntToStr(Files.Count)+') </H1>');

packages/fcl-web/tests/testcgiapp.lpi

@@ -0,0 +1,75 @@
+<?xml version="1.0"?>
+<CONFIG>
+  <ProjectOptions>
+    <Version Value="7"/>
+    <General>
+      <Flags>
+        <SaveOnlyProjectUnits Value="True"/>
+        <MainUnitHasCreateFormStatements Value="False"/>
+        <MainUnitHasTitleStatement Value="False"/>
+        <UseDefaultCompilerOptions Value="True"/>
+      </Flags>
+      <SessionStorage Value="InProjectDir"/>
+      <MainUnit Value="0"/>
+      <TargetFileExt Value=""/>
+      <ResourceType Value="res"/>
+      <UseXPManifest Value="True"/>
+      <Icon Value="0"/>
+    </General>
+    <VersionInfo>
+      <Language Value=""/>
+      <CharSet Value=""/>
+      <StringTable Comments="" CompanyName="" FileDescription="" FileVersion="" InternalName="" LegalCopyright="" LegalTrademarks="" OriginalFilename="" ProductName="" ProductVersion=""/>
+    </VersionInfo>
+    <PublishOptions>
+      <Version Value="2"/>
+      <IgnoreBinaries Value="False"/>
+      <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
+      <ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
+    </PublishOptions>
+    <RunParams>
+      <local>
+        <FormatVersion Value="1"/>
+        <LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
+      </local>
+    </RunParams>
+    <Units Count="1">
+      <Unit0>
+        <Filename Value="testcgiapp.pp"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="testcgiapp"/>
+      </Unit0>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="8"/>
+    <Target>
+      <Filename Value="testcgiapp"/>
+    </Target>
+    <SearchPaths>
+      <IncludeFiles Value="$(ProjOutDir)/"/>
+      <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
+    </SearchPaths>
+    <Parsing>
+      <SyntaxOptions>
+        <UseAnsiStrings Value="True"/>
+      </SyntaxOptions>
+    </Parsing>
+    <Other>
+      <CompilerPath Value="$(CompPath)"/>
+    </Other>
+  </CompilerOptions>
+  <Debugging>
+    <Exceptions Count="3">
+      <Item1>
+        <Name Value="EAbort"/>
+      </Item1>
+      <Item2>
+        <Name Value="ECodetoolError"/>
+      </Item2>
+      <Item3>
+        <Name Value="EFOpenError"/>
+      </Item3>
+    </Exceptions>
+  </Debugging>
+</CONFIG>

packages/fcl-web/tests/testcgiapp.pp

@@ -0,0 +1,277 @@
+program testcgiapp;
+
+{$mode objfpc}{$H+}
+
+uses
+  Classes, SysUtils, CustApp, inifiles, process, httpdefs,custcgi
+  { you can add units after this };
+
+type
+
+  { TTestCGIApplication }
+
+  TTestCGIApplication = class(TCustomApplication)
+  private
+    FCGB: String;
+    FCGIE: TStrings;
+    FCGV: TStrings;
+    FMethod: String;
+    Foutput: String;
+    FPostData: String;
+    FPathInfo : String;
+    FScriptName: String;
+    FURL: String;
+    procedure CheckEnvironment;
+    procedure CheckMethod;
+    procedure ProcessConfig;
+    procedure RunCGI;
+  protected
+    Property CGIEnvironment : TStrings Read FCGIE Write FCGIE;
+    Property URL : String Read FURL Write FURL;
+    Property PostData : String Read FPostData Write FPostData;
+    Property Method : String Read FMethod Write FMethod;
+    Property CGIOutput : String Read Foutput Write FOutput;
+    Property CGIBinary : String Read FCGB Write FCGB;
+    Property CGIVariables : TStrings Read FCGV Write FCGV;
+    Property PathInfo : String Read FPathInfo Write FPathInfo;
+    Property ScriptName : String Read FScriptName Write FScriptName;
+    procedure DoRun; override;
+  public
+    constructor Create(TheOwner: TComponent); override;
+    Destructor Destroy; override;
+    procedure WriteHelp; virtual;
+  end;
+
+{ TTestCGIApplication }
+
+Resourcestring
+   SErrUnsupportedMethod = 'Unsupported method: "%s"';
+   SErrNoCGIBinary       = 'No CGI binary specified';
+
+Const
+  SConfig        = 'Config';
+  KeyURL         = 'URL';
+  KeyEnvironment = 'Environment';
+  KeyMethod      = 'Method';
+  KeyPost        = 'PostData';
+
+  SEnvironment   = KeyEnvironment;
+  SVariables     = 'Variables';
+
+
+procedure TTestCGIApplication.ProcessConfig;
+
+Var
+  Ini : TInifile;
+  S : String;
+
+begin
+  Ini:=TIniFile.Create(GetOptionValue('c','config'));
+  try
+    With Ini do
+      begin
+      URL:=ReadString(SConfig,KeyURL,'');
+      S:=ReadString(SConfig,KeyEnvironment,'');
+      If (S<>'') and FileExists(S) then
+        CGIEnvironment.LoadFromFile(S);
+      If SectionExists(SEnvironment) then
+        ReadSectionValues(SEnvironment,CGIEnvironment);
+      If SectionExists(SVariables) then
+        ReadSectionValues(SVariables,CGIVariables);
+      If (Method='') then
+        Method:=ReadString(SConfig,KeyMethod,'GET');
+      PostData:=ReadString(SConfig,KeyPost,'');
+
+      end;
+  finally
+    Ini.Free;
+  end;
+end;
+
+procedure TTestCGIApplication.RunCGI;
+
+Var
+  Proc : TProcess;
+
+begin
+  If (CGIBinary='') then
+      Raise Exception.Create(SerrNoCGIBinary);
+  Proc:=TProcess.Create(Self);
+  try
+    Proc.CommandLine:=CGIBinary;
+    Proc.Environment:=CGIEnvironment;
+    Proc.Execute;
+
+  finally
+    Proc.Free;
+  end;
+end;
+
+procedure TTestCGIApplication.CheckMethod;
+
+begin
+  If (Method='') then
+    Method:='GET'
+  else
+    begin
+    Method:=Uppercase(Method);
+    If (Method<>'POST') and (Method<>'GET') then
+      Raise Exception.CreateFmt(SerrUnsupportedMethod,['METHOD']);
+    end;
+end;
+(*
+   ({ 1: 'AUTH_TYPE'               } fieldWWWAuthenticate, // ?
+    { 2: 'CONTENT_LENGTH'          } FieldContentLength,
+    { 3: 'CONTENT_TYPE'            } FieldContentType,
+    { 4: 'GATEWAY_INTERFACE'       } '',
+    { 5: 'PATH_INFO'               } '',
+    { 6: 'PATH_TRANSLATED'         } '',
+    { 7: 'QUERY_STRING'            } '',
+    { 8: 'REMOTE_ADDR'             } '',
+    { 9: 'REMOTE_HOST'             } '',
+    { 10: 'REMOTE_IDENT'           } '',
+    { 11: 'REMOTE_USER'            } '',
+    { 12: 'REQUEST_METHOD'         } '',
+    { 13: 'SCRIPT_NAME'            } '',
+    { 14: 'SERVER_NAME'            } '',
+    { 15: 'SERVER_PORT'            } '',
+    { 16: 'SERVER_PROTOCOL'        } '',
+    { 17: 'SERVER_SOFTWARE'        } '',
+    { 18: 'HTTP_ACCEPT'            } FieldAccept,
+    { 19: 'HTTP_ACCEPT_CHARSET'    } FieldAcceptCharset,
+    { 20: 'HTTP_ACCEPT_ENCODING'   } FieldAcceptEncoding,
+    { 21: 'HTTP_IF_MODIFIED_SINCE' } FieldIfModifiedSince,
+    { 22: 'HTTP_REFERER'           } FieldReferer,
+    { 23: 'HTTP_USER_AGENT'        } FieldUserAgent,
+    { 24: 'HTTP_COOKIE'            } FieldCookie,
+     // Additional Apache vars
+    { 25: 'HTTP_CONNECTION'        } FieldConnection,
+    { 26: 'HTTP_ACCEPT_LANGUAGE'   } FieldAcceptLanguage,
+    { 27: 'HTTP_HOST'              } '',
+    { 28: 'SERVER_SIGNATURE'       } '',
+    { 29: 'SERVER_ADDR'            } '',
+    { 30: 'DOCUMENT_ROOT'          } '',
+    { 31: 'SERVER_ADMIN'           } '',
+    { 32: 'SCRIPT_FILENAME'        } '',
+    { 33: 'REMOTE_PORT'            } '',
+    { 34: 'REQUEST_URI'            } '',
+    { 35: 'CONTENT'                } '',
+    { 36: 'XHTTPREQUESTEDWITH'     } ''
+
+*)
+
+procedure TTestCGIApplication.CheckEnvironment;
+
+Var
+  L : TStrings;
+  S,N,V : String;
+  I : Integer;
+
+begin
+  L:=CGIEnvironment;
+  If L.IndexOfName('REQUEST_METHOD')=-1 then
+    L.Values['REQUEST_METHOD']:=Method;
+  S:=ScriptName;
+  If (S='') then
+    S:=CGIBinary;
+  If L.IndexOfName('SCRIPT_NAME')=-1 then
+    L.Values['SCRIPT_NAME']:=S;
+  If L.IndexOfName('SCRIPT_FILENAME')=-1 then
+    L.Values['SCRIPT_FILENAME']:=S;
+  If (PathInfo<>'') then
+    L.Values['PATH_INFO']:=PathInfo;
+  If (Method='GET') then
+    begin
+    If L.IndexOfName('QUERY_STRING')=-1 then
+      begin
+      S:='';
+      If (CGIVariables.Count>0) then
+        For I:=0 to CGIVariables.Count-1 do
+          begin
+          CGIVariables.GetNameValue(I,N,V);
+          If (S<>'') then
+            S:=S+'&';
+          S:=S+N+'='+HTTPEncode(V);
+          end;
+       L.Add('QUERY_STRING='+S)
+       end;
+    end
+end;
+
+
+procedure TTestCGIApplication.DoRun;
+var
+  ErrorMsg: String;
+begin
+  // parse parameters
+  if HasOption('h','help') then begin
+    WriteHelp;
+    Terminate;
+    Exit;
+  end;
+  if HasOption('c','config') then
+    ProcessConfig;
+  If HasOption('u','url') then
+    URL:=GetOptionValue('u','url');
+  If HasOption('e','environment') then
+    CGIEnvironment.LoadFromFile(GetOptionValue('e','environment'));
+  If HasOption('o','output') then
+    CGIOutput:=GetOptionValue('o','output');
+  If HasOption('m','method') then
+    Method:=GetOptionValue('m','method');
+  If HasOption('p','pathinfo') then
+    PathInfo:=GetOptionValue('p','pathinfo');
+  If HasOption('s','scriptname') then
+    ScriptName:=GetOptionValue('s','scriptname');
+  If HasOption('r','variables') then
+    CGIOutput:=GetOptionValue('v','variables');
+  If HasOption('i','input') then
+    CGIBinary:=GetOptionValue('i','input');
+  CheckMethod;
+  CheckEnvironment;
+  RunCGI;
+  { add your program here }
+  // stop program loop
+  Terminate;
+end;
+
+constructor TTestCGIApplication.Create(TheOwner: TComponent);
+begin
+  inherited Create(TheOwner);
+  StopOnException:=True;
+  FCGIE:=TStringList.Create;
+  FCGV:=TStringList.Create;
+end;
+
+destructor TTestCGIApplication.Destroy;
+begin
+  FreeAndNil(FCGIE);
+  FreeAndNil(FCGV);
+  inherited Destroy;
+end;
+
+procedure TTestCGIApplication.WriteHelp;
+begin
+  Writeln('Usage: ',ExeName,' [options]');
+  Writeln('Where options is one of : ');
+  Writeln(' -h         this help');
+  Writeln(' -c|--config=file         use file for configuration');
+  Writeln(' -e|--environment=file    use file for CGI environment (overrides config).');
+  Writeln(' -i|--input=file          use file as CGI binary.');
+  Writeln(' -m|--method=method       use method to invoke CGI (overrides config, default is GET).');
+  Writeln(' -o|--output=file         use file for CGI output (overrides config).');
+  Writeln(' -p|--pathinfo=path       use path for PATH_INFO environment variable (overrides config).');
+  Writeln(' -r|--variables=file      read query variables from file (overrides config).');
+  Writeln(' -u|--url=URL             use URL as the URL (overrides config).');
+end;
+
+var
+  Application: TTestCGIApplication;
+
+begin
+  Application:=TTestCGIApplication.Create(nil);
+  Application.Title:='Test CGI application';
+  Application.Run;
+  Application.Free;
+end.
+