//Modul für Tabelle forum
//
// Easy-Modul für ein generisches Diskussionsforum mit folgenden Features
//                automatisches Löschen von Beiträgen
//                Thread-orientierter E-Mail-Support
//                maximale Thread-Tiefe = 80
//
// Voraussetzung: tdbengine 6.2.7 oder höher
//                EMail-Programm mit Spool-Funktion (nicht unbedingt notwendig)
//
// Bestandteile:  forum.prg       -> das eigentliche Programm
//                forum.ini       -> Konfigurations-Datei
//                forum.def       -> Tabellenstruktur
//                frameset.html   -> Basisseite
//                link_node.html  -> HTML-Fragment zur Ausgabe eines Knotens
//                old_node.html   -> HTML-Fragment zur Anzeige eines Postings
//                new_node.html   -> HTML-Fragment zur Eingabe eines Postings
//                startforum.html -> Startseite
//                getsearch.html  -> Formular für Suchbegriff
//                gettime.html    -> Formular für Startdatum
//                getpw           -> Formular zur Abfrage von Admin-ID und Passwort
//                mail.msg        -> Template für Mail-Support 
//
// Installation:  alle Programmteile in ein Verzeichnis kopieren
//                wichtig: http-User müssen in diesem Verzeichnis das Recht zum Anlegen neuer Dateien haben
//
// Konfiguration: Die Größe der Forumstabelle wird über die Einträge
//                max_nodes und max_days (in Tagen) gesteuert
//                Falls ein Eintrag mail_spool angegeben ist, werden hier
//                die Mails an die Forumsteilnehmer abgelegt.
//                mail_subject ist das Betreff der Mails,
//                mail_from der Absender
//
// Hinweise:      forum.prg kann ohne Semaphor laufen
//                deshalb in tdbengine.ini
//                [forum]
//                sema=nosema
//
//                Die Tabelle forum.dat wird beim ersten Start automatisch angelegt

USES cgimail.mod
// Bibliothek zum Mailversand
USES normstr.mod
// Suchbegriffe normieren

VAR s_headline, s_name, s_email, s_art, s_email_support, s_ref : STRING
VAR db, ini : STRING
VAR s_start, s_search : STRING
VAR hits : TBITS[]
VAR isadmin : INTEGER

PROCEDURE GenFulltextIndex(d, mode : INTEGER)
// Volltext-Indizierung im Forum
// mode 0 = Volltext-Index wird neu aufgebaut
// mode 1 = aktueller Datensatz wird indiziert
// mode 2 = aktueller Datensatz wird aus dem Index entfernt
VAR i,r : INTEGER
VAR fn_i, fn_r : STRING
  setpara('ec 1') // Fehlerbehandlung im Programm
  fn_i:='d-ind.dat'; fn_r:='d-rel.rel'
  IF mode=0 THEN
    delfile(fn_i); delfile(fn_r)
    genlist(fn_i); genrel('forum','d-ind',fn_r);
  END
  IF i:=opendb(fn_i,'',0,15) THEN
    IF r:=opendb(fn_r,'',0,15) THEN
      choice(mode+1,scanrecs(d,i,r,fields('complete')),scanrec(d,i,r,fields('complete')),unscanrec(d,i,r,fields('complete')))
      closedb(r)
    END
    closedb(i)
  END
  setpara('ec 0') // Fehlerbehandlung durch System
ENDPROC

PROCEDURE TestInitTable
VAR fc : INTEGER
  IF NOT isfile(db) THEN fc:=makedb(db,'',0,'forum.def') END
ENDPROC

PROCEDURE CheckTable(d : INTEGER)
// prüft, ob Datensätze gelöscht werden müssen, und macht das bei Bedarf
VAR i,max_nodes,max_days,buffer,changed : INTEGER
  max_nodes:=val(getident(ini,'max_nodes'))
  max_days:=val(getident(ini,'max_days'))
  IF max_nodes=0 AND max_days=0 THEN max_days:=60 /* 2 Monate default */  END
  IF d THEN
    IF NOT isfile('d-ind.dat') THEN GenFulltextIndex(d,0) END
    IF filesize(d)=0 THEN RETURN END
    access(d,indname(d,1));
    IF max_nodes>0 THEN
      buffer:=max_nodes DIV 10;  // 10% Puffer
      IF filesize(d)>max_nodes+buffer THEN
        nloop(i,filesize(d)-max_nodes,delrec(d,firstrec(d)));
        changed:=1
      END
    END
    IF max_days>0 THEN
      buffer:=max_days DIV 10;  // 10% Puffer
      readrec(d,firstrec(d));
      IF today - getrfield(d,'delete_date')>max_days+buffer THEN
        WHILE today - getrfield(d,'delete_date')>max_days DO
          delrec(d,recno(d))
          readrec(d,firstrec(d))
        END
        changed:=1
      END
    END
    IF changed THEN regenall(d); GenFulltextIndex(d,0) END
  END
ENDPROC

PROCEDURE SubstAction
// ersetzt in templates #action# durch den aktuellen Aufruf
  WHILE subst('#action#',paramstr(0)) DO END
ENDPROC

PROCEDURE LoadForm(s,msg : STRING) : INTEGER
// Lädt ein Template aus dem aktuellen Verzeichnis und bereitet es auf
  IF loadtemplate(s)=0 THEN
    subst('#msg#',msg,1)
    SubstAction
    RETURN 1
  ELSE
    RETURN 0
  END
ENDPROC

PROCEDURE t_cgigetparam(VAR s : STRING)
// spart Zeit und Speicher
  s:=ltrim(rtrim(cgigetparam(varname(s)[3,100])))
ENDPROC

PROCEDURE GetParamsFromCGI
// Holt alle Parameter aus dem Formular
  t_cgigetparam(s_headline)
  t_cgigetparam(s_name)
  t_cgigetparam(s_email)
  t_cgigetparam(s_art)
  t_cgigetparam(s_email_support)
  t_cgigetparam(s_ref)
ENDPROC

PROCEDURE JavaScriptHeader
// Damit wird die Änderungen in beiden Fenstern möglich
  cgiwriteln('<head>')
  cgiwriteln('<script language="JavaScript">')
  cgiwriteln('  <!--')
  cgiwriteln('    function twoframes(URL1,F1,URL2,F2)')
  cgiwriteln('   {  ')
  cgiwriteln('    parent.frames[F1].location.href=URL1;')
  cgiwriteln('    parent.frames[F2].location.href=URL2;')
  cgiwriteln('   }')
  cgiwriteln('  //-->')
  cgiwriteln('  </script>  ')
  cgiwriteln('</head>')
ENDPROC

PROCEDURE t_subst(VAR s : STRING)
// spart Zeit und Speicher
  subst('#'+varname(s)[3,100]+'#',s,1)
ENDPROC

PROCEDURE Beitrags_Formular(s_msg : STRING)
// Lädt das Posting-Forumlar und füllt es nach Vorgabe aus
  LoadForm('new_node.html',s_msg); subst('#ref#',s_ref);
  t_subst(s_headline); t_subst(s_name); t_subst(s_email);
  subst('#o_'+s_art+'#','selected')
  subst('#o_Frage#',''); subst('#o_Antwort#',''); subst('#o_News#',''); subst('#o_Sonstiges#','')
  subst('#c_email_support#',choice(sel(s_email_support like 'J*'),'checked',''))
  subst('#text:content#','ramtext:text:content',1)
  cgiwritetemplate
ENDPROC

