Perl Hit Counter Example

Provides an example script for taking and receiving a poll using Perl code.

#!/usr/bin/perl
#******************************************************
# This script creates and adds responses to a database
# of Operating Systems Characteristics survey responses. 
#******************************************************
$database_file = "/home/httpd/data/oschar1.dat";

$ASCII_thirteen = pack("c", 13);
$space = " ";


#Check to see if a cookie with the name ospoll1 and value done or start are on the client
$rcvd_cookies = $ENV{'HTTP_COOKIE'};
@cookies = split /;/, $rcvd_cookies;
foreach $cookie (@cookies)
{
   if ($cookie eq "ospoll1=done")
   { 
      $polltaken=1; #Poll was previously taken
   }
   if ($cookie eq "ospoll1=start")
   {
       $pollready=1;
   }
}

#If poll was not taken and this is not for display only as indicated by the query string
if (($ENV{'QUERY_STRING'} ne "display") && ($polltaken != 1) && ($pollready == 1))
{
    $polltaken=2;  
# Format the Web data received and make sure
# it does not contain any server-side includes
   %data_received = &Get_Data();
   &No_SSI(*data_received);

# Make sure all mandatory fields are full and
# truncate all strings to a maximum of 255 characters
# Also make sure no new-line characters.
   foreach $key (keys(%data_received)) {
	 $data_received{$key} =~ s/$ASCII_ten//ge; 
	$data_received{$key} =~ s/$ASCII_thirteen/$space/ge;
   }

   if (%data_received)
   {
      open(DATABASE,">>$database_file") || die "Content-type: text/html\n\nCannot open database.";

# Because the Web server could receive several requests for a CGI script at the same time
# Lock the database file now.
# The second parameter to the flock function, which in this case is 2, 
# is a code that determines the type of lock to be placed on the file. 
# The number 2 designates setting a write lock on the specified file stream. 
   flock(DATABASE, 2);

# each element in the %data_received associative array is printed one at a time, 
# surrounded by quotes and separated by commas

      print DATABASE $data_received{"expertise"} . "," . 
	$data_received{"security"} . "," . 
	$data_received{"stability"} . "," . 
	$data_received{"ease"} . "," . 
	$data_received{"networking"} . "," . 
	$data_received{"monitoring"} . "," . 
	$data_received{"learning"} . "," . 
	$data_received{"documentation"} . "," . 
	$data_received{"cost"} . "," . 
	$data_received{"compatability"} . "," .
        $data_received{"communication"} . "," . 
        $data_received{"speed"} . "," .
        $data_received{"people"} . "," .
        $data_received{"support"} . "," .
        $data_received{"scalability"} . "," .
        $data_received{"bugfix"} . "\n";


# The number 8 designates removing all locks from the specified file stream
      flock(DATABASE, 8);
      close(DATABASE);
   }  # end if data was received
}   # end if the poll was not taken
 
# Place a cookie on the user's machine to show the poll was taken.
if ($polltaken == 2)
{
    $fut_time=gmtime(time()+365*24*3600)." GMT";  # Add 12 months (365 days)
    $cookie = "ospoll1=done; path=/; expires=$fut_time; $secure";
    print "Set-Cookie: " . $cookie . "\n";
}

# Report statistics
# Generate database statistics for reporting
    open(DATABASE,"<$database_file") || die "Content-type: text/html\n\nCannot open database.";
    @lines = <DATABASE>
    $responses = 0;
    $expertise = 0;
    $security = 0;
    $stability = 0;
    $ease = 0;
    $networking = 0;
    $monitoring = 0;
    $learning = 0;
    $documentation = 0;
    $cost = 0;
    $compatability = 0;
    $communication = 0;
    $speed = 0;
    $people = 0;
    $support = 0;
    $scalability = 0;
    $bugfix = 0;
foreach $line (@lines)
{
    $responses++;
    @entries = split(/,/, $line);
    $security += $entries[1];
    $stability += $entries[2];
    $ease += $entries[3];
    $networking += $entries[4];
    $monitoring += $entries[5];
    $learning += $entries[6];
    $documentation += $entries[7];
    $cost += $entries[8];
    $compatability += $entries[9];
    $communication += $entries[10];
    $speed += $entries[11];
    $people += $entries[12];
    $support += $entries[13];
    $scalability += $entries[14];
    $bugfix += $entries[15];
}
$security = (10 * $security)/$responses;
$stability = (10 * $stability)/$responses;
$ease = (10 * $ease)/$responses;
$networking = (10 * $networking)/$responses;
$monitoring = (10 * $monitoring)/$responses;
$learning = (10 * $learning)/$responses;
$documentation = (10 * $documentation)/$responses;
$cost = (10 * $cost)/$responses;
$compatability = (10 * $compatability)/$responses;
$communication = (10 * $communication)/$responses;
$speed = (10 * $speed)/$responses;
$people = (10 * $people)/$responses;
$support = (10 * $support)/$responses;
$scalability = (10 * $scalability)/$responses;
$bugfix = (10 * $bugfix)/$responses;
close(DATABASE);

# Output success message
print "Content-type: text/html", "\n\n";        # MIME header.
print "<HTML>", "\n";
print "<HEAD>";
print "<TITLE>Poll Results.</TITLE>", "\n";
print "</HEAD>", "\n";
print '<BODY TEXT="#000000" BGCOLOR="#FFFFFF" LINK="#0000FF" VLINK="#51188E" 
ALINK="#FF0000" BACKGROUND="../gifs/clouds.gif">';
print "\n";
print '<center><A href="index.html" target="_top">Operating Systems Contents Page</A></center>' . "\n";
print "<center><H1>Current Poll Results</H1></center>\n";
print "<H2>Responses: $responses</H2>\n";
print "<B>Security:</B>\n";
print '<HR SIZE="15" ALIGN="left" width="' . $security . '%" color="ff0000">' . "\n";
print "<B>Stability:</B>\n";
print '<HR SIZE="15" ALIGN="left" width="' . $stability . '%" color="00ff00">' . "\n";
print "<B>Ease of Use:</B>\n";
print '<HR SIZE="15" ALIGN="left" width="' . $ease . '%" color="0000ff">' . "\n";
print "<B>Networking:</B>\n";
print '<HR SIZE="15" ALIGN="left" width="' . $networking . '%" color="800000">' . "\n";
print "<B>Monitoring and Auditing:</B>\n";
print '<HR SIZE="15" ALIGN="left" width="' . $monitoring . '%" color="008000">' . "\n";
print "<B>Learning:</B>\n";
print '<HR SIZE="15" ALIGN="left" width="' . $learning . '%" color="000080">' . "\n";
print "<B>Documentation:</B>\n";
print '<HR SIZE="15" ALIGN="left" width="' . $documentation . '%" color="800080">' . "\n";
print "<B>Cost:</B>\n";
print '<HR SIZE="15" ALIGN="left" width="' . $cost . '%" color="808000">' . "\n";
print "<B>Compatability:</B>\n";
print '<HR SIZE="15" ALIGN="left" width="' . $compatability . '%" color="008080">' ."\n";
print "<B>Communication with foreign OSs:</B>\n";
print '<HR SIZE="15" ALIGN="left" width="' . $communication . '%" color="ff0000">' . "\n";
print "<B>Speed:</B>\n";
print '<HR SIZE="15" ALIGN="left" width="' . $speed . '%" color="00ff00">' . "\n";
print "<B>Available IT people:</B>\n";
print '<HR SIZE="15" ALIGN="left" width="' . $people . '%" color="0000ff">' . "\n";
print "<B>Support:</B>\n";
print '<HR SIZE="15" ALIGN="left" width="' . $support . '%" color="800000">' . "\n";
print "<B>Scalability:</B>\n";
print '<HR SIZE="15" ALIGN="left" width="' . $scalability . '%" color="008000">' . "\n";
print "<B>Speed of getting bugs fixed:</B>\n";
print '<HR SIZE="15" ALIGN="left" width="' . $bugfix . '%" color="000080">' ."\n";
print "<BR>\n";
print '<center><A href="index.html" target="_top">Operating Systems Contents Page</A></center>' . "\n";

print "</BODY>", "\n";
print "</HTML>", "\n";



sub Get_Data { 
	local (%user_data, $input_string, $nv_pair, 
		@nv_pairs, $name, $value); 

	# If the data was sent via POST, then it is available 
	# from standard input. Otherwise, the data is in the 
	# QUERY_STRING environment variable. 
	if ( $ENV{'REQUEST_METHOD'} eq "POST" )
        {
#                $len = $ENV{`CONTENT_LENGTH`};
		read(STDIN,$input_string,$ENV{'CONTENT_LENGTH'});
	} 
	else {
		$input_string = $ENV{'QUERY_STRING'}; 
	}
	
	# This line changes the + signs to spaces. 
	$input_string =~ s/\+/ /g;

	# This line places each name/value pair as a separate 
	# element in the name_value_pairs array. 
	@nv_pairs = split(/&/, $input_string); 
	# This code loops over each element in the name_value_pairs 
	# array, splits it on the = sign, and places the value 
	# into the user_data associative array with the name as the 
	# key.
	foreach $nv_pair (@nv_pairs) {
	       ($name, $value) = split(/=/, $nv_pair); 

		# These two lines decode the values from any URL
		 # hexadecimal encoding. The first section searches for a 
		# hexadecimal number and the second part converts the 
		# hex number to decimal and returns the character 
		# equivalent. 
		$name =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/ge; 
		$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/ge; 

		# If the name/value pair has already been given a value, 
		# as in the case of multiple items being selected, then 
		# separate the items with a ":".
		if (defined($user_data{$name})) {
			$user_data{$name} .= ":" . $value; } 
		else { 
			$user_data{$name} = $value; 
		} 
	} 
	return %user_data;
}

sub No_SSI {
	 local (*data) = @_;
	 foreach $key (sort keys(%data)) { 
		$data{$key} =~ s/<!--(.|\n)*-->//g; 
	}
}