Create a gist now

Instantly share code, notes, and snippets.

1997 Turbo Pascal Web Guestbook CGI program, with <font> tags and other features.
{$M 16384,0,655360}
uses dos,strings,cgitool,filetool;
var OutBuf,InBuf:array[0..2047] of char;
gb:file;
i,j,k:integer;
ch:char;
susername,semail,sdate:String;
comment:array[0..2047] of char;
s,qs:string;
GesAnz:longint;
commentlength:longint;
procedure CreateNewGBfile;
var ch:char;
begin
rewrite(gb,1);
GesAnz:=0;ch:=#255;
BlockWrite(gb,GesAnz,SizeOf(GesAnz));
BlockWrite(gb,ch,1);
end;
{********************}
function CDate:string;
var day,year,month,dayofweek:word;
function z(w:word):string;
var s:string;
begin
str(w,s);
while length(s)<2 do s:='0'+s;
z:=s;
end;
{********************}
function cTime:string;
var hour, minute, second, hund:word;
begin
GetTime(Hour, Minute, Second, hund);
cTime:=z(hour)+z(minute);
end;
begin
GetDate(Year,Month,Day,DayOfWeek);
if year>1999 then s:=z(year-2000)
else s:=z(year-1900);
CDate:=cTime+z(month)+z(day)+s;
end;
{********************}
function eCount:longint;
begin
seek(gb,0);
blockRead(gb,GesAnz,sizeOf(GesAnz));
ecount:=GesAnz;
end;
{********************}
procedure IncGesAnz;
var ch:char;
begin
seek(gb,0);ch:=#255;
blockRead(gb,GesAnz,sizeOf(GesAnz));
inc(GesAnz);
seek(gb,0);
BlockWrite(gb,GesAnz,sizeOf(GesAnz));
BlockWrite(gb,ch,1);
end;
{********************}
function convert(s:string):string;
var s2:string;
i:integer;
x:integer;
begin
while pos('%',s)<>0 do begin
x:=pos('%',s);
s2:=copy(s,x,3);
delete(s,x,3);
insert(HexToChar(s2),s,x);
end;
while pos('+',s)<>0 do begin
x:=pos('+',s);
delete(s,x,1);
insert(' ',s,x);
end;
convert:=s;
end;
procedure convertarray;
var buf:array [0..2047] of char;
opos,bufpos:integer;
ch1,ch2,ch3:char;
i:integer;
begin
opos:=0;bufpos:=0;
while comment[opos]<>#0 do begin
if comment[opos] in ['+','%'] then begin
if comment[opos]='+' then begin buf[bufpos]:=' ';inc(bufpos);end;
if comment[opos]='%' then begin
ch1:=comment[opos+1];
ch2:=comment[opos+2];
ch3:=HexToChar(comment[opos]+ch1+ch2);
if (ch3<>#10) and (ch3<>#13) and (ch3<>#27) then
begin
buf[bufpos]:=ch3;
inc(bufpos);
end;
inc(opos,2);
end;
inc(opos);
end
else begin buf[bufpos]:=comment[opos];inc(bufpos);inc(opos);end;
end;
for i:=0 to bufpos do comment[i]:=buf[i];
commentlength:=bufpos+1;
end;
{********************}
procedure GetEntrys;
var c:char;
i:integer;
w:word;
p,p2:pchar;
begin
i:=0;
while not eof do begin read(c);inbuf[i]:=c;inc(i);end;
{**************************************}
p:=Strpos(inbuf,'UserName=');
w:=StrLen(p)-StrLen(StrScan(p,'&'));
for i:=9 to w do susername[i-8]:=p[i];
susername[0]:=chr(w-9);
susername:=convert(susername);
{**************************************}
p:=Strpos(inbuf,'Email=');
w:=StrLen(p)-StrLen(StrScan(p,'&'));
for i:=6 to w do semail[i-5]:=p[i];
semail[0]:=chr(w-6);
semail:=convert(semail);
{**************************************}
p:=Strpos(inbuf,'comment=');
w:=StrLen(p);
for i:=8 to w do comment[i-8]:=p[i];
convertarray;
{**************************************}
sDate:=cDate;
{**************************************}
end;
{***************************************************************************}
function convertDate(d:string):string;
begin
convertDate:=d[1]+d[2]+':'+d[3]+d[4]+' at '+d[5]+d[6]+'/'+d[7]+d[8]+'/'+d[9]+d[10];
end;
{***************************************************************************}
procedure ReadTheGB;
var size:word;
AnzToShow:integer;
i,j,x,z,count,err:integer;
buffer:array[0..2047] of char;
StartPos,EndPos:integer;
p:pchar;
s,s2:string;
function GetStartPos:integer;
var i:integer;
begin
for i:=StrLen(buffer) downto 0 do if buffer[i]=#1 then begin GetStartPos:=i;exit;end;
end;
procedure fillArray(i:integer);
var x:integer;
begin
for x:=i to 2047 do buffer[x]:=#0;
end;
begin
GesAnz:=eCount;AnzToShow:=20;
if AnzToShow>GesAnz then AnzToShow:=GesAnz;
seek(gb,fileSize(gb));
SendFile('gbhead.htm');
WriteLn('<CENTER><FONT SIZE="+1"><I>Currently there are ',GesAnz,' entrys in the GuestBook.<BR>This are the last',
AnzToShow,'entrys</I></FONT></CENTER>');
WriteLn('<P></P>');
WriteLn('<CENTER>');
WriteLn('<TABLE BORDER="0" WIDTH="50%" ALIGN="CENTER" CELLPADDING="2">');
for i:=1 to AnzToShow do begin
if filePos(gb)-5<2047 then size:=filePos(gb)-5
else size:=2047;
seek(gb,filePos(gb)-size-1);
BlockRead(gb,buffer,size);
seek(gb,FilePos(gb)+1);
buffer[size]:=#0;
p:=StrRScan(buffer,#1);
if (gesanz=AnzToShow) and (i=gesanz) then p:=StrScan(buffer,#255);
{**************************************************}
StartPos:=size-StrLen(p)+1;
EndPos:=StartPos+StrLen(p)+3;
{**************************************************}
count:=0;
s[0]:=#0;
susername[0]:=#0;
semail[0]:=#0;
while buffer[Startpos+count]<>#255 do
begin
if buffer[Startpos+count]<>#255 then s[count+1]:=buffer[count+startpos];
inc(count);
s[0]:=chr(ord(s[0])+1);
end;
inc(count);
z:=1;
{************************************}
while buffer[Startpos+count]<>#255 do
begin
if buffer[Startpos+count]<>#255 then susername[z]:=buffer[count+startpos];
inc(count);
inc(z);
susername[0]:=chr(ord(susername[0])+1);
end;
z:=1;
inc(count);
{************************************}
while buffer[Startpos+count]<>#255 do
begin
if buffer[Startpos+count]<>#255 then semail[z]:=buffer[count+startpos];
inc(count);
inc(z);
semail[0]:=chr(ord(semail[0])+1);
end;
z:=1;
inc(count);
s2[0]:=#0;
{************************************}
while buffer[Startpos+count]<>#255 do
begin
if buffer[Startpos+count]<>#255 then s2[z]:=buffer[count+startpos];
inc(count);
inc(z);
s2[0]:=chr(ord(s2[0])+1);
end;
{************************************}
val(s2,commentlength,err);
inc(count);
for j:=0 to commentlength do begin comment[j]:=buffer[count+startpos];inc(count);end;
seek(gb,filePos(gb)-(size-StartPos)-2);
WriteLn('<TR>');
WriteLn('<TD BGCOLOR="#DCF5FF">',comment,'</TD></TR>');
WriteLn('<TR>');
WriteLn('<TD BGCOLOR="#DCFAE9"><FONT COLOR="#0378ED"><I><A HREF=mailto:',semail,'>',susername,'</A>, ',convertDate(s));
WriteLn('</I></FONT></TD></TR>');
if i<>AnzToShow then WriteLn('<TR><TD><HR SIZE="5"></TD></TR>');
end;
WriteLn('</TABLE>');
WriteLn('</CENTER>');
SendFile('gbfoot.htm');
end;
{***************************************************************************}
procedure CreateNewGBentry;
var i:integer;
obp:integer;
obl:integer;
s:string;
begin
IncGesAnz;
GetEntrys;
{**************************************}
obp:=0;obl:=0;str(commentlength,s);
while length(s)<4 do s:='0'+s;
for i:=1 to length(sDate) do begin outbuf[obp]:=sDate[i];inc(obp);end;
outbuf[obp]:=#255;inc(obp);
for i:=1 to length(sUserName) do begin outbuf[obp]:=sUserName[i];inc(obp);end;
outbuf[obp]:=#255;inc(obp);
for i:=1 to length(sEmail) do begin outbuf[obp]:=sEmail[i];inc(obp);end;
outbuf[obp]:=#255;inc(obp);
for i:=1 to length(s) do begin outbuf[obp]:=s[i];inc(obp);end;
outbuf[obp]:=#255;inc(obp);
for i:=0 to commentlength-2 do begin outbuf[obp]:=comment[i];inc(obp);end;
outbuf[obp]:=#1;{inc(obp);}
{**************************************}
seek(gb,fileSize(gb));
BlockWrite(gb,outbuf,obp+1);
{**************************************}
ReadTheGB;
end;
{***************************************************************************}
procedure AdministrateGB;
begin
end;
{***************************************************************************}
begin
WriteLn('Content-type: text/html');
WriteLn;
assign(gb,'Guestbok.dat');
if ExistFile(gb) then reset(gb,1)
else CreateNewGBfile;
qs:=GetEnv('QUERY_STRING');
{ qs:='ReadEntry';}
if qs='NewEntry' then CreateNewGBentry;
if qs='ReadEntry' then ReadTheGB;
if qs='Admin' then AdministrateGB;
if qs='Count' then WriteLn(eCount);
close(gb);
end.
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment