line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
#=============================================================================== |
2
|
|
|
|
|
|
|
# |
3
|
|
|
|
|
|
|
# DESCRIPTION: controller |
4
|
|
|
|
|
|
|
# |
5
|
|
|
|
|
|
|
# AUTHOR: Aliaksandr P. Zahatski, <zag@cpan.org> |
6
|
|
|
|
|
|
|
#=============================================================================== |
7
|
|
|
|
|
|
|
package WebDAO::CV; |
8
|
|
|
|
|
|
|
our $VERSION = '0.03'; |
9
|
5
|
|
|
5
|
|
3553
|
use URI; |
|
5
|
|
|
|
|
19827
|
|
|
5
|
|
|
|
|
139
|
|
10
|
5
|
|
|
5
|
|
718
|
use Data::Dumper; |
|
5
|
|
|
|
|
6982
|
|
|
5
|
|
|
|
|
266
|
|
11
|
5
|
|
|
5
|
|
35
|
use strict; |
|
5
|
|
|
|
|
9
|
|
|
5
|
|
|
|
|
92
|
|
12
|
5
|
|
|
5
|
|
23
|
use warnings; |
|
5
|
|
|
|
|
10
|
|
|
5
|
|
|
|
|
114
|
|
13
|
5
|
|
|
5
|
|
2228
|
use HTTP::Body; |
|
5
|
|
|
|
|
180029
|
|
|
5
|
|
|
|
|
146
|
|
14
|
5
|
|
|
5
|
|
601
|
use WebDAO::Base; |
|
5
|
|
|
|
|
13
|
|
|
5
|
|
|
|
|
313
|
|
15
|
5
|
|
|
5
|
|
1554
|
use WebDAO::Util; |
|
5
|
|
|
|
|
40
|
|
|
5
|
|
|
|
|
156
|
|
16
|
5
|
|
|
5
|
|
34
|
use base qw( WebDAO::Base ); |
|
5
|
|
|
|
|
11
|
|
|
5
|
|
|
|
|
6902
|
|
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
__PACKAGE__->mk_attr(status=>200, _parsed_cookies=>undef); |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
sub new { |
21
|
14
|
|
|
14
|
1
|
3883
|
my $class = shift; |
22
|
14
|
50
|
33
|
|
|
118
|
my $self = bless( ( $#_ == 0 ) ? shift : {@_}, ref($class) || $class ); |
23
|
14
|
|
|
|
|
69
|
$self->{headers} = {}; |
24
|
14
|
|
|
|
|
155
|
$self |
25
|
|
|
|
|
|
|
} |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
=head2 url (-options1=>1) |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
from url: http://testwd.zag:82/Envs/partsh.sd?23=23 |
30
|
|
|
|
|
|
|
where options: |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
-path_info -> /Envs/partsh.sd |
33
|
|
|
|
|
|
|
-base -> http://example.com:82 |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
defaul http://testwd.zag:82/Envs/partsh.sd?23=23 |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
=cut |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
sub url { |
40
|
20
|
|
|
20
|
1
|
1057
|
my $self = shift; |
41
|
20
|
|
|
|
|
55
|
my %args = @_; |
42
|
20
|
|
|
|
|
39
|
my $env = $self->{env}; |
43
|
|
|
|
|
|
|
|
44
|
20
|
100
|
|
|
|
58
|
if ( exists $env->{FCGI_ROLE} ) { |
45
|
|
|
|
|
|
|
( $env->{PATH_INFO}, $env->{QUERY_STRING} ) = |
46
|
4
|
|
|
|
|
25
|
$env->{REQUEST_URI} =~ /([^?]*)(?:\?(.*)$)?/s; |
47
|
|
|
|
|
|
|
} |
48
|
20
|
|
100
|
|
|
81
|
my $path = $env->{PATH_INFO} || ''; # 'PATH_INFO' => '/Env' |
49
|
20
|
|
100
|
|
|
71
|
my $host = $env->{HTTP_HOST} || 'example.org'; # 'HTTP_HOST' => '127.0.0.1:5000' |
50
|
20
|
|
100
|
|
|
66
|
my $query = $env->{QUERY_STRING}|| ''; # 'QUERY_STRING' => '434=34&erer=2' |
51
|
20
|
|
50
|
|
|
73
|
my $proto = $env->{'psgi.url_scheme'} || 'http'; |
52
|
20
|
|
|
|
|
50
|
my $full_path = "$proto://${host}${path}?$query"; |
53
|
|
|
|
|
|
|
#clear / at end |
54
|
20
|
100
|
|
|
|
64
|
$full_path =~ s!/$!! if $path =~ m!^/!; |
55
|
20
|
|
|
|
|
83
|
my $uri = URI->new($full_path); |
56
|
|
|
|
|
|
|
|
57
|
20
|
100
|
|
|
|
29557
|
if ( exists $args{-path_info} ) { |
|
|
100
|
|
|
|
|
|
58
|
5
|
|
|
|
|
30
|
return $uri->path(); |
59
|
|
|
|
|
|
|
} |
60
|
|
|
|
|
|
|
elsif ( exists $args{-base} ) { |
61
|
9
|
|
|
|
|
93
|
return "$proto://$host"; |
62
|
|
|
|
|
|
|
} |
63
|
6
|
|
|
|
|
27
|
return URI->new($full_path)->canonical; |
64
|
|
|
|
|
|
|
} |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
=head2 method - HTTP method |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
retrun HTTP method |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
=cut |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
sub method { |
73
|
1
|
|
|
1
|
1
|
886
|
my $self = shift; |
74
|
1
|
50
|
|
|
|
7
|
$self->{env}->{REQUEST_METHOD} || "GET"; |
75
|
|
|
|
|
|
|
} |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
=head2 accept |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
return hashref |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
{ |
82
|
|
|
|
|
|
|
'application/xhtml+xml' => undef, |
83
|
|
|
|
|
|
|
'application/xml' => undef, |
84
|
|
|
|
|
|
|
'text/html' => undef |
85
|
|
|
|
|
|
|
}; |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
=cut |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
sub accept { |
90
|
5
|
|
|
5
|
1
|
12
|
my $self = shift; |
91
|
5
|
|
100
|
|
|
151
|
my $accept = $self->{env}->{HTTP_ACCEPT} || return {}; |
92
|
1
|
|
|
|
|
4
|
my ($types) = split( ';', $accept ); |
93
|
1
|
|
|
|
|
3
|
my %res; |
94
|
1
|
|
|
|
|
4
|
@res{ split( ',', $types ) } = (); |
95
|
1
|
|
|
|
|
7
|
\%res; |
96
|
|
|
|
|
|
|
} |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
=head2 param - return GET and POST params |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
return params |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
=cut |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
sub param { |
105
|
9
|
|
|
9
|
1
|
23
|
my $self = shift; |
106
|
9
|
|
|
|
|
16
|
my $params = $self->{parsed_params}; |
107
|
9
|
100
|
|
|
|
27
|
unless ($params) { |
108
|
|
|
|
|
|
|
#init by POST params |
109
|
5
|
|
|
|
|
32
|
$params = $self->_parse_body; |
110
|
5
|
|
|
|
|
17
|
my @get_params = $self->url()->query_form; |
111
|
5
|
|
|
|
|
1247
|
while (my ($k, $v) = splice(@get_params,0,2 )) { |
112
|
1
|
50
|
|
|
|
3
|
unless ( exists $params->{ $k } ) { |
113
|
1
|
|
|
|
|
5
|
$params->{ $k } = $v |
114
|
|
|
|
|
|
|
} else { |
115
|
0
|
|
|
|
|
0
|
my $val = $params->{ $k }; |
116
|
|
|
|
|
|
|
#if array ? |
117
|
0
|
0
|
|
|
|
0
|
if ( ref $val ) { |
118
|
0
|
|
|
|
|
0
|
push @$val, $v |
119
|
|
|
|
|
|
|
} else { |
120
|
0
|
0
|
|
|
|
0
|
$params->{ $k } = [$val, ref($v) ? @$v : $v] |
121
|
|
|
|
|
|
|
} |
122
|
|
|
|
|
|
|
} |
123
|
|
|
|
|
|
|
} |
124
|
5
|
|
|
|
|
16
|
$self->{parsed_params} = $params; |
125
|
|
|
|
|
|
|
} |
126
|
9
|
100
|
|
|
|
45
|
return keys %$params unless @_; |
127
|
1
|
50
|
|
|
|
4
|
return undef unless exists $params->{$_[0]}; |
128
|
1
|
|
|
|
|
3
|
my $res = $params->{$_[0]}; |
129
|
1
|
50
|
|
|
|
6
|
if ( ref($res) ) { |
130
|
0
|
0
|
|
|
|
0
|
return wantarray ? @$res : $res->[0] |
131
|
|
|
|
|
|
|
} |
132
|
1
|
|
|
|
|
6
|
return $res; |
133
|
|
|
|
|
|
|
} |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
#parse body |
136
|
|
|
|
|
|
|
sub _parse_body { |
137
|
5
|
|
|
5
|
|
11
|
my $self = shift; |
138
|
|
|
|
|
|
|
|
139
|
5
|
|
|
|
|
13
|
my $content_type = $self->{env}->{CONTENT_TYPE}; |
140
|
5
|
|
|
|
|
12
|
my $content_length = $self->{env}->{CONTENT_LENGTH}; |
141
|
5
|
50
|
33
|
|
|
33
|
if (!$content_type && !$content_length) { |
142
|
5
|
|
|
|
|
15
|
return {}; |
143
|
|
|
|
|
|
|
} |
144
|
|
|
|
|
|
|
|
145
|
0
|
|
|
|
|
0
|
my $body = HTTP::Body->new($content_type, $content_length); |
146
|
0
|
|
|
|
|
0
|
$body->cleanup(1); |
147
|
|
|
|
|
|
|
|
148
|
0
|
|
|
|
|
0
|
my $input = $self->{env}->{'psgi.input'}; |
149
|
0
|
0
|
|
|
|
0
|
if ( $input ) { |
150
|
|
|
|
|
|
|
#reset IO |
151
|
0
|
|
|
|
|
0
|
$input->seek(0,0); |
152
|
|
|
|
|
|
|
} |
153
|
|
|
|
|
|
|
else { |
154
|
|
|
|
|
|
|
# for FCGI, Shell |
155
|
0
|
|
|
|
|
0
|
$input = \*STDIN |
156
|
|
|
|
|
|
|
} |
157
|
0
|
|
|
|
|
0
|
my $spin = 0; |
158
|
|
|
|
|
|
|
|
159
|
0
|
|
|
|
|
0
|
while ($content_length) { |
160
|
0
|
0
|
|
|
|
0
|
$input->read(my $chunk, $content_length < 8192 ? $content_length : 8192); |
161
|
0
|
|
|
|
|
0
|
my $read = length $chunk; |
162
|
0
|
|
|
|
|
0
|
$content_length -= $read; |
163
|
0
|
|
|
|
|
0
|
$body->add($chunk); |
164
|
0
|
0
|
0
|
|
|
0
|
if ($read == 0 && $spin++ > 2000) { |
165
|
0
|
|
|
|
|
0
|
Carp::croak "Bad Content-Length: maybe client disconnect? ($content_length bytes remaining)"; |
166
|
|
|
|
|
|
|
} |
167
|
|
|
|
|
|
|
} |
168
|
0
|
|
|
|
|
0
|
$self->{'http.body'} = $body; |
169
|
0
|
|
|
|
|
0
|
return $body->param |
170
|
|
|
|
|
|
|
} |
171
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
=head2 body - HTTP body file descriptor ( see get-body for get content) |
173
|
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
Return HTTP body file descriptor |
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
my $body; |
177
|
|
|
|
|
|
|
{ |
178
|
|
|
|
|
|
|
local $/; |
179
|
|
|
|
|
|
|
my $fd = $request->body; |
180
|
|
|
|
|
|
|
$body = <$fd>; |
181
|
|
|
|
|
|
|
} |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
=cut |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
sub body { |
186
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
187
|
0
|
0
|
|
|
|
0
|
unless ( exists $self->{'http.body'} ) { |
188
|
0
|
|
|
|
|
0
|
$self->_parse_body(); |
189
|
|
|
|
|
|
|
} |
190
|
|
|
|
|
|
|
|
191
|
0
|
|
0
|
|
|
0
|
my $http_body = $self->{'http.body'} || return undef; |
192
|
0
|
|
|
|
|
0
|
return $http_body->body; |
193
|
|
|
|
|
|
|
} |
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
=head2 get-body - HTTP body content |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
Return HTTP body text |
198
|
|
|
|
|
|
|
|
199
|
|
|
|
|
|
|
my $body= $r->get_body; |
200
|
|
|
|
|
|
|
|
201
|
|
|
|
|
|
|
=cut |
202
|
|
|
|
|
|
|
|
203
|
|
|
|
|
|
|
sub get_body { |
204
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
205
|
0
|
|
|
|
|
0
|
my $body; |
206
|
|
|
|
|
|
|
{ |
207
|
0
|
|
|
|
|
0
|
local $/; |
|
0
|
|
|
|
|
0
|
|
208
|
0
|
0
|
|
|
|
0
|
if ( my $fd = $self->body ) { |
209
|
0
|
|
|
|
|
0
|
$body = <$fd> |
210
|
|
|
|
|
|
|
} |
211
|
|
|
|
|
|
|
} |
212
|
0
|
|
|
|
|
0
|
return $body |
213
|
|
|
|
|
|
|
} |
214
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
=head2 upload - return upload content |
217
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
print Dumper $request->upload; |
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
For command: |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
curl -i -X POST -H "Content-Type: multipart/form-data"\ |
223
|
|
|
|
|
|
|
-F "data=@UserSettings.txt"\ |
224
|
|
|
|
|
|
|
http://example.org/Upload |
225
|
|
|
|
|
|
|
|
226
|
|
|
|
|
|
|
output: |
227
|
|
|
|
|
|
|
|
228
|
|
|
|
|
|
|
{ |
229
|
|
|
|
|
|
|
'data' => { |
230
|
|
|
|
|
|
|
'headers' => { |
231
|
|
|
|
|
|
|
'Content-Type' => 'text/plain', |
232
|
|
|
|
|
|
|
'Content-Disposition' => 'form-data; name="data"; filename="UserSettings.txt"' |
233
|
|
|
|
|
|
|
}, |
234
|
|
|
|
|
|
|
'tempname' => '/tmp/txBmaz5Bpf.txt', |
235
|
|
|
|
|
|
|
'size' => 6704, |
236
|
|
|
|
|
|
|
'filename' => 'UserSettings.txt', |
237
|
|
|
|
|
|
|
'name' => 'data' |
238
|
|
|
|
|
|
|
} |
239
|
|
|
|
|
|
|
}; |
240
|
|
|
|
|
|
|
|
241
|
|
|
|
|
|
|
=cut |
242
|
|
|
|
|
|
|
|
243
|
|
|
|
|
|
|
sub upload { |
244
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
245
|
0
|
0
|
|
|
|
0
|
unless ( exists $self->{'http.body'} ) { |
246
|
0
|
|
|
|
|
0
|
$self->_parse_body(); |
247
|
|
|
|
|
|
|
} |
248
|
|
|
|
|
|
|
|
249
|
0
|
|
0
|
|
|
0
|
my $http_body = $self->{'http.body'} || return {}; |
250
|
0
|
|
|
|
|
0
|
return $http_body->upload; |
251
|
|
|
|
|
|
|
} |
252
|
|
|
|
|
|
|
|
253
|
|
|
|
|
|
|
=head2 set_header |
254
|
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
$cv->set_header("Content-Type" => 'text/html; charset=utf-8') |
256
|
|
|
|
|
|
|
|
257
|
|
|
|
|
|
|
=cut |
258
|
|
|
|
|
|
|
|
259
|
|
|
|
|
|
|
sub set_header { |
260
|
5
|
|
|
5
|
1
|
18
|
my ( $self, $name, $par ) = @_; |
261
|
|
|
|
|
|
|
|
262
|
|
|
|
|
|
|
#collect -cookies |
263
|
5
|
50
|
|
|
|
20
|
if ( $name eq 'Set-Cookie' ) { |
264
|
0
|
|
|
|
|
0
|
push @{ $self->{headers}->{$name} }, $par; |
|
0
|
|
|
|
|
0
|
|
265
|
|
|
|
|
|
|
} |
266
|
|
|
|
|
|
|
else { |
267
|
5
|
|
|
|
|
24
|
$self->{headers}->{$name} = $par; |
268
|
|
|
|
|
|
|
} |
269
|
|
|
|
|
|
|
} |
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
=head3 print_headers [ header1=>value, ...] |
272
|
|
|
|
|
|
|
|
273
|
|
|
|
|
|
|
Method for output headers |
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
$self->response->get_request->set_header( |
276
|
|
|
|
|
|
|
'Set-Cookie', |
277
|
|
|
|
|
|
|
{ |
278
|
|
|
|
|
|
|
path => '/', |
279
|
|
|
|
|
|
|
domain => '.example.com', |
280
|
|
|
|
|
|
|
name => 'userid', |
281
|
|
|
|
|
|
|
value => $self->_current_user->id, |
282
|
|
|
|
|
|
|
expires => time() + 60 * 60 * 24 * 1, # 1 day |
283
|
|
|
|
|
|
|
secure => 1, |
284
|
|
|
|
|
|
|
httpOnly = >1 |
285
|
|
|
|
|
|
|
|
286
|
|
|
|
|
|
|
} |
287
|
|
|
|
|
|
|
); |
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
=cut |
290
|
|
|
|
|
|
|
|
291
|
|
|
|
|
|
|
sub print_headers { |
292
|
5
|
|
|
5
|
1
|
10
|
my $self = shift; |
293
|
|
|
|
|
|
|
#save cookie |
294
|
5
|
|
|
|
|
8
|
my $cookie = delete $self->{headers}->{"Set-Cookie"}; |
295
|
|
|
|
|
|
|
#merge in and exists headers |
296
|
5
|
|
|
|
|
9
|
my %headers = ( %{ $self->{headers} } , @_ ); |
|
5
|
|
|
|
|
16
|
|
297
|
|
|
|
|
|
|
#merge cookies |
298
|
5
|
50
|
|
|
|
15
|
if ( $cookie ) { |
299
|
0
|
|
|
|
|
0
|
push @{ $headers{"Set-Cookie"} }, @$cookie; |
|
0
|
|
|
|
|
0
|
|
300
|
|
|
|
|
|
|
} |
301
|
5
|
|
|
|
|
9
|
my @cookies_headers = (); |
302
|
|
|
|
|
|
|
#format cookies |
303
|
5
|
100
|
|
|
|
21
|
if ( my $cookies = delete $headers{"Set-Cookie"} ) { |
304
|
2
|
|
|
|
|
4
|
foreach my $c ( @$cookies ) { |
305
|
3
|
|
|
|
|
4
|
my $hvalue; |
306
|
3
|
50
|
|
|
|
7
|
if (ref($c) eq 'HASH') { |
307
|
|
|
|
|
|
|
# Set-Cookie: srote=ewe&1&1&2; path=$path |
308
|
3
|
|
|
|
|
9
|
$hvalue = "$c->{name}=$c->{value}"; |
309
|
3
|
|
50
|
|
|
23
|
my $path = $c->{path} || '/'; |
310
|
3
|
|
|
|
|
5
|
$hvalue .="; path=$path"; |
311
|
3
|
50
|
|
|
|
7
|
if ( my $domain = $c->{domain} ) { |
312
|
0
|
|
|
|
|
0
|
$hvalue .= "; domain=$domain" |
313
|
|
|
|
|
|
|
} |
314
|
3
|
100
|
|
|
|
7
|
if (my $expires = $c->{expires}) { |
315
|
2
|
|
|
|
|
14
|
$expires = WebDAO::Util::expire_calc($expires); |
316
|
2
|
|
|
|
|
9
|
my @MON = qw( Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec ); |
317
|
2
|
|
|
|
|
7
|
my @WDAY = qw( Sun Mon Tue Wed Thu Fri Sat ); |
318
|
2
|
|
|
|
|
13
|
my($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($expires); |
319
|
2
|
|
|
|
|
7
|
$year += 1900; |
320
|
2
|
|
|
|
|
14
|
$expires = sprintf("%s, %02d-%s-%04d %02d:%02d:%02d GMT", |
321
|
|
|
|
|
|
|
$WDAY[$wday], $mday, $MON[$mon], $year, $hour, $min, $sec); |
322
|
2
|
|
|
|
|
9
|
$hvalue .="; expires=$expires"; |
323
|
|
|
|
|
|
|
} |
324
|
3
|
100
|
|
|
|
8
|
if ( $c->{ secure } ) { |
325
|
1
|
|
|
|
|
2
|
$hvalue .= "; secure" |
326
|
|
|
|
|
|
|
} |
327
|
3
|
100
|
|
|
|
8
|
if ($c->{httponly}) { |
328
|
1
|
|
|
|
|
2
|
$hvalue .= "; HttpOnly" |
329
|
|
|
|
|
|
|
} |
330
|
0
|
|
|
|
|
0
|
} else { $hvalue = $c } |
331
|
3
|
|
|
|
|
8
|
push @cookies_headers, "Set-Cookie", $hvalue; |
332
|
|
|
|
|
|
|
} |
333
|
|
|
|
|
|
|
} |
334
|
5
|
|
|
|
|
93
|
my $status = $self->status; |
335
|
5
|
|
50
|
|
|
30
|
my $fd = $self->{writer}->([$status||"200", [%headers, @cookies_headers], undef]); |
336
|
5
|
|
|
|
|
74
|
$self->{fd} = $fd; |
337
|
|
|
|
|
|
|
} |
338
|
|
|
|
|
|
|
|
339
|
|
|
|
|
|
|
sub print { |
340
|
1
|
|
|
1
|
0
|
4
|
my $self = shift; |
341
|
1
|
50
|
|
|
|
3
|
if (exists $self->{fd}) { |
342
|
1
|
|
|
|
|
6
|
foreach my $line (@_) { |
343
|
1
|
50
|
|
|
|
5
|
utf8::encode( $line) if utf8::is_utf8($line); |
344
|
1
|
|
|
|
|
5
|
$self->{fd}->write($line); |
345
|
|
|
|
|
|
|
} |
346
|
|
|
|
|
|
|
} else { |
347
|
0
|
|
|
|
|
0
|
print @_; |
348
|
|
|
|
|
|
|
} |
349
|
|
|
|
|
|
|
} |
350
|
|
|
|
|
|
|
|
351
|
|
|
|
|
|
|
=head2 get_cookie |
352
|
|
|
|
|
|
|
|
353
|
|
|
|
|
|
|
return hashref to {key=>value} |
354
|
|
|
|
|
|
|
|
355
|
|
|
|
|
|
|
=cut |
356
|
|
|
|
|
|
|
|
357
|
|
|
|
|
|
|
sub get_cookie { |
358
|
1
|
|
|
1
|
1
|
764
|
my $self = shift; |
359
|
1
|
|
50
|
|
|
5
|
my $str = $self->{env}->{HTTP_COOKIE} || return {}; |
360
|
1
|
50
|
|
|
|
23
|
if ($self->_parsed_cookies) { return $self->_parsed_cookies }; |
|
0
|
|
|
|
|
0
|
|
361
|
1
|
|
|
|
|
3
|
my %res; |
362
|
|
|
|
|
|
|
%res = |
363
|
1
|
|
|
|
|
6
|
map { URI::Escape::uri_unescape($_) } map { split '=',$_,2 } split(/\s*[;]\s*/, |
|
4
|
|
|
|
|
25
|
|
|
2
|
|
|
|
|
6
|
|
364
|
|
|
|
|
|
|
$str); |
365
|
1
|
|
|
|
|
26
|
$self->_parsed_cookies(\%res); |
366
|
1
|
|
|
|
|
5
|
\%res; |
367
|
|
|
|
|
|
|
} |
368
|
|
|
|
|
|
|
|
369
|
|
|
|
|
|
|
|
370
|
|
|
|
|
|
|
1; |
371
|
|
|
|
|
|
|
|
372
|
|
|
|
|
|
|
|