#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_new_jar>

Params: none

Return: $jar

Create a new cookie jar, for use with the other functions.  Even though
the jar is technically just a hash, you should still use this function
in order to be future-compatible (should the jar format change).

=cut

sub cookie_new_jar {
    return {};
}

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

=item B<cookie_read>

Params: $jar, \%response [, \%request, $reject ]

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[2]' header
appearance.

If the optional %request hash is supplied, then it will be used to
calculate default host and path values, in case the cookie doesn't
specify them explicitly.  If $reject is set to 1, then the %request
hash values are used to calculate and reject cookies which are not
appropriate for the path and domains of the given request.

=cut

sub cookie_read {
    my ( $count, $jarref, $hrs, $hrq, $rej ) = ( 0, @_ );

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

		my @opt;
		if(defined $hrq && ref($hrq)){
			push @opt, $hrq->{whisker}->{host};
			my $u = $hrq->{whisker}->{uri};
			$u=~s#/.*?$##;
			$u='/' if($u eq '');
			push @opt, $u, $rej;
		}

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

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

=item B<cookie_parse>

Params: $jar, $cookie [, $default_domain, $default_path, $reject ]

Return: nothing

Parses the cookie into the various parts and then sets the appropriate 
values in the cookie $jar. If the cookie value is blank, it will delete 
it from the $jar.  See the 'docs/cookies.txt' document for a full
explanation of how Libwhisker parses cookies and what RFC aspects are 
supported.

The optional $default_domain value is taken literally.  Values with no 
leading dot (e.g. 'www.host.com') are considered to be strict hostnames 
and will only match the identical hostname.  Values with leading dots (e.g. 
'.host.com') are treated as sub-domain matches for a single domain level.
If the cookie does not indicate a domain, and a $default_domain is not
provided, then the cookie is considered to match all domains/hosts.

The optional $default_path is used when the cookie does not specify a path.
$default_path must be absolute (start with '/'), or it will be ignored.  If
the cookie does not specify a path, and $default_path is not provided, then
the default value '/' will be used.

Set $reject to 1 if you wish to reject cookies based upon the provided
$default_domain and $default_path.  Note that $default_domain and 
$default_path must be specified for $reject to actually do something 
meaningful.

=cut

sub cookie_parse {
    my ( $jarref, $header ) = (shift, shift);
		my ( $Dd, $Dp, $R ) = (shift, shift, shift||0);

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

		my @C = ( undef, undef, undef, undef, 0 );

		$header =~ tr/\r\n//d;
		my ($f,%seen,$n,$t) = (1);
    while( length($header) ){
    	$header =~ s/^[ \t]+//;
    	last if(!($header =~ s/^([^ \t=;]+)//));
    	my $an = lc($1);
			my $av = undef;
    	$header =~ s/^[ \t]+//;
    	if(substr($header,0,1) eq '='){
    		$header=~s/^=[ \t]*//;
    		if(substr($header,0,1) eq '"'){
    			my $p = index($header,'"',1);
    			last if($p == -1);
    			$av = substr($header,1,$p-1);
    			substr($header,0,$p+1)='';
    		} else {
					$av = $1 if($header =~ s/^([^ \t;,]*)//);
    		}
    	} else {
    		my $p = index($header,';');
    		substr($header,0,$p)='';
    	}
    	$header =~ s/^.*?;//;
			if($f){
				return if(!defined $av);
				($f,$n,$C[0])=(0,$an,$av);
			} else {
				$seen{$an}=$av if(!exists $seen{$an});
  		}
    }

		return if(!defined $n || $n eq '');
		my $del = 0;
		$del++ if($C[0] eq '');
		$del++ if(defined $seen{'max-age'} && $seen{'max-age'} eq '0');
		if($del){
        delete $$jarref{$n} if exists $$jarref{$n};			
        return;
		}

		if(defined $seen{domain} && $seen{domain} ne ''){
			$t = $seen{domain};
			$t='.'.$t if(substr($t,0,1) ne '.' && !_is_ip_address($t));
		} else {
			$t=$Dd;
		}
		$t=~s/\.+$// if(defined $t);
		$C[1]=$t;

		if(defined $seen{path}){
			$t = $seen{path};
		} else {
			$t=$Dp || '/';
		}
		$t=~s#/+$##;
		$t='/' if(substr($t,0,1) ne '/');
		$C[2]=$t;

		$C[4]=1 if(exists $seen{secure});

		return if($R && !_is_valid_cookie_match($C[1], $C[2], $Dd, $Dp));
    $$jarref{$n} = \@C;
}

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

sub _is_ip_address {
	my $n = shift;
	return 1 if($n=~/^[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}$/);
	return 0;
}

sub _is_valid_cookie_match {
	my ($cd, $cp, $td, $tp) = @_;
	return 0 if(index($tp,$cp)!=0);
	if(substr($cd,0,1) eq '.'){
		if( $td =~ /(.+)$cd$/ ){
			return 1 if(index($1,'.') == -1);
		}
		return 0;
	} else {
		return 0 if($cd ne $td);
	}
	return 1;
}

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

=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 secure, domain and 
path restrictions of the cookies are ignored and all cookies are essentially
included.

Notice: cookie expiration is currently not implemented.  URL restriction
comparision is also case-insensitive.

=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 '' );
        if($override){
            $out .= "$name=$$jarref{$name}->[0];";
            next;
        }
        next if ( $$hin{'whisker'}->{'ssl'} == 0 && $$jarref{$name}->[4] > 0 );
        if ( $$hin{'whisker'}->{'host'} =~ /$$jarref{$name}->[1]$/i
                && $$hin{'whisker'}->{'uri'} =~ /^$$jarref{$name}->[2])/ )
        {
            $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.  The
returned items will be an array in the following order:

value, domain, path, expire, secure

value  = cookie value, should always be non-empty string
domain = domain root for cookie, can be undefined
path   = URL path for cookie, should always be a non-empty string
expire = undefined (depreciated, but exists for backwards-compatibility)
secure = whether or not the cookie is limited to HTTPs; value is 0 or 1

=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_get_names>

Params: $jar

Return: @names

Fetch all the cookie names from the jar, which then let you cooke_get()
them individually.

=cut

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

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

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

=item B<cookie_get_valid_names>

Params: $jar, $domain, $url, $ssl

Return: @names

Fetch all the cookie names from the jar which are valid for the given
$domain, $url, and $ssl values.  $domain should be string scalar of the
target host domain ('www.example.com', etc.).  $url should be the absolute 
URL for the page ('/index.html', '/cgi-bin/foo.cgi', etc.).  $ssl should be 
0 for non-secure cookies, or 1 for all (secure and normal) cookies.  The 
return value is an array of names compatible with cookie_get().

=cut

sub cookie_get_valid_names {
    my ( $jarref, $domain, $url, $ssl ) = @_;

    return () if ( !( defined $jarref && ref($jarref) ) );
		return () if ( !defined $domain || $domain eq '' );
		return () if ( !defined $url || $url eq '' );
		$ssl ||= 0;

		my (@r, $name);
    foreach $name ( keys %$jarref ) {
        next if ( $name eq '' );
        next if ( $$jarref{$name}->[4] > 0 && $ssl == 0 );
        if ( $domain =~ /$$jarref{$name}->[1]$/i
                && $url =~ /^$$jarref{$name}->[2])/i ) {
            push @r, $name;
        }
    }
    
    return @r;
}


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

=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.  $name is 
required to be a non-empty string.  $value is required, and will delete
the named cookie from the $jar if it is an empty string.  $domain and
$path can be strings or undefined.  $expire is ignored (but exists
for backwards-compatibility).  $secure should be the numeric value of
0 or 1.

=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 ( !defined $value || $value eq '' ) {
        delete $$jarref{$name};
        return;
    }
    $path   = $path   || '/';
    $secure = $secure || 0;

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

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