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

use strict; # Vorschlag von Arne
use locale; # ****XXXX**** fuers Datum
use POSIX qw(strftime); # Locale-Zeitstring
require 5.004; # wegen locale handler
use POSIX qw(locale_h); # eigene Locale-Wahl statt LC_CTYPE, LC_ALL, LANG
setlocale(LC_CTYPE, "de");
# wo vorhanden auch: setlocale(LC_CTYPE, "de_DE.ISO8859-1");

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 und so weiter:
# ****XXXX****
my $ME="eric";
# ****XXXX****
my $MYDOMAIN="www.example.com";
# ****XXXX****
my $HOMEPATHS="home";
# ****XXXX****
my $WHEREAMI="stuff/uv-gb";

# ****XXXX****
my $PAGE_TEMPLATE="/$HOMEPATHS/$ME/public_html/$WHEREAMI/gaestebuch-template.ht";

# YES/NO: ausser in URL HTML erlauben?
my $HTML="NO";

# 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.
#  url:          Homepage Adresse des Gastes (muss http://DOMAIN/ETC sein)
#  name, woher:  Name und Herkunft des Gastes, kann je nach Wert von
#                $HTML HTML enthalten
#  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:
# ****XXXX****
# my $NEW_REQUIRED="name,message";
my $NEW_REQUIRED="name";

# 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
# ****XXXX****
my $GUESTBOOK="/$HOMEPATHS/$ME/public_html/$WHEREAMI/gaeste.html";

# $GUESTBOOK_URL : Url des Gaestebuches - nach Ausfuehrung des CGI gibt es
# eine automatische Umleitung zum Gaestebuch zurueck!
# ****XXXX****
my $GUESTBOOK_URL="http://www.$MYDOMAIN/~$ME/$WHEREAMI/gaeste.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!
# ****XXXX****
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!!!
# ****XXXX****
my $MY_EMAIL="$ME\@$MYDOMAIN"; 

# 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.
# ****XXXX****
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 (gross/klein egal)
# @CENSORED_EVEN_AS_PART_OF_WORD ist dasselbe fuer Wort-Abschnitte...
my @CENSORED=('fuck','shit','asshole','fick','arsch','scheiss');
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.
# ****XXXX****
my $VALID_DOMAIN="www.$MYDOMAIN";

##################################################################
#             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 
                  # (must be checked before &load_template)
# ****XXXX****
  &load_gbtemplate; # read in template for new entries (by Eric 1/2001)
  &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" || $TELL_ME eq "NO"))
    { &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 "Name: $fields{'name'}\nWoher: $fields{'woher'}\n";
  print MZT "Homepage: $fields{'url'}\nPrivat: $fields{'private'}\n";
  print MZT "Wiedas: $fields{'wiedas'}\nText:\n$fields{'message'}\n"; 

  close (MZT);
}

