#!/usr/bin/perl -w

use strict;

my $log = "../LOG";
#my $log = "LOG";
my $COUNTFILE = "COUNT";

my @setcookies;

my $incookies = cookie_parse();

# We use (set and read) four cookies: reqs (requests), visits, visitor, se
# (session)

# If there's no visitor cookie, we assign a new visitor number, set visits and
# requests cookies to 1, session to some.

# If there's no visitor cookie and no session cookie and this is an inter-page
# request, we try to set the session cookie.

# If that's an inter-page request and there is no visitor cookie, we check the
# session cookie.  If there isn't, we do not assign a new visitor number, but
# we do assign a session cookie.

# If that's an external visitor and it has no visitor cookie, we do assign a
# new visitor number.

# Session cookie we assign every time, no matter what.


my $session = $incookies ->{se};
my $origvisitor = 
  my $visitor = $incookies ->{visitor};

my $reqs = $incookies ->{reqs} || 0;
$reqs ++;
my $visits = $incookies ->{visits} || 0;
if ( not $session ) {
  $visits ++;
}


my $par = parse_query_string_into_hash();

my $pg  = $par->{pg}  || '';
my $ref = $par->{ref} || '';

my $justpage;

if ( $pg and $ref ) {
  my ( $host1 ) = ( $pg  =~ m!^(\w+://[^/]+)!i );
  my ( $host2 ) = ( $ref =~ m!^(\w+://[^/]+)!i );
  $host1 = lc $host1;
  $host2 = lc $host2;
  if ( $host2 eq $host1 ) {
    $justpage = 1;
  }
}

  
if ( not defined $visitor ) {
  if ( not $justpage ) {
    $visitor = assign_new_visitor_no();
  } else {
    $visitor = "unk";
  }
} 
#warn "visitor is $visitor";  


push @setcookies, cookie_create( -name => "se",
                                 -value => "1",
                                 -expires => "+30m",
);


push @setcookies, cookie_create( -name => "reqs",
                                 -value => $reqs,
                                 -expires => "+10y",
);

push @setcookies, cookie_create( -name => "visits",
                                 -value => $visits,
                                 -expires => "+10y",
);

push @setcookies, cookie_create( -name => "visitor",
                       -value => $visitor,
                       -expires => "+10y",
);


sub p { print @_,"\n"; }


p "Content-type: image/gif";
# p "Content-type: text/plain";

#p "";

foreach ( @setcookies ) {
  p "Set-Cookie: $_";
}

my $GIF = 'GIF89a  ‘  ÿÿÿ         !ù            ,         ;';
p "";
p $GIF;

#p "\nvisitor: $visitor\n";
#p( "\nsession: $session\n" )
#  if $session;
#p keys %$incookies;


my $ua = $ENV{HTTP_USER_AGENT} || '';

if ( open  LOG, ">>$log" ) {
  print LOG scalar localtime, " ", $pg, " ", $ref, " (", $ua, ") $visitor/$reqs/$visits\n";
  close LOG;
}


sub assign_new_visitor_no {
  my $count;
  my $new = '0';
  if ( open COUNT, "<$COUNTFILE" ) {
    $count = <COUNT>;
    close COUNT;
  } else {
    $count = 0;
    warn "can't read counter file $COUNTFILE";
  }
    
  if ( defined $count 
       and $count =~ /^\d+$/ ) {
    $new = $count +1;
    if ( open COUNT, ">$COUNTFILE" ) {
      print COUNT $new;
      close COUNT;
    }
  }
  return $new;
}


# ------------------------------------------------------------
# subroutine  PARSE QUERY STRING INTO HASH
#
sub parse_query_string_into_hash {
    my %par;

    my $query = $ENV{QUERY_STRING} || '';
    my @in    = split( /[&;]/, $query );
    foreach my $i ( @in ) {
        $i =~ s/\+/ /g;
        my ( $key, $val ) = split( /=/, $i, 2);
        $key =~ s/\%u([\da-f]{4})/pack("c",hex($1))/ige;
        $val =~ s/\%u([\da-f]{4})/pack("c",hex($1))/ige;
        $key =~ s/%([\da-f]{2})/pack("c",hex($1))/ige;
        $val =~ s/%([\da-f]{2})/pack("c",hex($1))/ige;
        $par{$key} .= "\0" if defined($par{$key});
        $par{$key} .= $val;
    }

    return \%par;
}


sub cookie_create {
  my $hash  = { @_ };
  my $name  = $hash ->{-name} || die;
  my $value = $hash ->{-value} || '';
  my $domain  = $hash ->{-domain};
  my $path    = $hash ->{-path} || "/";
  my $expires = $hash ->{-expires};
  if ( $expires ) { 
    $expires = expires( $expires );
  }
  
  $name  = escape($name);
  if ( not defined $name ) { die; }

  $value = escape($value);
  if ( not defined $value ) { die; }

  my $first = $name . "=". $value;
  
  my @attr;
  push @attr, $first;
  push( @attr, "domain=$domain" )
    if $domain;
  push( @attr, "path=$path" )
    if $path;
  push( @attr, "expires=$expires" )
    if $expires;

  join( "; ", @attr );
}


sub cookie_parse {

  my $raw_cookie = $ENV{HTTP_COOKIE} || $ENV{COOKIE} || '';
  my %results;

  my(@pairs) = split(/; ?/,$raw_cookie);
  foreach (@pairs) {
    s/\s*(.*?)\s*/$1/;
    my( $key,$value ) = split("=",$_,2);

    # Some foreign cookies are not in name=value format, so ignore
    # them.
    next if !defined($value);

    my $val = unescape( $value );
#    my @values = ();
#    if ($value ne '') {
#      @values = map unescape($_),split(/[&;]/,$value.'&dmy');
#      pop @values;
#    }
    $key = unescape($key);
    # A bug in Netscape can cause several cookies with same name to
    # appear.  The FIRST one in HTTP_COOKIE is the most recent version.
#    $results{$key} ||= \@values;
    $results{$key} ||= $val;
  }
  return \%results unless wantarray;
  return %results;
}


# unescape URL-encoded data
sub unescape {
  my $todecode = shift;
  return undef
    unless defined($todecode);
  $todecode =~ tr/+/ /;       # pluses become spaces
  $todecode =~ s/%(?:([0-9a-fA-F]{2})|u([0-9a-fA-F]{4}))/
    defined($1)? chr hex($1) : utf8_chr(hex($2))/ge;
  return $todecode;
}

# URL-encode data
sub escape {
  my $toencode = shift;
  return undef 
    unless defined($toencode);
  $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
  return $toencode;
}


sub utf8_chr ($) {
        my $c = shift(@_);

        if ($c < 0x80) {
                return sprintf("%c", $c);
        } elsif ($c < 0x800) {
                return sprintf("%c%c", 0xc0 | ($c >> 6), 0x80 | ($c & 0x3f));
        } elsif ($c < 0x10000) {
                return sprintf("%c%c%c",
                                           0xe0 |  ($c >> 12),
                                           0x80 | (($c >>  6) & 0x3f),
                                           0x80 | ( $c          & 0x3f));
        } elsif ($c < 0x200000) {
                return sprintf("%c%c%c%c",
                                           0xf0 |  ($c >> 18),
                                           0x80 | (($c >> 12) & 0x3f),
                                           0x80 | (($c >>  6) & 0x3f),
                                           0x80 | ( $c          & 0x3f));
        } elsif ($c < 0x4000000) {
                return sprintf("%c%c%c%c%c",
                                           0xf8 |  ($c >> 24),
                                           0x80 | (($c >> 18) & 0x3f),
                                           0x80 | (($c >> 12) & 0x3f),
                                           0x80 | (($c >>  6) & 0x3f),
                                           0x80 | ( $c          & 0x3f));

        } elsif ($c < 0x80000000) {
                return sprintf("%c%c%c%c%c%c",
                                           0xfe |  ($c >> 30),
                                           0x80 | (($c >> 24) & 0x3f),
                                           0x80 | (($c >> 18) & 0x3f),
                                           0x80 | (($c >> 12) & 0x3f),
                                           0x80 | (($c >> 6)  & 0x3f),
                                           0x80 | ( $c          & 0x3f));
        } else {
                return ''; # was: utf8( 0xfffd );
        }
}

# This internal routine creates date strings suitable for use in
# cookies and HTTP headers.  (They differ, unfortunately.)
# Thanks to Mark Fisher for this.
sub expires {
    my($time,$format) = @_;
    $format ||= 'http';

    my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
    my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;

    # pass through preformatted dates for the sake of expire_calc()
    $time = expire_calc($time);
    return $time 
      unless $time =~ /^\d+$/;

    # make HTTP/cookie date string from GMT'ed time
    # (cookies use '-' as date separator, HTTP uses ' ')
    my($sc) = ' ';
    $sc = '-' if $format eq "cookie";
    my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
    $year += 1900;
    return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
                   $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
}

# This internal routine creates an expires time exactly some number of
# hours from the current time.  It incorporates modifications from
# Mark Fisher.
sub expire_calc {
    my($time) = @_;
    my(%mult) = ('s'=>1,
                 'm'=>60,
                 'h'=>60*60,
                 'd'=>60*60*24,
                 'M'=>60*60*24*30,
                 'y'=>60*60*24*365);
    # format for time can be in any of the forms...
    # "now" -- expire immediately
    # "+180s" -- in 180 seconds
    # "+2m" -- in 2 minutes
    # "+12h" -- in 12 hours
    # "+1d"  -- in 1 day
    # "+3M"  -- in 3 months
    # "+2y"  -- in 2 years
    # "-3m"  -- 3 minutes ago(!)
    # If you don't supply one of these forms, we assume you are
    # specifying the date yourself
    my $offset;
    if (!$time || (lc($time) eq 'now')) {
        $offset = 0;

    } elsif ($time=~/^\d+/) {
        return $time;

    } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/) {
        $offset = ($mult{$2} || 1)*$1;

    } else {
        return $time;
    }
    return (time+$offset);
}