Apache-FakeCookie

 view release on metacpan or  search on metacpan

FakeCookie.pm  view on Meta::CPAN

    my(@pairs) = split("; ?",$raw_cookie);
    foreach (@pairs) {
      s/\s*(.*?)\s*/$1/;
      my($key,$value) = split("=",$_,2);
    # Some foreign cookies are not in name=value format, so ignore
    # them.
      next if !defined($value);
      my @values = ();
      if ($value ne '') {
        @values = map unescape($_),split(/[&;]/,$value.'&dmy');
        pop @values;
      }
      $key = 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(undef,-name=>$key,-value=>\@values);
    }
    $self = \%results;
    bless $self, $class;
    $Cookies = $self;
  }
  @_ = ($self);
  goto &fetch;

FakeCookie.pm  view on Meta::CPAN

    delete $Cookies->{$name} if exists $Cookies->{$name};
  } else {
    delete $Cookies->{$self->{-name}}
	if exists $Cookies->{$self->{-name}};
  }
}
sub as_string {
  my $self = shift;
  return '' unless $self->name;
  my %cook = %$self;
  my $cook = ($cook{-name}) ? escape($cook{-name}) . '=' : '';
  if ($cook{-value}) {
    my $i = '';
    foreach(@{$cook{-value}}) {
      $cook .= $i . escape($_);
      $i = '&'; 
    }
  }  
  foreach(qw(domain path)) {
    $cook .= "; $_=" . $cook{"-$_"} if $cook{"-$_"};
  }
  $cook .= "; expires=$_" if ($_ = expires(\%cook));
  $cook .= ($cook{-secure}) ? '; secure' : '';
}

FakeCookie.pm  view on Meta::CPAN

# Don't see how this can hurt in the real world...  MAR 9-2-02
    if ( $item eq '-name' &&
	 exists $Cookies->{$self->{-name}} ) {
      $Cookies->{$val} = $Cookies->{$self->{-name}};
      delete  $Cookies->{$self->{-name}};
    }
    $self->{$item} = $val;
  }
  return (exists $self->{$item}) ? $self->{$item} : '';
}
sub escape {
  my ($x) = @_;
  return undef unless defined($x);
  $x =~ s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
  return $x;
}
# unescape URL-data, but leave +'s alone
sub unescape {  
  my ($x) = @_;
  return undef unless defined($x);
  $x =~ tr/+/ /;       # pluses become spaces
  $x =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge;
  return $x;
}
1
__END__

=head1 NAME

t/a_cookie.t  view on Meta::CPAN

$loaded = 1;
print "ok 1\n";
######################### End of black magic.

# Insert your test code below (better if it prints "ok 13"
# (correspondingly "not ok 13") depending on the success of chunk 13
# of the test code):

$test = 2;

*escape = \&Apache::Cookie::escape;

sub ok {
  print "ok $test\n";
  ++$test;
}

sub next_sec {
  my ($then) = @_;
  $then = time unless $then;
  my $now;

t/a_cookie.t  view on Meta::CPAN

  push(@constant_values,'domain='.$cp->{-domain})
	if exists $cp->{-domain} && defined $cp->{-domain};
  push(@constant_values,'path='.$cp->{-path})
	if exists $cp->{-path} && defined $cp->{-path};
  push(@constant_values,'expires='. &cook_time($cp->{-expires}))
	if exists $cp->{-expires} && defined $cp->{-expires};
  push(@constant_values,'secure') 
	if exists $cp->{-secure} && $cp->{-secure};

  my($key) = escape($cp->{-name});
  my($cookie) = (exists $cp->{-value} && defined $cp->{-value})
	? join("=",$key,join("&",map escape($_),@{$cp->{-value}}))
	: '';
  return join("; ",$cookie,@constant_values);
}

my $r = undef;			# never used

### cookie tests

my %testcookie = (
	-name	=> "testcookie",