#!/usr/local/bin/perl
# (Change first line to the perl file on your Web server.)
# program name : gcl (graphic counter by cgi and gif images using lock file)
#
# function     : count the number of guests and send counter gif file to 
#                browser.
#
# note         : This counter is made for web site where cgi written by perl
#                is available and flock of Perl is not available. 
#                Instead of flock of Perl, symlink is used in this cgi
#                If symlik is not available, use link. If link is not 
#                available, use lock file rename procedure for lock, which
#                may not be atomic.
#
# programmer   : makoto takenaka : takesoft@mxs.meshnet.or.jp
#
# copyright    : (c) 1997 by Takesoft
#
# version(date): 
#    1.0(Jan  18, 1997) Made from gcounter version 1.2
#    1.1(Jan  29, 1997) Change (6) to delete lock file even if open
#                       $countfile failed.
#
# calling form : 
#    <IMG SRC="gcl.cgi?digit=n" BORDER=0 ALT="">   
#    or
#    <IMG SRC="gcl.cgi?cf=countgc.txt&digit=n" BORDER=0 ALT="">
#    ,where n means the n-th digit of the counter from the right.
#     If cf is not specified, cf=count.txt is supporsed.
#
#(1) set constants.
#
   $max_digit = 10;
#
#  If absolute dir is required, change $count_dir and $gif_dir such as 
#  "/home*/user_id/public_html/" or "/home/usr*/user_id/public_html/image/",
#  where * is a number.
#
   $count_dir   = "./"; #directory of count file
   $lock_dir    = "./lock/";    # directory of lock file
   $target_file = $lock_dir."gcltrgt.txt";   # target file of lock
   $lock_file   = $lock_dir."gcllock.txt";   # lock file
   $gif_dir     = "./image/"; # directory of gif files
#
#(2) get parameters from string.
#
   $buffer = $ENV{'QUERY_STRING'};
#
   @pairs = split(/&/, $buffer);
#

   foreach $pair (@pairs)
      {
      ($name, $value) = split(/=/, $pair);
      $parameters{$name}    = $value;
      }
#
   $digit = $parameters{'digit'};
   $cf    = $parameters{'cf'};
   unless($cf)
      {$cf = "count.txt";}           # default value of cf
#
   $countfile = $count_dir.$cf;   # file of count number
#
#(3) Set $count.
#
   open(COUNTFILE, $countfile) 
     || &error_mail("(3): Unable to open $countfile as read only file");
   $count = <COUNTFILE>;
   close(COUNTFILE);
#
#  add ten "0" ahead of $count.
#
   $count = "0000000000".$count;
#
#(4) get n-th digit from right in $count
#    and send the gif image of the digit.
#
   if($digit<1 || $digit > $max_digit)
      {&error_mail("(4) wrong position in counter from right, digit = $digit")}
#
   $d = substr($count, (-1)*($digit), 1);
#
   if($d < 0 || $d > 9)
      {&error_mail("(5) wrong number d, d = $d")}
#
   $gif_file = $gif_dir."${d}.gif";
#
#(5) send gif file to browser.
#
   print "Content-type: image/gif\n\n";
#
#  next part is equivalent to
#
#  system("/bin/cat $gif_file"); or `/bin/cat $gif_file`;
#
#  but not available in meshnet.
#
   open(GIF_FILE, $gif_file)
      ||&error_mail("(5) Unable to open gif file.");
   while(read(GIF_FILE, $buf, 16384))
      {
      print $buf;
      }
#   print <GIF_FILE>;
   close(GIF_FILE);
#
#(6) Increment $count if $digit is 1.
#
   if ($digit == 1)
      {
#
#(6.1) Wait a while to be the last completed cgi if $digit is 1.
#      If select is not supported in your server, use "sleep(1);"
#      to wait 0-1 sec.
#
   select(undef, undef, undef, 0.3); # Wait 0.3 sec.
#
#(6.2) Open $countfile and increment $count.
#
     if(symlink($target_file, $lock_file))
         {
         if(open(COUNTFILE, "+< $countfile"))
            {
            $count = <COUNTFILE>;
            $count = $count + 1;
            seek(COUNTFILE, 0, 0);
            print COUNTFILE $count;
            close(COUNTFILE);
            unlink($lock_file);
            }
         else
            {
            unlink($lock_file);
            &error_mail("(6): Unable to open $countfile");
            }
         }
      }
   exit 0;
#
sub error_mail
   {
   local($message) = @_;
#
#(sub routine) Send error mail.
#
#   If you want to use error mail, change mail address to yours
#   and uncomment(remove #) next four lines.
#   But at some provider such as rimnet, sending mail from cgi may not
#   be allowed. At some provider simple mail command may not available.
#   In such case, do not mail, but print on some file, which is to be
#   prepared with access mask "606".
#
#   open(MAIL, "|mail user-id\@xxx.yyyyyyy.or.jp");
#   print MAIL "Error Message from gcl.cgi of home page: \n";
#   print MAIL "$message\n";
#   close(MAIL);
#
#  stop this perl program.
#
   exit(1);
   }