use
version;
our
$VERSION
= qv(
sprintf
'0.5.%d'
,
q$Rev: 1139 $
=~ /\d+/gmx );
sub
delete_cookie {
my
(
$self
,
$c
,
$args
) =
@_
;
my
$name
=
$args
->{name} or
return
;
my
$key
=
$args
->{key } or
return
;
my
$cookie
=
$c
->req->cookie(
$name
) or
return
;
my
$pairs
= NUL;
for
(__get_pairs_for(
$cookie
,
$name
)) {
m{ \A
$key
~ }mx and
next
;
$pairs
and
$pairs
.=
q(+)
;
$pairs
.=
$_
;
}
$c
->res->cookies->{
$name
} = {
value
=>
$pairs
};
return
;
}
sub
get_browser_state {
my
(
$self
,
$c
,
$name
) =
@_
;
my
$cfg
=
$c
->config;
my
$res
= {};
my
$args
= {
name
=>
$name
,
key
=>
q(debug)
};
my
$debug
=
$self
->get_cookie(
$c
,
$args
);
$res
->{debug } =
$debug
&&
$debug
eq
q(true)
? TRUE : FALSE;
$args
->{key } =
q(footer)
;
$res
->{fstate } =
$self
->get_cookie(
$c
,
$args
) eq
q(true)
? TRUE : FALSE;
$args
->{key } =
q(language)
;
$res
->{lang } =
$self
->get_cookie(
$c
,
$args
);
$args
->{key } =
q(sidebar)
;
$res
->{sbstate} =
$self
->get_cookie(
$c
,
$args
) ? TRUE : FALSE;
$args
->{key } =
q(skin)
;
my
$skin
;
$skin
=
$self
->get_cookie(
$c
,
$args
)
and -d
$self
->catdir(
$cfg
->{skindir},
$skin
)
and
$res
->{skin} =
$skin
;
$args
->{key} =
q(width)
;
my
$width
;
$width
=
$self
->get_cookie(
$c
,
$args
)
and
$res
->{width} =
$width
;
return
$res
;
}
sub
get_cookie {
my
(
$self
,
$c
,
$args
) =
@_
;
my
$name
=
$args
->{name} or
return
NUL;
my
$key
=
$args
->{key } or
return
NUL;
my
$cookie
=
$c
->req->cookie(
$name
) or
return
NUL;
for
(__get_pairs_for(
$cookie
,
$name
)) {
m{ \A
$key
~ }msx and
return
(
split
m{ ~ }mx,
$_
)[1];
}
return
NUL;
}
sub
set_cookie {
my
(
$self
,
$c
,
$args
) =
@_
;
my
$value
=
$args
->{value};
my
$name
=
$args
->{name } or
return
;
my
$key
=
$args
->{key } or
return
;
$key
.=
q(~)
;
my
$cookie
=
$c
->req->cookie(
$name
) || NUL;
my
$found
= FALSE;
my
$pairs
= NUL;
for
(__get_pairs_for(
$cookie
,
$name
)) {
$pairs
and
$pairs
.=
q(+)
;
if
(m{ \A
$key
}mx) {
$pairs
.=
$key
.
$value
;
$found
= TRUE }
else
{
$pairs
.=
$_
}
}
unless
(
$found
) {
$pairs
and
$pairs
.=
q(+)
;
$pairs
.=
$key
.
$value
}
$c
->res->cookies->{
$name
} = {
value
=>
$pairs
};
return
;
}
sub
__get_pairs_for {
my
(
$cookie
,
$name
) =
@_
;
my
$pairs
= (
grep
{ m{ \A
$name
= }msx }
map
{ s{ \s+ }{}gmx;
$_
}
split
m{ ; }mx,
$cookie
|| NUL)[0] or
return
NUL;
my
$v
= (
split
m{ = }mx,
$pairs
)[1] || NUL;
$v
=~ s{ % ([0-9A-Fa-f]{2}) }{
chr
(
hex
($1))}egmsx;
return
split
m{ \+ }mx,
$v
;
}
1;