line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Net::WebSocket::HTTP_R; |
2
|
|
|
|
|
|
|
|
3
|
1
|
|
|
1
|
|
118325
|
use strict; |
|
1
|
|
|
|
|
14
|
|
|
1
|
|
|
|
|
29
|
|
4
|
1
|
|
|
1
|
|
5
|
use warnings; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
200
|
|
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
=encoding utf-8 |
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
=head1 NAME |
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
Net::WebSocket::HTTP_R - logic for HTTP::Request & HTTP::Response |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
=head1 SYNOPSIS |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
Client: |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
my $resp = HTTP::Response->parse_string($http_response); |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
my $handshake = Net::WebSocket::Handshake::Client->new( .. ); |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
Net::WebSocket::HTTP_R::handshake_consume_response( $handshake, $resp ); |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
Server: |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
my $req = HTTP::Request->parse_string($http_request); |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
my $handshake = Net::WebSocket::Handshake::Server->new( .. ); |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
Net::WebSocket::HTTP_R::handshake_consume_request( $handshake, $req ); |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
=head1 DESCRIPTION |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
Net::WebSocket is agnostic as to which tools an implementor may use to parse |
33
|
|
|
|
|
|
|
HTTP headers. CPAN offers a number of options for doing this, and different |
34
|
|
|
|
|
|
|
applications may have varying reasons to prefer one or the other—or an |
35
|
|
|
|
|
|
|
entirely different approach altogether. |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
This module provides convenient logic for the L and |
38
|
|
|
|
|
|
|
L CPAN modules. Any implementation that uses one of these |
39
|
|
|
|
|
|
|
modules (or a compatible implementation) can use Net::WebSocket::HTTP_R and |
40
|
|
|
|
|
|
|
save a bit of time. |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
=cut |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
sub handshake_consume_request { |
45
|
1
|
|
|
1
|
0
|
8
|
my ($hsk, $req) = @_; |
46
|
|
|
|
|
|
|
|
47
|
1
|
|
|
|
|
4
|
$hsk->valid_method_or_die( $req->method() ); |
48
|
|
|
|
|
|
|
|
49
|
1
|
|
|
|
|
4
|
return _handshake_consume_common($hsk, $req); |
50
|
|
|
|
|
|
|
} |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
sub handshake_consume_response { |
53
|
1
|
|
|
1
|
0
|
290
|
my ($hsk, $resp) = @_; |
54
|
|
|
|
|
|
|
|
55
|
1
|
|
|
|
|
3
|
$hsk->valid_status_or_die( $resp->code(), $resp->message() ); |
56
|
|
|
|
|
|
|
|
57
|
1
|
|
|
|
|
4
|
return _handshake_consume_common($hsk, $resp); |
58
|
|
|
|
|
|
|
} |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
sub _handshake_consume_common { |
61
|
2
|
|
|
2
|
|
5
|
my ($hsk, $r_obj) = @_; |
62
|
|
|
|
|
|
|
|
63
|
2
|
|
|
|
|
11
|
my $hdrs_obj = $r_obj->headers(); |
64
|
|
|
|
|
|
|
|
65
|
2
|
|
|
|
|
14
|
my @hdrs; |
66
|
2
|
|
|
|
|
8
|
for my $hname ($hdrs_obj->header_field_names()) { |
67
|
10
|
|
|
|
|
140
|
my $value = $hdrs_obj->header($hname); |
68
|
10
|
50
|
|
|
|
368
|
if ('ARRAY' eq ref $value) { |
69
|
0
|
|
|
|
|
0
|
push @hdrs, $hname => $_ for @$value; |
70
|
|
|
|
|
|
|
} |
71
|
|
|
|
|
|
|
else { |
72
|
10
|
|
|
|
|
31
|
push @hdrs, $hname => $value; |
73
|
|
|
|
|
|
|
} |
74
|
|
|
|
|
|
|
} |
75
|
|
|
|
|
|
|
|
76
|
2
|
|
|
|
|
20
|
return $hsk->consume_headers(@hdrs); |
77
|
|
|
|
|
|
|
} |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
1; |