##################################################################
sub test_required
{
 my $tst;
 foreach $tst (@mandatory) { 
   if ( ($fields{$tst} eq "") || (!($fields{$tst} =~ /^[A-Za-z0-9]+.*$/)) )
   {
   $errmesg = "\nBitte mehr Felder ausfuellen - $tst war zu leer"; 
   $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)
# \ ' NUL MAX und neu 23.1.01 $ rauswerfen und ersetzen!
# ****XXXX****
    $content =~ tr/\\\`\0\377\$/\/\'  %/;
    $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;
    # 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 eq "url") ) # Eric: Kein HTML in URL!
     {
      $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;
     }
      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)
        $content =~ s-</T([^>]|\n)*>--g;
        $content =~ s-</t([^>]|\n)*>--g;
        $content =~ s-<T([^>]|\n)*>--g;
        $content =~ s-<t([^>]|\n)*>--g;
        $content =~ s-<[/]?STYLE([^>]|\n)*>--ig;
        $checkthis = $content;
        &check_html;       # zuletzt HTML-Syntax sicherstellen (!)
      }
    # \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; }

    # 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!?)

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; }

 if ( -e $PAGE_TEMPLATE) { }
 else
   { $errmesg = "Interner Fehler: Datei laut \$PAGE_TEMPLATE existiert nicht\n";
     &error_exit; }
 if ( -r $PAGE_TEMPLATE) { }
 else
   { $errmesg ="Interner Fehler: Datei laut \$PAGE_TEMPLATE ist nicht lesbar\n";
     &error_exit; }
}

##################################################################
sub write_entry
{
   &get_the_lock; # verhindern, dass das Gaestebuch zweimal zugleich
                  # geschrieben wird
   $errmesg = "Kann das Buch nicht aufmachen\n";
   open(RDBK,"<$GUESTBOOK") || &error_exit;
   my @book=<RDBK>;  
   close(RDBK);

   open(WRBK,">$GUESTBOOK") || &error_exit;
   # 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; }
  $errmesg = "Lockfile kann nicht angelegt werden\n";
  open(LOCK_FILE, ">$lockfile"); # ****XXXX**** || &error_exit;
  # 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 $testurl = $fields{'url'};
  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; }
}

##################################################################
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; } 
      # noch pingeliger waere es, alles bis zum "?" zu vergleichen...
   else  { $errmesg = "Skript muss vom Gaestebuch aus starten\n"; &error_exit; }
 }

##################################################################
sub load_gbtemplate
{
   $errmesg = "Template kann nicht geladen werden\n";
   open(RDBK,"<$PAGE_TEMPLATE") || &error_exit;
   my @templ=<RDBK>;
   close(RDBK);
   $PAGE_TEMPLATE = "";

   my $line;
   foreach $line (@templ)
    { chomp $line;
      $PAGE_TEMPLATE .= "$line\n";
    }
}

##################################################################
sub setup_pageentry
{
  my $tzn = $fields{'email'};
#  if ($MUNG eq "YES") { $tzn =~ s/\./_PKT_/g; $tzn =~ s/\@/_BEI_/g; };
# ****XXXX****
  if ($MUNG eq "YES") { $tzn =~ s/\@/\&lt;BEI\&gt;/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\&\$/XXXXX/;

my $seite = $fields{'url'};
if ($seite eq "") 
# ****XXXX****
    { $seite ="<em>keine Homepage</em>";
    }
   else { $seite = "<a href=\"$fields{'url'}\">$fields{'url'}</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{'message'}
#  </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__

# ****XXXX****
if ($fields{'woher'} eq "") { $fields{'woher'} = "<em>unbekannt</em>"; }
$PAGE_ENTRY=$PAGE_TEMPLATE;
$PAGE_ENTRY =~ s/SIGNERNAME/$fields{'name'}/g;
$PAGE_ENTRY =~ s/SIGNERMAIL/$tzn/g;
$PAGE_ENTRY =~ s/SIGNERURLWITHTAG/$seite/g;
$PAGE_ENTRY =~ s/SIGNERPLACE/$fields{'woher'}/g;

# $PAGE_ENTRY =~ s/SIGNERDATE/$the_date/g;
my $german_date = strftime "%d. %B %Y", gmtime;
# %a Kurzwochentag %A lang... %b Kurzmonatsname %B lang... %w Wochentagsnummer
# %c local Date-Time-Default-Format %S Sekunde %x Date-Default %X Time-Default
# %U Wochennummer (Sonntagswochen) %u ... (Montagswochen)
# %d Tag %H Stunde %I 12h-Stunde %j Jahrestag %m Monat %M Minute %p am/pm
# %y Jahr2 %Y Jahr4 %Z Zeitzone %% %
# siehe man perlfunc -> gmtime, time, ctime, timegm, POSIX::strftime 
# da die .de locale leider oft fehlt: us -> de mimimalistisch:
$german_date =~ s/y /i /g;             $german_date =~ s/uari/uar/g;
$german_date =~ s/March/M\&auml;rz/g; $german_date =~ s/June/Juni/g;
$german_date =~ s/Oct/Okt/g;          $german_date =~ s/Dec/Dez/g;

$PAGE_ENTRY =~ s/SIGNERDATE/$german_date/g;

$PAGE_ENTRY =~ s/SIGNERTEXT/$fields{'message'}/g;
$PAGE_ENTRY .= "<!-- $snoop -->";

}