#GPL
#GPL  libwhisker copyright 2000-2004 by rfp.labs
#GPL
#GPL  This program is free software; you can redistribute it and/or
#GPL  modify it under the terms of the GNU General Public License
#GPL  as published by the Free Software Foundation; either version 2
#GPL  of the License, or (at your option) any later version.
#GPL
#GPL  This program is distributed in the hope that it will be useful,
#GPL  but WITHOUT ANY WARRANTY; without even the implied warranty of
#GPL  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#GPL  GNU General Public License for more details.
#GPL


=item B<COOKIE FUNCTIONS>

Cookies are stored in a "jar" (hash), indexed by cookie name.  The 
contents are an anonymous array:

 $jar{'name'}=[ 'value', 'domain', 'path', 'expire', 'secure' ]
 $jar{'name'}=[ 'value', { ..parameters.. }, version ] 

=cut

########################################################################

=item B<cookie_read>

Params: \%jar, \%response

Return: $num_of_cookies_read

Read in cookies from an %response hash, and put them in %jar.

Notice: cookie_read uses internal magic done by http_do_request
in order to read cookies regardless of 'Set-Cookie' header
appearance.

=cut

sub cookie_read {
 my ($count,$jarref,$href)=(0,@_);

 return 0 if(!(defined $jarref && ref($jarref)));
 return 0 if(!(defined $href   && ref($href)  ));
 return 0 if(!(defined $$href{whisker}->{cookies} &&
 	ref($$href{whisker}->{cookies})));

 foreach (@{$href->{whisker}->{cookies}}){
		cookie_parse($jarref,$_);
		$count++; }
 return $count;
}

########################################################################

=item B<cookie_parse>

Params: \%jar, $cookie

Return: nothing

Parses the cookie into the various parts and then sets the appropriate 
values in the %jar under the name; if the cookie is blank, it will delete 
it from the jar.

=cut

sub cookie_parse {
 my ($jarref, $header)=@_;
 my ($del,$part,@parts,@construct,$cookie_name)=(0);

 return if(!(defined $jarref && ref($jarref)));
 return if(!(defined $header && length($header)>0));

 @parts=split(/;/,$header);

 foreach $part (@parts){
	if($part=~/^[ \t]*(.+?)=(.*)$/){
		my ($name,$val)=($1,$2);
		if($name=~/^domain$/i){		
			$val=~s#^http://##;
			$val=~s#/.*$##;
			$construct[1]=$val;
		} elsif($name=~/^path$/i){
			$val=~s#/$## if($val ne '/');
			$construct[2]=$val;
		} elsif($name=~/^expires$/i){
			$construct[3]=$val;
		} else {
			$cookie_name=$name;
			if($val eq ''){		$del=1;
			} else {		$construct[0]=$val;}
		}	
	} else {
		if($part=~/secure/){
			$construct[4]=1;}
 }	}

 if($del){
  	delete $$jarref{$cookie_name} if defined $$jarref{$cookie_name};
 } else {
	$$jarref{$cookie_name}=\@construct;
 }
}

########################################################################

=item B<cookie_write>

Params: \%jar, \%request, $override

Return: nothing

Goes through the given jar and sets the Cookie header in %req pending the 
correct domain and path.  If $override is true, then the domain and path
restrictions of the cookies are ignored.

Todo: factor in expire and secure.

=cut

sub cookie_write {
 my ($jarref, $hin, $override)=@_;
 my ($name,$out)=('','');

 return if(!(defined $jarref && ref($jarref)));
 return if(!(defined $hin    && ref($hin)   ));

 $override=$override||0;
 $$hin{'whisker'}->{'ssl'}=$$hin{'whisker'}->{'ssl'}||0;

 foreach $name (keys %$jarref){
	next if($name eq '');
	next if($$hin{'whisker'}->{'ssl'}==0 && $$jarref{$name}->[4]>0);
	if($override || 
          ($$hin{'whisker'}->{'host'}=~/$$jarref{$name}->[1]$/i &&
	   $$hin{'whisker'}->{'uri'}=~/$$jarref{$name}->[2]/i)){
		$out.="$name=$$jarref{$name}->[0];";
 }	}

 if($out ne ''){ $$hin{'Cookie'}=$out; }

}

########################################################################

=item B<cookie_get>

Params: \%jar, $name

Return: @elements

Fetch the named cookie from the jar, and return the components.

=cut

sub cookie_get {
 my ($jarref,$name)=@_;

 return undef if(!(defined $jarref && ref($jarref)));

 if(defined $$jarref{$name}){
	return @{$$jarref{$name}};}

 return undef;
}

########################################################################

=item B<cookie_set>

Params: \%jar, $name, $value, $domain, $path, $expire, $secure

Return: nothing

Set the named cookie with the provided values into the %jar.

=cut

sub cookie_set {
 my ($jarref,$name,$value,$domain,$path,$expire,$secure)=@_;
 my @construct;

 return if(!(defined $jarref && ref($jarref)));

 return if($name eq '');
 if($value eq ''){
	delete $$jarref{$name};
	return;}
 $path=$path||'/';
 $secure=$secure||0;

 @construct=($value,$domain,$path,$expire,$secure);
 $$jarref{$name}=\@construct; 
}

########################################################################