PROCEDURE GenJavaScriptLink(a,b : STRING) : STRING
// Sorgt dafür, dass im opberen Fenster ein Thread aufgeklappt wird
// und gleichzeitig das entsprechende erste Posting angezeigt wird.
// Bei Einträgen innerhalb eines Threads wird nur das untere Fenster aktualisiert.
VAR result, link_1, link_2, startdate, searchstr : STRING
  IF startdate:=cgigetparam('start')='' THEN startdate:=getquerystring('start') END
  IF searchstr:=cgigetparam('search')='' THEN searchstr:=getquerystring('search') END
  result:='<a href="'
  IF a=b THEN
    link_1:=paramstr(0)+'?action=list_all'
    IF startdate THEN link_1:=link_1+'&start='+tohtml(startdate) END
    IF searchstr THEN link_1:=link_1+'&search='+tohtml(searchstr) END
    link_1:=link_1+'&a_no='+a+'&b_no='+b+'#'+a
    link_2:=paramstr(0)+'?action=view&a_no='+a
    result:=result+"javascript:twoframes('"+link_1+"',0,'"+link_2+"',1)"+'">'
  ELSE
    result:=result+paramstr(0)+'?action=view&a_no='+a+'" target="content">'
  END
  RETURN result
ENDPROC

PROCEDURE FindTop(d, domodify : INTEGER) : STRING
// Finden den Basiseintrag eines Threads. 
// Aktualisiert für alle Einträe auf dem Weg dorthin das Datum
VAR ref : INTEGER
  WHILE ref:=getrfield(d,'antwort_auf') DO
    readrec(d,findrec(d,str(ref),'forum.inr',1))
    IF domodify, recno(d) THEN
      setfield(d,'delete_date',datestr(today))
      setrfield(d,'delete_time',now)
      writerec(d,recno(d))
    END
  END
  RETURN str(AutoRecNo(d))
ENDPROC

PROCEDURE PrintThread(d, n, indent, mode : INTEGER; b_no : STRING)
// Schreibt einen kompletten Thread für b_no, ansonsten nur den Basiseintrag.
VAR i, x : INTEGER
VAR a_no, t, listall, l_openthread : STRING
VAR tmarks : MARKS
  readrec(d,n); a_no:=str(AutoRecNo(d))
  IF mode=0,getquerystring('b_no')=a_no THEN cgiwriteln('<a name="'+a_no+'">') END
  LoadForm('link_node.html','')
  subst('#the_time_s#',timestr(getrfield(d,'the_time')))
  subst('#the_date_s#',getfield(d,'the_date')[1,5])
  subst('#delete_date_s#',getfield(d,'delete_date')[1,5])
  subst('#delete_time_s#',timestr(getrfield(d,'delete_time')))
  subst('#the_time#',timestr(getrfield(d,'the_time'),0))
  subst('#delete_time#',timestr(getrfield(d,'delete_time'),0))
  nloop(i,maxlabel(d)-1,choice(sel(gettype(d,i+1) like "M"),0,subst('#'+label(d,i+1)+'#',d,i+1,1)))
  subst('#b_no#',b_no)
  subst('#width#',str(5+20*indent))
  subst('#link#',l_openthread:=GenJavaScriptLink(a_no,b_no))
  IF mode=0,getquerystring('b_no')=str(AutoRecNo(d)) THEN
    listall:=paramstr(0)+'?action=list_all'
    IF s_start THEN listall:=listall+'&start='+s_start END
    IF s_search THEN listall:=listall+'&search='+tohtml(s_search) END
    subst('#img#','<a href="'+listall+'"><img src="'+paramstr(0)+'?img=nfollow_r.gif" border="0"></a>') 
  ELSIF mode=0,findrec(d,str(AutoRecNo(d)),'forum.in1',1) THEN
    subst('#img#','#l_openthread##arrow#</a>')
    subst('#l_openthread#',l_openthread)
    subst('#arrow#','<img src="'+paramstr(0)+'?img=nfollow.gif" border=0>')
  ELSE
    subst('#img#','<img src="'+paramstr(0)+'?img=n_leer.gif">')
  END
  IF GetField(d,"art")="News" THEN
    subst('#img_posting#','<img src="'+paramstr(0)+'?img='+choice(hits[n],'news_g.gif','news.gif')+'">')
  ELSIF GetField(d,"art")="Frage" THEN
    subst('#img_posting#','<img src="'+paramstr(0)+'?img=frage.gif">')
  ELSIF GetField(d,"art")="Antwort" THEN
    subst('#img_posting#','<img src="'+paramstr(0)+'?img=antwort.gif">')
  ELSIF GetField(d,"art")="Tipp" THEN
    subst('#img_posting#','<img src="'+paramstr(0)+'?img=tipp.gif">')
  ELSIF GetField(d,"art")="Kritik" THEN
    subst('#img_posting#','<img src="'+paramstr(0)+'?img=kritik.gif">')
  ELSE
    subst('#img_posting#','<img src="'+paramstr(0)+'?img=sonstiges.gif">')
  END
  subst('#img_found#',choice(hits[n],'<img src="'+paramstr(0)+'?img=found.gif">',''))
  cgiwritetemplate
  IF mode=0,getquerystring('b_no')<>str(AutoRecNo(d)) THEN RETURN END
  // ab hier aktiver Thread
  access(d,indname(d,2))
  setfilter(d,t:=str(AutoRecNo(d)),t)
  getmarks(d,tmarks); delmarks(d);
  x:=firstrec(d)
  WHILE x DO setmark(d,x); x:=nextrec(d) END
  x:=firstmark(d)
  // Rekusrsion !!
  WHILE x DO PrintThread(d,x,indent+1,1,b_no); x:=nextmark(d,x) END
  delmarks(d); putmarks(d,tmarks)
