fpc/fcl/inc/ezcgi.pp

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.