#!/usr/local/bin/perl
#
#  Copyright (c) 1999 by Per Cederberg
#
#  The code in this file is made freely available for any purpose
#  whatsoever. The authors do not take any responsability for the
#  correctness or suitability for some particular purpose.
#
######################################################################
#
#  Contains common subroutines and constants for CGI scripts.
#
#  Authors:   Per Cederberg, per at percederberg dot net
#  Version:   1.2.2
#  Date:      17th of January 2000
#
#
#  Description:
#  ------------
#    Contains common subroutines and global constants for CGI scripts.
#
#
#  Revision history:
#  -----------------
#
#  Version 1.2.2 (2000-01-17, Per Cederberg)
#   - Corrected bug with BASEURL ending with an '/'.
#
#  Version 1.2.1 (1999-09-26, Per Cederberg)
#   - Changed TEMPLATEDIR and removed TEMPLATEURL.
#
#  Version 1.2 (1998-11-17, Per Cederberg)
#   - Changed all directory constants.
#   - Added TEMPLATEDIR and TEMPLATEURL.
#   - Removed ICONDIR and ICONURL.
#   - Removed BACKGROUNDDIR and BACKGROUNDURL.
#   - Added CollectFields routine.
#
#  Version 1.1.2 (98-06-24, Per Cederberg)
#   - Added optional HTML codes to CreateHTMLImage.
#   - Added optional HTML codes to CreateHTMLLink.
#
#  Version 1.1.1 (98-06-23, Per Cederberg)
#   - Added ICONURL and BAKGROUNDURL constants.
#
#  Version 1.1 (98-06-22, Per Cederberg)
#   - Changed implentation of FileExists to use -e operator.
#   - Added Directory Exists routine.
#   - Added FindMatchingFiles routine.
#   - Changed to use COMMONFILE as the file variable everywhere.
#   - Added ReadDataFile and WriteDataFile routines.
#   - Added ReadAccessCount and IncreaseAccessCount routines.
#
#  Version 1.0.1 (98-06-18, Per Cederberg)
#   - Corrected spelling bug in PrintErrorMessage.
#   - Added the FileExists routine.
#   - Added the LockFile and UnlockFile routines.
#
#  Version 1.0 (98-06-16, Per Cederberg)
#   - First version of this script.
#
######################################################################


######################################################################
#
# GLOBAL CONSTANTS AND VARIABLES
#

###### Constants for directories ######
$BASEDIR = "/home/d93/d93-pol/public_html";
$CGIDIR = "/public/www.student/cgi-bin/d93-pol";
$TEMPLATEDIR = "$CGIDIR/templates";

###### Constants for URLs ######
$BASEURL = "http://www.student.nada.kth.se/~d93-pol";
$CGIURL = "http://cgi.student.nada.kth.se/cgi-bin/d93-pol";

###### Other global constants ######
$MAILPROG = '/usr/lib/sendmail';  # The sendmail program
$CURDATE = 'No value yet';        # Current date, '1998-06-10' for example
$CURTIME = 'No value yet';        # Current time, '13:39' for example
$CURCENTURY = 'No value yet';     # Current century, '19' or '20'

###### Global variables ######
$method = 'No value yet';         # The form method, 'GET' or 'POST'
%form = {};                       # The form data exchange variable
$errors = 0;                      # The number of errors found in the form
%formerror = {};                  # The errors for each field in the form



######################################################################
#
# INITIALIZING
#

#
# Initialize
#
#   Initializing CURDATE, CURTIME and CURCENTURY. This routine is 
#   executed once upon loading this script.
#

sub Initialize 
{
    local ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
	localtime(time);

    if ($year gt '95') {
	$CURCENTURY = "19"
    } else {
	$year = $year - 100;
	$CURCENTURY = "20";
    }
    $CURDATE = sprintf("%.2d%.2d-%.2d-%.2d", $CURCENTURY, $year, $mon+1, 
		       $mday);
    $CURTIME = sprintf("%.2d:%.2d", $hour, $min);
}