ENDPROC

PROCEDURE ViewNode
// Zeigt einen Eintrag im unteren Fenster
VAR d,i,x,n_refs, r_ref : INTEGER
VAR mail, s_name : STRING
  IF d:=opendb(db), x:=readrec(d,findrec(d,getquerystring('a_no'),'forum.inr')) THEN
    LoadForm(choice(isadmin,'admin_node.html','old_node.html'),'')
    subst('#the_time#',timestr(getrfield(d,'the_time')))
    subst('#dayofweek#',dayofweek(getrfield(d,'the_date')))
    IF NOT isadmin THEN
      IF mail:=getfield(d,'email') THEN
        s_name:='<a href="mailto:'+mail+'">'+tohtml(getfield(d,'name'))+'</a>'
      ELSE
        s_name:=tohtml(getfield(d,'name'))
      END
      subst('#name#',s_name)
    END
    nloop(i,maxlabel(d)-1,choice(sel(gettype(d,i+1) like "M"),0,subst('#'+label(d,i+1)+'#',d,i+1,1)))
    subst('#text:content#',d,'content',5-4*isadmin)
    WHILE r_ref:=getrfield(d,'antwort_auf') DO
      subst('#refs#','#refs#<a href="'+paramstr(0)+'?action=view&a_no='+str(r_ref)+'">#nn_'+str(n_refs:=n_refs+1)+'#</a>&nbsp;&nbsp;')
      readrec(d,findrec(d,str(r_ref),'forum.inr'))
    END
    IF n_refs=0 THEN
      subst('#refs#','<none>',1)
    ELSE
      subst('#refs#',''); i:=0
      WHILE i:=i+1<=n_refs DO
        subst('#nn_'+str(i)+'#',str(1+n_refs - i))
      END
    END
    IF NOT isadmin THEN
      WHILE subst('&lt;pre&gt;','<pre>')  DO END
      WHILE subst('&lt;/pre&gt;','</pre>') DO END
    END
    cgiwritetemplate
  ELSE
    cgiwriteln('database error (sorry)//.')
  END
ENDPROC

