#!/usr/bin/perl
$|=1;       # Ausgaben nicht puffern (fuer Browser evtl angenehmer)

use strict; # Vorschlag von Arne
my $errmesg = "Kein Fehler!?";
my %fields; # Variable aus dem CGI Aufruf landen hier!
my $the_date;
my $checkthis;
my $PAGE_ENTRY; # 1 Funktion schreibt das, die 2. liest es...

# Benutzername bei der COLI:
my $ME="eric";
# YES/NO: ausser in URL HTML erlauben?
my $HTML="YES";

# bnbbook.cgi: yes, another guest book script....
# Release 1.0 on 09/06/98
# (C) 1998 BigNoseBird.Com, Inc. This program is freeware and may 
# be used at no cost to you (just leave this notice intact). 
# Feel free to modify, hack, and play  with this script. 
# This guestbook (like the world really needs another one) 
# has borrowed several ideas from the works of Selena Sol 
# (http://www.extropia.com/) and Matt Wright
# (http://cgi-resources.com/). The script is the result of user
# requests for something smaller and simpler to work with, but 
# with some new tricks.

# Diese Version wurde heftigst veraendert von Eric Auer
# um es "vollkommen HTML- und Narren-Sicher" zu machen!
# Ausserdem wurde die Funktion stark angepasst...

##################################################################
#           START USER CONFIGURATION SECTION                     #
##################################################################
#
#  FORMULAR-WERTE die dieses Skript verwendet: (siehe auch gbook.html)
#
#  email: Adresse des Gastes - auch fuer automatische Mail verwendet
#                (muss NAME@DOMAIN sein, DOMAIN: IP oder Textformat erlaubt)
#  private:      Wenn "YES" wird der Eintrag Dir gemailt STATT eingetragen.
#  zzurl:        Homepage Adresse des Gastes (muss http://DOMAIN/ETC sein)
#  url:          Spamskript-Bait: Wer das Feld statt zzurl verwendet saugt!
#  name, woher:  Name und Herkunft des Gastes, kann je nach Wert von
#                $HTML HTML enthalten - oder doch lieber nicht (10/2006)
#  wiedas:       So kam der Gast her (gedacht fuer eine Drop-Down-Liste)
#                Kann auch HTML enthalten.
#
#  Fast alle Einschraenkungen, was in den Formularwerten stehen darf,
#  wurden von mir neu hinzugefuegt oder verschaerft. Eric.
#
##################################################################

# War eine Hidden-Form-Value, Skript-intern ist aber besser:
my $NEW_REQUIRED="name,massage";

# set $HTML="NO" if you do not want users to be able to enter HTML tags
# # # habe ich schon ganz oben gesetzt...   $HTML="YES";

# $GUESTBOOK : Dateiname (mit vollem Pfad!) des Gaestebuches
my $GUESTBOOK="/.../gbook.html";

# $GUESTBOOK_URL : Url des Gaestebuches - nach Ausfuehrung des CGI gibt es
# eine automatische Umleitung zum Gaestebuch zurueck!
my $GUESTBOOK_URL="http://.../gbook.html";

# $TEMPDIR : Hier wird der Lockfile (etc) sein, aber nur waehrend das Skript 
# laeuft - muss also ein schreibbares Verzeichnis sein;
# Um Symlinks zu vermeiden, besser ein EIGENES Verzeichnis verwenden!
my $TEMPDIR="/tmp/$ME" . "s_guestbook";
my $lockfile="$TEMPDIR/bnbbook.lck"; # A propos: Locking sollte atomar sein...

# $MY_EMAIL : Deine E-Mail Adresse, fuer die Mails die Dir sagen, dass
# sich Jemand ins Gaestebuch eingetragen hat... @ als \@ schreiben!!!
my $MY_EMAIL="$ME\@..."; 
### $ME habe ich schon oben gesetzt - viele Variablen sind so schon 

