CGI-PSGI
view release on metacpan or search on metacpan
lib/CGI/PSGI.pm view on Meta::CPAN
120121122123124125126127128129130131132133134135136137138139140141push
(
@header
,
"Window-Target"
,
$target
)
if
$target
;
if
(
$p3p
) {
$p3p
=
join
' '
,
@$p3p
if
ref
(
$p3p
) eq
'ARRAY'
;
push
(
@header
,
"P3P"
,
qq(policyref="/w3c/p3p.xml", CP="$p3p")
);
}
# push all the cookies -- there may be several
if
(
$cookie
) {
my
(
@cookie
) =
ref
(
$cookie
) &&
ref
(
$cookie
) eq
'ARRAY'
? @{
$cookie
} :
$cookie
;
for
(
@cookie
) {
my
$cs
= UNIVERSAL::isa(
$_
,
'CGI::Cookie'
) ?
$_
->as_string :
$_
;
push
(
@header
,
"Set-Cookie"
,
$cs
)
if
$cs
ne
''
;
}
}
# if the user indicates an expiration time, then we need
# both an Expires and a Date header (so that the browser is
# uses OUR clock)
push
(
@header
,
"Expires"
, CGI::expires(
$expires
,
'http'
))
if
$expires
;
push
(
@header
,
"Date"
, CGI::expires(0,
'http'
))
if
$expires
||
$cookie
||
$nph
;
push
(
@header
,
"Pragma"
,
"no-cache"
)
if
$self
->cache();
push
(
@header
,
"Content-Disposition"
,
"attachment; filename=\"$attachment\""
)
if
$attachment
;
lib/CGI/PSGI.pm view on Meta::CPAN
158159160161162163164165166167168169170171172173174175176177178
$url
||=
$self
->self_url;
my
(
@o
);
for
(
@other
) {
tr
/\
"//d; push(@o,split("
=",
$_
,2)); }
unshift
(
@o
,
'-Status'
=>
$status
,
'-Location'
=>
$url
,
'-nph'
=>
$nph
);
unshift
(
@o
,
'-Target'
=>
$target
)
if
$target
;
unshift
(
@o
,
'-Type'
=>
''
);
my
@unescaped
;
unshift
(
@unescaped
,
'-Cookie'
=>
$cookie
)
if
$cookie
;
return
$self
->psgi_header((
map
{
$self
->unescapeHTML(
$_
)}
@o
),
@unescaped
);
}
# The list is auto generated and modified with:
# perl -nle '/^sub (\w+)/ and $sub=$1; \
# /^}\s*$/ and do { print $sub if $code{$sub} =~ /([\%\$]ENV|http\()/; undef $sub };\
# $code{$sub} .= "$_\n" if $sub; \
# /^\s*package [^C]/ and exit' \
# `perldoc -l CGI`
for
my
$method
(qw(
34567891011121314151617181920212223use
strict;
#-----------------------------------------------------------------------------
# make sure module loaded
#-----------------------------------------------------------------------------
BEGIN {use_ok(
'CGI::Cookie'
);}
use
CGI::PSGI;
my
@test_cookie
= (
'foo=123; bar=qwerty; baz=wibble; qux=a1'
,
'foo=123; bar=qwerty; baz=wibble;'
,
'foo=vixen; bar=cow; baz=bitch; qux=politician'
,
'foo=a%20phrase; bar=yes%2C%20a%20phrase; baz=%5Ewibble; qux=%27'
,
);
#-----------------------------------------------------------------------------
42434445464748495051525354555657585960616263646566676869707172737475767778
delete
$ENV
{HTTP_COOKIE};
delete
$ENV
{COOKIE};
# now set a cookie in the environment and try again
my
$env
= {};
$env
->{HTTP_COOKIE} =
$test_cookie
[2];
my
%result
=
$get_cookie
->(
$env
);
ok(eq_set([
keys
%result
], [
qw(foo bar baz qux)
]),
"expected cookies extracted"
);
is(
ref
(
$result
{foo}),
'CGI::Cookie'
,
'Type of objects returned is correct'
);
is(
$result
{foo}->value,
'vixen'
,
"cookie foo is correct"
);
is(
$result
{bar}->value,
'cow'
,
"cookie bar is correct"
);
is(
$result
{baz}->value,
'bitch'
,
"cookie baz is correct"
);
is(
$result
{qux}->value,
'politician'
,
"cookie qux is correct"
);
# Delete that and make sure it goes away
delete
$env
->{HTTP_COOKIE};
%result
=
$get_cookie
->(
$env
);
ok(
keys
%result
== 0,
"No cookies in environment, returns empty list"
);
# try another cookie in the other environment variable thats supposed to work
$env
->{COOKIE} =
$test_cookie
[3];
%result
=
$get_cookie
->(
$env
);
ok(eq_set([
keys
%result
], [
qw(foo bar baz qux)
]),
"expected cookies extracted"
);
is(
ref
(
$result
{foo}),
'CGI::Cookie'
,
'Type of objects returned is correct'
);
is(
$result
{foo}->value,
'a phrase'
,
"cookie foo is correct"
);
is(
$result
{bar}->value,
'yes, a phrase'
,
"cookie bar is correct"
);
is(
$result
{baz}->value,
'^wibble'
,
"cookie baz is correct"
);
is(
$result
{qux}->value,
"'"
,
"cookie qux is correct"
);
}
#-----------------------------------------------------------------------------
# Test raw_fetch
#-----------------------------------------------------------------------------
( run in 0.333 second using v1.01-cache-2.11-cpan-1dc43b0fbd2 )