PROCEDURE ShowList(d : INTEGER)
// Zeigt alle gefundenen Beiträge
VAR Marks : TBits[]
VAR x,y,l,d0 : INTEGER
VAR s_sortmode : STRING
  ?s_sortmode:=getident(ini,'sortmode')=''/s_sortmode:='delete_date,delete_time'
  cgiwriteln('<html>')
  JavaScriptHeader
  cgiwriteln('<body bgcolor="white">')
  LoadForm('forum.header','')
  IF s_start='' THEN
    IF d0:=val(getident('ini','max_days'))=0 THEN d0:=60 END
    subst('#v_start#',datestr(today - d0),1)
  ELSE
    subst('#v_start#',s_start,1)
  END
  WHILE subst('#start#',s_start) DO END
  IF s_search='' THEN
    subst('#v_search#','*')
  ELSE
    subst('#v_search#',s_search,1)
  END
  WHILE subst('#search#',s_search,1) DO END
  cgiwritetemplate
  InitArray(Marks[filesize(d)])
  x:=firstmark(d)
  WHILE x DO
    y:=readrec(d,x)
    WHILE l:=getrfield(d,'antwort_auf') DO
      y:=readrec(d,findrec(d,str(l),indname(d,0),1))
    END
    IF y THEN Marks[y]:=1 END
    x:=nextmark(d,x)
  END
  delmarks(d); putmarks(d,Marks)
  cgiwriteln('<a name="top">')
  sortmark(d,s_sortmode)
  x:=firstmark(d)
  WHILE x, readrec(d,x) DO
    PrintThread(d,x,0,0,str(AutoRecNo(d)))
    x:=nextmark(d,x)
  END
  cgiwriteln('<a name="bottom">')
  cgiwriteln('</body>')
  cgiwriteln('</html>')
ENDPROC

PROCEDURE FindAll(d : INTEGER; s : STRING)
// findet alle ab dem Startdatum s
VAR x, s0 : INTEGER
VAR b_no : STRING = getquerystring('b_no')
  setpara('ec 0'); s0:=val(s); setpara('ec 1')
  findandmark(d,'$the_date>='+datestr(s0))
  IF b_no THEN setmark(d,findauto(d,val(b_no))) END
  sortmark(d,'$the_date,$the_time')
  ShowList(d)
ENDPROC

PROCEDURE FindByIndex(d : INTEGER; s : STRING)
// findet alle mit dem Suchbegriff s
VAR i,r : INTEGER
  //GenFulltextIndex(d,0)
  CheckTable(d)
  IF i:=opendb('d-ind.dat')
    IF r:=opendb('d-rel.rel')
       InitArray(hits[filesize(d)])
       markbits(d,i,NormStr(s,0,'1'),'','',0,hits,r)
       putmarks(d,hits)
       ShowList(d)
       closedb(r)
    END
    closedb(i)
  END
ENDPROC

PROCEDURE MarkThread(d : INTEGER; VAR result : TBits[])
// Markiert die Sätze eines (Teil-)Threads
VAR t : STRING
VAR tmarks : MARKS
VAR x : INTEGER
  x:=recno(d); result[x]:=1
  access(d,indname(d,2))
  setfilter(d,t:=str(AutoRecNo(d)),t)
  getmarks(d,tmarks); delmarks(d);
  x:=firstrec(d)
  WHILE x
    setmark(d,x); x:=nextrec(d)
  END
  x:=firstmark(d)
  WHILE x
    readrec(d,x)
    MarkThread(d,result)
    x:=nextmark(d,x)
  END
  delmarks(d); putmarks(d,tmarks)
ENDPROC

//////////////////////////////////////////////////////.
//  auto-mailer
// 
//  verwendet cgimail.mod
//
VAR mail_subject, mail_from : STRING;

PROCEDURE InStringArray(target : STRING; VAR StringArray : STRING[]) : INTEGER
VAR i : INTEGER
  WHILE i<=high(1,StringArray), StringArray[i]
    IF StringArray[i] like target THEN RETURN 1 END
    i:=i+1
  END
  RETURN 0
ENDPROC

