mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-07-23 03:16:19 +02:00
440 lines
9.0 KiB
ObjectPascal
440 lines
9.0 KiB
ObjectPascal
unit uncgi;
|
|
{
|
|
$Id$
|
|
|
|
UNCGI UNIT 2.0.11
|
|
----------------
|
|
}
|
|
|
|
interface
|
|
uses
|
|
strings
|
|
{$ifdef linux}
|
|
,linux
|
|
{$endif}
|
|
{$IFDEF OS2}
|
|
, DosCalls
|
|
{$ENDIF OS2}
|
|
;
|
|
|
|
{***********************************************************************}
|
|
|
|
const
|
|
maxquery = 100;
|
|
hextable : array[0..15] of char=('0','1','2','3','4','5','6','7',
|
|
'8','9','A','B','C','D','E','F');
|
|
uncgi_version = 'UNCGI 2.0.11';
|
|
uncgi_year = '1999';
|
|
maintainer_name = 'Your Name Here';
|
|
maintainer_email= 'your@email.address.here';
|
|
|
|
Type cgi_error_proc = procedure (Const Proc,Err : String);
|
|
|
|
var
|
|
get_nodata : boolean;
|
|
query_read : word;
|
|
query_array : array[1..2,1..maxquery] of pchar;
|
|
uncgi_error : cgi_error_proc;
|
|
|
|
{***********************************************************************}
|
|
|
|
{ FUNCTION
|
|
|
|
This function returns the REQUEST METHOD of the CGI-BIN script
|
|
|
|
Input - Nothing
|
|
Output - [GET|POST]
|
|
}
|
|
function http_request_method: pchar;
|
|
|
|
{ FUNCTION
|
|
|
|
This function returns the "referring" page. i.e. the page you followed
|
|
the link to this CGI-BIN from
|
|
|
|
Input - Nothing
|
|
Output - [http://somewhere.a.tld]
|
|
}
|
|
function http_referer: pchar;
|
|
|
|
{ FUNCTION
|
|
|
|
This function returns the users's USER AGENT, the browser name etc.
|
|
|
|
Input - Nothing
|
|
Output - user agent string
|
|
}
|
|
function http_useragent: pchar;
|
|
|
|
{ FUNCTION
|
|
|
|
This function returns a value from an id=value pair
|
|
|
|
Input - The identifier you want the value from
|
|
Output - If the identifier was found, the resulting value is
|
|
the output, otherwise the output is NIL
|
|
}
|
|
function get_value(id: pchar): pchar;
|
|
|
|
{ PROCEDURE
|
|
|
|
This procedure writes the content-type to the screen
|
|
|
|
Input - The content type in MIME format
|
|
Output - Nothing
|
|
|
|
Example - set_content('text/plain');
|
|
set_content('text/html');
|
|
}
|
|
procedure set_content(ctype: string);
|
|
|
|
procedure cgi_init;
|
|
procedure cgi_deinit;
|
|
|
|
implementation
|
|
|
|
{$IFDEF OS2}
|
|
function GetEnv (EnvVar: string): PChar;
|
|
|
|
var RC: longint;
|
|
P, Q: PChar;
|
|
|
|
begin
|
|
GetMem (Q, Succ (Length (EnvVar)));
|
|
RC := DosScanEnv (Q, P);
|
|
FreeMem (Q, Succ (Length (EnvVar)));
|
|
GetEnv := P;
|
|
end;
|
|
{$ENDIF OS2}
|
|
|
|
{$ifdef win32}
|
|
Var EnvP : PChar;
|
|
EnvLen : Longint;
|
|
OldExitProc : Pointer;
|
|
|
|
function GetEnvironmentStrings : pchar; external 'kernel32' name 'GetEnvironmentStringsA';
|
|
function FreeEnvironmentStrings(p : pchar) : longbool; external 'kernel32' name 'FreeEnvironmentStringsA';
|
|
|
|
Procedure FInitWin32CGI;
|
|
begin
|
|
{ Free memory }
|
|
FreeMem (EnvP,EnvLen);
|
|
ExitProc:=OldExitProc;
|
|
end;
|
|
|
|
Procedure InitWin32CGI;
|
|
var s : String;
|
|
i,len : longint;
|
|
hp,p : pchar;
|
|
|
|
begin
|
|
{ Make a local copy of environment}
|
|
p:=GetEnvironmentStrings;
|
|
hp:=p;
|
|
envp:=Nil;
|
|
envlen:=0;
|
|
while hp[0]<>#0 do
|
|
begin
|
|
len:=strlen(hp);
|
|
hp:=hp+len+1;
|
|
EnvLen:=Envlen+len+1;
|
|
end;
|
|
GetMem(EnvP,Envlen);
|
|
Move(P^,EnvP^,EnvLen);
|
|
FreeEnvironmentStrings(p);
|
|
OldExitProc:=ExitProc;
|
|
ExitProc:=@FinitWin32CGI;
|
|
end;
|
|
|
|
Function GetEnv(envvar: string): pchar;
|
|
{ Getenv that can return environment vars of length>255 }
|
|
var s : String;
|
|
i,len : longint;
|
|
hp : pchar;
|
|
|
|
begin
|
|
s:=Envvar+#0;
|
|
getenv:=Nil;
|
|
hp:=envp;
|
|
while hp[0]<>#0 do
|
|
begin
|
|
len:=strlen(hp);
|
|
i:=Longint(strscan(hp,'='))-longint(hp);
|
|
if StrLIComp(@s[1],HP,i-1)=0 then
|
|
begin
|
|
Len:=Len-i;
|
|
getmem (getenv,len);
|
|
Move(HP[I+1],getenv^,len+1);
|
|
break;
|
|
end;
|
|
{ next string entry}
|
|
hp:=hp+len+1;
|
|
end;
|
|
end;
|
|
{$endif}
|
|
|
|
{$ifdef GO32V2}
|
|
Function GetEnv(envvar: string): pchar;
|
|
var
|
|
hp : ppchar;
|
|
p : pchar;
|
|
hs : string;
|
|
eqpos : longint;
|
|
begin
|
|
envvar:=upcase(envvar);
|
|
hp:=envp;
|
|
getenv:=nil;
|
|
while assigned(hp^) do
|
|
begin
|
|
hs:=strpas(hp^);
|
|
eqpos:=pos('=',hs);
|
|
if copy(hs,1,eqpos-1)=envvar then
|
|
begin
|
|
getenv:=hp^+eqpos;
|
|
exit;
|
|
end;
|
|
inc(hp);
|
|
end;
|
|
end;
|
|
{$endif}
|
|
|
|
|
|
var
|
|
done_init : boolean;
|
|
|
|
procedure set_content(ctype: string);
|
|
begin
|
|
writeln('Content-Type: ',ctype);
|
|
writeln;
|
|
end;
|
|
|
|
function http_request_method: pchar;
|
|
begin
|
|
http_request_method :=getenv('REQUEST_METHOD');
|
|
end;
|
|
|
|
function http_referer: pchar;
|
|
begin
|
|
http_referer :=getenv('HTTP_REFERER');
|
|
end;
|
|
|
|
function http_useragent: pchar;
|
|
begin
|
|
http_useragent :=getenv('HTTP_USER_AGENT');
|
|
end;
|
|
|
|
function hexconv(h1,h2: char): char;
|
|
var
|
|
cnt : byte;
|
|
thex : byte;
|
|
begin
|
|
for cnt :=0 to 15 do if upcase(h1)=hextable[cnt] then thex := cnt * 16;
|
|
for cnt :=0 to 15 do if upcase(h2)=hextable[cnt] then thex := thex + cnt;
|
|
hexconv := chr(thex);
|
|
end;
|
|
|
|
procedure def_uncgi_error(const pname,perr: string);
|
|
begin
|
|
set_content('text/html');
|
|
writeln('<html><head><title>UNCGI ERROR</title></head>');
|
|
writeln('<body>');
|
|
writeln('<center><hr><h1>UNCGI ERROR</h1><hr></center><br><br>');
|
|
writeln('UnCgi encountered the following error: <br>');
|
|
writeln('<ul><br>');
|
|
writeln('<li> procedure: ',pname,'<br>');
|
|
writeln('<li> error: ',perr,'<br><hr>');
|
|
writeln(
|
|
'<h5><p><i>uncgi (c) ',uncgi_year,' ',maintainer_name,
|
|
{ skelet fix }
|
|
'<a href="mailto:',maintainer_email,'">',
|
|
maintainer_email,'</a></i></p></h5>');
|
|
writeln('</body></html>');
|
|
halt;
|
|
end;
|
|
|
|
function get_value(id: pchar): pchar;
|
|
var
|
|
cnt : word;
|
|
begin
|
|
get_value:=Nil;
|
|
if done_init then
|
|
for cnt :=1 to query_read do
|
|
if strcomp(strupper(id),strupper(query_array[1,cnt]))=0 then
|
|
begin
|
|
get_value := query_array[2,cnt];
|
|
exit;
|
|
end;
|
|
end;
|
|
|
|
Function UnEscape(QueryString: PChar): PChar;
|
|
var
|
|
qunescaped : pchar;
|
|
sptr : longint;
|
|
cnt : word;
|
|
qslen : longint;
|
|
|
|
begin
|
|
qslen:=strlen(QueryString);
|
|
if qslen=0 then
|
|
begin
|
|
Unescape:=#0;
|
|
get_nodata:=true;
|
|
exit;
|
|
end
|
|
else
|
|
get_nodata :=false;
|
|
{ skelet fix }
|
|
getmem(qunescaped,qslen+1);
|
|
if qunescaped=nil then
|
|
begin
|
|
writeln ('Oh-oh');
|
|
halt;
|
|
end;
|
|
sptr :=0;
|
|
for cnt := 0 to qslen do
|
|
begin
|
|
case querystring[cnt] of
|
|
'+': qunescaped[sptr] := ' ';
|
|
'%': begin
|
|
qunescaped[sptr] :=
|
|
hexconv(querystring[cnt+1], querystring[cnt+2]);
|
|
inc(cnt,2);
|
|
end;
|
|
else
|
|
qunescaped[sptr] := querystring[cnt];
|
|
end;
|
|
inc(sptr);
|
|
{ skelet fix }
|
|
qunescaped[sptr]:=#0;
|
|
end;
|
|
UnEscape:=qunescaped;
|
|
end;
|
|
|
|
Function Chop(QunEscaped : PChar) : Longint;
|
|
var
|
|
qptr : word;
|
|
cnt : word;
|
|
qslen : longint;
|
|
|
|
begin
|
|
qptr := 1;
|
|
qslen:=strlen(QUnescaped);
|
|
query_array[1,qptr] := qunescaped;
|
|
for cnt := 0 to qslen-1 do
|
|
case qunescaped[cnt] of
|
|
'=': begin
|
|
qunescaped[cnt] := #0;
|
|
{ save address }
|
|
query_array[2,qptr] := @qunescaped[cnt+1];
|
|
end;
|
|
'&': begin
|
|
qunescaped[cnt] := #0;
|
|
{ Unescape previous one. }
|
|
query_array[2,qptr]:=unescape(query_array[2,qptr]);
|
|
inc(qptr);
|
|
query_array[1,qptr] := @qunescaped[cnt+1];
|
|
end;
|
|
end; { Case }
|
|
{ Unescape last one. }
|
|
query_array[2,qptr]:=unescape(query_array[2,qptr]);
|
|
Chop :=qptr;
|
|
end;
|
|
|
|
procedure cgi_read_get_query;
|
|
var
|
|
querystring : pchar;
|
|
qslen : longint;
|
|
begin
|
|
querystring :=strnew(getenv('QUERY_STRING'));
|
|
if querystring<>NIL then
|
|
begin
|
|
qslen :=strlen(querystring);
|
|
if qslen=0 then
|
|
begin
|
|
get_nodata :=true;
|
|
exit;
|
|
end
|
|
else
|
|
get_nodata :=false;
|
|
query_read:=Chop(QueryString);
|
|
end;
|
|
done_init :=true;
|
|
end;
|
|
|
|
procedure cgi_read_post_query;
|
|
var
|
|
querystring : pchar;
|
|
qslen : longint;
|
|
sptr : longint;
|
|
clen : string;
|
|
ch : char;
|
|
|
|
begin
|
|
if getenv('CONTENT_LENGTH')<>Nil then
|
|
begin
|
|
clen:=strpas (getenv('CONTENT_LENGTH'));
|
|
val(clen,qslen);
|
|
if upcase(strpas(getenv('CONTENT_TYPE')))='APPLICATION/X-WWW-FORM-URLENCODED'
|
|
then
|
|
begin
|
|
getmem(querystring,qslen+1);
|
|
sptr :=0;
|
|
while sptr<>qslen do
|
|
begin
|
|
read(ch);
|
|
pchar(longint(querystring)+sptr)^ :=ch;
|
|
inc(sptr);
|
|
end;
|
|
{ !!! force null-termination }
|
|
pchar(longint(querystring)+sptr)^ :=#0;
|
|
query_read:=Chop(QueryString);
|
|
end;
|
|
end;
|
|
done_init :=true;
|
|
end;
|
|
|
|
procedure cgi_init;
|
|
var
|
|
rmeth : pchar;
|
|
begin
|
|
query_read:=0;
|
|
rmeth :=http_request_method;
|
|
if rmeth=nil then
|
|
begin
|
|
uncgi_error('cgi_init()','No REQUEST_METHOD passed from server!');
|
|
exit;
|
|
end;
|
|
if strcomp('POST',rmeth)=0 then cgi_read_post_query else
|
|
if strcomp('GET',rmeth)=0 then cgi_read_get_query else
|
|
uncgi_error('cgi_init()','No REQUEST_METHOD passed from server!');
|
|
end;
|
|
|
|
procedure cgi_deinit;
|
|
begin
|
|
done_init :=false;
|
|
query_read :=0;
|
|
fillchar(query_array,sizeof(query_array),0);
|
|
end;
|
|
|
|
|
|
|
|
begin
|
|
{$ifdef win32}
|
|
InitWin32CGI;
|
|
{$endif}
|
|
uncgi_error:=@def_uncgi_error;
|
|
done_init :=false;
|
|
fillchar(query_array,sizeof(query_array),0);
|
|
end.
|
|
|
|
{
|
|
HISTORY
|
|
$Log$
|
|
Revision 1.3 2000-12-19 00:47:11 hajny
|
|
+ OS/2 support added
|
|
|
|
Revision 1.2 2000/07/13 11:33:32 michael
|
|
+ removed logs
|
|
|
|
}
|