#!/usr/bin/perl
# $
# $        (Guestbook version 4.7)
# $
# $        Thank you for using my guestbook script, this has been popular with the web community
# $        and I have noticed many people using it on the internet, especially 2 sites that I
# $        know of that have been offering use of it for free.  This means a lot to me because
# $        they have chosen it over the many other guestbook scripts out there.
# $
# $        This code is distributed in the hope that is will be useful but WITHOUT ANY
# $        WARRANTY. ALL WARRANTIES, EXPRESS OR IMPLIED ARE HEREBY DISCLAMED. This includes
# $        but isn't limited to warranties of MERCHANTABILITY or FITNESS FOR A PARTICULAR
# $        PURPOSE.  The RESELLING of this code is STRICTLY PROHIBITED.
# $
# $        $Revision: 4.7
# $        $Author: Paul Williams
# $        $Email: paul@rainbow.nwnet.co.uk
# $        $URL: http://www.cgiuk.com/
# $        $Created: 05/07/1996 17:16
# $        $Last Modified: 07/01/2000 21:37
# $
# $        Copyright 1996, 1997, 1998, 1999, 2000 Cougasoft.  All rights reserved.
# $
# $           Deutsche Bearbeitung von Carsten Schubert (Webmasterwelt: http://www.wmwelt.de)
# $           Email: wmwelt@gmx.net
# $           Das Copyright des Autors bleibt natürlich trotz der deutschsprachigen Lokalisation bestehen
# $           Copyright 1999, 2000 Webmasterwelt


#
# $--------------------------------------------------------------------------------------------
#
#  M  A  I  N          P  R        O  G  R  A  M
#
# $--------------------------------------------------------------------------------------------
#

        $VERSION = sprintf("%d.%02d", q$Revision: 4.72 $ =~ /(\d+)\.(\d+)/);


        unless ( (my $pref = &preferences("data/igb-pref.pref", 34) ) == 1
                || (my $pref2 = &preferences("igb-pref.pref", 34) ) == 1)
        {
                print "Content-type: text/plain\n\n";
                print "Error initiating preference file(s);\n\n";
                print "$pref\n$pref2\n\nScript currently residing in:" . (`pwd`);
                exit;
        }

          my (%INPUT, %PREF, %ERR, $FLAGPOST, $FLAGFORMPRINT, $cgiopt, $cgicount, $cgierr, $comments);
        &ReadInput();

#
# $--------------------------------------------------------------------------------------------
#
#  A  C  T  I  O  N    =    S  I  G  N          G  U        E  S  T  B  O  O  K
#
# $--------------------------------------------------------------------------------------------
#

        sub signguestbook
        {
                my $i = 0;

                $comments = $INPUT{'COMMENTS'};
                $INPUT{'COMMENTS'} =~ s/\cM//g;
                $INPUT{'COMMENTS'} =~ s/( |\t)+/ /g;
                $INPUT{'COMMENTS'} =~ s/\n+/<BR>/g;

                # $ Open the file which containts the words we want to disallow, you must
                # $ edit this file by hand, at the moment I'm not allowing it to be edited by
                # $ the administration but it might be a feature in a newer version.
                if ($PREF{'DISALLOW'}) {
                        &openf("DISALLOW", $PREF{'DISALLOWFILE'});
                        while (<DISALLOW>) {
                                chop;
                                return $ERR{general} = "Ihr Eintrag enthält ein verbotenes Wort [$_] bitte ändern." if ($INPUT{'COMMENTS'} =~ /$_/i);
                         }
                        close(DISALLOW);
                }

                my (@longwords) = split(/\s+/, $INPUT{'COMMENTS'});
                $INPUT{'COMMENTS'} = "";
                foreach (@longwords) {
                        $INPUT{'COMMENTS'} .= "$_ " unless ($PREF{'CHECKBIGWORD'} && length > 30);
                        $i++;
                }

                return $ERR{general} = "Bitte benutzen Sie mindestens $PREF{'MAXWORDS'} Wörter, bisher benutzt $i" if ($PREF{'MAXWORDS'} && $i >= $PREF{'MAXWORDS'});

                &write();
                &sendmail();

                &top_html("Erfolg !", 2);
                &FormPrint("CELLSPACING=0 CELLPADDING=4 BGCOLOR=\"$PREF{TBCOLOR}\" WIDTH=70% BORDER=0", 25, undef, 'YES',
                        HEADER, "Submitted&nbsp;Variables", "\n",
                        STRING, "Name", &Ternary($INPUT{NAME}), "\n",
                        STRING, "Email", &Ternary($INPUT{EMAIL}), "\n",
                        STRING, "Stadt", &Ternary($INPUT{CITY}), "\n",
                        STRING, "Land", &Ternary($INPUT{COUNTRY}), "\n",
                        STRING, ($INPUT{LINK}?"Homepage":undef), "<a href=\"$INPUT{LINK}\" target=\"$PREF{TARGET_URL}\">$INPUT{LINK}</a>", "\n",
                        STRING, "Komentar", &Ternary($INPUT{COMMENTS}), "\n"
                );
                print "<br><center><font size=-1>Bitte <a href=\"$ENV{SCRIPT_NAME}?q=review\" target=\"$PREF{TARGET}\">hier klicken</a> , wenn Sie Ihren Eintrag sehen möchten.</font></center>" if !$INPUT{'NOPOST'};
                print "<br><center><font size=-1>Danke für Ihren Eintrag, <A HREF=\"$PREF{'HOME'}\" TARGET=\"$PREF{'TARGET'}\">h i e r</A> gehts zurück zu meiner Seite!&nbsp;</font></center>" if $INPUT{'NOPOST'};
                &bottom(1);
        }

          if ($INPUT{'&q'} eq "sign")
           {
                my $SVCOMMENT = $INPUT{COMMENTS};

                   # Check to see if there are any errors, if there are not then this person
                   # can be added to the database.  If you look below there should be exactly
                   # five fields submitted with no errors.
                   if ($FLAGPOST and $cgierr == 0 and $cgicount >= 6
                           and $ENV{HTTP_REFERER} =~ m,$ENV{SCRIPT_NAME},i)
                   {
                                &signguestbook();
                   }

                $ERR{general} = "Bitte schauen sie unten für mehr Details über den Fehler." if ($FLAGPOST and !$ERR{general});

                &top_html("Sign in...", 2);
                FormPrint("CELLSPACING=0 CELLPADDING=4", 25, "q=sign", 'yes',
                        HEADER, "SIGN GUESTBOOK", "\n",
                        TEXT, "Name", "_rs[h]_NAME", &Ternary($INPUT{NAME}), 40, 100, "\n",
                        TEXT, "Email Adresse", "_re_EMAIL", &Ternary($INPUT{EMAIL}), 40, 255, "\n",
                        TEXT, "Stadt", "_s[h]_CITY", &Ternary($INPUT{CITY}), 40, 100, "\n",
                        TEXT, "Land", "_s[h]_COUNTRY", &Ternary($INPUT{COUNTRY}), 40, 100, "\n",
                        TEXT, "Homepage", "_u_LINK", &Ternary($INPUT{LINK}), 40, 100, "\n",
                        TEXTAREA, "Komentar", "_r".($PREF{HTML}=='0'?undef:'s[h]')."l[10][2500]_COMMENTS", &Ternary($SVCOMMENT), 50, 7, "\n",
                        CHECKBOX, "Als Mitteilung senden", "NOPOST", "1", $INPUT{NOPOST}, "Wenn markiert, Eintrag erscheint nicht im Gästebuch, sondern wird per Mail gesendet.", "\n"
                );
                &bottom(1);
          }