PROCEDURE MailNode(d : INTEGER)
// Untersucht einen Thread auf etwaige Mail-Aufträge und führt diese aus
VAR marks : TBits[]
VAR s_mail : STRING[1000]  // zum Unterbinden von Doppel-Mails
VAR mail_to : STRING
VAR x,t,n_mail : INTEGER
  IF mail_from:=getident(ini,'mail_from')="" THEN RETURN END
  mail_subject:=getident(ini,'mail_subject')
  IF s_email THEN s_mail[0]:=s_email; n_mail:=1 END
  loadtemplate('mail.msg'); close(255);
  subst('#headline#',s_headline,2)
  subst('#name#',s_name,2)
  subst('#email#',s_email,2)
  subst('#the_date#',datestr(today))
  subst('#the_time#',timestr(now,0))
  subst('#content#','ramtext:text:content',2)
  subst('#forum#','http://'+getenv('HTTP_HOST')+paramstr(0))

  // Mails aus Mailing-Liste
  IF IsFile('mailing.list') THEN
    t:=reset('mailing.list')
    WHILE NOT EOT(t) DO
      IF mail_to:=readln(t) THEN
        IF mail_to[1]<>'#', NOT InStringArray(mail_to,s_mail) THEN
          s_mail[n_mail]:=mail_to; n_mail:=n_mail+1
          MailRamText(mail_to,mail_subject,mail_from)
        END
      END
    END
  END

  // Mails aus aktuellem Thread
  initarray(marks[filesize(d)]); MarkThread(d,marks)
  delmarks(d); putmarks(d,marks)
  x:=firstmark(d)
  WHILE x DO
    readrec(d,x)
    IF getrfield(d,'email_support'),mail_to:=getfield(d,'email') THEN
      IF NOT InStringArray(mail_to,s_mail) THEN
        s_mail[n_mail]:=mail_to; n_mail:=n_mail+1
        MailRamText(mail_to,mail_subject,mail_from)
      END
    END
    x:=nextmark(d,x)
  END
ENDPROC

////////////////////////////////////////////////////////////////

PROCEDURE NewEntry(a,b : STRING)
// Pseudo-Seite - aktualisert nach der Eingabe eines Beitrags beide Fenster
VAR link_1, link_2 : STRING
  link_1:=paramstr(0)+'?action=list_all&a_no='+a+'&b_no='+b+'#'+a
  link_2:=paramstr(0)+'?action=view&a_no='+a
  cgiwriteln('<html>')
  JavaScriptHeader
  cgiwriteln('<body onload="twoframes('+"'"+link_1+"',0,'"+link_2+"',1)"+'">')
  cgiwriteln('</body>')
  cgiwriteln('</html>')
ENDPROC

PROCEDURE AppendNode
// Hängt einen neuen Eintrag in der Tabelle an
VAR error_msg, a_no, b_no : STRING
VAR d : INTEGER
  EndSema // falls doch gesetzt
  GetParamsFromCGI
  IF s_headline="" THEN
    error_msg:="Bitte geben Sie ein Thema an"
  ELSIF s_name="" THEN
    error_msg:="Bitte geben Sie einen Namen an. Anonyme Beiträge werden nicht angenommen."
  ELSIF GetSize("ramtext:text:content")<5 THEN
    error_msg:="Was ist Ihr Beitrag?"
  ELSIF s_email_support like "JA", s_email="" THEN
    error_msg:="Bitte geben Sie Ihre E-Mail-Adresse an"
  END
  IF error_msg THEN Beitrags_Formular(error_msg)
  ELSIF waitsema('forum.sema',10000) THEN // wichtig !!!
    IF d:=opendb(db,'',0,15) THEN
      CheckTable(d)
      readrec(d,0)
      setfield(d,'headline',s_headline)
      setfield(d,'name',s_name)
      setfield(d,'email',s_email)
      IF s_ref THEN setfield(d,'antwort_auf',s_ref) END
      setfield(d,'the_date',datestr(today))
      setrfield(d,'the_time',now)
      setfield(d,'delete_date',datestr(today))
      setrfield(d,'delete_time',now)
      setfield(d,'art',s_art)
      setfield(d,'email_support',choice(sel(s_email_support),'JA','NEIN'))
      writerec(d,filesize(d)+1)
      readmemo(d,'content','ramtext:text:content',1,1)
      GenFulltextIndex(d,1)
      a_no:=str(AutoRecNo(d))
      b_no:=FindTop(d,1)
      MailNode(d)
      closedb(d)
    END
    NewEntry(a_no,b_no)
    endsema
  ELSE
    cgiwriteln('error locking database (sorry).')
  END
