#!/usr/mesh/bin/perl
#
# program name : ldc.cgi (Link Destination Counter)
#
# function     : Count the clicked number of each link tag. 
#
# note         : This counter is made for web site where cgi written by perl
#                is available.
#
# programmer   : makoto takenaka : takesoft@mxs.meshnet.or.jp
#
# copyright     : (c) 1996 by Takesoft
#
# version(date): 
#    1.0(Nov  4, 1996)
#    1.1(Nov 15, 1996) Add bdir and ldc1 parameters.
#                      Change die to exit 1 in sub error_mail
#    1.2(Nov 20, 1996) Add truncate.
#    1.3(Nov 23, 1996) Change "if(/$url/)" to "if(/$url\s/)".
#
# calling form : 
#    <A HREF="ldc.cgi?url=http://www2a.meshnet.or.jp/~takesoft/">Takesoft</A>
#    <A HREF="../ldc.cgi?bdir=/home/usr5/user-id/public_html/link/&ldc1=ldca1&
#url=http://www.coolsite.or.jp/~hotspot/">[Cool Site]</A>
#    (Do not break lines in real tags between double quotes.)
#
#(1) set constants and initial value.
#
   $def_bdir  = "./";                 # default name of directory
   $def_ldc1  = "ldc1";               # default ldc1
#
   $url_found = 0;                    # = 1; if url is found.
#
#  If absolute directory name is required, change $def_bdir such as 
#  "/home*/user_id/public_html/link/" or 
#  "/home/usr*/user_id/public_html/link/",
#  where * is a number, "link" is an example of directory of link page.
#
#(2) get parameters from string.
#
   $buffer = $ENV{'QUERY_STRING'};
#
   @pairs = split(/&/, $buffer);
#

   foreach $pair (@pairs)
      {
      ($name, $value) = split(/=/, $pair);
      $parameters{$name}    = $value;
      }
#
   $url  = $parameters{'url'};
   $bdir = $parameters{'bdir'};
   $ldc1 = $parameters{'ldc1'};
#
   unless($url)
      {exit 0;}           # Do nothing.
   unless($bdir)
      {$bdir = $def_bdir;}
   unless($ldc1)
      {$ldc1     = $def_ldc1;}
   $ldc2         = $ldc1;
   $ldc2         =~ s/1$/2/;  # Change last "1" to "2".
   if($ldc2 eq $ldc1)
      {&error_mail("(2): Last character of ldc1 should be 1. ldc1=$ldc1");}
#
   $ldc1_file = "$bdir$ldc1.txt"; # file of link destination count
   $ldc2_file = "$bdir$ldc2.txt"; # work file
#
#(3) Search $url and count number.
#
   open(LDC1, "+<$ldc1_file") 
     || &error_mail("(3): Unable to open $ldc1_file file");
   flock(LDC1, 2);
#
   open(LDC2, "+<$ldc2_file") 
     || &error_mail("(3): Unable to open $ldc2_file file");
   flock(LDC2, 2);
#
   while(<LDC1>)
      {
      if(/$url\s/)
         {
         $count = $` + 1;
         print LDC2 "$count ", $&, $';
         $url_found = 1;
         print LDC2 <LDC1>;
         last;
         }
      else
         {
         print LDC2 $_;
         }
      }
#
   if($url_found == 0)
      {
      print LDC2 "1 $url\n";
      }
   truncate(LDC2, tell(LDC2));
#
#(4) Reset file pointer and copy LDC2 to LDC1.
#
   seek(LDC1, 0, 0);
   seek(LDC2, 0, 0);
#
   print LDC1 <LDC2>;
#
   flock(LDC2, 8);
   close(LDC2);
   flock(LDC1, 8);
   close(LDC1);
#
#(5) Go to link destination.
#
   print "Location: $url\n\n";
#
#(6) Normal end of main program
#
   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 is not
#   allowed. At some provider simple mail command may not available.
#   In such case, do not mail, but print on some file having a access
#   mask of 606.
#
#   open(MAIL, "|mail user-id\@xxx.yyyyy.or.jp");
#   print MAIL "Error Message from ldc.cgi of Web page: \n";
#   print MAIL "$message\n";
#   close(MAIL);
#
#  stop this perl program.
#
   exit 1;
   }