package TDS::Cookie;
#$Id: Cookie.pm,v 1.19 2001/01/10 08:12:43 tom Exp $
################################################################

use strict;
use vars qw($EnableCookie
	    $Expires);

use CGI::CookieTool;
use TDS;
use TDS::IdentInfo;

$EnableCookie = 0 unless defined $EnableCookie;
$Expires = '+1y' unless defined $Expires;

# [ATTENTION]
# for users who have installed 1.1.4.
# 1.1.4 outputs cookie with path which has right-most '/',
# but lynx regards it as 'invalid'.
#
# we discussed about this problem, and send mail to lynx-dev
# (http://www.mail-archive.com/lynx-dev%40sig.net/msg05478.html),
# and decide that we do NOT add right-most '/' in path.
#
# user agent who visits diary using tds-1.1.4
# accepts cookies with right-most / path, and other time,
# when visits the page which version-ups to tds-1.2.0 again,
# it will accept cookies which do NOT have right-most '/' path.
#
# in that case, new cookie is NOT applied entirely, because
# old right-most / cookie is prefered than new cookie.
# and as result, it's occured tha visiting times has NEVER changed.
#
# for resolving this problem, user who used tds-1.1.4 expires
# old cookie (with right-most '/') by setting $ExpireInivalidCookie as true.
#
# demerit using this method is that number of cookie which diary outputs
# is doubled to 4. but by applying this method for a week,
# frequency visitor's old cookie will be expired.

#$ExpireInvalidCookie = 0 unless defined $ExpireInvalidCookie;


################################################################
sub AsCookieHeaders
{

    my $status = $TDS::Status;
    return undef unless $EnableCookie && !$status->is_robot && $status->id;
    
    my $header;
    my $path = TDS::IdentInfo->Get('url');
    $path =~ s!^http://[^/]+!!;
    my $path_sla = $path;
    $path_sla =~ s!/?[^/]+$!!;

    my $is_lynx = $ENV{'HTTP_USER_AGENT'} &&
	$ENV{'HTTP_USER_AGENT'} =~ /^lynx/i;
    
    if (1){ # $is_lynx){ #  || !$status->is_author){
	# lynx regards path=/bar/diary/ as invalid, so eliminate right-most '/'
	# see http://www.flora.org/lynx-dev/html/month081999/msg00254.html
	#   and http://www.mail-archive.com/lynx-dev%40sig.net/msg05478.html

	# not add the right-most '/'(thanks for ari3)
	$path =~ s!/[^/]*$!!;    
    } else {
	# for author access, add right-most '/' except accessing by lynx
	# ATTENTION: not effective even if / added only if author-access.
	# because in first access, the ID output as not author,
	# so alreadly the cookie is known by other URI which is prefix of
	# the URI.
	
	$path =~ s!/?[^/]+$!!;
    }
    $path = ($path) ? $path : "/";

    # create header string
    $header .= AsCookieHeader('id', $status->id->GetID(), $Expires, 0, $path);
    $header .= AsCookieHeader('times', $status->id->GetTimes(), $Expires, 0, $path);
#    if ($ExpireInvalidCookie){ # && !$status->is_author){
#    die &CGI::CookieTool::GetNumberOfCookie('id'), ", ",
#	&CGI::CookieTool::GetNumberOfCookie('times');

    my $id_number = CGI::CookieTool::GetNumberOfCookie('id');
    my $times_number = CGI::CookieTool::GetNumberOfCookie('times');
    if ($id_number == 2 && $times_number== 2){
	# expire old cookie which has right-most '/' in path
	# thanks to KKI
	$header .= AsCookieHeader('id', $status->id->GetID(), '-1y', 0, $path_sla);
	$header .= AsCookieHeader('times', $status->id->GetTimes(), '-1y', 0, $path_sla);
    }
    return $header;
}

1;