ENDPROC

PROCEDURE New_Node(a_no : STRING)
// Zeigt Formular für neuen Beitrag und füllt diesen aus
VAR d,x,rt : INTEGER
VAR t : STRING
  GetParamsFromCGI
  IF s_headline="",a_no THEN
    d:=opendb(db); s_ref:=a_no
    x:=findrec(d,a_no,'forum.inr')
    readrec(d,x)
    IF t:=getfield(d,'headline') like 're:*' THEN
      s_headline:=t
    ELSE
      s_headline:='re: '+t
    END
    rt:=rewrite('ramtext'); write(rt,'> '); write(rt,'#content##~~#'); close(rt)
    subst('#content#',d,'content')
    WHILE subst(^J,'>~') DO END
    WHILE subst('>~',^J+'> ') DO END
    subst('#~~#',^M+^J)
    copyfile('ramtext','ramtext:text:content')
    s_art:='Antwort'
  END
  Beitrags_Formular('Bitte geben Sie in "Thema" Ihre Frage/Antwort an')
ENDPROC

PROCEDURE MainPage
// Startseite
VAR delta, d : INTEGER
VAR s_start, a_no, b_no : STRING
  IF delta:=val(getident(ini,'view_last'))=0 THEN delta:=120 END
  IF s_start:=getident(ini,'start')='' THEN s_start:='#bottom' END
  IF LoadForm('frameset.html','') THEN 
    IF a_no:=getquerystring('a_no') THEN
       d:=opendb(db);
       readrec(d,findauto(d,val(a_no)));
       b_no:=FindTop(d,0);
       subst('?action=list_all','?action=list_all&a_no='+a_no+'&b_no='+b_no)
       subst('?action=show_help','?action=view&a_no='+a_no)
    END
    subst('#start#',datestr(today - delta)+s_start)
    cgiwritetemplate
  ELSE
    cgiwriteln('frameset.html  not found')
  END
ENDPROC

PROCEDURE image(fn : STRING)
// Bilder
  cgiclosebuffer
  cgiwriteln('content-type: image/gif')
  cgiwriteln('')
  copyfile(fn,'con')
ENDPROC

PROCEDURE ListNodes
// Grundseite für oberes Fenster
VAR d,d0 : INTEGER
.ec 1
  IF d:=opendb(db) THEN
    IF s_search:=cgigetparam('search')='' THEN s_search:=getquerystring('search') END
    IF s_search THEN FindByIndex(d,s_search)
    ELSE
      IF s_start:=cgigetparam('start')='' THEN s_start:=getquerystring('start') END
      d0:=val(s_start); s_start:=datestr(d0)
      FindAll(d,s_start)
    END
  ELSE
    cgiwriteln('database error (sorry)')
  END
ENDPROC

PROCEDURE GetSearch // Leitet eine Stichwortsuche ein
  LoadForm('getsearch.html','')
  subst('#search#',getquerystring('search'),1)
  CgiWriteTemplate
ENDPROC

PROCEDURE GetStart // Holt ein neues Startdatum vom Anwender
  LoadForm('getstart.html','')
  subst('#start#',getquerystring('start'),1)
  CgiWriteTemplate
ENDPROC

// ------------------- Administrations-Teil

PROCEDURE AdminLoginForm
  LoadForm('getpw.html','')
  CgiWriteTemplate
ENDPROC

PROCEDURE DelLinked(d,x : INTEGER)
VAR x1 : INTEGER
  WHILE x1:=findrec(d,str(x),'forum.in1',1) DO
    readrec(d,x1)
    DelLinked(d,getrfield(d,'Laufende_Nummer'))
    delrec(d,x1)
  END
ENDPROC

