mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-07-26 00:45:56 +02:00
413 lines
8.8 KiB
ObjectPascal
413 lines
8.8 KiB
ObjectPascal
{
|
|
$Id$
|
|
This file is part of the Free Component Library (FCL)
|
|
Copyright (c) 1999-2000 by Michael Van Canneyt and Florian Klaempfl
|
|
|
|
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.
|
|
|
|
**********************************************************************}
|
|
unit ezcgi;
|
|
|
|
{$mode delphi}
|
|
{$H+ }
|
|
|
|
interface
|
|
|
|
uses classes, strings, sysutils;
|
|
|
|
const
|
|
hexTable = '0123456789ABCDEF';
|
|
|
|
type
|
|
ECGIException = class(Exception);
|
|
|
|
TEZcgi = class(TObject)
|
|
private
|
|
{ Private declarations }
|
|
FVariables : TStringList;
|
|
FName : String;
|
|
FEmail : String;
|
|
FQueryString : String;
|
|
|
|
{ Token variables }
|
|
aString : String;
|
|
aSepStr : String;
|
|
aPos : Byte;
|
|
aLenStr : Byte;
|
|
aLenSep : Byte;
|
|
|
|
procedure InitToken(aStr, aSep : String);
|
|
function NextToken(var aToken : String; var aSepChar : Char) : Boolean;
|
|
|
|
procedure GetQueryItems;
|
|
procedure ProcessRequest;
|
|
procedure LoadEnvVariables;
|
|
function GetVal(Index : String) : String;
|
|
function GetName(Index : Integer) : String;
|
|
function GetVariable(Index : Integer) : String;
|
|
function GetVarCount : Integer;
|
|
procedure ReadPostQuery;
|
|
procedure ReadGetQuery;
|
|
protected
|
|
{ Protected declarations }
|
|
|
|
procedure OutputError(errorMessage : String);
|
|
public
|
|
{ Public declarations }
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
procedure Run;
|
|
procedure WriteContent(ctype : String);
|
|
procedure PutLine(sOut : String);
|
|
function GetValue(Index : String; defaultValue : String) : String;
|
|
|
|
procedure DoPost; virtual;
|
|
procedure DoGet; virtual;
|
|
|
|
property Values[Index : String] : String read GetVal;
|
|
property Names[Index : Integer] : String read GetName;
|
|
property Variables[Index : Integer] : String read GetVariable;
|
|
property VariableCount : Integer read GetVarCount;
|
|
|
|
property Name : String read FName write FName;
|
|
property Email : String read FEmail write FEmail;
|
|
end;
|
|
|
|
implementation
|
|
|
|
{ *********** Include OS-dependent Getenv Call ************ }
|
|
|
|
{$I ezcgi.inc}
|
|
|
|
{ *********** Public Methods *************** }
|
|
|
|
constructor TEZcgi.Create;
|
|
begin
|
|
FName := 'No name available';
|
|
FEmail := 'Email address unavailable';
|
|
|
|
FVariables := TStringList.Create;
|
|
|
|
LoadEnvVariables;
|
|
|
|
end;
|
|
|
|
destructor TEZcgi.Destroy;
|
|
begin
|
|
FVariables.Free;
|
|
end;
|
|
|
|
procedure TEZcgi.Run;
|
|
begin
|
|
ProcessRequest;
|
|
end;
|
|
|
|
procedure TEZcgi.DoPost;
|
|
begin
|
|
// Must be overriden by child class
|
|
end;
|
|
|
|
procedure TEZcgi.DoGet;
|
|
begin
|
|
// Must be overriden by child class
|
|
end;
|
|
|
|
procedure TEZcgi.WriteContent(ctype : String);
|
|
begin
|
|
writeln('Content-Type: ',ctype);
|
|
writeln;
|
|
end;
|
|
|
|
procedure TEZcgi.PutLine(sOut : String);
|
|
begin
|
|
writeln(sOut);
|
|
end;
|
|
|
|
function TEZcgi.GetValue(Index, defaultValue : String) : String;
|
|
begin
|
|
result := GetVal(Index);
|
|
if result = '' then
|
|
result := defaultValue;
|
|
end;
|
|
|
|
|
|
{ *********** Private Methods *************** }
|
|
|
|
procedure TEZcgi.LoadEnvVariables;
|
|
|
|
procedure GetEData(variable : String);
|
|
var
|
|
tempStr : String;
|
|
begin
|
|
// This is a system dependent call !!
|
|
tempStr := GetEnv(variable);
|
|
if tempStr <> '' then
|
|
FVariables.Add(variable + '=' + tempStr);
|
|
end;
|
|
|
|
begin
|
|
|
|
{ Standard CGI Environment Variables }
|
|
GetEData('AUTH_TYPE');
|
|
GetEData('CONTENT_LENGTH');
|
|
GetEData('CONTENT_TYPE');
|
|
GetEData('GATEWAY_INTERFACE');
|
|
GetEData('PATH_INFO');
|
|
GetEData('PATH_TRANSLATED');
|
|
GetEData('QUERY_STRING');
|
|
GetEData('REMOTE_ADDR');
|
|
GetEData('REMOTE_HOST');
|
|
GetEData('REMOTE_IDENT');
|
|
GetEData('REMOTE_USER');
|
|
GetEData('REQUEST_METHOD');
|
|
GetEData('SCRIPT_NAME');
|
|
GetEData('SERVER_NAME');
|
|
GetEData('SERVER_PORT');
|
|
GetEData('SERVER_PROTOCOL');
|
|
GetEData('SERVER_SOFTWARE');
|
|
|
|
|
|
{ Standard HTTP Environment Variables }
|
|
GetEData('HTTP_ACCEPT');
|
|
GetEData('HTTP_ACCEPT_CHARSET');
|
|
GetEData('HTTP_ACCEPT_ENCODING');
|
|
GetEData('HTTP_IF_MODIFIED_SINCE');
|
|
GetEData('HTTP_REFERER');
|
|
GetEData('HTTP_USER_AGENT');
|
|
end;
|
|
|
|
procedure TEZcgi.ProcessRequest;
|
|
var
|
|
request : String;
|
|
begin
|
|
|
|
request := GetVal('REQUEST_METHOD');
|
|
|
|
if request = '' then
|
|
OutputError('No REQUEST_METHOD passed from server!')
|
|
else if request = 'POST' then
|
|
begin
|
|
ReadPostQuery;
|
|
DoPost;
|
|
end
|
|
else if request = 'GET' then
|
|
begin
|
|
ReadGetQuery;
|
|
DoGet;
|
|
end
|
|
else
|
|
OutputError('Invalid REQUEST_METHOD passed from server!');
|
|
end;
|
|
|
|
function TEZcgi.GetVal(Index : String) : String;
|
|
begin
|
|
result := FVariables.Values[Index];
|
|
end;
|
|
|
|
function TEZcgi.GetName(Index : Integer) : String;
|
|
begin
|
|
result := FVariables.Names[Index];
|
|
end;
|
|
|
|
function TEZcgi.GetVariable(Index : Integer) : String;
|
|
begin
|
|
result := FVariables[Index];
|
|
end;
|
|
|
|
function TEZcgi.GetVarCount : Integer;
|
|
begin
|
|
result := FVariables.Count;
|
|
end;
|
|
|
|
procedure TEZcgi.ReadPostQuery;
|
|
var
|
|
index : Integer;
|
|
ch : Char;
|
|
temp : String;
|
|
code : Word;
|
|
contentLength : Integer;
|
|
theType : String;
|
|
|
|
begin
|
|
|
|
temp := GetVal('CONTENT_LENGTH');
|
|
if Length(temp) > 0 then
|
|
begin
|
|
Val(temp, contentLength, code);
|
|
if code <> 0 then
|
|
contentLength := 0;
|
|
end;
|
|
|
|
if contentLength = 0 then
|
|
OutputError('No content length passed from server!');
|
|
|
|
theType := UpperCase(GetVal('CONTENT_TYPE'));
|
|
|
|
if theType <> 'APPLICATION/X-WWW-FORM-URLENCODED' then
|
|
OutputError('No content type passed from server!');
|
|
|
|
FQueryString := '';
|
|
|
|
for index := 0 to contentLength do
|
|
begin
|
|
Read(ch);
|
|
FQueryString := FQueryString + ch;
|
|
end;
|
|
|
|
GetQueryItems;
|
|
end;
|
|
|
|
procedure TEZcgi.ReadGetQuery;
|
|
begin
|
|
FQueryString := GetVal('QUERY_STRING');
|
|
|
|
if FQueryString = '' then
|
|
OutputError('No QUERY_STRING passed from server!');
|
|
|
|
GetQueryItems;
|
|
end;
|
|
|
|
procedure TEZcgi.GetQueryItems;
|
|
var
|
|
queryItem : String;
|
|
delimiter : Char;
|
|
|
|
function hexConverter(h1, h2 : Char) : Char;
|
|
var
|
|
thex : byte;
|
|
begin
|
|
tHex := (Pos(upcase(h1), hexTable) - 1) * 16;
|
|
tHex := tHex + Pos(upcase(h2), hexTable) - 1;
|
|
|
|
result := chr(thex);
|
|
end;
|
|
|
|
procedure Convert_ESC_Chars;
|
|
var
|
|
index : Integer;
|
|
begin
|
|
repeat
|
|
index := Pos('+', queryItem);
|
|
if index > 0 then
|
|
queryItem[index] := Chr(32);
|
|
until index = 0;
|
|
repeat
|
|
index := Pos('%', queryItem);
|
|
if index > 0 then
|
|
begin
|
|
queryItem[index] := hexConverter(queryItem[index + 1], queryItem[index + 2]);
|
|
system.Delete(queryItem, index + 1, 2);
|
|
end;
|
|
until index = 0;
|
|
end;
|
|
|
|
begin
|
|
InitToken(FQueryString, '&');
|
|
|
|
while NextToken(queryItem, delimiter) do
|
|
begin
|
|
if queryItem <> '' then
|
|
begin
|
|
Convert_ESC_Chars;
|
|
FVariables.Add(queryItem);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TEZcgi.OutputError(errorMessage : String);
|
|
begin
|
|
WriteContent('text/html');
|
|
writeln('<html><head><title>CGI ERROR</title></head>');
|
|
writeln('<body>');
|
|
writeln('<center><hr><h1>CGI ERROR</h1><hr></center><br><br>');
|
|
writeln('This CGI application encountered the following error: <br>');
|
|
writeln('<ul><br>');
|
|
writeln('<li> error: ',errorMessage,'<br><hr>');
|
|
writeln('<h5><p><i>Notify ',FName,' <a href="mailto:',FEmail,'">',FEmail,'</a></i></p></h5>');
|
|
writeln('</body></html>');
|
|
|
|
Raise ECGIException.Create(errorMessage);
|
|
end;
|
|
|
|
procedure TEZcgi.InitToken(aStr, aSep : String);
|
|
begin
|
|
aString := aStr;
|
|
aSepStr := aSep;
|
|
aPos := 1;
|
|
aLenStr := Length(aString);
|
|
aLenSep := Length(aSepStr);
|
|
end;
|
|
|
|
function TEZcgi.NextToken(var aToken : String; var aSepChar : Char) : Boolean;
|
|
var
|
|
i : Byte;
|
|
j : Byte;
|
|
BoT : Byte;
|
|
EoT : Byte;
|
|
isSep : Boolean;
|
|
|
|
begin
|
|
BoT := aPos;
|
|
EoT := aPos;
|
|
for i := aPos to aLenStr do
|
|
begin
|
|
IsSep := false;
|
|
for j := 1 to aLenSep do
|
|
begin
|
|
if aString[i] = aSepStr[j] then
|
|
begin
|
|
IsSep := true;
|
|
Break;
|
|
end;
|
|
end;
|
|
if IsSep then
|
|
begin
|
|
EoT := i;
|
|
aPos := i + 1;
|
|
aSepChar := aString[i];
|
|
Break;
|
|
end
|
|
else
|
|
begin
|
|
if i = aLenStr then
|
|
begin
|
|
EoT := i;
|
|
aPos := i;
|
|
Break;
|
|
end;
|
|
end;
|
|
end;
|
|
if aPos < aLenStr then
|
|
begin
|
|
aToken := Copy(aString, BoT, EoT - BoT);
|
|
Result := true;
|
|
end
|
|
else
|
|
begin
|
|
if aPos = aLenStr then
|
|
begin
|
|
aToken := Copy(aString, BoT, EoT - BoT + 1);
|
|
Result := true;
|
|
aPos := aPos + 1;
|
|
end
|
|
else
|
|
begin
|
|
Result := false;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
end.
|
|
|
|
{
|
|
$Log$
|
|
Revision 1.2 2000-07-13 11:32:59 michael
|
|
+ removed logs
|
|
|
|
}
|