1997 Turbo Pascal Web Guestbook CGI program, with <font> tags and other features.

Guestbok.pas

{$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.