&Initialize();



######################################################################
#
# INPUT ROUTINES
#

#
# ParseInput
#
#   Parses the input sent via the CGI standard. The global variables
#   $method and %form will be set to new values when executing this
#   function. Each form field in the input will be found in the form
#   variable as a key with value. On multiple value for a single field
#   the values are concatenated with '\0' characters in the same string.
#
#   The special input format in the CGI standard is handled and 
#   converted to normal Perl strings. Also some substitutions of
#   characters with a special meaning in HTML is done.
#

sub ParseInput 
{
    local ($buffer, @pairs);

    # Read input
    if ($ENV{'REQUEST_METHOD'} eq 'POST') 
    {
	$method = 'POST';
	read(STDIN, $buffer, $ENV{'CONTENT_LENGTH'});
	@pairs = split(/&/, $buffer);
    } 
    else 
    {
	$method = 'GET';
	@pairs = split(/&/, $ENV{'QUERY_STRING'});
    }

    # Parse input
    %form = {};
    foreach (@pairs) 
    {
	local ($name, $value) = split(/=/, $_);
	
	$value =~ tr/+/ /;
	$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
	$value =~ s/&/&/g;
	$value =~ s/</&lt;/g;
	$value =~ s/>/&gt;/g;
	$value =~ s/\"/&quot;/g;
#	$value =~ s/å/&aring;/g;
#	$value =~ s/Å/&Aring;/g;
#	$value =~ s/ä/&auml;/g;
#	$value =~ s/Ä/&Auml;/g;
#	$value =~ s/ö/&ouml;/g;
#	$value =~ s/Ö/&Ouml;/g;

	$form{$name} .= "\0" if (defined $form{$name} && $value ne '');
	$form{$name} .= $value;
    }
    
    return %form;
}


#
# RevertSubstitutions
#
#   Reverts some of the imput substitutions made in the ParseInput
#   function, ie. converts some HTML sequences to single characters.
#
# Arguments:
#   string    - the string containing the HTML special sequences
#
# Returns:
#   A string without the HTML sequences created in the input parsing.
#

sub RevertSubstitutions 
{
    local ($string) = @_;

    $string =~ s/&quot;/\"/g;
    $string =~ s/&lt;/</g;
    $string =~ s/&gt;/>/g;
    $string =~ s/&amp;/&/g;

    return $string;
}



######################################################################
#
# LIST HANDLING ROUTINES
#

#
# PosInList
#
#   Returns the position of a string in a given list.
#
# Arguments:
#   string    - the string to search for
#   list      - the list to search in
#
# Returns:
#   An index in the list (from zero), or -1 if the string wasn't found.
#

