Apache-FakeCookie
view release on metacpan or search on metacpan
Revision history for Perl extension Apache::FakeCookie
0.08 Mon Sep 11 11:39:50 PDT 2006
modify tests to conform to perl 5.0503
0.07 Fri Jan 17 08:56:01 PST 2003
rename to: ApacheFakeCookie
from Apache::Test::CookieEmulator
0.06 Thu Jan 16 18:04:38 PST 2003
Correct documentation errors in POD
0.05 Fri Sep 13 14:33:32 PDT 2002
add complete functionality for 'expires' to
set and return date strings like Apache::Cookie
0.04 Tue Sep 3 11:47:15 PDT 2002
various small bug fixes and documentation updates
0.03 Tue Sep 3 05:36:05 PDT 2002
correct module name in a_cookie.t
0.02 Tue Sep 3 02:00:52 PDT 2002
added method 'parse'
updated to accept non-scalar values
FakeCookie.pm view on Meta::CPAN
package Apache::FakeCookie;
use vars qw($VERSION);
$VERSION = do { my @r = (q$Revision: 0.08 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
# Oh!, we really don't live in this package
package Apache::Cookie;
use vars qw($Cookies);
use strict;
$Cookies = {};
# emluation is fairly complete
# cookies can be created, altered and removed
#
sub fetch { return wantarray ? %{$Cookies} : $Cookies; }
sub path {&do_this;}
sub secure {&do_this;}
sub name {&do_this;}
sub domain {&do_this;}
sub value {
my ($self, $val) = @_;
$self->{-value} = $val if defined $val;
if (defined $self->{-value}) {
return wantarray ? @{$self->{-value}} : $self->{-value}->[0]
} else {
return wantarray ? () : '';
}
}
sub new {
my $proto = shift; # bless into Apache::Cookie
shift; # waste reference to $r;
my @vals = @_;
my $self = {@vals};
my $class = ref($proto) || $proto;
# make sure values are in array format
my $val = $self->{-value};;
if (defined $val) {
$val = $self->{-value};
if (ref($val) eq 'ARRAY') {
@vals = @$val;
FakeCookie.pm view on Meta::CPAN
$self->{-value} = [@vals];
}
$self->{-expires} = _expires($self->{-expires})
if exists $self->{-expires} && defined $self->{-expires};
bless $self, $class;
return $self;
}
sub bake {
my $self = shift;
if ( defined $self->{-value} ) {
$Cookies->{$self->{-name}} = $self;
} else {
delete $Cookies->{$self->{-name}};
}
}
sub parse { # adapted from CGI::Cookie v1.20 by Lincoln Stein
my ($self,$raw_cookie) = @_;
if ($raw_cookie) {
my $class = ref($self) || $self;
my %results;
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
FakeCookie.pm view on Meta::CPAN
@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;
}
sub expires {
my $self = shift;
$self->{-expires} = _expires(shift)
if @_;
return (exists $self->{-expires} &&
defined $self->{-expires})
? $self->{-expires} : undef;
}
# Adapted from CGI::Cookie v1.20 by Lincoln Stein
# This internal routine creates date strings suitable for use in
# cookies and HTTP headers. (They differ, unfortunately.)
# Thanks to Mark Fisher for this.
sub _expires {
my($time) = @_;
my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
# pass through preformatted dates for the sake of expire_calc()
$time = _expire_calc($time);
return $time unless $time =~ /^\d+$/;
my $sc = '-';
my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
$year += 1900;
return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
$WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
}
# Copied directly from CGI::Cookie v1.20 by Lincoln Stein
# This internal routine creates an expires time exactly some number of
# hours from the current time. It incorporates modifications from
# Mark Fisher.
sub _expire_calc {
my($time) = @_;
my(%mult) = ('s'=>1,
'm'=>60,
'h'=>60*60,
'd'=>60*60*24,
'M'=>60*60*24*30,
FakeCookie.pm view on Meta::CPAN
} elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/) {
$offset = ($mult{$2} || 1)*$1;
} else {
return $time;
}
return (time+$offset);
}
sub remove {
my ($self,$name) = @_;
if ($name) {
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}}) {
FakeCookie.pm view on Meta::CPAN
}
# get or set a named item in cookie hash
sub cookie_item {
my($self,$item,$val) = @_;
if ( defined $val ) {
#
# Darn! this modifies a cookie item if user is generating
# a replacement cookie and has not yet "baked" it...
# 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;
FakeCookie.pm view on Meta::CPAN
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
Apache::FakeCookie - fake request object for debugging
=head1 SYNOPSIS
use Apache::FakeCookie;
loads into Apache::Cookie namespace
=head1 DESCRIPTION
This module assists authors of Apache::* modules write test suites that
would use B<Apache::Cookie> without actually having to run and query
a server to test the cookie methods. Loaded in the test script after the
author's target module is loaded, B<Apache::FakeCookie>
Usage is the same as B<Apache::Cookie>
=head1 METHODS
Implements all methods of Apache::Cookie
See man Apache::Cookie for details of usage.
=over 4
=item remove -- new method
Delete the given named cookie or the cookie represented by the pointer
$cookie->remove;
Apache::Cookie->remove('name required');
$cookie->remove('some name');
for test purposes, same as:
$cookie = Apache::Cookie->new($r,
-name => 'some name',
);
$cookie->bake;
=item new
$cookie = Apache::Cookie->new($r,
-name => 'some name',
-value => 'my value',
-expires => 'time or relative time,
-path => 'some path',
-domain => 'some.domain',
-secure => 1,
);
The B<Apache> request object, B<$r>, is not used and may be undef.
=item bake
Store the cookie in local memory.
$cookie->bake;
=item fetch
Return cookie values from local memory
$cookies = Apache::Cookie->fetch; # hash ref
%cookies = Apache::Cookie->fetch;
=item as_string
Format the cookie object as a string,
same as Apache::Cookie
=item parse
The same as fetch unless a cookie string is present.
$cookies = Apache::Cookie->fetch(raw cookie string);
%cookies = Apache::Cookie->fetch(raw cookie string)
Cookie memory is cleared and replaced with the contents
of the parsed "raw cookie string".
=item name, value, domain, path, secure
Get or set the value of the designated cookie.
These are all just text strings for test use,
"value" accepts SCALARS, HASHrefs, ARRAYrefs
=item expires
Sets or returns time in the same format as Apache::Cookie
and CGI::Cookie. See their man pages for details
=back
=head1 SEE ALSO
Apache::Cookie(3)
=head1 AUTHORS
Michael Robinton michael@bizsystems.com
Inspiration and code for subs (expires, expires_calc, parse)
from CGI::Util by Lincoln Stein
=head1 COPYRIGHT and LICENSE
Copyright 2003 Michael Robinton, BizSystems.
Changes
ARTISTIC
GPL
MANIFEST
Makefile.PL
FakeCookie.pm
t/a_cookie.t
META.yml Module meta-data (added by MakeMaker)
# http://module-build.sourceforge.net/META-spec.html
#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
name: Apache-FakeCookie
version: 0.08
version_from: FakeCookie.pm
installdirs: site
requires:
distribution_type: module
generated_by: ExtUtils::MakeMaker version 6.30
Makefile.PL view on Meta::CPAN
use ExtUtils::MakeMaker;
# See lib/ExtUtils/MakeMaker.pm for details of how to influence
# the contents of the Makefile that is written.
WriteMakefile(
'NAME' => 'Apache::FakeCookie',
'VERSION_FROM' => 'FakeCookie.pm', # finds $VERSION
'dist' => {COMPRESS=>'gzip', SUFFIX=>'gz'}
);
t/a_cookie.t view on Meta::CPAN
# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl test.pl'
use diagnostics;
######################### We start with some black magic to print on failure.
# Change 1..1 below to 1..last_test_to_print .
# (It may become useful if the test is moved to ./t subdirectory.)
BEGIN { $| = 1; print "1..47\n"; }
END {print "not ok 1\n" unless $loaded;}
use Apache::FakeCookie;
$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
}
} else {
@vals = ($val);
}
$cookie->{-value} = [@vals];
return $cookie;
}
# input is pointer to cookie hash or array
sub cook2text { # inspired by CGI::Cookie, Lincoln D. Stein.
my $cp = shift;
return '' unless $cp->{-name};
my @constant_values;
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}))
t/a_cookie.t view on Meta::CPAN
my $fake = fake_cookie(%testcookie);
my $expected = cook2text(\%testcookie);
print "internal test implementation failed
fake: $_
ne
cook: $expected\nnot "
unless $expected eq ($_ = cook2text($fake));
&ok;
## test 3 check cookie generation
my $cookie = Apache::Cookie->new($r,%testcookie);
print "failed to create cookie,
results: $_
ne
expected: $expected\nnot "
unless $expected eq ($_ = cook2text($cookie));
&ok;
## test 4 check as_string
print "as_string failure:
results: $_
ne
expected: $expected\nnot "
unless $expected eq ($_ = $cookie->as_string);
&ok;
## test 5 fetch should fail
my $cookies = Apache::Cookie->fetch;
print "found unwanted cookies\nnot "
if scalar %$cookies;
&ok;
## test 6 insert cookie and check value
$cookie->bake;
my %cookies = Apache::Cookie->fetch;
my $count = 0;
foreach (keys %cookies) {
++$count;
check_cook($_,$cookies{$_});
}
## test 7 count should be one
print "bad cookie count $count\nnot "
unless $count == 1;
&ok;
## test 8 - 10 add and check all cookies
my @cooks = keys %{$finder};
foreach(@cooks) {
my $cookie = Apache::Cookie->new($r,%{$finder->{$_}});
$cookie->bake;
}
# one of the cookies was a duplicate
# also check that "parse" is a stand in for "fetch"
%cookies = Apache::Cookie->parse;
$count = 0;
foreach (keys %cookies) {
++$count;
check_cook($_,$cookies{$_});
}
## test 11 3 cookies
print "bad cookie count $count\nnot "
unless $count == @cooks;
&ok;
## test 12 - 13 delete a cookie with bake
$cookie = Apache::Cookie->new($r,%tcd);
$cookie->bake;
%cookies = Apache::Cookie->fetch;
$count = 0;
foreach (keys %cookies) {
++$count;
check_cook($_,$cookies{$_});
}
## test 14 2 cookies
print "bad cookie count $count\nnot "
unless $count == @cooks -1;
&ok;
## test 15 - 16 remaining cookies should be...
foreach my $x (qw(tc2 tc3)) {
check_cook($x,$cookies{$x});
}
## test 17 remove a cookie directly, use hash pointer
$cookies{tc2}->remove;
$cookies = Apache::Cookie->fetch;
$count = 0;
foreach (keys %$cookies) {
++$count;
check_cook($_,$cookies->{$_});
}
## test 18 1 cookie left
print "bad cookie count $count\nnot "
unless $count == 1;
&ok;
## test 19 - 21 add and check all cookies
foreach(keys %$finder) {
my $cookie = Apache::Cookie->new($r,%{$finder->{$_}});
$cookie->bake;
}
$cookies = Apache::Cookie->fetch;
$count = 0;
foreach (keys %$cookies) {
++$count;
check_cook($_,$cookies->{$_});
}
## test 22 should be 3 cookies
print "bad cookie count $count\nnot "
unless $count == 3;
&ok;
## test 23 remove by name
$cookies->{tc2}->remove('testcookie');
$cookies->{tc2}->remove('tc3');
$cookies = Apache::Cookie->fetch;
$count = 0;
foreach (keys %$cookies) {
++$count;
check_cook($_,$cookies->{$_});
}
## test 24 1 cookie left
print "bad cookie count $count\nnot "
unless $count == 1;
&ok;
t/a_cookie.t view on Meta::CPAN
}
}
&ok;
# trailing action
$_ = [reverse @keys];
$cookies->{tc2}->value($_);
## test 37 change the name
$cookies->{tc2}->name('newname');
$cookies = Apache::Cookie->fetch;
print "failed to change name\nnot "
if exists $cookies->{tc2};
&ok;
## test 38 - 40 recheck under new name, should work
pop @keys; # remove 'expires'
$count = $start;
foreach(@keys) {
my $rv = eval "\$cookies->{newname}->$_";
print "results: $rv\n ne\nexpected: ",$start,"\nnot "
t/a_cookie.t view on Meta::CPAN
my %hash = $cookies->{newname}->value;
foreach(my $i=0; $i<=$#keys; $i+=2) {
unless ($keys[$i] eq $hash{$keys[$i+1]}) {
print "value hash not stored\nnot ";
last;
}
}
&ok;
## test 43 - 44 check that parse can handle a new cookie string
my $cook1 = 'Cookie1=foo&bar&stuff&more';
my $cook2 = 'Cookie2=some%40email.com' ;
my %cook1 = (
-name => 'Cookie1',
-value => [qw( foo bar stuff more)],
);
my %cook2 = (
-name => 'Cookie2',
-value => ['some@email.com'],
);
$finder->{Cookie1} = \%cook1;
$finder->{Cookie2} = \%cook2;
$cookies = Apache::Cookie->parse($cook1 .'; '. $cook2);
$count = 0;
foreach $_ (keys %{$cookies}) {
check_cook($_, $cookies->{$_});
++$count;
}
## test 45 count should be two
print "bad cookie count $count\nnot "
unless $count == 2;
&ok;
( run in 0.407 second using v1.01-cache-2.11-cpan-e9199f4ba4c )