Mercurial > hg > nginx-tests

comparison lib/Test/Nginx/HTTP2.pm @ 876:a6abbfed42c0

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
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 ###############################################################################