#
# $--------------------------------------------------------------------------------------------
#
#  A  C  T  I  O  N    =    R  A  N  D        O  M        L  I  N  K
#
# $--------------------------------------------------------------------------------------------
#

         elsif ($INPUT{'&q'} eq 'random')
          {
                &openf("DATA", "$PREF{'DATA'}");
                   my @data = <DATA>; close DATA;

                srand(time ^ $$);

                for (my $n = 0; $n < 3; $n++)
                 {
                            my $l = $data[rand($#data)];
                            my ($email, $name, $city, $state, $comment, $link, $date, $country) = split('\|\|', $l);

                            if ($link =~ m`^http://`) {
                                  print "Location: $link\n\n";
                                  exit 0;
                              }
                 }

                print "Location: http://www.rostock-elektronik.de/\n\n";
          }

#
# $--------------------------------------------------------------------------------------------
#
#  A  C  T  I  O  N    =    E  L  S  E
#
# $--------------------------------------------------------------------------------------------
#

          else
           {
                my ($i, @lines);
                $INPUT{'&trail'} = $PREF{PERPAGE} unless $INPUT{'&trail'};

                &openf("DISPLAY", "$PREF{'DATA'}");
                     if ($PREF{'DISPLAY'} == 2) { @lines = reverse(<DISPLAY>); }
                     else { @lines = <DISPLAY>; }
                close(DISPLAY);

                &top_html("Willkommen !", 1);
                   print "<CENTER><TABLE CELLSPACING=0 CELLPADDING=1 WIDTH=\"60%\" >\n";

                foreach (@lines)
                 {
                        next if ($i++ < $INPUT{'&trail'} - $PREF{'PERPAGE'});

                           my ($email, $name, $city, $state, $comment, $link, $date, $country) = split('\|\|');

                        print "<TR BGCOLOR=\"$PREF{'RESHADE'}\">\n<TD><FONT SIZE=-2>&nbsp;</FONT>";
                        print "</TD>\n</TR>\n\n";

                        print "<TR>\n<TD>";
                        print "<FONT SIZE=-1><B><A HREF=\"mailto:$email\">$name</A></B> - <I>$date</I><BR>\n";
                        print "$city " if $city;
                        print "[$country]" if $country;
                        print "<BR>" unless !$state && !$city;
                        print "$comment <BR>\n\n";
                        print "<B><A HREF=\"$link\" TARGET='$PREF{'TARGET_URL'}'>$link</A></B>\n" if $link;
                        print "</FONT></FONT>";
                        print "</TD>\n</TR>\n\n";

                        last if ($i == $INPUT{'&trail'});
                 }

                   print "<TR BGCOLOR=\"$PREF{'RESHADE'}\">\n<TD><FONT SIZE=-2>&nbsp;</FONT>";
                   print "</TD>\n</TR>\n\n";
                   print "</TABLE>\n";

                &multipages($#lines + 1,$i,$INPUT{'&trail'},$PREF{PERPAGE},undef) if ($i == $INPUT{'&trail'} or $INPUT{'&trail'} != $PREF{PERPAGE});
                print "<P><HR SIZE=1 WIDTH=\"45%\" NOSHADE>" if (! ($i == $INPUT{'&trail'} or $INPUT{'&trail'} != $PREF{PERPAGE}) );

                # $ Please don't change this and claim you wrote the script, I have seen it
                # $ done on quite a few websites, its a little dis-heartening, thank you :)
                print "<FONT SIZE=-1>Script written by Paul Williams <A HREF=\"http://www.cgiuk.com/\" TARGET='$PREF{'TARGET_URL'}'>" .
                          "CougaSoft</A> & <A HREF='http://www.wmwelt.de/' TARGET='$PREF{'TARGET'}'>" ."WmWelt</A></FONT></P></CENTER>";
                &bottom(1);
        }

#
# $--------------------------------------------------------------------------------------------
#
#  S  U  B  R  O  U  T  I N  E  S
#
# $--------------------------------------------------------------------------------------------
#

        sub top_html
           {
                print "Content-type: text/html\n\n" .
                # $ Please don't change this, people seem to like to alter the written by which is
                # $ a little dis-heartening, especially as its hidden inside the html output. The
                # $ version number is also embedded in the script which helps me if ever you have
                # $ trouble with it.
                    "<!-- Inter Guestbook $VERSION Written by Paul Williams, Cougasoft [paul\@rainbow.nwnet.co.uk] -->\n" .
                        "<HTML>\n" .
                        "<HEAD>\n" .
                        "         <TITLE>$PREF{'GBNAME'} Guestbook - $_[0]</TITLE>\n" .
                        "</HEAD>\n" .
                        "<BODY TEXT='$PREF{'BODYTEXT'}' BGCOLOR='$PREF{'BGCOLOR'}' LINK='$PREF{'LINK'}' VLINK='$PREF{'VLINK'}' ALINK='$PREF{'ALINK'}' BACKGROUND='$PREF{'BACKGROUND'}'>\n\n";
                print "<CENTER><IMG SRC='$PREF{'GIF'}'></CENTER>\n\n" if $PREF{GIF};

                print "<CENTER><FONT SIZE=-1>[<A HREF='$ENV{'SCRIPT_NAME'}?q=sign' TARGET='$PREF{'TARGET'}'>Eintragen</A>] - [<A HREF='$PREF{'HOME'}' TARGET='$PREF{'TARGET'}'>H o m e</A>] - " .
                        "[<A HREF='$ENV{'SCRIPT_NAME'}?q=random' TARGET='$PREF{'TARGET_URL'}'>Zufallslink</A>] </FONT></CENTER><BR>" if $_[1] == 1;

                print "<CENTER><FONT SIZE=-1>[<A HREF='$ENV{'SCRIPT_NAME'}?q=view' TARGET='$PREF{'TARGET'}'>Einträge lesen</A>] - [<A HREF='$PREF{'HOME'}' TARGET='$PREF{'TARGET'}'>H o m e</A>] - " .
                        "[<A HREF='$ENV{'SCRIPT_NAME'}?q=random' TARGET='$PREF{'TARGET_URL'}'>Zufallslink</A>] </FONT></CENTER><BR>" if $_[1] == 2;
           }

#
# $--------------------------------------------------------------------------------------------
#
#  S  U  B  -  W  R  I        T  E        G  U  E  S  T  B  O  O        K
#
# $--------------------------------------------------------------------------------------------
#

         sub write
          {
                # $ Open the data file and read through it until we reach the end, the way we
                # $ work out if the post has already been added is if the comments match.  This
                # $ is the only way to really do it because we can't match other variables as
                # $ people may post again with some more compliments ;)
                &openf("DATABASE", "+>>$PREF{'DATA'}");

                # $ Get data but before we wipe it, make sure its not been added.
                seek DATABASE, 0, 0; my @results = <DATABASE>;

                foreach (@results)
                {
                             my ($email, $name, $city, $state, $comment, $link, $date, $country) = split('\|\|');

                             close(DATABASE), &notify("500 Internal Server Error", "Ihr Eintrag ist bereits aufgenommen.<BR>Bitte " .
                                "<A HREF=\"$ENV{'SCRIPT_NAME'}?action=review\" TARGET='$PREF{'TARGET'}'>hier klicken</A> um ihn zu lesen.", 0) if ($comment eq $INPUT{'COMMENTS'});
                }

                # If we have got this far then this is a new comment, as this is the case we
                # can now wipe the file clean and append the results (in chronological order).
                     if (!$INPUT{'NOPOST'})
                      {
                        seek DATABASE, 0, 0; truncate DATABASE, 0;

                        my $date = &date(); my $init = 0;

                                   print DATABASE "$INPUT{'EMAIL'}||$INPUT{NAME}||$INPUT{'CITY'}||" .
                                                 "||$INPUT{'COMMENTS'}||$INPUT{'LINK'}||$date||$INPUT{'COUNTRY'}||\n";
                                while ( --$PREF{'MAXIMUM'} ) {
                                print DATABASE "$results[$init]";
                                $init++;
                                }
                      }
                close DATABASE;
          }

#
# $--------------------------------------------------------------------------------------------
#
#  S  U  B  -  T  E  R        N  A  R  Y
#
# $--------------------------------------------------------------------------------------------
#

        sub Ternary
        {
                my $ternval = shift;
                $ternval =~ s,",&quot;,g;

                return $ternval ? $ternval : undef;
        }

#
# $--------------------------------------------------------------------------------------------
#
#  S  U  B  -  R  E  A        D  -  I  N  P U  T
#
# $--------------------------------------------------------------------------------------------
#

        sub ReadInput
         {
                my $choice = shift;

                 if ($ENV{'QUERY_STRING'})
                  {
                        my (@pairs, $pair, $name, $value);

                        @pairs = split($choice?'\&':'\+', $ENV{'QUERY_STRING'});

                        foreach $pair (@pairs)
                        {
                                ($name, $value) = split(/=/, $pair);

                                $value =~ tr/+/ /;
                                $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
                                $INPUT{"&$name"} = $value;
                        }
                  }

                my (@pairs, $input, $pair, $name, $value, $opt);

                if ($ENV{'CONTENT_LENGTH'})
                  {
                        read(STDIN, $input, $ENV{'CONTENT_LENGTH'});

                        @pairs = split(/&/, $input);

                        foreach $pair (@pairs)
                        {
                                ($name, $value) = split(/=/, $pair);

                                $name =~ tr/+/ /;
                                $name =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;

                                $value =~ tr/+/ /;
                                $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
                                    $value =~ s/^\s*//; # Don't allow people to just use a space by
                                    $value =~ s/\s*$//; # chopping all preceding and trailing spaces.

                                # Check the $name key above for a little more information.
                                if ($name =~ s/^_(.*?)_([A-Z\- ]+)$/$2/)
                                {
                                        $opt = $1;

                                          # $ Must do the substitution option now because it contains some
                                          # $ flags which the others may need to work with (eg 'u').
                                          if ($opt =~ /s\[([shutle]+)\]/)
                                         {
                                                 $_ = $1;
                                                 if ($value)
                                                 {
                                                         $value =~ s/<([^>]|\n)*>//g if /h/;
                                                         $value =~ s/\s+/ /g if /s/;
                                                         $value =~ s/'/\\'/g if /e/; # Escape
                                                         $value =~ s/\b(\w){1}(\w+)\b/(uc $1) . (lc $2)/ge if /t/;
                                                         $value = uc $value if /u/;
                                                         $value = lc $value if /l/;
                                                 }

                                                # Remove all the sub flags from the option.
                                                 $opt =~ s/s\[$_\]//;
                                         }

                                        # $ B = banned/disallowed characters. $opt comes in the form
                                        # $ of a regular expression so make sure its right ;)
                                        if ($opt =~ /b\[(.*?)\]/)
                                         {
                                                 my $regexp = $1;
                                                 $ERR{"$name"} = "Character" . (length $regexp == 1?"":"s") . " [$regexp] " .
                                                         (length $regexp == 1?"is":"are") . " not allowed inside this field.", $cgierr++ if $value && $value =~ m#[$regexp]#;

                                                 # Remove regular expression from the option.
                                                 $opt =~ s/b\[$regexp\]//;
                                         }

                                        if ($opt =~ /r/ && !$value)
                                         { $ERR{"$name"} = "Fehlende Angabe", $cgierr++; }
                                        elsif ($opt =~ /d/ && $value && ($value !~ /^[0-9]+$/))
                                         { $ERR{"$name"} = "Das Feld $name kann nur Zahlen enthalten.", $cgierr++; }
                                        elsif ($opt =~ /h/ && $value && ($value !~ /^\#[0-9a-zA-Z]+$/ || length($value) != 7))
                                         { $ERR{"$name"} = "Es gibt ein Syntax Problem mit $name, bitte im Hex-Format [#FFDCED] schreiben", $cgierr++; }
                                        elsif ($opt =~ /e/ && $value && &mailcheck($value) == -1)
                                         { $ERR{"$name"} = "Incorrect email syntax, please write like 'yourname\@yourhost.com'", $cgierr++; }
                                        elsif ($opt =~ /u/ && $value && $value !~ m,^http://([^/:]+)(?::(\d+))?(/\S*)?$,)
                                         { $ERR{"$name"} = "$name does not have the correct URL syntax.", $cgierr++; }
                                        elsif ($opt =~ /i/ && $value && $value !~ /(\.gif|\.jpeg|\.jpg)$/i)
                                         { $ERR{"$name"} = "$name has incorrect IMAGE syntax, please use a .GIF or .JPG graphic", $cgierr++; }
                                        elsif ($opt =~ /t/ && !-e $value)
                                         { $ERR{"$name"} = "$name ($value) does not exist on the server", $cgierr++; }
                                        elsif ($opt =~ /w/ && $value && $value =~ /\s/)
                                         { $ERR{"$name"} = "Variable $name can not contain any spaces.", $cgierr++; }
                                          elsif ($opt =~ /l\[([\d]+)\]\[([\d]+)\]/ && $value)
                                         {
                                                 $cgierr++, $ERR{"$name"} = "Minimum length for $name is $1, you've only used " . length($value) . " characters" if $1 && length($value) < $1;
                                                 $cgierr++, $ERR{"$name"} = "Maximum length for $name is $2, you've used " . length($value) . " characters" if $2 && length($value) > $2;
                                         }

                                        # $ Push all the values of $name to an array of the same name,
                                        # $ not very pretty but at least it does the trick.
                                        push @$name, $value if $opt =~ /p/;

                                        $cgiopt++;
                                }

                                $INPUT{$name} = $value, $cgicount++;
                         }

                        $FLAGPOST = 1;
                  }

                #  Couple of global variables that I call here to save time.
                $INPUT{'time'} = time;

                1;

          # $ Read Input ()
        }

#
# $--------------------------------------------------------------------------------------------
#
#  S  U  B  -  F  O  R        M    P        R  I  N  T
#
# $--------------------------------------------------------------------------------------------
#

        sub FormPrint
        {
                my ($tablepref, $tdwidth, $action, $finishform, @type) = @_;
                my ($inputname, $value, $tmp, $errbr);

                $PREF{'ERR'} = "RED" unless $PREF{'ERR'};

                # $ FormPrint can not handle every event I would like it too (I may add it
                # $ in the future but I am trying to keep the code small) so I have the
                # $ option to pause the printing
                unless ($FLAGFORMPRINT)
                {
                        $action = "?" . $action if $action;

                        print qq!\n\n<FORM METHOD="POST" ACTION="$ENV{'SCRIPT_NAME'}$action">\n! if $action;
                        print qq!<CENTER>\n<TABLE $tablepref BGCOLOR="$PREF{'TBCOLOR'}" >\n!;
                        print qq!<caption><font size="-1" color="$PREF{ERR}">Error: $ERR{general}</font></caption>! if $ERR{general};
                }

                while (my(@args), @type)
                {

                        # $ I had to think about this for a while and the answer actually came
                        # $ while I was asleep (thats where I solve most my problems).
                        # $
                        # $ The problem here was I couldn't use undef because if the value of
                        # $ the input field was undef, the whole function was mixed up.  I have
                        # $ realised that because my readinput trims leading and trailing spaces,
                        # $ the char '\n' can be used to separate each command.

                        push(@args, $_) while (@type && ($_ = shift @type) ne "\n");


                        $_ = shift @args; # Table command: TEXT, SELECT etc...
                        ($inputname = $args[1]) =~ s/_(.*?)_([A-Z]+)/$2/; # Trimmed Form Name

                        $errbr = "<BR>" unless length($ERR{$inputname}) < 20;
                        $ERR{$inputname} =~ s/\s+/&nbsp;/g;

                        if (/TEXT\b|PASSWORD/i)
                        {
                                     $value = (/PASSWORD/i ? "password" : "text");

                                     print qq!<TR><TD WIDTH="$tdwidth\%"><FONT SIZE="-1">$args[0] </FONT></TD>
                                        <TD><INPUT type="$value" name="$args[1]" size="$args[3]" maxlength="$args[4]" value="$args[2]">!;
                                print qq!$errbr<FONT COLOR="$PREF{'ERR'}" SIZE="-1">&nbsp;$ERR{$inputname}</FONT>\n! if $ERR{$inputname};
                                print qq!</TD></TR>\n\n!;
                        }
                        elsif (/HEADER/i)
                        {
                                print qq!<TR BGCOLOR="$PREF{'RESHADE'}">
                                        <TD><FONT FACE="ARIAL" SIZE="-1"><B>$args[0]&nbsp;</B></TD>
                                        <TD>&nbsp;</TD></TR>!;
                        }
                        elsif (/STRING/i)
                        {
                                # $ Just a simple option to place a string value into the
                                # $ form table, there is no error checking here.
                                print qq!<TR><TD WIDTH="$tdwidth\%"><FONT SIZE="-1">$args[0]</FONT></TD>
                                        <TD><FONT SIZE="-1">&nbsp;$args[1] </FONT>\n</TD></TR>\n\n! if ($args[0] and $args[1]);
                        }
                        elsif (/SELECT/i)
                        {
                                     print "<TR><TD><FONT SIZE=-1>" . (shift @args) . "</FONT></TD>\n<TD><SELECT NAME=\"" . (shift @args) . "\">\n";
                                $value = shift @args; # Get the next argument which should be the selected value

                                while ( $tmp = shift @args )
                                {
                                        print "\t<OPTION VALUE='" . ($_ = shift @args) . "'" .
                                              ($_ eq $value ? "SELECTED" : "") . "> $tmp\n";
                                }

                                print "</SELECT>\n";
                                print "<FONT COLOR='$PREF{'ERR'}' SIZE=-1>$ERR{$inputname}</FONT>\n" if $ERR{$inputname};
                                print "</TD></TR>\n";
                        }
                        elsif (/TEXTAREA/i)
                        {

                                # $ We have two types of textareas, the selling point here
                                # $ is we only take notice of TEXTAREAFILE if there is nothing
                                # $ being posted. (So we are not constantly rewriting data back)
                                if (/TEXTAREA\b/i or $FLAGPOST)
                                 {
                                        ($args[2] =~ s/</&lt;/g);
                                        print qq!<TR><TD><FONT SIZE="-1">$args[0]</FONT></TD>
                                                <TD><TEXTAREA NAME="$args[1]" COLS="$args[3]" ROWS="$args[4]">$args[2]</TEXTAREA>\n!;
                                        print qq!$errbr<FONT COLOR="$PREF{'ERR'}" SIZE="-1">$ERR{$inputname}</FONT>\n! if $ERR{$inputname};
                                        print qq!</TD></TR>\n\n!;
                                 }
                                else
                                 {
                                        print qq!<TR><TD><FONT SIZE="-1">$args[0]</FONT></TD>
                                                <TD><TEXTAREA NAME="$args[1]" COLS="$args[3]" ROWS="$args[4]">!;
                                        &dumpfile($args[2], 1);
                                        print qq!</TEXTAREA>\n\n</TD></TR>\n\n!;
                                 }

                        }
                        elsif (/HIDDEN/i)
                        {
                                print qq!<INPUT TYPE="HIDDEN" NAME="$args[0]" VALUE="$args[1]">\n!;

                        }
                        elsif (/RADIO|CHECKBOX/i)
                        {
                                $value = (/RADIO/i ? "radio" : "checkbox");

                                print "<TR><TD><FONT SIZE=-1>$args[0]</FONT></TD>\n";
                                print "<TD><INPUT type=\"$value\" name=\"$args[1]\" value=\"$args[2]\" ", ($args[3] eq $args[2]?"CHECKED":""), ">";
                                print "<FONT SIZE=-1>$args[4] </FONT>\n";
                                print "</TD></TR>\n";
                        }
                        else
                        {
                                 print "Unknown Argument: '$_'";
                        }
                }

                if ($finishform) {
                    $PREF{'FORMCOLSPAN'} = 2 unless $PREF{'FORMCOLSPAN'};
                    print "<TR><TD COLSPAN='$PREF{'FORMCOLSPAN'}' ALIGN=RIGHT BGCOLOR=\"$PREF{'RESHADE'}\"><FONT SIZE=-1><INPUT TYPE=\"submit\" VALUE=\"s u b m i t\">" .
                        "</FONT></TD></TR></FORM>\n" if $action;
                         print "</TABLE></CENTER>\n\n";

                         $FLAGFORMPRINT = 0; # $ Another form can now be created.
                }

                # $ We know the form has been created, this allows us to include our
                # $ own code into the form or break the code into multiple calls.
                $FLAGFORMPRINT = 1 unless $finishform;

        }

#
# $--------------------------------------------------------------------------------------------
#
#  S  U  B  -  M  U  L        T  I  P  A  G  E  S
#
# $--------------------------------------------------------------------------------------------
#

        sub multipages
        {
                my ($i, $pos, $trail, $perpage, $equer) = @_;

                   if ($i > $perpage)
                {
                        print "<BR><P><CENTER><FONT FACE=\"Arial,Helvetica\" SIZE=-2><HR SIZE=\"1\" NOSHADE WIDTH=\"50%\">";
                             if ($i > $perpage)
                             {
                                my $andv = '&' if $equer; # For query if equer is already present

                                if ($pos <= $trail && $trail - $perpage != 0)
                                       { print "<A HREF=\"$ENV{SCRIPT_NAME}?$equer$andv" . "trail=" . ($trail-$perpage) . "\">[last $perpage]</A> "; }
                                     else
                                       { print "[last $perpage] "; }

                                     if ($trail < $i) # && $trail + $perpage != 120)
                                       { print "<A HREF=\"$ENV{SCRIPT_NAME}?$equer$andv" . "trail=" . ($trail+$perpage) . "\">[Next $perpage]</A> "; }
                                     else
                                       { print "[Next $perpage] "; }
                             }
                             print "<hr SIZE=1 NOSHADE WIDTH=\"50%\"></CENTER></FONT></P>";
                }
        }

#
# $--------------------------------------------------------------------------------------------
#
#  S  U  B  -  S  E  N        D  M  A  I  L
#
# $--------------------------------------------------------------------------------------------
#

          sub sendmail
           {
                my $date = &date();

                     if ($PREF{'EMAIL_YOU'})
                      {
                        $PREF{'MAIL'} =~ s/%n/$INPUT{'NAME'}/g;
                        $PREF{'MAIL'} =~ s/%e/$INPUT{'EMAIL'}/g;
                        $PREF{'MAIL'} =~ s/%d/$date/g;
                        $PREF{'MAIL'} =~ s/%u/$INPUT{'LINK'}/g;
                        $PREF{'MAIL'} =~ s/%c/$INPUT{'COMMENTS'}/g;
                        $PREF{'MAIL'} =~ s/%g/http:\/\/$ENV{'HTTP_HOST'}$ENV{'SCRIPT_NAME'}/g;
                        $PREF{'MAIL'} =~ s/\\n/\n/g;

                        open(MAIL, "| $PREF{'MAILPGRM'} -t") || &notify("500 Internal Server Error", "I was not able to pipe to the sendmail program<BR>verify the location and try again<BR><BR>If this is not admin, please let him/her<BR> know about this problem.", 0);
                                print MAIL "To: $INPUT{'FIRST-NAME'} <$INPUT{'EMAIL'}>\n";
                                print MAIL "From: $PREF{'YOURNAME'} <$PREF{'YOUREMAIL'}>\n";
                                print MAIL "Subject: $PREF{'SUBJECT'}\n";
                                print MAIL "\n";
                                print MAIL "$PREF{'MAIL'}\n\n";
                        close(MAIL);
                }

                     if ($INPUT{'NOPOST'})
                {
                        open(MAIL, "| $PREF{'MAILPGRM'} -t") || &notify("500 Internal Server Error", "I was not able to pipe to the sendmail program<BR>verify the location and try again<BR><BR>If this is not admin, please let him/her<BR> know about this problem.", 0);
                                   print MAIL "To: $PREF{'YOURNAME'} <$PREF{'YOUREMAIL'}>\n";
                                print MAIL "From: $INPUT{'EMAIL'}\n";
                                print MAIL "Organization: Cougasoft automatic post response.\n";
                                print MAIL "Subject: INTERGUESTBOOK: Neue Mitteilung [$date]\n";
                                print MAIL "\n";
                                print MAIL "Bestimmt als Komentar:-\n";
                                print MAIL "\n";
                                print MAIL "Name        : $INPUT{'NAME'}\n";
                                print MAIL "E-mail        : $INPUT{'EMAIL'}\n";
                                print MAIL "Unveränderter Komentar :\n";
                                print MAIL "          $comments\n\n\n";
                                print MAIL "Alles Gute,\n";
                                print MAIL "Ihr Gästebuch.\n\n\n";
                                print MAIL "--------------------------------------------->>-\n";
                                print MAIL "http:\/\/$ENV{'HTTP_HOST'}$ENV{'SCRIPT_NAME'}\n";
                                print MAIL "---------------------------------------------<<-\n";
                        close(MAIL);
                }

                elsif ($PREF{'NOTIFY'})
                {
                        open(MAIL, "| $PREF{'MAILPGRM'} -t") || &notify("500 Internal Server Error", "I was not able to pipe to the sendmail program<BR>verify the location and try again<BR><BR>If this is not admin, please let him/her<BR> know about this problem.", 0);
                                print MAIL "To: $PREF{'YOURNAME'} <$PREF{'YOUREMAIL'}>\n";
                                print MAIL "From: $INPUT{'EMAIL'}\n";
                                print MAIL "Organization: Cougasoft automatic post response.\n";
                                print MAIL "Subject: INTERGUESTBOOK: Neuer Gästebucheintrag [$date]\n";
                                print MAIL "\n";
                                print MAIL "Neuer Eintrag:-\n";
                                print MAIL "\n";
                                print MAIL "Name        : $INPUT{'FIRST-NAME'} $INPUT{'LAST-NAME'}\n";
                                print MAIL "E-mail        : $INPUT{'EMAIL'}\n";
                                print MAIL "Unveränderter Komentar :\n";
                                print MAIL "          $comments\n\n\n";
                                print MAIL "Alles Gute,\n";
                                print MAIL "Ihr Gästebuch.\n\n\n";
                                print MAIL "--------------------------------------------->>-\n";
                                print MAIL "http:\/\/$ENV{'HTTP_HOST'}$ENV{'SCRIPT_NAME'}\n";
                                print MAIL "---------------------------------------------<<-\n";
                        close(MAIL);
                }
          }

#
# $--------------------------------------------------------------------------------------------
#
#  S  U  B  -  M  A  I        L  C  H  E  C  K
#
# $--------------------------------------------------------------------------------------------
#

        # $ Checks the argument $_[0] for correct email syntax, this little regexp
        # $ doesn't actually check everything but i think its good enough for now ;)

        sub mailcheck
        {
                     if  (($_[0] =~ /[,|\/\\]|(@.*@)|(\.\.)|(\.$)/)
                         || ($_[0] !~/^[\w\-\.]+[\%\+]?[\w\-\.]*\@[0-9a-zA-Z\-]+\.[0-9a-zA-Z\-\.]+$/))
                {
                        &notify("E-mail address problem !", "There is a problem with your e-mail !", 1);
                     }
          }

#
# $--------------------------------------------------------------------------------------------
#
#  S  U  B  -  D  A  T        E
#
# $--------------------------------------------------------------------------------------------
#

        # $ simply concats the date format into the $date variable ready for inclusion in
         # $ the script, to initiate the variable $date, &date(); must be called before its use
        sub date
        {
                my @days = qw(Sontag Montag Dienstag Mittwoch Donnerstag Freitag Samstag);
                my @months = qw(Januar Februar März April Mai Juni Juli August September Oktober November Dezember);

                # $ '$_[0]' is read only so we must copy the contents to a new variable and
                # $ then we can make our modifications, if there are no substitutions I assume
                # $ there is either no argument or some kind of problem with the string.
                my ($date, $timevar, %D) = (shift, shift, undef);

                ($D{sec}, $D{min}, $D{hour}, $D{mday}, $D{mon}, $D{year}, $D{wday}, $D{yday}) = localtime($timevar?$timevar:time);

                $D{sec}                = "0$D{sec}" if ($D{sec} < 10);
                $D{min}                = "0$D{min}" if ($D{min} < 10);
                $D{hour}        = "0$D{hour}" if ($D{hour} < 10);
                $D{year}        = $D{year}+1900;

                # $ Now I need to add a few extra variables to the %DATE hash, namely the
                # $ literal day, month and wether the time is AM or PM.
                $D{day}                = sprintf "%." . (($D{wday} == 2 or $D{wday}==4)?4:3) . 's', $days[$D{wday}];
                $D{month}        = sprintf "%." . ($D{mon} == 9?4:3) . 's', $months[$D{mon}];
                $D{lday}        = $days[$D{wday}];
                $D{lmonth}        = $months[$D{mon}];

                $D{'24hour'}        = $D{hour};
                $D{ampm}        = $D{hour} >= 12 ? ($D{hour} -= 12, 'PM') : 'AM';


                return ($date =~ s/\[([^\]]*)\]/$D{$1}/g) ? $date
                        : "$D{'month'} $D{'mday'}, $D{'year'} - $D{'hour'}:$D{'min'}:$D{'sec'}";
        }

#
# $--------------------------------------------------------------------------------------------
#
#  S  U  B  -  N  F  R        A  M  E
#
# $--------------------------------------------------------------------------------------------
#

         # $ notifying frame - just a simple subroutine that prints out a table with
        # $ the first argument you pass it embedded in it, saves me a lot of time !

        sub nframe
         {
                print "<BR><CENTER><TABLE CELLSPACING=0 CELLPADDING=9 >\n",
                      " <TR>\n<TD ALIGN=CENTER BGCOLOR='$PREF{'TBCOLOR'}'><TT>\n",
                      " $_[0]</TT></TD>\n </TR>\n";
                print "</TABLE></CENTER>\n\n";
         }

#
# $--------------------------------------------------------------------------------------------
#
#  S  U  B  -  M  I  S        S  I  N  G
#
# $--------------------------------------------------------------------------------------------
#

         # $ subroutine I call when a variable is missing, in the future, I might
        # $ include this in the parsing function above which would save xxx time and
        # $ also let people change my scripts more successfully ?

        sub missing
        {
                &top_html("Fehlende Angabe", 0);
                &nframe("Missing Field [$_[0]]<BR> Zurück zum" .
                   "<a href='$ENV{'HTTP_REFERER'}' TARGET='$PREF{'TARGET'}'> Formular</a> und erneut versuchen.");
                &bottom(1);
        }

#
# $--------------------------------------------------------------------------------------------
#
#  S  U  B  -  N  O  T        I  F   Y
#
# $--------------------------------------------------------------------------------------------
#

         # $ there are 3 arguments passed to this function, 1=TITLE, 2=DISPLAY_TEXT, 3=ADDITIONAL
        # $ the title is self explanatory, the display text is just the text you would like to
        # $ display to the user and the additional is which additional text to add to the nframe

        sub notify
        {
                my ($title, $info, $more, $extra) = (shift, shift, shift, undef);

                $extra = qq!<BR>Zurück zum <a href="$ENV{'HTTP_REFERER'}"> Formular</a> und erneut versuchen.! if $more == 1;
                $extra = qq!<BR>Zurück zu meiner<A HREF="$PREF{'HOME'}">Seite</A>.! if $more == 2;

                &top_html("$title");
                &nframe("<TT>$info $extra</TT>");
                &bottom(1);
        }

#
# $--------------------------------------------------------------------------------------------
#
#  S  U  B  -  B  O  T        T  O  M
#
# $--------------------------------------------------------------------------------------------
#

         # $ hmmmmm ? what does this do I hear you all cry, well I just don't know, I wrote
        # $ it a long time ago and took me about an hour but I don't know what its for ?!?!
        # $ [please note I was being sarcastic, no more emails about what it does] ;)

        sub bottom
        {
                print "</BODY>\n";
                print "</HTML>\n";
                exit 0 if ($_[0]);
        }

#
# $--------------------------------------------------------------------------------------------
#
#  S  U  B  -  P  R  E        F  E  R  E  N  C  E  S
#
# $--------------------------------------------------------------------------------------------
#

        sub preferences
        {
                my ($no, $prefno);

                open(PREF, $_[0]) || return "$_[0]: Preference file can not be found";
                  for ($no = 1; (<PREF>); $no++)
                {
                        if (/^#|^;/)
                        {
                                $PREF{'__COMMENTS__'} .= $_ if (!$prefno);
                        }
                        elsif (/^(\w+)\s*=\s?(.*)$/)
                        {
                                $PREF{$1} = $2;
                                $prefno++;
                        }
                        else
                        {
                                return "$_[0]:Line $no: incorrect preference structure.";
                        }
                }
                close(PREF);

                return ($_[1] == $prefno) ? 1 : "$_[0]: Incorrect number of preferences.";
        }

#
# $--------------------------------------------------------------------------------------------
#
#  S  U  B  -  O  P  E        N  F  I  L  E
#
# $--------------------------------------------------------------------------------------------
#

        sub openf
        {
                my ($FILE, $filename, $type) = (shift, shift, undef);

                $type = ($filename =~ /^(\+|>)/) ? "write to" : "find";

                open $FILE, $filename or &notify('500 Internal Server Error', "I was not able to $type '" . (($filename =~ s/^(\W)+//) ? $filename : $filename) . "'<BR>" .
                "check you've entered the correct location & permissions.<BR><BR>If this is not admin, please let him/her<BR> know about this problem.", 0);
                flock $FILE, 2 if $PREF{'FLOCK'};
        }

#
# $--------------------------------------------------------------------------------------------
#  ===========================================================================================
# $--------------------------------------------------------------------------------------------
#