package UBBCGI::Cookie;

# Copyright 1995-1999, Lincoln D. Stein.  All rights reserved.
# It may be used and modified freely, but I do request that this copyright
# notice remain attached to the file.  You may modify this module as you 
# wish, but if you redistribute a modified version, please attach a note
# listing the modifications you have made.

$UBBCGI::Cookie::VERSION='1.12';

use UBBCGI qw(-no_debug);
use overload '""' => \&as_string,
    'cmp' => \&compare,
    'fallback'=>1;

# fetch a list of cookies from the environment and
# return as a hash.  the cookies are parsed as normal
# escaped URL data.
sub fetch {
    my $class = shift;
    my $raw_cookie = $ENV{HTTP_COOKIE} || $ENV{COOKIE};
    return () unless $raw_cookie;
    return $class->parse($raw_cookie);
}

# fetch a list of cookies from the environment and
# return as a hash.  the cookie values are not unescaped
# or altered in any way.
sub raw_fetch {
    my $class = shift;
    my $raw_cookie = $ENV{HTTP_COOKIE} || $ENV{COOKIE};
    return () unless $raw_cookie;
    my %results;
    my($key,$value);

    my(@pairs) = split("; ",$raw_cookie);
    foreach (@pairs) {
	if (/^([^=]+)=(.*)/) {
	    $key = $1;
	    $value = $2;
	}
	else {
	    $key = $_;
	    $value = '';
	}
	$results{$key} = $value;
    }
    return \%results unless wantarray;
    return %results;
}

sub parse {
    my ($self,$raw_cookie) = @_;
    my %results;

    my(@pairs) = split("; ",$raw_cookie);
    foreach (@pairs) {
	my($key,$value) = split("=");
	my(@values) = map UBBCGI::unescape($_),split('&',$value);
	$key = UBBCGI::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} ||= $self->new(-name=>$key,-value=>\@values);
    }
    return \%results unless wantarray;
    return %results;
}

sub new {
    my $class = shift;
    $class = ref($class) if ref($class);
    my($name,$value,$path,$domain,$secure,$expires) =
	UBBCGI->rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@_);

    # Pull out our parameters.
    my @values;
    if (ref($value)) {
	if (ref($value) eq 'ARRAY') {
	    @values = @$value;
	} elsif (ref($value) eq 'HASH') {
	    @values = %$value;
	}
    } else {
	@values = ($value);
    }

    bless my $self = {
	'name'=>$name,
	'value'=>[@values],
	},$class;

    # IE requires the path and domain to be present for some reason.
    $path   = UBBCGI::url(-absolute=>1) unless defined $path;
# however, this breaks networks which use host tables without fully qualified
# names, so we comment it out.
#    $domain = CGI::virtual_host()    unless defined $domain;

    $self->path($path)     if defined $path;
    $self->domain($domain) if defined $domain;
    $self->secure($secure) if defined $secure;
    $self->expires($expires) if defined $expires;
    return $self;
}

sub as_string {
    my $self = shift;
    return "" unless $self->name;

    my(@constant_values,$domain,$path,$expires,$secure);

    push(@constant_values,"domain=$domain") if $domain = $self->domain;
    push(@constant_values,"path=$path") if $path = $self->path;
    push(@constant_values,"expires=$expires") if $expires = $self->expires;
    push(@constant_values,'secure') if $secure = $self->secure;

    my($key) = UBBCGI::escape($self->name);
    my($cookie) = join("=",$key,join("&",map UBBCGI::escape($_),$self->value));
    return join("; ",$cookie,@constant_values);
}

sub compare {
    my $self = shift;
    my $value = shift;
    return "$self" cmp $value;
}

# accessors
sub name {
    my $self = shift;
    my $name = shift;
    $self->{'name'} = $name if defined $name;
    return $self->{'name'};
}

sub value {
    my $self = shift;
    my $value = shift;
    $self->{'value'} = $value if defined $value;
    return wantarray ? @{$self->{'value'}} : $self->{'value'}->[0]
}

sub domain {
    my $self = shift;
    my $domain = shift;
    $self->{'domain'} = $domain if defined $domain;
    return $self->{'domain'};
}

sub secure {
    my $self = shift;
    my $secure = shift;
    $self->{'secure'} = $secure if defined $secure;
    return $self->{'secure'};
}

sub expires {
    my $self = shift;
    my $expires = shift;
    $self->{'expires'} = UBBCGI::expires($expires,'cookie') if defined $expires;
    return $self->{'expires'};
}

sub path {
    my $self = shift;
    my $path = shift;
    $self->{'path'} = $path if defined $path;
    return $self->{'path'};
}

1;

