1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
|
package Dancer2::Core::Cookie;
# ABSTRACT: A cookie representing class
$Dancer2::Core::Cookie::VERSION = '1.1.0';
use Moo;
use URI::Escape;
use Dancer2::Core::Types;
use Dancer2::Core::Time;
use Carp 'croak';
use Ref::Util qw< is_arrayref is_hashref >;
use overload '""' => \&_get_value;
BEGIN {
my $try_xs =
exists($ENV{PERL_HTTP_XSCOOKIES}) ? !!$ENV{PERL_HTTP_XSCOOKIES} :
exists($ENV{PERL_ONLY}) ? !$ENV{PERL_ONLY} :
1;
my $use_xs = 0;
$try_xs and eval {
require HTTP::XSCookies;
$use_xs++;
};
if ( $use_xs ) {
*to_header = \&xs_to_header;
}
else {
*to_header = \&pp_to_header;
}
*_USE_XS = $use_xs ? sub () { !!1 } : sub () { !!0 };
}
sub xs_to_header {
my $self = shift;
# HTTP::XSCookies can't handle multi-value cookies.
return $self->pp_to_header(@_) if @{[ $self->value ]} > 1;
return HTTP::XSCookies::bake_cookie(
$self->name,
{ value => $self->value,
path => $self->path,
domain => $self->domain,
expires => $self->expires,
httponly => $self->http_only,
secure => $self->secure,
samesite => $self->same_site,
}
);
}
sub pp_to_header {
my $self = shift;
my $value = join( '&', map uri_escape($_), $self->value );
my $no_httponly = defined( $self->http_only ) && $self->http_only == 0;
my @headers = $self->name . '=' . $value;
push @headers, "Path=" . $self->path if $self->path;
push @headers, "Expires=" . $self->expires if $self->expires;
push @headers, "Domain=" . $self->domain if $self->domain;
push @headers, "SameSite=" . $self->same_site if $self->same_site;
push @headers, "Secure" if $self->secure;
push @headers, 'HttpOnly' unless $no_httponly;
return join '; ', @headers;
}
has value => (
is => 'rw',
isa => ArrayRef,
required => 0,
coerce => sub {
my $value = shift;
my @values =
is_arrayref($value) ? @$value
: is_hashref($value) ? %$value
: ($value);
return [@values];
},
);
around value => sub {
my $orig = shift;
my $self = shift;
my $array = $orig->( $self, @_ );
return wantarray ? @$array : $array->[0];
};
# this is only for overloading; need a real sub to refer to, as the Moose
# attribute accessor won't be available at that point.
sub _get_value { shift->value }
has name => (
is => 'rw',
isa => Str,
required => 1,
);
has expires => (
is => 'rw',
isa => Str,
required => 0,
coerce => sub {
Dancer2::Core::Time->new( expression => $_[0] )->gmt_string;
},
);
has domain => (
is => 'rw',
isa => Str,
required => 0,
);
has path => (
is => 'rw',
isa => Str,
default => sub {'/'},
predicate => 1,
);
has secure => (
is => 'rw',
isa => Bool,
required => 0,
default => sub {0},
);
has http_only => (
is => 'rw',
isa => Bool,
required => 0,
default => sub {1},
);
has same_site => (
is => 'rw',
isa => Enum[qw[Strict Lax None]],
required => 0,
);
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Dancer2::Core::Cookie - A cookie representing class
=head1 VERSION
version 1.1.0
=head1 SYNOPSIS
use Dancer2::Core::Cookie;
my $cookie = Dancer2::Core::Cookie->new(
name => $cookie_name, value => $cookie_value
);
my $value = $cookie->value;
print "$cookie"; # objects stringify to their value.
=head1 DESCRIPTION
Dancer2::Core::Cookie provides a HTTP cookie object to work with cookies.
=head1 ATTRIBUTES
=head2 value
The cookie's value.
(Note that cookie objects use overloading to stringify to their value, so if
you say e.g. return "Hi, $cookie", you'll get the cookie's value there.)
In list context, returns a list of potentially multiple values; in scalar
context, returns just the first value. (So, if you expect a cookie to have
multiple values, use list context.)
=head2 name
The cookie's name.
=head2 expires
The cookie's expiration date. There are several formats.
Unix epoch time like 1288817656 to mean "Wed, 03-Nov-2010 20:54:16 GMT"
It also supports a human readable offset from the current time such as "2 hours".
See the documentation of L<Dancer2::Core::Time> for details of all supported
formats.
=head2 domain
The cookie's domain.
=head2 path
The cookie's path.
=head2 secure
If true, it instructs the client to only serve the cookie over secure
connections such as https.
=head2 http_only
By default, cookies are created with a property, named C<HttpOnly>,
that can be used for security, forcing the cookie to be used only by
the server (via HTTP) and not by any JavaScript code.
If your cookie is meant to be used by some JavaScript code, set this
attribute to 0.
=head2 same_site
Whether the cookie ought not to be sent along with cross-site requests.
Valid values are C<Strict>, C<Lax>, or C<None>. Default is unset.
Refer to
L<RFC6265bis|https://tools.ietf.org/html/draft-ietf-httpbis-cookie-same-site>
for further details regarding same-site context.
=head1 METHODS
=head2 my $cookie=Dancer2::Core::Cookie->new(%opts);
Create a new Dancer2::Core::Cookie object.
You can set any attribute described in the I<ATTRIBUTES> section above.
=head2 my $header=$cookie->to_header();
Creates a proper HTTP cookie header from the content.
=head1 AUTHOR
Dancer Core Developers
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2023 by Alexis Sukrieh.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
|
