Mercurial > hg > nginx-tests
comparison lib/Test/Nginx/HTTP2.pm @ 876:a6abbfed42c0
Tests: split HTTP/2 tests, HTTP2 package introduced.
author | Andrey Zelenkov <zelenkov@nginx.com> |
---|---|
date | Wed, 23 Mar 2016 17:23:08 +0300 |
parents | |
children | 48d277065309 |
comparison
equal
deleted
inserted
replaced
875:c380b4b7e2e4 | 876:a6abbfed42c0 |
---|---|
1 package Test::Nginx::HTTP2; | |
2 | |
3 # (C) Sergey Kandaurov | |
4 # (C) Nginx, Inc. | |
5 | |
6 # Module for nginx HTTP/2 tests. | |
7 | |
8 ############################################################################### | |
9 | |
10 use warnings; | |
11 use strict; | |
12 | |
13 use base qw/ Exporter /; | |
14 our @EXPORT = qw/ new_session new_stream h2_read /; | |
15 our %EXPORT_TAGS = ( | |
16 io => [ qw/ raw_write raw_read / ], | |
17 frame => [ qw/ h2_ping h2_rst h2_goaway h2_priority h2_window | |
18 h2_settings h2_unknown h2_continue h2_body/ ] | |
19 ); | |
20 our @EXPORT_OK = ( @{ $EXPORT_TAGS{'io'} }, @{ $EXPORT_TAGS{'frame'} } ); | |
21 | |
22 use Test::More qw//; | |
23 use IO::Select; | |
24 use IO::Socket; | |
25 use Socket qw/ CRLF /; | |
26 | |
27 use Test::Nginx; | |
28 | |
29 my %cframe = ( | |
30 0 => { name => 'DATA', value => \&data }, | |
31 1 => { name => 'HEADERS', value => \&headers }, | |
32 # 2 => { name => 'PRIORITY', value => \&priority }, | |
33 3 => { name => 'RST_STREAM', value => \&rst_stream }, | |
34 4 => { name => 'SETTINGS', value => \&settings }, | |
35 # 5 => { name => 'PUSH_PROMISE', value => \&push_promise }, | |
36 6 => { name => 'PING', value => \&ping }, | |
37 7 => { name => 'GOAWAY', value => \&goaway }, | |
38 8 => { name => 'WINDOW_UPDATE', value => \&window_update }, | |
39 9 => { name => 'CONTINUATION', value => \&headers }, | |
40 ); | |
41 | |
42 sub h2_ping { | |
43 my ($sess, $payload) = @_; | |
44 | |
45 raw_write($sess->{socket}, pack("x2C2x5a8", 8, 0x6, $payload)); | |
46 } | |
47 | |
48 sub h2_rst { | |
49 my ($sess, $stream, $error) = @_; | |
50 | |
51 raw_write($sess->{socket}, pack("x2C2xNN", 4, 0x3, $stream, $error)); | |
52 } | |
53 | |
54 sub h2_goaway { | |
55 my ($sess, $stream, $lstream, $err, $debug, %extra) = @_; | |
56 $debug = '' unless defined $debug; | |
57 my $len = defined $extra{len} ? $extra{len} : 8 + length($debug); | |
58 my $buf = pack("x2C2xN3A*", $len, 0x7, $stream, $lstream, $err, $debug); | |
59 | |
60 my @bufs = map { | |
61 raw_write($sess->{socket}, substr $buf, 0, $_, ""); | |
62 select undef, undef, undef, 0.4; | |
63 } @{$extra{split}}; | |
64 | |
65 raw_write($sess->{socket}, $buf); | |
66 } | |
67 | |
68 sub h2_priority { | |
69 my ($sess, $w, $stream, $dep, %extra) = @_; | |
70 | |
71 $stream = 0 unless defined $stream; | |
72 $dep = 0 unless defined $dep; | |
73 $dep |= $extra{excl} << 31 if exists $extra{excl}; | |
74 raw_write($sess->{socket}, pack("x2C2xNNC", 5, 0x2, $stream, $dep, $w)); | |
75 } | |
76 | |
77 sub h2_window { | |
78 my ($sess, $win, $stream) = @_; | |
79 | |
80 $stream = 0 unless defined $stream; | |
81 raw_write($sess->{socket}, pack("x2C2xNN", 4, 0x8, $stream, $win)); | |
82 } | |
83 | |
84 sub h2_settings { | |
85 my ($sess, $ack, %extra) = @_; | |
86 | |
87 my $len = 6 * keys %extra; | |
88 my $buf = pack_length($len) . pack "CCx4", 0x4, $ack ? 0x1 : 0x0; | |
89 $buf .= join '', map { pack "nN", $_, $extra{$_} } keys %extra; | |
90 raw_write($sess->{socket}, $buf); | |
91 } | |
92 | |
93 sub h2_unknown { | |
94 my ($sess, $payload) = @_; | |
95 | |
96 my $buf = pack_length(length($payload)) . pack("Cx5a*", 0xa, $payload); | |
97 raw_write($sess->{socket}, $buf); | |
98 } | |
99 | |
100 sub h2_continue { | |
101 my ($ctx, $stream, $uri) = @_; | |
102 | |
103 $uri->{h2_continue} = 1; | |
104 return new_stream($ctx, $uri, $stream); | |
105 } | |
106 | |
107 sub h2_body { | |
108 my ($sess, $body, $extra) = @_; | |
109 $extra = {} unless defined $extra; | |
110 | |
111 my $len = length $body; | |
112 my $sid = $sess->{last_stream}; | |
113 | |
114 if ($len > $sess->{conn_window} || $len > $sess->{streams}{$sid}) { | |
115 h2_read($sess, all => [{ type => 'WINDOW_UPDATE' }]); | |
116 } | |
117 | |
118 if ($len > $sess->{conn_window} || $len > $sess->{streams}{$sid}) { | |
119 return; | |
120 } | |
121 | |
122 $sess->{conn_window} -= $len; | |
123 $sess->{streams}{$sid} -= $len; | |
124 | |
125 my $buf; | |
126 | |
127 my $split = ref $extra->{body_split} && $extra->{body_split} || []; | |
128 for (@$split) { | |
129 $buf .= pack_body($sess, substr($body, 0, $_, ""), 0x0, $extra); | |
130 } | |
131 | |
132 $buf .= pack_body($sess, $body, 0x1, $extra) if defined $body; | |
133 | |
134 $split = ref $extra->{split} && $extra->{split} || []; | |
135 for (@$split) { | |
136 raw_write($sess->{socket}, substr($buf, 0, $_, "")); | |
137 return if $extra->{abort}; | |
138 select undef, undef, undef, ($extra->{split_delay} || 0.2); | |
139 } | |
140 | |
141 raw_write($sess->{socket}, $buf); | |
142 } | |
143 | |
144 sub pack_body { | |
145 my ($ctx, $body, $flags, $extra) = @_; | |
146 | |
147 my $pad = defined $extra->{body_padding} ? $extra->{body_padding} : 0; | |
148 my $padlen = defined $extra->{body_padding} ? 1 : 0; | |
149 | |
150 my $buf = pack_length(length($body) + $pad + $padlen); | |
151 $flags |= 0x8 if $padlen; | |
152 vec($flags, 0, 1) = 0 if $extra->{body_more}; | |
153 $buf .= pack 'CC', 0x0, $flags; # DATA, END_STREAM | |
154 $buf .= pack 'N', $ctx->{last_stream}; | |
155 $buf .= pack 'C', $pad if $padlen; # DATA Pad Length? | |
156 $buf .= $body; | |
157 $buf .= pack "x$pad" if $padlen; # DATA Padding | |
158 return $buf; | |
159 } | |
160 | |
161 sub new_stream { | |
162 my ($ctx, $uri, $stream) = @_; | |
163 my ($input, $buf); | |
164 my ($d, $status); | |
165 | |
166 $ctx->{headers} = ''; | |
167 | |
168 my $host = $uri->{host} || '127.0.0.1:8080'; | |
169 my $method = $uri->{method} || 'GET'; | |
170 my $scheme = $uri->{scheme} || 'http'; | |
171 my $path = $uri->{path} || '/'; | |
172 my $headers = $uri->{headers}; | |
173 my $body = $uri->{body}; | |
174 my $prio = $uri->{prio}; | |
175 my $dep = $uri->{dep}; | |
176 | |
177 my $pad = defined $uri->{padding} ? $uri->{padding} : 0; | |
178 my $padlen = defined $uri->{padding} ? 1 : 0; | |
179 | |
180 my $type = defined $uri->{h2_continue} ? 0x9 : 0x1; | |
181 my $flags = defined $uri->{continuation} ? 0x0 : 0x4; | |
182 $flags |= 0x1 unless defined $body || defined $uri->{body_more}; | |
183 $flags |= 0x8 if $padlen; | |
184 $flags |= 0x20 if defined $dep || defined $prio; | |
185 | |
186 if ($stream) { | |
187 $ctx->{last_stream} = $stream; | |
188 } else { | |
189 $ctx->{last_stream} += 2; | |
190 $ctx->{streams}{$ctx->{last_stream}} = $ctx->{iws}; | |
191 } | |
192 | |
193 $buf = pack("xxx"); # Length stub | |
194 $buf .= pack("CC", $type, $flags); # END_HEADERS | |
195 $buf .= pack("N", $ctx->{last_stream}); # Stream-ID | |
196 | |
197 $dep = 0 if defined $prio and not defined $dep; | |
198 $prio = 16 if defined $dep and not defined $prio; | |
199 | |
200 unless ($headers) { | |
201 $input = hpack($ctx, ":method", $method); | |
202 $input .= hpack($ctx, ":scheme", $scheme); | |
203 $input .= hpack($ctx, ":path", $path); | |
204 $input .= hpack($ctx, ":authority", $host); | |
205 $input .= hpack($ctx, "content-length", length($body)) if $body; | |
206 | |
207 } else { | |
208 $input = join '', map { | |
209 hpack($ctx, $_->{name}, $_->{value}, | |
210 mode => $_->{mode}, huff => $_->{huff}) | |
211 } @$headers if $headers; | |
212 } | |
213 | |
214 $input = pack("B*", '001' . ipack(5, $uri->{table_size})) . $input | |
215 if defined $uri->{table_size}; | |
216 | |
217 my $split = ref $uri->{continuation} && $uri->{continuation} || []; | |
218 my @input = map { substr $input, 0, $_, "" } @$split; | |
219 push @input, $input; | |
220 | |
221 # set length, attach headers, padding, priority | |
222 | |
223 my $hlen = length($input[0]) + $pad + $padlen; | |
224 $hlen += 5 if $flags & 0x20; | |
225 $buf |= pack_length($hlen); | |
226 | |
227 $buf .= pack 'C', $pad if $padlen; # Pad Length? | |
228 $buf .= pack 'NC', $dep, $prio if $flags & 0x20; | |
229 $buf .= $input[0]; | |
230 $buf .= (pack 'C', 0) x $pad if $padlen; # Padding | |
231 | |
232 shift @input; | |
233 | |
234 while (@input) { | |
235 $input = shift @input; | |
236 $flags = @input ? 0x0 : 0x4; | |
237 $buf .= pack_length(length($input)); | |
238 $buf .= pack("CC", 0x9, $flags); | |
239 $buf .= pack("N", $ctx->{last_stream}); | |
240 $buf .= $input; | |
241 } | |
242 | |
243 $split = ref $uri->{body_split} && $uri->{body_split} || []; | |
244 for (@$split) { | |
245 $buf .= pack_body($ctx, substr($body, 0, $_, ""), 0x0, $uri); | |
246 } | |
247 | |
248 $buf .= pack_body($ctx, $body, 0x1, $uri) if defined $body; | |
249 | |
250 $split = ref $uri->{split} && $uri->{split} || []; | |
251 for (@$split) { | |
252 raw_write($ctx->{socket}, substr($buf, 0, $_, "")); | |
253 goto done if $uri->{abort}; | |
254 select undef, undef, undef, ($uri->{split_delay} || 0.2); | |
255 } | |
256 | |
257 raw_write($ctx->{socket}, $buf); | |
258 done: | |
259 return $ctx->{last_stream}; | |
260 } | |
261 | |
262 sub h2_read { | |
263 my ($sess, %extra) = @_; | |
264 my (@got); | |
265 my $s = $sess->{socket}; | |
266 my $buf = ''; | |
267 | |
268 while (1) { | |
269 $buf = raw_read($s, $buf, 9); | |
270 last if length $buf < 9; | |
271 | |
272 my $length = unpack_length($buf); | |
273 my $type = unpack('x3C', $buf); | |
274 my $flags = unpack('x4C', $buf); | |
275 | |
276 my $stream = unpack "x5 B32", $buf; | |
277 substr($stream, 0, 1) = 0; | |
278 $stream = unpack("N", pack("B32", $stream)); | |
279 | |
280 $buf = raw_read($s, $buf, $length + 9); | |
281 last if length($buf) < $length + 9; | |
282 | |
283 $buf = substr($buf, 9); | |
284 | |
285 my $frame = $cframe{$type}{value}($sess, $buf, $length, $flags, | |
286 $stream); | |
287 $frame->{length} = $length; | |
288 $frame->{type} = $cframe{$type}{name}; | |
289 $frame->{flags} = $flags; | |
290 $frame->{sid} = $stream; | |
291 push @got, $frame; | |
292 | |
293 $buf = substr($buf, $length); | |
294 | |
295 last unless $extra{all} && test_fin($got[-1], $extra{all}); | |
296 }; | |
297 return \@got; | |
298 } | |
299 | |
300 sub test_fin { | |
301 my ($frame, $all) = @_; | |
302 my @test = @{$all}; | |
303 | |
304 # wait for the specified DATA length | |
305 | |
306 for (@test) { | |
307 if ($_->{length} && $frame->{type} eq 'DATA') { | |
308 # check also for StreamID if needed | |
309 | |
310 if (!$_->{sid} || $_->{sid} == $frame->{sid}) { | |
311 $_->{length} -= $frame->{length}; | |
312 } | |
313 } | |
314 } | |
315 @test = grep { !(defined $_->{length} && $_->{length} == 0) } @test; | |
316 | |
317 # wait for the fin flag | |
318 | |
319 @test = grep { !(defined $_->{fin} | |
320 && $_->{sid} == $frame->{sid} && $_->{fin} & $frame->{flags}) | |
321 } @test if defined $frame->{flags}; | |
322 | |
323 # wait for the specified frame | |
324 | |
325 @test = grep { !($_->{type} && $_->{type} eq $frame->{type}) } @test; | |
326 | |
327 @{$all} = @test; | |
328 } | |
329 | |
330 sub headers { | |
331 my ($ctx, $buf, $len, $flags) = @_; | |
332 $ctx->{headers} .= substr($buf, 0, $len); | |
333 return unless $flags & 0x4; | |
334 { headers => hunpack($ctx, $ctx->{headers}, length($ctx->{headers})) }; | |
335 } | |
336 | |
337 sub data { | |
338 my ($ctx, $buf, $len) = @_; | |
339 return { data => substr($buf, 0, $len) }; | |
340 } | |
341 | |
342 sub settings { | |
343 my ($ctx, $buf, $len) = @_; | |
344 my %payload; | |
345 my $skip = 0; | |
346 | |
347 for (1 .. $len / 6) { | |
348 my $id = hex unpack "\@$skip n", $buf; $skip += 2; | |
349 $payload{$id} = unpack "\@$skip N", $buf; $skip += 4; | |
350 | |
351 $ctx->{iws} = $payload{$id} if $id == 4; | |
352 } | |
353 return \%payload; | |
354 } | |
355 | |
356 sub ping { | |
357 my ($ctx, $buf, $len) = @_; | |
358 return { value => unpack "A$len", $buf }; | |
359 } | |
360 | |
361 sub rst_stream { | |
362 my ($ctx, $buf, $len) = @_; | |
363 return { code => unpack "N", $buf }; | |
364 } | |
365 | |
366 sub goaway { | |
367 my ($ctx, $buf, $len) = @_; | |
368 my %payload; | |
369 | |
370 my $stream = unpack "B32", $buf; | |
371 substr($stream, 0, 1) = 0; | |
372 $stream = unpack("N", pack("B32", $stream)); | |
373 $payload{last_sid} = $stream; | |
374 | |
375 $len -= 4; | |
376 $payload{code} = unpack "x4 N", $buf; | |
377 $payload{debug} = unpack "x8 A$len", $buf; | |
378 return \%payload; | |
379 } | |
380 | |
381 sub window_update { | |
382 my ($ctx, $buf, $len, $flags, $sid) = @_; | |
383 my $value = unpack "B32", $buf; | |
384 substr($value, 0, 1) = 0; | |
385 $value = unpack("N", pack("B32", $value)); | |
386 | |
387 unless ($sid) { | |
388 $ctx->{conn_window} += $value; | |
389 | |
390 } else { | |
391 $ctx->{streams}{$sid} = $ctx->{iws} | |
392 unless defined $ctx->{streams}{$sid}; | |
393 $ctx->{streams}{$sid} += $value; | |
394 } | |
395 | |
396 return { wdelta => $value }; | |
397 } | |
398 | |
399 sub pack_length { | |
400 pack 'c3', unpack 'xc3', pack 'N', $_[0]; | |
401 } | |
402 | |
403 sub unpack_length { | |
404 unpack 'N', pack 'xc3', unpack 'c3', $_[0]; | |
405 } | |
406 | |
407 sub raw_read { | |
408 my ($s, $buf, $len, $log) = @_; | |
409 $log = \&log_in unless defined $log; | |
410 my $got = ''; | |
411 | |
412 while (length($buf) < $len && IO::Select->new($s)->can_read(1)) { | |
413 $s->sysread($got, 16384) or last; | |
414 $log->($got); | |
415 $buf .= $got; | |
416 } | |
417 return $buf; | |
418 } | |
419 | |
420 sub raw_write { | |
421 my ($s, $message) = @_; | |
422 | |
423 local $SIG{PIPE} = 'IGNORE'; | |
424 | |
425 while (IO::Select->new($s)->can_write(0.4)) { | |
426 log_out($message); | |
427 my $n = $s->syswrite($message); | |
428 last unless $n; | |
429 $message = substr($message, $n); | |
430 last unless length $message; | |
431 } | |
432 } | |
433 | |
434 sub new_session { | |
435 my ($port, %extra) = @_; | |
436 | |
437 my $s = new_socket($port, %extra); | |
438 my $preface = $extra{preface} | |
439 || 'PRI * HTTP/2.0' . CRLF . CRLF . 'SM' . CRLF . CRLF; | |
440 | |
441 if ($extra{proxy}) { | |
442 raw_write($s, $extra{proxy}); | |
443 } | |
444 | |
445 # preface | |
446 | |
447 raw_write($s, $preface); | |
448 | |
449 my $ctx = { socket => $s, last_stream => -1, | |
450 dynamic_encode => [ static_table() ], | |
451 dynamic_decode => [ static_table() ], | |
452 static_table_size => scalar @{[static_table()]}, | |
453 iws => 65535, conn_window => 65535, streams => {}}; | |
454 | |
455 return $ctx if $extra{pure}; | |
456 | |
457 # update windows, if any | |
458 | |
459 h2_read($ctx, all => [ | |
460 { type => 'WINDOW_UPDATE' }, | |
461 { type => 'SETTINGS'} | |
462 ]); | |
463 | |
464 return $ctx; | |
465 } | |
466 | |
467 sub new_socket { | |
468 my ($port, %extra) = @_; | |
469 my $npn = $extra{'npn'}; | |
470 my $alpn = $extra{'alpn'}; | |
471 my $s; | |
472 | |
473 $port = 8080 unless defined $port; | |
474 | |
475 eval { | |
476 local $SIG{ALRM} = sub { die "timeout\n" }; | |
477 local $SIG{PIPE} = sub { die "sigpipe\n" }; | |
478 alarm(2); | |
479 $s = IO::Socket::INET->new( | |
480 Proto => 'tcp', | |
481 PeerAddr => "127.0.0.1:$port", | |
482 ); | |
483 require IO::Socket::SSL if $extra{'SSL'}; | |
484 IO::Socket::SSL->start_SSL($s, | |
485 SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_NONE(), | |
486 SSL_npn_protocols => $npn ? [ $npn ] : undef, | |
487 SSL_alpn_protocols => $alpn ? [ $alpn ] : undef, | |
488 SSL_error_trap => sub { die $_[1] } | |
489 ) if $extra{'SSL'}; | |
490 alarm(0); | |
491 }; | |
492 alarm(0); | |
493 | |
494 if ($@) { | |
495 log_in("died: $@"); | |
496 return undef; | |
497 } | |
498 | |
499 return $s; | |
500 } | |
501 | |
502 sub static_table { | |
503 [ '', '' ], # unused | |
504 [ ':authority', '' ], | |
505 [ ':method', 'GET' ], | |
506 [ ':method', 'POST' ], | |
507 [ ':path', '/' ], | |
508 [ ':path', '/index.html' ], | |
509 [ ':scheme', 'http' ], | |
510 [ ':scheme', 'https' ], | |
511 [ ':status', '200' ], | |
512 [ ':status', '204' ], | |
513 [ ':status', '206' ], | |
514 [ ':status', '304' ], | |
515 [ ':status', '400' ], | |
516 [ ':status', '404' ], | |
517 [ ':status', '500' ], | |
518 [ 'accept-charset', '' ], | |
519 [ 'accept-encoding', 'gzip, deflate' ], | |
520 [ 'accept-language', '' ], | |
521 [ 'accept-ranges', '' ], | |
522 [ 'accept', '' ], | |
523 [ 'access-control-allow-origin', | |
524 '' ], | |
525 [ 'age', '' ], | |
526 [ 'allow', '' ], | |
527 [ 'authorization', '' ], | |
528 [ 'cache-control', '' ], | |
529 [ 'content-disposition', | |
530 '' ], | |
531 [ 'content-encoding', '' ], | |
532 [ 'content-language', '' ], | |
533 [ 'content-length', '' ], | |
534 [ 'content-location', '' ], | |
535 [ 'content-range', '' ], | |
536 [ 'content-type', '' ], | |
537 [ 'cookie', '' ], | |
538 [ 'date', '' ], | |
539 [ 'etag', '' ], | |
540 [ 'expect', '' ], | |
541 [ 'expires', '' ], | |
542 [ 'from', '' ], | |
543 [ 'host', '' ], | |
544 [ 'if-match', '' ], | |
545 [ 'if-modified-since', '' ], | |
546 [ 'if-none-match', '' ], | |
547 [ 'if-range', '' ], | |
548 [ 'if-unmodified-since', | |
549 '' ], | |
550 [ 'last-modified', '' ], | |
551 [ 'link', '' ], | |
552 [ 'location', '' ], | |
553 [ 'max-forwards', '' ], | |
554 [ 'proxy-authenticate', '' ], | |
555 [ 'proxy-authorization', | |
556 '' ], | |
557 [ 'range', '' ], | |
558 [ 'referer', '' ], | |
559 [ 'refresh', '' ], | |
560 [ 'retry-after', '' ], | |
561 [ 'server', '' ], | |
562 [ 'set-cookie', '' ], | |
563 [ 'strict-transport-security', | |
564 '' ], | |
565 [ 'transfer-encoding', '' ], | |
566 [ 'user-agent', '' ], | |
567 [ 'vary', '' ], | |
568 [ 'via', '' ], | |
569 [ 'www-authenticate', '' ], | |
570 } | |
571 | |
572 # RFC 7541, 5.1. Integer Representation | |
573 | |
574 sub ipack { | |
575 my ($base, $d) = @_; | |
576 return sprintf("%.*b", $base, $d) if $d < 2**$base - 1; | |
577 | |
578 my $o = sprintf("%${base}b", 2**$base - 1); | |
579 $d -= 2**$base - 1; | |
580 while ($d >= 128) { | |
581 $o .= sprintf("%8b", $d % 128 + 128); | |
582 $d /= 128; | |
583 } | |
584 $o .= sprintf("%08b", $d); | |
585 return $o; | |
586 } | |
587 | |
588 sub iunpack { | |
589 my ($base, $b, $s) = @_; | |
590 | |
591 my $len = unpack("\@$s B8", $b); $s++; | |
592 my $prefix = substr($len, 0, 8 - $base); | |
593 $len = '0' x (8 - $base) . substr($len, 8 - $base); | |
594 $len = unpack("C", pack("B8", $len)); | |
595 | |
596 return ($len, $s, $prefix) if $len < 2**$base - 1; | |
597 | |
598 my $m = 0; | |
599 my $d; | |
600 | |
601 do { | |
602 $d = unpack("\@$s C", $b); $s++; | |
603 $len += ($d & 127) * 2**$m; | |
604 $m += $base; | |
605 } while (($d & 128) == 128); | |
606 | |
607 return ($len, $s, $prefix); | |
608 } | |
609 | |
610 sub hpack { | |
611 my ($ctx, $name, $value, %extra) = @_; | |
612 my $table = $ctx->{dynamic_encode}; | |
613 my $mode = defined $extra{mode} ? $extra{mode} : 1; | |
614 my $huff = $extra{huff}; | |
615 | |
616 my ($index, $buf) = 0; | |
617 | |
618 # 6.1. Indexed Header Field Representation | |
619 | |
620 if ($mode == 0) { | |
621 ++$index until $index > $#$table | |
622 or $table->[$index][0] eq $name | |
623 and $table->[$index][1] eq $value; | |
624 $buf = pack('B*', '1' . ipack(7, $index)); | |
625 } | |
626 | |
627 # 6.2.1. Literal Header Field with Incremental Indexing | |
628 | |
629 if ($mode == 1) { | |
630 splice @$table, $ctx->{static_table_size}, 0, [ $name, $value ]; | |
631 | |
632 ++$index until $index > $#$table | |
633 or $table->[$index][0] eq $name; | |
634 my $value = $huff ? huff($value) : $value; | |
635 | |
636 $buf = pack('B*', '01' . ipack(6, $index) | |
637 . ($huff ? '1' : '0') . ipack(7, length($value))); | |
638 $buf .= $value; | |
639 } | |
640 | |
641 # 6.2.1. Literal Header Field with Incremental Indexing -- New Name | |
642 | |
643 if ($mode == 2) { | |
644 splice @$table, $ctx->{static_table_size}, 0, [ $name, $value ]; | |
645 | |
646 my $name = $huff ? huff($name) : $name; | |
647 my $value = $huff ? huff($value) : $value; | |
648 my $hbit = ($huff ? '1' : '0'); | |
649 | |
650 $buf = pack('B*', '01000000'); | |
651 $buf .= pack('B*', $hbit . ipack(7, length($name))); | |
652 $buf .= $name; | |
653 $buf .= pack('B*', $hbit . ipack(7, length($value))); | |
654 $buf .= $value; | |
655 } | |
656 | |
657 # 6.2.2. Literal Header Field without Indexing | |
658 | |
659 if ($mode == 3) { | |
660 ++$index until $index > $#$table | |
661 or $table->[$index][0] eq $name; | |
662 my $value = $huff ? huff($value) : $value; | |
663 | |
664 $buf = pack('B*', '0000' . ipack(4, $index) | |
665 . ($huff ? '1' : '0') . ipack(7, length($value))); | |
666 $buf .= $value; | |
667 } | |
668 | |
669 # 6.2.2. Literal Header Field without Indexing -- New Name | |
670 | |
671 if ($mode == 4) { | |
672 my $name = $huff ? huff($name) : $name; | |
673 my $value = $huff ? huff($value) : $value; | |
674 my $hbit = ($huff ? '1' : '0'); | |
675 | |
676 $buf = pack('B*', '00000000'); | |
677 $buf .= pack('B*', $hbit . ipack(7, length($name))); | |
678 $buf .= $name; | |
679 $buf .= pack('B*', $hbit . ipack(7, length($value))); | |
680 $buf .= $value; | |
681 } | |
682 | |
683 # 6.2.3. Literal Header Field Never Indexed | |
684 | |
685 if ($mode == 5) { | |
686 ++$index until $index > $#$table | |
687 or $table->[$index][0] eq $name; | |
688 my $value = $huff ? huff($value) : $value; | |
689 | |
690 $buf = pack('B*', '0001' . ipack(4, $index) | |
691 . ($huff ? '1' : '0') . ipack(7, length($value))); | |
692 $buf .= $value; | |
693 } | |
694 | |
695 # 6.2.3. Literal Header Field Never Indexed -- New Name | |
696 | |
697 if ($mode == 6) { | |
698 my $name = $huff ? huff($name) : $name; | |
699 my $value = $huff ? huff($value) : $value; | |
700 my $hbit = ($huff ? '1' : '0'); | |
701 | |
702 $buf = pack('B*', '00010000'); | |
703 $buf .= pack('B*', $hbit . ipack(7, length($name))); | |
704 $buf .= $name; | |
705 $buf .= pack('B*', $hbit . ipack(7, length($value))); | |
706 $buf .= $value; | |
707 } | |
708 | |
709 return $buf; | |
710 } | |
711 | |
712 sub hunpack { | |
713 my ($ctx, $data, $length) = @_; | |
714 my $table = $ctx->{dynamic_decode}; | |
715 my %headers; | |
716 my $skip = 0; | |
717 my ($index, $name, $value); | |
718 | |
719 my $field = sub { | |
720 my ($b) = @_; | |
721 my ($len, $s, $huff) = iunpack(7, @_); | |
722 | |
723 my $field = substr($b, $s, $len); | |
724 $field = $huff ? dehuff($field) : $field; | |
725 $s += $len; | |
726 return ($field, $s); | |
727 }; | |
728 | |
729 my $add = sub { | |
730 my ($h, $n, $v) = @_; | |
731 return $h->{$n} = $v unless exists $h->{$n}; | |
732 $h->{$n} = [ $h->{$n} ] unless ref $h->{$n}; | |
733 push @{$h->{$n}}, $v; | |
734 }; | |
735 | |
736 while ($skip < $length) { | |
737 my $ib = unpack("\@$skip B8", $data); | |
738 | |
739 if (substr($ib, 0, 1) eq '1') { | |
740 ($index, $skip) = iunpack(7, $data, $skip); | |
741 $add->(\%headers, | |
742 $table->[$index][0], $table->[$index][1]); | |
743 next; | |
744 } | |
745 | |
746 if (substr($ib, 0, 2) eq '01') { | |
747 ($index, $skip) = iunpack(6, $data, $skip); | |
748 $name = $table->[$index][0]; | |
749 | |
750 ($name, $skip) = $field->($data, $skip) unless $name; | |
751 ($value, $skip) = $field->($data, $skip); | |
752 | |
753 splice @$table, | |
754 $ctx->{static_table_size}, 0, [ $name, $value ]; | |
755 $add->(\%headers, $name, $value); | |
756 next; | |
757 } | |
758 | |
759 if (substr($ib, 0, 4) eq '0000') { | |
760 ($index, $skip) = iunpack(4, $data, $skip); | |
761 $name = $table->[$index][0]; | |
762 | |
763 ($name, $skip) = $field->($data, $skip) unless $name; | |
764 ($value, $skip) = $field->($data, $skip); | |
765 | |
766 $add->(\%headers, $name, $value); | |
767 next; | |
768 } | |
769 last; | |
770 } | |
771 | |
772 return \%headers; | |
773 } | |
774 | |
775 sub huff_code { scalar { | |
776 pack('C', 0) => '1111111111000', | |
777 pack('C', 1) => '11111111111111111011000', | |
778 pack('C', 2) => '1111111111111111111111100010', | |
779 pack('C', 3) => '1111111111111111111111100011', | |
780 pack('C', 4) => '1111111111111111111111100100', | |
781 pack('C', 5) => '1111111111111111111111100101', | |
782 pack('C', 6) => '1111111111111111111111100110', | |
783 pack('C', 7) => '1111111111111111111111100111', | |
784 pack('C', 8) => '1111111111111111111111101000', | |
785 pack('C', 9) => '111111111111111111101010', | |
786 pack('C', 10) => '111111111111111111111111111100', | |
787 pack('C', 11) => '1111111111111111111111101001', | |
788 pack('C', 12) => '1111111111111111111111101010', | |
789 pack('C', 13) => '111111111111111111111111111101', | |
790 pack('C', 14) => '1111111111111111111111101011', | |
791 pack('C', 15) => '1111111111111111111111101100', | |
792 pack('C', 16) => '1111111111111111111111101101', | |
793 pack('C', 17) => '1111111111111111111111101110', | |
794 pack('C', 18) => '1111111111111111111111101111', | |
795 pack('C', 19) => '1111111111111111111111110000', | |
796 pack('C', 20) => '1111111111111111111111110001', | |
797 pack('C', 21) => '1111111111111111111111110010', | |
798 pack('C', 22) => '111111111111111111111111111110', | |
799 pack('C', 23) => '1111111111111111111111110011', | |
800 pack('C', 24) => '1111111111111111111111110100', | |
801 pack('C', 25) => '1111111111111111111111110101', | |
802 pack('C', 26) => '1111111111111111111111110110', | |
803 pack('C', 27) => '1111111111111111111111110111', | |
804 pack('C', 28) => '1111111111111111111111111000', | |
805 pack('C', 29) => '1111111111111111111111111001', | |
806 pack('C', 30) => '1111111111111111111111111010', | |
807 pack('C', 31) => '1111111111111111111111111011', | |
808 pack('C', 32) => '010100', | |
809 pack('C', 33) => '1111111000', | |
810 pack('C', 34) => '1111111001', | |
811 pack('C', 35) => '111111111010', | |
812 pack('C', 36) => '1111111111001', | |
813 pack('C', 37) => '010101', | |
814 pack('C', 38) => '11111000', | |
815 pack('C', 39) => '11111111010', | |
816 pack('C', 40) => '1111111010', | |
817 pack('C', 41) => '1111111011', | |
818 pack('C', 42) => '11111001', | |
819 pack('C', 43) => '11111111011', | |
820 pack('C', 44) => '11111010', | |
821 pack('C', 45) => '010110', | |
822 pack('C', 46) => '010111', | |
823 pack('C', 47) => '011000', | |
824 pack('C', 48) => '00000', | |
825 pack('C', 49) => '00001', | |
826 pack('C', 50) => '00010', | |
827 pack('C', 51) => '011001', | |
828 pack('C', 52) => '011010', | |
829 pack('C', 53) => '011011', | |
830 pack('C', 54) => '011100', | |
831 pack('C', 55) => '011101', | |
832 pack('C', 56) => '011110', | |
833 pack('C', 57) => '011111', | |
834 pack('C', 58) => '1011100', | |
835 pack('C', 59) => '11111011', | |
836 pack('C', 60) => '111111111111100', | |
837 pack('C', 61) => '100000', | |
838 pack('C', 62) => '111111111011', | |
839 pack('C', 63) => '1111111100', | |
840 pack('C', 64) => '1111111111010', | |
841 pack('C', 65) => '100001', | |
842 pack('C', 66) => '1011101', | |
843 pack('C', 67) => '1011110', | |
844 pack('C', 68) => '1011111', | |
845 pack('C', 69) => '1100000', | |
846 pack('C', 70) => '1100001', | |
847 pack('C', 71) => '1100010', | |
848 pack('C', 72) => '1100011', | |
849 pack('C', 73) => '1100100', | |
850 pack('C', 74) => '1100101', | |
851 pack('C', 75) => '1100110', | |
852 pack('C', 76) => '1100111', | |
853 pack('C', 77) => '1101000', | |
854 pack('C', 78) => '1101001', | |
855 pack('C', 79) => '1101010', | |
856 pack('C', 80) => '1101011', | |
857 pack('C', 81) => '1101100', | |
858 pack('C', 82) => '1101101', | |
859 pack('C', 83) => '1101110', | |
860 pack('C', 84) => '1101111', | |
861 pack('C', 85) => '1110000', | |
862 pack('C', 86) => '1110001', | |
863 pack('C', 87) => '1110010', | |
864 pack('C', 88) => '11111100', | |
865 pack('C', 89) => '1110011', | |
866 pack('C', 90) => '11111101', | |
867 pack('C', 91) => '1111111111011', | |
868 pack('C', 92) => '1111111111111110000', | |
869 pack('C', 93) => '1111111111100', | |
870 pack('C', 94) => '11111111111100', | |
871 pack('C', 95) => '100010', | |
872 pack('C', 96) => '111111111111101', | |
873 pack('C', 97) => '00011', | |
874 pack('C', 98) => '100011', | |
875 pack('C', 99) => '00100', | |
876 pack('C', 100) => '100100', | |
877 pack('C', 101) => '00101', | |
878 pack('C', 102) => '100101', | |
879 pack('C', 103) => '100110', | |
880 pack('C', 104) => '100111', | |
881 pack('C', 105) => '00110', | |
882 pack('C', 106) => '1110100', | |
883 pack('C', 107) => '1110101', | |
884 pack('C', 108) => '101000', | |
885 pack('C', 109) => '101001', | |
886 pack('C', 110) => '101010', | |
887 pack('C', 111) => '00111', | |
888 pack('C', 112) => '101011', | |
889 pack('C', 113) => '1110110', | |
890 pack('C', 114) => '101100', | |
891 pack('C', 115) => '01000', | |
892 pack('C', 116) => '01001', | |
893 pack('C', 117) => '101101', | |
894 pack('C', 118) => '1110111', | |
895 pack('C', 119) => '1111000', | |
896 pack('C', 120) => '1111001', | |
897 pack('C', 121) => '1111010', | |
898 pack('C', 122) => '1111011', | |
899 pack('C', 123) => '111111111111110', | |
900 pack('C', 124) => '11111111100', | |
901 pack('C', 125) => '11111111111101', | |
902 pack('C', 126) => '1111111111101', | |
903 pack('C', 127) => '1111111111111111111111111100', | |
904 pack('C', 128) => '11111111111111100110', | |
905 pack('C', 129) => '1111111111111111010010', | |
906 pack('C', 130) => '11111111111111100111', | |
907 pack('C', 131) => '11111111111111101000', | |
908 pack('C', 132) => '1111111111111111010011', | |
909 pack('C', 133) => '1111111111111111010100', | |
910 pack('C', 134) => '1111111111111111010101', | |
911 pack('C', 135) => '11111111111111111011001', | |
912 pack('C', 136) => '1111111111111111010110', | |
913 pack('C', 137) => '11111111111111111011010', | |
914 pack('C', 138) => '11111111111111111011011', | |
915 pack('C', 139) => '11111111111111111011100', | |
916 pack('C', 140) => '11111111111111111011101', | |
917 pack('C', 141) => '11111111111111111011110', | |
918 pack('C', 142) => '111111111111111111101011', | |
919 pack('C', 143) => '11111111111111111011111', | |
920 pack('C', 144) => '111111111111111111101100', | |
921 pack('C', 145) => '111111111111111111101101', | |
922 pack('C', 146) => '1111111111111111010111', | |
923 pack('C', 147) => '11111111111111111100000', | |
924 pack('C', 148) => '111111111111111111101110', | |
925 pack('C', 149) => '11111111111111111100001', | |
926 pack('C', 150) => '11111111111111111100010', | |
927 pack('C', 151) => '11111111111111111100011', | |
928 pack('C', 152) => '11111111111111111100100', | |
929 pack('C', 153) => '111111111111111011100', | |
930 pack('C', 154) => '1111111111111111011000', | |
931 pack('C', 155) => '11111111111111111100101', | |
932 pack('C', 156) => '1111111111111111011001', | |
933 pack('C', 157) => '11111111111111111100110', | |
934 pack('C', 158) => '11111111111111111100111', | |
935 pack('C', 159) => '111111111111111111101111', | |
936 pack('C', 160) => '1111111111111111011010', | |
937 pack('C', 161) => '111111111111111011101', | |
938 pack('C', 162) => '11111111111111101001', | |
939 pack('C', 163) => '1111111111111111011011', | |
940 pack('C', 164) => '1111111111111111011100', | |
941 pack('C', 165) => '11111111111111111101000', | |
942 pack('C', 166) => '11111111111111111101001', | |
943 pack('C', 167) => '111111111111111011110', | |
944 pack('C', 168) => '11111111111111111101010', | |
945 pack('C', 169) => '1111111111111111011101', | |
946 pack('C', 170) => '1111111111111111011110', | |
947 pack('C', 171) => '111111111111111111110000', | |
948 pack('C', 172) => '111111111111111011111', | |
949 pack('C', 173) => '1111111111111111011111', | |
950 pack('C', 174) => '11111111111111111101011', | |
951 pack('C', 175) => '11111111111111111101100', | |
952 pack('C', 176) => '111111111111111100000', | |
953 pack('C', 177) => '111111111111111100001', | |
954 pack('C', 178) => '1111111111111111100000', | |
955 pack('C', 179) => '111111111111111100010', | |
956 pack('C', 180) => '11111111111111111101101', | |
957 pack('C', 181) => '1111111111111111100001', | |
958 pack('C', 182) => '11111111111111111101110', | |
959 pack('C', 183) => '11111111111111111101111', | |
960 pack('C', 184) => '11111111111111101010', | |
961 pack('C', 185) => '1111111111111111100010', | |
962 pack('C', 186) => '1111111111111111100011', | |
963 pack('C', 187) => '1111111111111111100100', | |
964 pack('C', 188) => '11111111111111111110000', | |
965 pack('C', 189) => '1111111111111111100101', | |
966 pack('C', 190) => '1111111111111111100110', | |
967 pack('C', 191) => '11111111111111111110001', | |
968 pack('C', 192) => '11111111111111111111100000', | |
969 pack('C', 193) => '11111111111111111111100001', | |
970 pack('C', 194) => '11111111111111101011', | |
971 pack('C', 195) => '1111111111111110001', | |
972 pack('C', 196) => '1111111111111111100111', | |
973 pack('C', 197) => '11111111111111111110010', | |
974 pack('C', 198) => '1111111111111111101000', | |
975 pack('C', 199) => '1111111111111111111101100', | |
976 pack('C', 200) => '11111111111111111111100010', | |
977 pack('C', 201) => '11111111111111111111100011', | |
978 pack('C', 202) => '11111111111111111111100100', | |
979 pack('C', 203) => '111111111111111111111011110', | |
980 pack('C', 204) => '111111111111111111111011111', | |
981 pack('C', 205) => '11111111111111111111100101', | |
982 pack('C', 206) => '111111111111111111110001', | |
983 pack('C', 207) => '1111111111111111111101101', | |
984 pack('C', 208) => '1111111111111110010', | |
985 pack('C', 209) => '111111111111111100011', | |
986 pack('C', 210) => '11111111111111111111100110', | |
987 pack('C', 211) => '111111111111111111111100000', | |
988 pack('C', 212) => '111111111111111111111100001', | |
989 pack('C', 213) => '11111111111111111111100111', | |
990 pack('C', 214) => '111111111111111111111100010', | |
991 pack('C', 215) => '111111111111111111110010', | |
992 pack('C', 216) => '111111111111111100100', | |
993 pack('C', 217) => '111111111111111100101', | |
994 pack('C', 218) => '11111111111111111111101000', | |
995 pack('C', 219) => '11111111111111111111101001', | |
996 pack('C', 220) => '1111111111111111111111111101', | |
997 pack('C', 221) => '111111111111111111111100011', | |
998 pack('C', 222) => '111111111111111111111100100', | |
999 pack('C', 223) => '111111111111111111111100101', | |
1000 pack('C', 224) => '11111111111111101100', | |
1001 pack('C', 225) => '111111111111111111110011', | |
1002 pack('C', 226) => '11111111111111101101', | |
1003 pack('C', 227) => '111111111111111100110', | |
1004 pack('C', 228) => '1111111111111111101001', | |
1005 pack('C', 229) => '111111111111111100111', | |
1006 pack('C', 230) => '111111111111111101000', | |
1007 pack('C', 231) => '11111111111111111110011', | |
1008 pack('C', 232) => '1111111111111111101010', | |
1009 pack('C', 233) => '1111111111111111101011', | |
1010 pack('C', 234) => '1111111111111111111101110', | |
1011 pack('C', 235) => '1111111111111111111101111', | |
1012 pack('C', 236) => '111111111111111111110100', | |
1013 pack('C', 237) => '111111111111111111110101', | |
1014 pack('C', 238) => '11111111111111111111101010', | |
1015 pack('C', 239) => '11111111111111111110100', | |
1016 pack('C', 240) => '11111111111111111111101011', | |
1017 pack('C', 241) => '111111111111111111111100110', | |
1018 pack('C', 242) => '11111111111111111111101100', | |
1019 pack('C', 243) => '11111111111111111111101101', | |
1020 pack('C', 244) => '111111111111111111111100111', | |
1021 pack('C', 245) => '111111111111111111111101000', | |
1022 pack('C', 246) => '111111111111111111111101001', | |
1023 pack('C', 247) => '111111111111111111111101010', | |
1024 pack('C', 248) => '111111111111111111111101011', | |
1025 pack('C', 249) => '1111111111111111111111111110', | |
1026 pack('C', 250) => '111111111111111111111101100', | |
1027 pack('C', 251) => '111111111111111111111101101', | |
1028 pack('C', 252) => '111111111111111111111101110', | |
1029 pack('C', 253) => '111111111111111111111101111', | |
1030 pack('C', 254) => '111111111111111111111110000', | |
1031 pack('C', 255) => '11111111111111111111101110', | |
1032 '_eos' => '111111111111111111111111111111', | |
1033 }}; | |
1034 | |
1035 sub huff { | |
1036 my ($string) = @_; | |
1037 my $code = &huff_code; | |
1038 | |
1039 my $ret = join '', map { $code->{$_} } (split //, $string); | |
1040 my $len = length($ret) + (8 - length($ret) % 8); | |
1041 $ret .= $code->{_eos}; | |
1042 | |
1043 return pack("B$len", $ret); | |
1044 } | |
1045 | |
1046 sub dehuff { | |
1047 my ($string) = @_; | |
1048 my $code = &huff_code; | |
1049 my %decode = reverse %$code; | |
1050 | |
1051 my $ret = ''; my $c = ''; | |
1052 for (split //, unpack('B*', $string)) { | |
1053 $c .= $_; | |
1054 next unless exists $decode{$c}; | |
1055 last if $decode{$c} eq '_eos'; | |
1056 | |
1057 $ret .= $decode{$c}; | |
1058 $c = ''; | |
1059 } | |
1060 | |
1061 return $ret; | |
1062 } | |
1063 | |
1064 ############################################################################### | |
1065 | |
1066 1; | |
1067 | |
1068 ############################################################################### |