PROCEDURE DeleteRecord // Löscht einen Satz aus der Tabelle
VAR d, x, a : INTEGER
VAR s_a : STRING
  setpara('ec 1')
  IF waitsema('forum.sema',10000) THEN // wichtig !!!
    IF d:=opendb(db,'',0,15) THEN
      IF x:=findrec(d,s_a:=cgigetparam('Laufende_Nummer'),'forum.inr',1) THEN
        DelLinked(d,VAL(s_a))
        delrec(d,x)
        GenFulltextIndex(d,0)
        NewEntry('0','0')
      ELSE
        cgiwriteln('record not found.')
      END
    ELSE
      cgiwriteln('database error.')
    END
  ELSE
    cgiwriteln('locking error.')
  END
ENDPROC

PROCEDURE RewriteRecord // Schreibt geänderten Datensatz zurück
VAR d, x, i : INTEGER
VAR a_no, b_no, fc : STRING
  setpara('ec 1')
  IF waitsema('forum.sema',10000) THEN // wichtig !!!
    IF d:=opendb(db,'',0,15) THEN
      IF x:=findrec(d,cgigetparam('Laufende_Nummer'),'forum.inr',1) THEN
        readrec(d,x)
        GenFulltextIndex(d,2)
        WHILE i:=i+1<=maxlabel(d) DO
          IF cgigetparam('c_'+label(d,i)), gettype(d,i)[1]<>'M' THEN
            fc:=setfield(d,i,cgigetparam(label(d,i)))
          END
        END
        writerec(d,x)
        IF cgigetparam('c_content') THEN
          readmemo(d,'content','ramtext:text:content',1,1)
        END
        GenFulltextIndex(d,1)
        a_no:=str(AutoRecNo(d))
        b_no:=FindTop(d,0)
      ELSE
        cgiwriteln('record not found.')
      END
      closedb(d)
    ELSE
      cgiwriteln('database error.')
    END
    endsema
    NewEntry(a_no,b_no)
  ELSE
    cgiwriteln('locking error.')
  END
ENDPROC

PROCEDURE DoAdmin
  IF cgigetparam('command')='delete' THEN DeleteRecord
  ELSIF cgigetparam('command')='rewrite' THEN RewriteRecord
  END
ENDPROC

PROCEDURE Main
VAR action, fn, session, test : STRING
  EndSema;  // zur Sicherheit
  SetPara('ec 1')
  IF fn:=getquerystring('img') THEN  // Hier wird nur ein Bild geholt
    SetCGILog('image: '+fn)
    image(fn); HALT
  END
  db:='forum.dat'; ini:='forum.ini'; SetCGILog('tdb-engine')
  IF action:=cgigetparam(varname(action))="" THEN action:=getquerystring(varname(action)) END
  cgiwriteln('content-type: text/html')
  IF action='adminlogin' THEN
    IF getident(ini,cgigetparam('id')+'.password')=test:=cgigetparam('pw'), test THEN // tricky?
      cgiwriteln('set-cookie: forum='+session:=cgigetsession)
      setident(ini,'adminsession',session)
      isadmin:=1; action:=''
    ELSE
      action:='startadmin'
    END
  END
  cgiwriteln('')

  //Admin-Mode testen
  isadmin:=sel(cgitestsession(session:=cgigetparam('cookie.forum')),session:=getident(ini,'adminsession'))

  IF action like 'append_node' THEN AppendNode
  ELSIF action='new_node' THEN New_Node('')
  ELSIF action='reply' THEN New_Node(getquerystring('a_no'))
  ELSIF action='list_all' THEN ListNodes
  ELSIF action='show_help' THEN LoadForm('startforum.html',''); cgiwritetemplate
  ELSIF action='view' THEN ViewNode
  ELSIF action='getstart' THEN GetStart
  ELSIF action='getsearch' THEN GetSearch
  ELSIF action='startadmin' THEN AdminLoginForm
  ELSIF action='doadmin' THEN DoAdmin
  ELSIF action='' THEN TestInitTable; MainPage
  ELSE cgiwriteln('command not found: '+action)
  END
ENDPROC