# ReadCookie.pm - Created by James Pattie, 11/10/2000.

# Copyright (c) 2000 PC & Web Xperience, Inc. http://www.pcxperience.com/
# All rights reserved.  This program is free software; you can redistribute it
# and/or modify it under the same terms as Perl itself.

# This is the Object Oriented cookie module for all our programs that allows us to read cookies
# from the client (server).

# updated 02/24/2001 - updated naming scheme
# updated 11/20/2001 - Fixed the decodeCharsHash entries for /, $, ?, + since they don't need to be \ escaped

package HTMLObject::ReadCookie;
use strict;
use vars qw($AUTOLOAD $VERSION @ISA @EXPORT @EXPORT_OK);

require Exporter;

@ISA = qw(Exporter AutoLoader);
@EXPORT = qw(
);

$VERSION = '2.28';

my @DecodeChars = ( '%3A', '%26', '%3D', '%2C', '%3B', '%2B', '%25', '%22', '%23', '%24', '%2F', '%3F', '%3C', '%3E', '%40', '%A' );

# new - Instantiates an instance of the ReadCookie Object to allow us to work with cookies.
sub new
{
  my $that = shift;
  my $class = ref($that) || $that;
  my $self = bless {}, $class;
  my %args = (  @_ );

  $self->{decodeCharsArray} = \@DecodeChars;  # changed from [] to \
  $self->{cookies} = {};

  return $self;
}

# decodeString
# Takes:        String to un-URI encode.
# Returns:      un-URI encoded string.
sub decodeString
{
  my $self = shift;
  my %args = ( @_, );
  my $string = $args{'string'};

  # fixup the + to space first.
  $string =~ s/\+/ /g;

  # now handle all the % hex values.
  foreach my $char (@{$self->{decodeCharsArray}})
  {
    (my $tmp = $char) =~ s/^%//; # remove the leading %.
    $string =~ s/$char/pack("c", hex($tmp))/ige;
  }

  return $string;
}

# getCookies() - Gets Cookie(s) from the Server Environment.
# Takes: 	cookies (Array of Cookie Names) or Nothing.
# Returns:	a hash that contains all cookies found, empty if an error occurred.

sub getCookies
{
  my $self = shift;
  my %args = ( cookies => [], @_ );
  my @browserCookies = @{$args{cookies}};

  my ($cookie, $value);
  my %cookiesFound = ();

  # check and make sure that the Browser sent us some cookies via the server.
  if (exists $ENV{'HTTP_COOKIE'})
  {
    # see if they requested a particular cookie(s).
    if (scalar @browserCookies > 0)
    {
      foreach my $temp (split(/; /,$ENV{'HTTP_COOKIE'}))
      {
        # Split the name=value pairs.

        ($cookie,$value) = split /=/, $temp;

        # do URL decoding
        $cookie = $self->decodeString( string => "$cookie" ); 
        $value = $self->decodeString( string => "$value" );

        # Check and see if this cookie was requested.
        foreach my $temp2 (@browserCookies)
        {
          if ($temp2 eq $cookie)
          {
            $self->{cookies}->{$cookie} = $value;
            $cookiesFound{$cookie} = $value; # signal we found one of the specified cookies
          }
        }
      }
    }
    else # get all cookies passed in by the browser.
    {
      foreach my $temp (split(/; /,$ENV{'HTTP_COOKIE'}))
      {
        ($cookie,$value) = split /=/, $temp;

        # do URL decoding
        $cookie = $self->decodeString( string => "$cookie" ); 
        $value = $self->decodeString( string => "$value" );

        $self->cookies->{$cookie} = $value;
        $cookiesFound{$cookie} = $value; # signal we succeeded.
      }
    }
  }
  
  return %cookiesFound;
}

# getCompressedCookies - This takes the compressed cookie names, and optionally the names of specific cookies you want returned
#                and uncompresses them, setting the values into %Cookies.  Specific names of cookies are optional and if not specified
#                all cookies found in the compressed cookie will be set.
# Takes -	cname - Name of the compressed cookie to be uncompressed.
#               names - Optional array of names of cookies to be returned from the
#                       compressed cookie if you don't want them all.
# Returns:       hash of cookie names uncompressed from this compressed cookie.