sub PosInList 
{
    local ($string, @list) = @_;
    local ($index);

    for ($index = 0; $index <= $#list; $index++) 
    {
	if ($list[$index] eq $string) 
	{
	    return $index;
	}
    }

    return -1;
}


#
# MergeLists
#
#   Merges several lists into one, removing copies and empty strings.
#
# Arguments:
#   list1, list2, ...    - the lists to merge
#
# Returns:
#   A list with all the distinct elements from the given lists. 
#

sub MergeLists 
{
    local (@list) = @_;
    local ($i, @new);

    for ($i = 0; $i <= $#list; $i++) 
    {
	if (&PosInList($list[$i],@new) == -1 && $list[$i] ne '') 
	{
	    $new[$#new+1] = $list[$i];
	}
    }

    return @new;
}


#
# RemoveElement
#
#   Removes all occurrencies of an element from a list.
#
# Arguments:
#   elem     - a list element
#   list     - a list
#
# Returns:
#   A list where there are no occurrencies of the given element.
#

sub RemoveElement 
{
    local ($elem, @list) = @_;
    local ($pos);

    while (($pos = &PosInList($elem, @list)) > -1) 
    {
	splice(@list, $pos, 1);
    }

    return @list;
}


#
# SumList
#
#   Sums all elements in a list. The elements has to be valid numbers.
#
# Arguments:
#   list      - a list with numbers
#
# Returns:
#   The sum of all the numbers in the list.
#

sub SumList {

    local (@list) = @_;
    local ($i, $sum);
    
    $sum = 0;
    for ($i = 0; $i <= $#list; $i++) 
    {
	$sum += $list[$i];
    }

    return $sum;
}


#
# WrapList
#
#   Returns a new list where each element is "wrapped up" into some
#   template element. 
#
# Arguments:
#   tag       - a tag in the template string (where to put each list elem)
#   string    - a template string
#   list      - a list
#
# Returns:
#   A list where each element is of the template form but with the
#   original list element inserted on each occurrence of the tag.
#

sub WrapList 
{
    local ($tag, $string, @list) = @_;
    local ($temp, @new);

    foreach (@list) 
    {
	$temp = $string;
	$temp =~ s/$tag/$_/g;
	$new[$#new+1] = $temp;
    }

    return @new;
}



######################################################################
#
# LIST TO AND FROM FORM ROUTINES
#

#
# CollectFields
#
#   Collects all form fields with a given name base into an
#   ordered list based on the field numbers.
#
# Arguments:
#   fieldname   - a base field name
#
# Returns:
#   A list with all the field values in order from the lowest
#   numbered field to the highest.
#

sub CollectFields
{
    local ($fieldname) = @_;
    local ($i, @res);

    $i = 1;
    @res = ();
    while ($form{"$fieldname$i"} ne '')
    {
        $res[$#res+1] = $form{"$fieldname$i"};
	$i++;
    }

    return @res;
}


######################################################################
#
# STRING MANIPULATION ROUTINES
#

#
# ChopWhitespace
#
#   Removes trailing whitespaces on each line in a string, but keeps
#   the number of newlines.
#
# Arguments:
#   string      - a string, possibly consisting of several lines
#
# Returns:
#   A string where all the trailing whitespace characters have
#   been removed for each line.
#

sub ChopWhitespace 
{
    local ($string) = @_;
    local ($result, $lastchar, $newlinecount, @lines);

    # Count the number of newlines
    $newlinecount = 0;
    while ($string =~m/\n/g) {
	$newlinecount++;
    }
    
    # Chop off all whitespace
    @lines = split(/\n/, $string);
    foreach (@lines) 
    {
	if (length($_) > 0) 
	{
	    $lastchar = chop($_);
	    while (length($_) > 0 && $lastchar =~ m/[ \n\r\t\v]/) 
	    {
		$lastchar = chop($_);
	    }
	    if ($lastchar =~ m/[ \n\r\t\v]/) 
	    {
		$lastchar = '';
	    }
	    $result .= "$_$lastchar\n";
	} 
	else 
	{
	    $result .= "\n";
	}
    }
    chop ($result);   # To remove last newline added

    # Add missing newlines
    while ($result =~ m/\n/g) 
    {
	$newlinecount--;
    }
    while ($newlinecount > 0) 
    {
	$result .= "\n";
	$newlinecount--;
    }

    return $result;
}


#
# SplitLine
#
#   Splits a string on a single line into a string containing 
#   several lines. The trailing whitespace characters on each
#   line will be removed with ChopWhitespace.
#
# Arguments:
#   line       - a string, possibly with newline characters
#   maxlen     - a value for the maximum line lenght
#
# Returns:
#   A string where no line exceeds the maximum line length. 
#

sub SplitLine 
{
    local ($string, $maxlen) = @_;
    local (@lines, $result, $index, $lastchar);

    $string = &ChopWhitespace($string);
    if (length($string) <= $maxlen) 
    {
	return $string
    }
    @lines = split(/\n/, $string);
    foreach (@lines) 
    {
	while (length($_) > $maxlen) 
	{
	    $index = rindex($_, " ", $maxlen-1);
	    if ($index < 1) 
	    {
		$result .= substr($_, 0, $maxlen-1);
		$result .= "-\n";
		$_ = substr($_, $maxlen-1);
	    } 
	    else 
	    {
		$result .= substr($_, 0, $index+1);
		$result .= "\n";
		$_ = substr($_, $index+1);
	    }
	}
	$result .= "$_\n";
    }

    return $result;
}


#
# Linkify
#
#   Detects URIs in a string and replaced them with HTML hyperlinks.
#
# Arguments:
#   string      - a string
#
# Returns:
#   A string where all URI are linked to their respective address.
#

sub Linkify 
{
    local ($string) = @_;
    local (@links);

    @links = ($string =~ m/http:[^ \n\r\t\v]+/g);
    @links = &MergeLists(@links);  # To remove unneccesary copies
    foreach (@links) 
    {
	$string =~ s|$_|<A href="$_">$_</A>|g;
    }

    return $string;
}



######################################################################
#
# HTML CREATION ROUTINES
#

#
# CreateHTMLLink
#
#   Creates a HTML link.
#
# Arguments:
#   url        - the URL to link to
#   text       - the link text
#   extra      - optional extra arguments to the A tag
#
# Returns:
#   A string containing the HTML hyperlink code.
#

sub CreateHTMLLink
{
    local ($url, $text, $extra) = @_;
    local ($result);

    $extra = " $extra" if ($extra ne '');
    $result = "<A href=\"$url\"$extra>$text</A>\n";

    return $result;
}


#
# CreateHTMLImage
#
#   Creates a HTML image insertion.
#
# Arguments:
#   src        - the source of the image
#   text       - the alternate text, can be left empty
#   extra      - optional extra arguments to the IMG tag
#
# Returns:
#   A string containing the HTML image code.
#

sub CreateHTMLImage
{
    local ($src, $text, $extra) = @_;
    local ($result);

    $result = "<IMG src=\"$src\"";
    if ($text ne '')
    {
	$result .= " alt=\"$text\"";
    }
    $result .= " $extra" if ($extra ne '');
    $result .= ">";

    return $result;
}


#
# CreateHTMLList
#
#   Returns a html list from a given list.
#
# Arguments:
#   emptymsg     - a string to use if the list is empty
#   list         - a list
#
# Returns:
#   A string with HTML code for the list, but with the <UL> or <NL> 
#   missing.
#

sub CreateHTMLList 
{
    local ($emptymsg, @list) = @_;
    local ($htmllist);

    if ($list[0] eq 0) 
    {
	return 0;
    }
    if (@list) 
    {
	foreach (@list) 
	{
	    $htmllist .= "<LI>$_</LI>\n";
	}
    } 
    else 
    {
	$htmllist = "<P>$emptymsg</P>\n";
    }

    return $htmllist;
}


#
# CreateHTMLOptions
#
#   Returns a html option list from a given list.
#
# Arguments:
#   default     - the default option
#   list        - a list of options
#
# Returns:
#   A string containing HTML code for the options.
#

sub CreateHTMLOptions 
{
    local ($default, @list) = @_;
    local ($options);

    if ($list[0] eq 0) 
    {
	return 0;
    }
    $options = "\n";
    foreach (@list) 
    {
	if ($default eq $_) 
	{
	    $options .= "<OPTION SELECTED>$_\n";
	} else {
	    $options .= "<OPTION>$_\n";
	}
    }

    return $options;
}



######################################################################
#
# INPUT CONTROL ROUTINES
#

#
# CheckForm
#
#   Checks the form data variable for errors in the values. On
#   detection of errors the global error and formerror variables
#   are set. 
#
#   The following fields are tested:
#     - the given fields may no be empty
#     - Mail or MailX fields will be checked as mail addresses
#     - Date or DateX fields will be checked as dates
#     - No field is permitted to have a dot on a single line
#
# Arguments:
#   field1, field2 ...    - a list of the fields not supposed to be blank
#

sub CheckForm 
{
    local (@fields) = @_;
    local ($i, $key, $value);

    # Check fields not allowed to be empty
    for ($i = 0; $i <= $#fields; $i++) {
	if ($form{$fields[$i]} eq '' && $formerror{$fields[$i]} eq '') {
	    $errors += 1;
	    $formerror{$fields[$i]} = 'Cannot be left empty';
	}
    }
    
    while (($key, $value) = each(%form)) {
	if ($formerror{$key} ne '') 
	{
	    next;
	}

	# Remove trailing spaces
	$value = &ChopWhitespace($value);
	$form{$key} = $value;

	# Check mail fields 
	if ($key =~ m/Mail([0-9]|$)/) {
	    &CheckMailField($key);
	}

	# Check date fields
	if ($key =~ m/Date([0-9]|$)/) {
	    &CheckDateField($key);
	}

	# Check for fields with a singe dot on a single line
	if ($formerror{$key} eq '' && $value =~ m/(^|\n)\.($|\n)/) {
	    $errors += 1;
	    $formerror{$key} = "Cannnot contain a dot ('.') on a single line.";
	}
    }
}


#
# CheckMailField
#
#   Checks a mail address field for containing blanks or not being
#   in the form name@domain. On error the global errors and formerror
#   variables are set.
#
# Arguments:
#   key       - the field name
#

sub CheckMailField 
{
    local ($key) = @_;

    if ($form{$key} =~ m/ /) {
	$errors += 1;
	$formerror{$key} = 'May not contain blanks (whitespace)';
	return;
    }
    if ($form{$key} ne '' && ! ($form{$key} =~ m/^[^@]+@[^@]+/)) {
	$errors += 1;
	$formerror{$key} = 'Must be an address of the form name@domain';
	return;
    }
}


#
# CheckDateField
#
#   Checks a date field for containing blanks or not being in the 
#   form YYYY-MM-DD. The routine corrects for missing century,
#   and checks each numeric field for a reasonable value. On 
#   errors the global errors and formerror variables are set.
#
# Arguments:
#   field       - the field name
#

sub CheckDateField 
{
    local ($field) = @_;
    local ($year, $month, $day);

    if ($form{$field} eq '') {
	return 1;
    }
    if ($form{$field} =~ m/ /o) {
	$errors += 1;
	$formerror{$field} = 'Contains blanks (spaces)';
	return 0;
    }

    # Change to standard year format
    if (($year) = ($form{$field} =~ m/^([0-9][0-9])-/o)) {
	if ($year > 95) {
	    $form{$field} = "19$form{$field}";
	} else {
	    $form{$field} = "20$form{$field}";
	}
    }

    # Should be an exact match!
    if (($year, $month, $day) = ($form{$field} =~ m/^([0-9][0-9][0-9][0-9])-([0-9][0-9])-([0-9][0-9])$/o)) {
	if ($year lt "1990") {
	    $errors += 1;
	    $formerror{$field} = "Year cannot be earlier than 1990";
	    return 0;
	}
	if ($month lt "01" || $month gt "12") {
	    $errors += 1;
	    $formerror{$field} = "Month number must be between 01 and 12";
	    return 0;
	}
	if ($day lt "01" || $day gt "31") {
	    $errors += 1;
	    $formerror{$field} = "Day number must be between 01 and 31";
	    return 0;
	}
    } else {
	$errors += 1;
	$formerror{$field} = "Isn't in a valid date format (i.e. YYYY-MM-DD)";
    }
}


#
# CheckFileName
#
#   Checks that the a field value can be a valid file name. The
#   field is only allowed to contain the normal (english) 
#   alphanumeric characters and may not contain blanks.
#   On error the global variables errors and formerror is set.
#
# Arguments:
#   key      - a field key (name) whose value to check
#

sub CheckFileName 
{
    local ($key) = @_;

    if ($formerror{$key} eq '' && $form{$key} =~ m/ /o) 
    {
	$errors += 1;
	$formerror{$key} = 'May not contain blanks (whitespace).';
    }
    if ($formerror{$key} eq '' && $form{$key} =~ m/[^a-zA-Z0-9_-]/o) 
    {
	$errors += 1;
	$formerror{$key} = 'Contains non-alphanumeric characters';
    }
}



######################################################################
#
# FILE HANDLING ROUTINES
#

#
# FileExists
#
#   Checks if a file exists.
#
# Arguments:
#   filename     - a file name
#
# Returns:
#   Returns 1 if a named file exists, 0 otherwise.
#

sub FileExists
{
    local ($filename) = @_;

    if (-e $filename) 
    {
	return 1;
    } else {
	return 0;
    }
}


#
# DirectoryExists
#
#   Checks if a directory file exists.
#
# Arguments:
#   dirname     - a directory file name
#
# Returns:
#   Returns 1 if a named directory exists, 0 otherwise.
#

sub DirectoryExists
{
    local ($dirname) = @_;

    if (-d $dirname) 
    {
	return 1;
    } else {
	return 0;
    }
}


#
# FindMatchingFiles
#
#   Finds all files matching a specified pattern, possibly containing
#   wildcards (as accepted by the background shell). The file names 
#   are returned with the same path that the pattern given. Directory
#   names are terminated by a '/' character.
#
# Arguments:
#   pattern    - a file name pattern that may containg wildcards
#
# Returns:
#   A list of the file names matching the pattern given. Empty on 
#   no matches.
#

sub FindMatchingFiles
{
    local ($pattern) = @_;
    local ($res, @list);
    
    $res = `ls -dp1 $pattern`;
    if ($res !~ m/ls:/)
    {
	@list = split(/\n/, $res);
    }

    return @list;
}


#
# LockFile
#
#   Locks a specified file by creating a file 'filename.lock'.
#   This does not stop reading or writing to the original file,
#   but may be used to check for collisions.
#
# Arguments:
#   filename   - a file name
#
# Returns:
#   Returns 1 if the file was sucessfully locked, 0 on failure to
#   lock file (lock already existed, no write permission, etc).
#

sub LockFile 
{
    local ($filename) = @_;

    # Check for previous lock
    if (&FileExists("$filename.lock")) {
	return 0;
    }
    
    # Add new lock
    open (COMMONFILE, ">>$filename.lock");
    print COMMONFILE "File locked on $TODAY.\n";  # Less than 30 characters!

    # Check if some other process added lock while checking for one
    if (tell(COMMONFILE) > 30) {
	close (COMMONFILE);
	return 0;
    } else {
	close (COMMONFILE);
	return 1;
    }
}


#
# UnlockFile
#
#   Unlocks a specified file by removing it's corresponding
#   'filename.lock' file.
#
# Arguments:
#   filename     - a file name
#

sub UnlockFile 
{
    local ($filename) = @_;

    `rm $filename.lock`;
}



######################################################################
#
# FILE I/O ROUTINES
#

#
# ReadFile
#
#   Returns the entries of a text file.
#
# Arguments:
#   filename     - a filename
#
# Returns:
#   A string containing the whole contents of the file or 0 if
#   the file couldn't be opened.
#

sub ReadFile
{
    local ($filename) = @_;
    local ($output);

    open (COMMONFILE, "$filename") || return 0;
    foreach (<COMMONFILE>) 
    {
	$output .= $_;
    }
    close (COMMONFILE);

    return $output;
}


#
# ReadTemplate
#
#   Returns the entries of a template file with all the templates
#   (<#name>) substituted with their respective value in the 
#   form global variable. Note that template names are case sensitive.
#
# Arguments:
#   filename     - a filename
#
# Returns:
#   A string containing the whole contents of the file or 0 if
#   the file couldn't be opened.
#

sub ReadTemplate 
{
    local ($filename) = @_;
    local ($output, $key);

    open (COMMONFILE, "$filename") || return 0;
    foreach (<COMMONFILE>) 
    {
	# Note template names are case sensitive
	while (($key) = m/<#([a-zA-Z0-9_-]+)>/o) 
	{
	    s/<#$key>/$form{$key}/g;
        }
	$output .= $_;
    }
    close (COMMONFILE);

    return $output;
}


#
# ReadDataFile
#
#   Reads an association list from a file to a given variable.
#   Note that the association list given will be cleared and 
#   filled with data from the file.
#
# Arguments:
#   filename      - a file name
#   data          - a reference to an association list variable
#
# Returns:
#   One (1) on success, zero (0) on failure to read the file.
#

sub ReadDataFile 
{
    local ($filename, *data) = @_;
    local ($key, $value);

    %data = {};
    open(COMMONFILE, "<$filename") || return 0;
    foreach (<COMMONFILE>) 
    {
	chop;            # Avoid \n in the value field
	s/<BR>/\n/gi;    # Compensate for newlines
	($key, $value) = split(/=/, $_, 2);
	$data{$key} = $value;
    }
    close(COMMONFILE);

    return 1;
}


#
# WriteDataFile
#
#   Writes an association list from a given variable to a file.
#   Note that all the data from the association list given will be
#   written to the file, that will be overwritten.
#
# Arguments:
#   filename      - a file name
#   data          - a reference to an association list variable
#
# Returns:
#   One (1) on success, zero (0) on failure to write to the file.
#

sub WriteDataFile 
{
    local ($filename, *data) = @_;
    local ($key, $value);

    open(COMMONFILE, ">$filename") || return 0;
    while (($key, $value) = each(%data)) 
    {
	$value =~ s/\n/<BR>/gi;     # Compensate for newlines
	print COMMONFILE "$key=$value\n";
    }
    close(COMMONFILE);

    return 1;
}



######################################################################
#
# OUTPUT FUNCTIONS
#

#
# ReadAccessCount
#
#   Reads and returns the access count for a specific key (normally
#   a file name). The access counts are stored in the given file.
#
# Arguments:
#   key         - an access count key
#   filename    - a file name
#
# Returns:
#   An access count number.
#

sub ReadAccessCount
{
    local ($key, $filename) = @_;
    local (%counts);

    &ReadDataFile($filename, *counts) || return 0;
    if ($counts{$key} ne '')
    {
	return $counts{$key};
    } else {
	return 0;
    }
}


#
# IncreaseAccessCount
#
#   Increases the access count for a specific key (normally a file
#   name). The access counts are stored in the given file.
#
# Arguments:
#   key         - an access count key
#   filename    - a file name (writeable)
#
# Returns:
#   One (1) on success, zero (0) otherwise. 
#

sub IncreaseAccessCount
{
    local ($key, $filename) = @_;
    local (%counts);
    
    # Read old counts
    &ReadDataFile($filename, *counts);

    # Increase count
    if ($counts{$key} eq '')
    {
	$counts{$key} = 1;
    } else {
	$counts{$key}++;
    }
    
    # Write counts
    &WriteDataFile($filename, *counts) || return 0;

    return 1;
}


#
# PrintHTMLHeader
#
#   Prints the "Content-type: ..." information for text/html.
#

sub PrintHTMLHeader
{
    print "Content-type: text/html; charset=ISO-8859-1\n\n";
}


#
# PrintErrorMessage
#
#   Prints an error message in the form of a HTML document
#   and terminates the script.
#
# Arguments:
#   errormsg     - an error message to print
#

sub PrintErrorMessage
{
    local ($errormsg) = @_;

    &PrintHTMLHeader();

    # Print the doctype information
    print "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2//EN\">\n";

    # Print the HTML header
    print "<HTML>\n<HEAD>\n";
    print "\t<TITLE>Error Message</TITLE>\n";
    print "</HEAD>\n";

    # Print the HTML body
    print "<BODY>\n\n";
    print "<H2>An error occurred:</H2>\n\n";
    print "<UL>\n<LI><B>$errormsg</B></LI>\n</UL>\n\n";
    print "</BODY>\n</HTML>\n";

    exit(0);
}



######################################################################
#
# END OF FILE
#

1;