# Wenn du $TELL_ME="YES" setzt, bekommst du immer Mail, wenn sich Jemand
# ins Gaestebuch eingetragen hat. Du kannst aber auch $TELL_ME="NO" setzen.
my $TELL_ME="YES";

# $MAIL_PROGRAM ist dein Mail-Programm (vergiss nicht das -t !!!)
# Meistens ist es "/usr/lib/sendmail -t"  oder "/usr/sbin/sendmail -t"
my $MAIL_PROGRAM="/usr/lib/sendmail -t";

# $MUNG="YES" ersetzt @ und . in E-Mail-Adressen, um "Spam-Spiders" abzuhalten
my $MUNG="YES";

# @CENSORED sind Worte, die im Gaestebuch zensiert werden (Kleinschreibung egal)
# @CENSORED_EVEN_AS_PART_OF_WORD ist dasselbe fuer Wort-Abschnitte...
my @CENSORED=('leave.your.mark', 'fuck','shit','asshole','fick','Arsch','Scheiss','Scheiß');
my @CENSORED_EVEN_AS_PART_OF_WORD=('fick','fuck','arsch');

# $VALID_DOMAIN ist "" oder der Name der Domain von der das Skript
# gerufen werden darf - normalerweise der Name Deiner Domain.
my $VALID_DOMAIN="www...";