sub getCompressedCookies
{
  my $self = shift;
  my %args = ( cname => "", names => [], @_ );
  my $cookieName = $args{cname};
  my @cookies = @{$args{names}};
  my %cookiesFound = ();
  my ($resultingCookie, $cookie, $value);

  my %result = $self->getCookies(cookies => [ $cookieName ]);
  if (scalar keys %result == 1)
  { # we found the cookie in question
    if (scalar @cookies > 0)
    {
      foreach my $temp (split(/&/, $self->{cookies}->{$cookieName}))
      {
        # Split the cookie name and value pair.

        ($cookie, $value) = split /::/, $temp;

        # if we get a match, set the cookie.

        foreach $resultingCookie (@cookies)
        {
          if ($resultingCookie eq $cookie)
          {
            $self->{cookies}->{$cookie} = $value;
            $cookiesFound{$cookie} = $value;
          }
        }
      }
    }
    else # get all cookies
    {
      foreach my $temp (split(/&/, $self->cookies->{$cookieName}))
      {
        ($cookie, $value) = split /::/, $temp;

        $self->{cookies}->{$cookie} = $value;
        $cookiesFound{$cookie} = $value;
      }
    }

    delete($self->cookies->{$cookieName}); # remove the Compressed cookie so it is not used by accident.
  }

  return %cookiesFound;
}

sub DESTROY
{
  my $self = shift;
}

sub AUTOLOAD
{
  my $self = shift;
  my $type = ref($self) || die "$self is not an object";
  my $name = $AUTOLOAD;
  $name =~ s/.*://;	# strip fully-qualified portion
  unless (exists $self->{$name})
  {
    die "Can't access `$name' field in object of class $type";
  }
  if (@_)
  {
    return $self->{$name} = shift;
  }
  else
  {
    return $self->{$name};
  }
}

1;
__END__

=head1 NAME

HTMLObject::ReadCookie - Perl extension for HTMLObject.

=head1 SYNOPSIS

  use HTMLObject::ReadCookie;
  my $cookies = HTMLObject::ReadCookie->new;
  my %cookies = $cookies->getCookies;
  
  # print all cookies gathered.
  foreach my $cookie (keys %cookies)
  {
    print "Cookie = '$cookie' has value = '" . $cookies->cookies->{$cookie} . "'\n";
  }
  
  if (exists $cookies->cookies->{'cookie name'})
  {
    print "Cookie 'cookie name' exists!\n";
  }

=head1 DESCRIPTION

The ReadCookie module allows you to check for the existance of cookies
that were set via the HTMLObject set_cookie method.  You can retrieve the
value(s) of any cookie you set and then proceed to work with them as
necessary.  This is much easier to work with than HTMLObject::GetCookie.

=head1 Exported FUNCTIONS

  obj new(void)
    Instantiates an instance of the ReadCookie object.

  scalar decodeString( string => '' )
    un-URI encodes the string and returns it.

  hash getCookies(cookies)
    Takes: 	cookies - array of cookie names or Nothing.
    Returns:	hash of cookies found, empty if none found.

  hash getCompressedCookies(cname, names)
    This takes the compressed cookie name (cname), and optionally the names of
    specific cookies you want returned and uncompresses them, setting the
    values into %cookies.  Specific names of cookies are optional and if
    not specified all cookies found in the compressed cookie will be set.
    Takes -	cname - Name of the compressed cookie to be uncompressed.
                names - Optional array of names of cookies to be returned 
                    from the compressed cookie if you don't want them all.
    Returns:    hash of cookies found, empty if none found.
    
    
  The Global hash %Cookies is now %cookies.  

=head1 AUTHOR

James A. Pattie, htmlobject@pcxperience.com

=head1 SEE ALSO

perl(1), HTMLObject::Base(3), HTMLObject::Normal(3), HTMLObject::FrameSet(3), HTMLObject::WAP(3).

=cut