##################################################################
sub setup_pageentry
{
  my $tzn = $fields{'email'};
  if ($MUNG eq "YES") { $tzn =~ s/\./_PKT_/g; $tzn =~ s/\@/_BEI_/g; };

  # Info in $snoop kann gefaelscht werden, also HTML killen!!! (2/2000, Eric) 
  my $snoop = "From $ENV{'REMOTE_HOST'} [$ENV{'REMOTE_ADDR'}] with ";
  $snoop .= "$ENV{'HTTP_USER_AGENT'}";
  $snoop =~ s/\213/&lt\;/g;
  $snoop =~ s/\233/&gt\;/g;
  $snoop =~ s/</&lt\;/g;
  $snoop =~ s/>/&gt\;/g;
  $snoop =~ tr/\\\`\0\&/XXXX/;

my $seite = $fields{'zzurl'};
# 3/2006 rel=nofollow to make search engines ignore potentially spammy hrefs in my guestbook
if ($seite eq "") 
   { $seite ="<a rel=\"nofollow\" href=\"http://www.example.com/\">";
     $seite .= "<em>keine</em></a>"; }
   else { $seite = "<a rel=\"nofollow\" href=\"$fields{'zzurl'}\">$fields{'zzurl'}</a>"; };

$PAGE_ENTRY=<<__END_OF_PAGE_ENTRY__;
<BR>
<TABLE WIDTH="100%" CELLPADDING="1">
  <TR><TD BGCOLOR="#ffcccc"><I>
  <B>$fields{'name'}</B> &nbsp; ($tzn) ($fields{'woher'}) schreibt:
  </I></TD></TR>
  <TR><TD BGCOLOR="#ccccff">$fields{'massage'}
  </TD></TR>
  <TR><TD BGCOLOR="#ccffcc">
  Heimseite: $seite
  - Datum: $the_date<br>
  Wie kam $fields{'name'} hier her?: $fields{'wiedas'}
  <!-- $snoop  -->
  </TD></TR>
</TABLE>
<HR ALIGN=LEFT WIDTH="100%">
__END_OF_PAGE_ENTRY__

}
##################################################################
#             END USER CONFIGURATION SECTION                     #
##################################################################

# MAIN ###########################################################
# This is where the script starts execution from
  my @mandatory=split( /,/ , $NEW_REQUIRED ); 
    # read in list of mandatory fields (changed by Eric)
  &valid_page;    # referer checked
  $the_date=localtime();
  &findbook;      # file exists and is writeable
  &decode_vars;   # read in form fields (HTML killer really improved by Eric)
  &valid_address; # email is in valid syntax (improved by Eric)
  &valid_url;     # url is in valid syntax and contains a domain (Eric)
  &test_required; # everything filled out
  &setup_pageentry;
  if (($MY_EMAIL ne "") && ($TELL_ME eq "YES"))
    { &notify_me;} # send mail to tell me that my guestbook was signed
  ### ... if ($fields{'private'} ne "YES") { 
    &write_entry;
  ### ... } # add entry to guestbook
  print "Location: $GUESTBOOK_URL\n\n"; # CGI now responds with REDIRECT...
  exit;

##################################################################
# NOTE! Windows 95/98/NT users will have to edit this routine
##################################################################
sub notify_me
{
 my $SBJ = "Neues vom Gaestebuch";
 my $tmpename = $fields{'email'};
 if ($fields{'email'} eq "")
   { $SBJ .= " (ohne Email-Adresse)";
     $tmpename=$MY_EMAIL; }

  open (MZT,"|$MAIL_PROGRAM") || die "Content-type: text/plain\n\n Unable to send mail"; 
  print MZT "To: $MY_EMAIL\n";
  print MZT "From: $tmpename\n"; # darf keine Zeilenwechsel enthalten... ok.
  print MZT "Subject: $SBJ\n\n";

  # Auf Wunsch kann die folgende Mail auch anders formuliert werden...
  print MZT "Caller DNS: $ENV{'REMOTE_HOST'}\nCaller IP: [$ENV{'REMOTE_ADDR'}\n";
  print MZT "Name: $fields{'name'}\nWoher: $fields{'woher'}\n";
  print MZT "Homepage: $fields{'zzurl'}\n";
  print MZT "Bait1: $fields{'zzzurl'}\nBait2: $fields{'url'}\n";
  print MZT "BaitMsg: $fields{'message'}\n";
  print MZT "Wiedas: $fields{'wiedas'}\nText:\n$fields{'massage'}\n"; 

  close (MZT);
}

##################################################################
sub test_required
{
 my $tst;
 foreach $tst (@mandatory) { 
#  if ( ($fields{$tst} eq "") || (!($fields{$tst} =~ /^[A-Za-z0-9]+.*$/)) )
### (changed 10/2004, the above rule was too picky...)
   if ( ($fields{$tst} eq "") || (!($fields{$tst} =~ /[A-Za-z0-9]/)) )
   {
   $errmesg = "\nBitte mehr Felder ausfuellen - $tst war zu leer";
###   $errmesg .= "\n(Es war: " . $fields{$tst} . ")";
   if ($tst eq "massage") { $errmesg = "Du musst eine Botschaft eintragen!"; }
###   $errmesg .= "\nDiese Felder sollen ausgefuellt werden: $NEW_REQUIRED";
   &error_exit; 
   }
 }
}

##################################################################
sub decode_vars
{
  my $i=0;
  my $temp;
  my $item;
  my $citem;

  if ( $ENV{'REQUEST_METHOD'} eq "GET")
   { $temp=$ENV{'QUERY_STRING'};}
   else { read(STDIN,$temp,$ENV{'CONTENT_LENGTH'});}                                          

  my @pairs=split(/&/,$temp);
  foreach $item(@pairs)
   {
    my ($key,$content)=split(/=/,$item,2);
    $content=~tr/+/ /;
    $content=~s/%(..)/pack("c",hex($1))/ge;
    $content =~ s/<!--(.|\n)*-->//g; # Kommentare weg (SSI Gefahr)
    $content =~ tr/\\\`\0\377/XXXX/;
    $content =~ s/ä/\&auml;/g;
    $content =~ s/ö/\&ouml;/g;
    $content =~ s/ü/\&uuml;/g;
    $content =~ s/Ä/\&Auml;/g;
    $content =~ s/Ö/\&Ouml;/g;
    $content =~ s/Ü/\&Uuml;/g;
    $content =~ s/ß/\&szlig;/g;

    my $oldcontent = $content;
    # Netscape-JS-Entities und nummerierte Zeichen rauswerfen: 3/00
    $content =~ s/\&\{([^\}]|\n)*\};/NS-JS-ENTITY/g;
    $content =~ s/\&\{//g;
    $content =~ s/\&\#[0-9]*;/\&oslash;/g;
    $content =~ s/\&\#//g;

    if ( ($HTML eq "NO") || ($key ne "massage") )
     {	# war: kein HTML in URL  -> neu 10/2006:  HTML nur in Message
      $content =~ s/<([^>]|\n)*>//g;          # der Rest ist neu (Eric):
      $content =~ s/\213([^\233]|\n)*\233//g;
      $content =~ s/</&lt;/g;
      $content =~ s/\213/&lt;&lt;/g;
      $content =~ s/>/&gt;/g;
      $content =~ s/\233/&gt;&gt;/g;
      $content =~ s/\026/&quot;/g;
      $content =~ s/http//g;	# klingt nach URL, klingt nach Spam :-p
     }
      else
      {
      $content =~ s/\213/&lt;<!-- cannot accept that -->/g;
      $content =~ s/\233/&gt;/g;
      $content =~ s/<!--([^>]|\n)*>//g; # Kommentare kommen IMMER weg
        # dieser 2. Durchlauf ist radikaler (manchmal uebergruendlich)...
      # Jetzt alle Tags mit T... rauswerfen - keine Tabellen erlauben!
      # verhindert zugleich absichtliche Verwirrung der Tabelle, die
      # den Gaestebucheintrag darstellt (Vorteil Tabelle: verzeiht
      # weggelassene schliessende Tags! Ausserhalb der Tabelle alles wieder OK)
      # Neu 9/2006: Tags mit M auch blocken, z.B. META REFRESH... :-P
        $content =~ s-</[TtMm]([^>]|\n)*>--g;
        $content =~ s-<[TtMm]([^>]|\n)*>--g;
        $content =~ s-<[/]?STYLE([^>]|\n)*>--ig;
        $checkthis = $content;
        &check_html;       # zuletzt HTML-Syntax sicherstellen (!)
      }
    $content =~ s-URL--g;	# Spammers like to say [URL=...]
    if ($oldcontent ne $content) {
      $errmesg = "Meep Meep!";
      &error_exit;
    }
    # \b steht hier fuer "Leerraum"... darum unten noch mal ohne...
    foreach $citem (@CENSORED) {
      $content =~ s/\b$citem\b/\*\*\*/gi;
    }
    foreach $citem (@CENSORED_EVEN_AS_PART_OF_WORD) {
      $content =~ s/$citem/\.\.\./gi;
    }
    if ($oldcontent ne $content) {
      $errmesg = "Meep!";
      &error_exit;
    }

    # Zeilenwechsel und gefaelschte Bookmark-Zeilen entfernen veraendern
    $content =~ s/\015\012/\015/g;
    $content =~ s/\012\015/\015/g;
    $content =~ s/\012/\015/g;
    $content =~ s/\015/\012 /g; # Leerzeichen nach Zeilenwechsel hinzufuegen
    $content =~ s/<!--bookmark-->/<!-- you tried to fake the bookmark -->/g;

    $fields{$key}=$content;
   }
}

##################################################################
sub error_exit
{
  print "Content-type: text/plain\n\nFehler:\n$errmesg\n\n";
  print "Bitte BACK Button druecken und Eintrag korrigieren.\n";
  exit;
}

##################################################################
sub check_html
{
# Erwartet Code ohne \213 und \233 - ansonsten jetzt
# SEHR VIEL SICHERER vor syntaktisch falschem HTML... Eric.
# Neu 2/2000 Eric: Java-Leute aergern und () entfernen... grins...
# CSS verwenden normal {}, ist also ok... CSS-Kommentare sind (* ... *)
my $tocheck = $checkthis;
$tocheck =~ s/SCRIPT/SMALL/gi; # Verarscht... =8-P
$tocheck =~ s/javascript/javashit/gi; # Verarscht Nummer 2 (nicht sicher,
   # da offenbar &#... statt Buchstaben in Tag-Properties erlaubt sind!?)
# 3/2006 - sorry, keine href mehr, viel zu viel spam :-(
if ( $tocheck =~ /href/i )
 {
   $errmesg = "\nHREF are forbidden, there was too much spam, sorry!\n";
   &error_exit;
   # damit die Spammer hoffentlich mal merken, dass es keinen Sinn hat.
 }
# alternativ: Verarscht Nummer 3: $tocheck =~ s-href-label-ig;

my $quote_flag=0;
my $open_flag=0;
my $i;
for ($i=0;$i<length($tocheck);$i++)
 {
  my $tc= substr($tocheck,$i,1);
  if ( ($tc eq "\"") && ($open_flag == 0) )
     { $errmesg = "\nAnfuehrungszeichen nur in HTML Tags erlaubt,\n";
       $errmesg .= "verwende bitte &quot; stattdessen\n"; &error_exit; }
  if ( ($tc eq "\"") && ($open_flag == 1) ) { $quote_flag = 1 - $quote_flag; }

  if ( ($tc eq "<") && ($open_flag != 0) )
     { $errmesg = "\nAuf < muss > folgen - HTML Fehler\n"; &error_exit; }
     # --- verhindert auch < innerhalb ", da " innerhalb < sein muss ---
  if ( ($tc eq "<") && ($open_flag == 0) ) { $open_flag++; }
  if ( ($tc eq "(") && ($open_flag != 0) )
     { $errmesg = "\nIn <> darf kein () stehen - HTML Fehler\n"; &error_exit; }
  if ( ($tc eq ")") && ($open_flag != 0) )
     { $errmesg = "\nIn <> darf kein () stehen - HTML Fehler\n"; &error_exit; }

  if ( ($tc eq ">") && (($open_flag != 1) || ($quote_flag != 0)) )
     { $errmesg = "\n> darf nicht ohne <\n";
       $errmesg .= "oder innerhalb eines Zitates stehen\n"; &error_exit; }
  if ( ($tc eq ">") && ($open_flag == 1) && ($quote_flag == 0) ) { $open_flag--; }
 }
 if ( ($open_flag != 0) || ($quote_flag != 0) )
  {  $errmesg = "Am Ende waren noch einsame < oder \" uebrig!\n"; &error_exit; }
}

##################################################################
sub findbook
{
 if ( -e $GUESTBOOK) { }
 else
   { $errmesg = "Interner Fehler: Datei laut \$GUESTBOOK existiert nicht\n";
     &error_exit; }
 if ( -w $GUESTBOOK) { }
 else
   { $errmesg ="Interner Fehler: Datei laut \$GUESTBOOK ist nicht schreibbar\n";
     &error_exit; }
}

##################################################################
sub write_entry
{
   &get_the_lock; # verhindern, dass das Gaestebuch zweimal zugleich
                  # geschrieben wird
   open(RDBK,"<$GUESTBOOK");  
   my @book=<RDBK>;  
   close(RDBK);

   open(WRBK,">$GUESTBOOK");
   # Wer das Buch wohin getan hat, wo Symlinks drohen, ist selber Schuld.
   # Das Buch sollte nur vom Webserver geschrieben werden duerfen,
   # wer das kann, sollte es also httpd uebereignen (und chmod 644 setzen).
   my $line;
   foreach $line (@book)
    { chomp $line;
      if ($line eq "<!--bookmark-->")
        { print WRBK "<!--bookmark-->\n"; print WRBK "$PAGE_ENTRY\n"; }
      else { print WRBK "$line\n"; }
    }
   close(WRBK);
   &drop_the_lock; # Schreibzugriff als beendet markieren, damit der
                   # naechste wartende Eintrag rein kann
}

##################################################################
sub get_the_lock
{
  # ??? local ($endtime);                                   
  my $endtime = 60;                                      
  $endtime = time + $endtime;                         
  while (-e $lockfile && time < $endtime) { $endtime = $endtime; } # wait...
  if (time >= $endtime)  
    { $errmesg = "Das Gaestebuch ist zur Zeit ueberlastet...\n"; &error_exit; }
  open(LOCK_FILE, ">$lockfile"); 
  # OVERWRITE! Besser append, ausserdem zusaetzlich vor Symlinks schuetzen?
  # Tipp Arne: until (symlink('dangling link','lockfile')) { sleep $i++; }
}

##################################################################
sub drop_the_lock
{
  # ??? close($lockfile);
  unlink($lockfile); # or warn 'No Lockfile'
  # UNLINK! Zusaetzlich vor Symlinks schuetzen?
}

##################################################################
sub valid_address 
 {
  my $testmail = $fields{'email'};
  if ($testmail eq "") { return; }
  if (!($testmail =~ /^[a-zA-Z0-9\-\.\_]+\@([a-zA-Z0-9\-\.]+\.[a-zA-Z]{2,3}|[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3})$/ ))
   # Kontrolle stark verschaerft - Eric
   { $fields{'email'} = "";
     $errmesg = "Trage bitte KEINE oder eine RICHTIGE E-Mail Adresse ein!\n";
     if ($MUNG eq "YES") 
       { $errmesg .= "Keine Sorge, das Gaestebuch \"tarnt\" @ und . ...\n"; }
     &error_exit;
   }
}

##################################################################
sub valid_url # neu von Eric... ziemlich pingelig eingestellt...
 {
  my $spamurl = $fields{'zzzurl'}; # bait 1
  $spamurl .= $fields{'url'}; # bait 2
  $spamurl .= $fields{'message'}; # bait 3
  if ($spamurl ne "") { $errmesg = "Spambots suck!"; &error_exit; }
  my $testurl = $fields{'zzurl'};
  if ($testurl eq "") { return; } # Leere URL ist erlaubt...
  if (!($testurl =~ /^http:\/\/([a-zA-Z0-9\-\.]+\.[a-zA-Z]{2,3}|[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3})\/[a-zA-Z0-9\%\/\~\-\_\.\?\&\=\+]*$/ ))
   { $errmesg = "Bitte gib KEINE oder eine GUELTIGE URL ein!"; &error_exit; }
  if (($testurl =~ /ialis/i) || ($testurl =~ /amadol/i) || ($testurl =~ /ambl/i) || ($testurl =~ /insurance/i))
   { $errmesg = "Leider musste ich wegen Spam-Idioten bestimmte URLs blockieren!"; &error_exit; }
  if (($testurl =~ /buy/i) || ($testurl =~ /soma/i) || ($testurl =~ /phenter/i) || ($testurl =~ /iagra/i))
   { $errmesg = "Leider musste ich wegen Spam-Idioten bestimmte URLs blockieren!"; &error_exit; }
  if (($testurl =~ /casin/i) || ($testurl =~ /gambl/i) || ($testurl =~ /mp3/i) || ($testurl =~ /ring/i))
   { $errmesg = "Leider musste ich wegen Spam-Idioten bestimmte URLs blockieren!"; &error_exit; }
}

##################################################################
sub valid_page                                                         
 {                                                                     
   if ($VALID_DOMAIN eq "") { return; }
   my $DN=$ENV{'HTTP_REFERER'};
   if ($DN eq "") # bisher akzeptierte das Skript unbekannte Referer (Eric)
    { $errmesg= "Skript blockiert - REFERER unbekannt\n"; &error_exit; }
   $DN =~ tr/A-Z/a-z/;
   $VALID_DOMAIN =~ tr/A-Z/a-z/;
   if ($DN =~ /$VALID_DOMAIN/) { return; } 
   else  { $errmesg = "Skript muss vom Gaestebuch aus starten\n"; &error_exit; }
      # noch pingeliger waere es, alles bis zum "?" zu vergleichen...
 }