package Test::Nginx::HTTP2;

# (C) Sergey Kandaurov
# (C) Nginx, Inc.

# Module for nginx HTTP/2 tests.

###############################################################################

use warnings;
use strict;

use base qw/ Exporter /;
our @EXPORT = qw/ new_session new_stream h2_read /;
our %EXPORT_TAGS = (
	io => [ qw/ raw_write raw_read / ],
	frame => [ qw/ h2_ping h2_rst h2_goaway h2_priority h2_window
		h2_settings h2_unknown h2_continue h2_body/ ]
);
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'io'} }, @{ $EXPORT_TAGS{'frame'} } );

use Test::More qw//;
use IO::Select;
use IO::Socket;
use Socket qw/ CRLF /;
use Data::Dumper;

use Test::Nginx;

my %cframe = (
	0 => { name => 'DATA', value => \&data },
	1 => { name => 'HEADERS', value => \&headers },
#	2 => { name => 'PRIORITY', value => \&priority },
	3 => { name => 'RST_STREAM', value => \&rst_stream },
	4 => { name => 'SETTINGS', value => \&settings },
#	5 => { name => 'PUSH_PROMISE', value => \&push_promise },
	6 => { name => 'PING', value => \&ping },
	7 => { name => 'GOAWAY', value => \&goaway },
	8 => { name => 'WINDOW_UPDATE', value => \&window_update },
	9 => { name => 'CONTINUATION', value => \&headers },
);

sub h2_ping {
	my ($sess, $payload) = @_;

	raw_write($sess->{socket}, pack("x2C2x5a8", 8, 0x6, $payload));
}

sub h2_rst {
	my ($sess, $stream, $error) = @_;

	raw_write($sess->{socket}, pack("x2C2xNN", 4, 0x3, $stream, $error));
}

sub h2_goaway {
	my ($sess, $stream, $lstream, $err, $debug, %extra) = @_;
	$debug = '' unless defined $debug;
	my $len = defined $extra{len} ? $extra{len} : 8 + length($debug);
	my $buf = pack("x2C2xN3A*", $len, 0x7, $stream, $lstream, $err, $debug);

	my @bufs = map {
		raw_write($sess->{socket}, substr $buf, 0, $_, "");
		select undef, undef, undef, 0.4;
	} @{$extra{split}};

	raw_write($sess->{socket}, $buf);
}

sub h2_priority {
	my ($sess, $w, $stream, $dep, %extra) = @_;

	$stream = 0 unless defined $stream;
	$dep = 0 unless defined $dep;
	$dep |= $extra{excl} << 31 if exists $extra{excl};
	raw_write($sess->{socket}, pack("x2C2xNNC", 5, 0x2, $stream, $dep, $w));
}

sub h2_window {
	my ($sess, $win, $stream) = @_;

	$stream = 0 unless defined $stream;
	raw_write($sess->{socket}, pack("x2C2xNN", 4, 0x8, $stream, $win));
}

sub h2_settings {
	my ($sess, $ack, %extra) = @_;

	my $len = 6 * keys %extra;
	my $buf = pack_length($len) . pack "CCx4", 0x4, $ack ? 0x1 : 0x0;
	$buf .= join '', map { pack "nN", $_, $extra{$_} } keys %extra;
	raw_write($sess->{socket}, $buf);
}

sub h2_unknown {
	my ($sess, $payload) = @_;

	my $buf = pack_length(length($payload)) . pack("Cx5a*", 0xa, $payload);
	raw_write($sess->{socket}, $buf);
}

sub h2_continue {
	my ($ctx, $stream, $uri) = @_;

	$uri->{h2_continue} = 1;
	return new_stream($ctx, $uri, $stream);
}

sub h2_body {
	my ($sess, $body, $extra) = @_;
	$extra = {} unless defined $extra;

	my $len = length $body;
	my $sid = $sess->{last_stream};

	if ($len > $sess->{conn_window} || $len > $sess->{streams}{$sid}) {
		h2_read($sess, all => [{ type => 'WINDOW_UPDATE' }]);
	}

	if ($len > $sess->{conn_window} || $len > $sess->{streams}{$sid}) {
		return;
	}

	$sess->{conn_window} -= $len;
	$sess->{streams}{$sid} -= $len;

	my $buf;

	my $split = ref $extra->{body_split} && $extra->{body_split} || [];
	for (@$split) {
		$buf .= pack_body($sess, substr($body, 0, $_, ""), 0x0, $extra);
	}

	$buf .= pack_body($sess, $body, 0x1, $extra) if defined $body;

	$split = ref $extra->{split} && $extra->{split} || [];
	for (@$split) {
		raw_write($sess->{socket}, substr($buf, 0, $_, ""));
		return if $extra->{abort};
		select undef, undef, undef, ($extra->{split_delay} || 0.2);
	}

	raw_write($sess->{socket}, $buf);
}

sub pack_body {
	my ($ctx, $body, $flags, $extra) = @_;

	my $pad = defined $extra->{body_padding} ? $extra->{body_padding} : 0;
	my $padlen = defined $extra->{body_padding} ? 1 : 0;

	my $buf = pack_length(length($body) + $pad + $padlen);
	$flags |= 0x8 if $padlen;
	vec($flags, 0, 1) = 0 if $extra->{body_more};
	$buf .= pack 'CC', 0x0, $flags;		# DATA, END_STREAM
	$buf .= pack 'N', $ctx->{last_stream};
	$buf .= pack 'C', $pad if $padlen;	# DATA Pad Length?
	$buf .= $body;
	$buf .= pack "x$pad" if $padlen;	# DATA Padding
	return $buf;
}

sub new_stream {
	my ($ctx, $uri, $stream) = @_;
	my ($input, $buf);
	my ($d, $status);

	$ctx->{headers} = '';

	my $host = $uri->{host} || 'localhost';
	my $method = $uri->{method} || 'GET';
	my $scheme = $uri->{scheme} || 'http';
	my $path = $uri->{path} || '/';
	my $headers = $uri->{headers};
	my $body = $uri->{body};
	my $prio = $uri->{prio};
	my $dep = $uri->{dep};

	my $pad = defined $uri->{padding} ? $uri->{padding} : 0;
	my $padlen = defined $uri->{padding} ? 1 : 0;

	my $type = defined $uri->{h2_continue} ? 0x9 : 0x1;
	my $flags = defined $uri->{continuation} ? 0x0 : 0x4;
	$flags |= 0x1 unless defined $body || defined $uri->{body_more};
	$flags |= 0x8 if $padlen;
	$flags |= 0x20 if defined $dep || defined $prio;

	if ($stream) {
		$ctx->{last_stream} = $stream;
	} else {
		$ctx->{last_stream} += 2;
		$ctx->{streams}{$ctx->{last_stream}} = $ctx->{iws};
	}

	$buf = pack("xxx");			# Length stub
	$buf .= pack("CC", $type, $flags);	# END_HEADERS
	$buf .= pack("N", $ctx->{last_stream});	# Stream-ID

	$dep = 0 if defined $prio and not defined $dep;
	$prio = 16 if defined $dep and not defined $prio;

	unless ($headers) {
		$input = hpack($ctx, ":method", $method);
		$input .= hpack($ctx, ":scheme", $scheme);
		$input .= hpack($ctx, ":path", $path);
		$input .= hpack($ctx, ":authority", $host);
		$input .= hpack($ctx, "content-length", length($body)) if $body;

	} else {
		$input = join '', map {
			hpack($ctx, $_->{name}, $_->{value},
			mode => $_->{mode}, huff => $_->{huff})
		} @$headers if $headers;
	}

	$input = pack("B*", '001' . ipack(5, $uri->{table_size})) . $input
		if defined $uri->{table_size};

	my $split = ref $uri->{continuation} && $uri->{continuation} || [];
	my @input = map { substr $input, 0, $_, "" } @$split;
	push @input, $input;

	# set length, attach headers, padding, priority

	my $hlen = length($input[0]) + $pad + $padlen;
	$hlen += 5 if $flags & 0x20;
	$buf |= pack_length($hlen);

	$buf .= pack 'C', $pad if $padlen;		# Pad Length?
	$buf .= pack 'NC', $dep, $prio if $flags & 0x20;
	$buf .= $input[0];
	$buf .= (pack 'C', 0) x $pad if $padlen;	# Padding

	shift @input;

	while (@input) {
		$input = shift @input;
		$flags = @input ? 0x0 : 0x4;
		$buf .= pack_length(length($input));
		$buf .= pack("CC", 0x9, $flags);
		$buf .= pack("N", $ctx->{last_stream});
		$buf .= $input;
	}

	$split = ref $uri->{body_split} && $uri->{body_split} || [];
	for (@$split) {
		$buf .= pack_body($ctx, substr($body, 0, $_, ""), 0x0, $uri);
	}

	$buf .= pack_body($ctx, $body, 0x1, $uri) if defined $body;

	$split = ref $uri->{split} && $uri->{split} || [];
	for (@$split) {
		raw_write($ctx->{socket}, substr($buf, 0, $_, ""));
		goto done if $uri->{abort};
		select undef, undef, undef, ($uri->{split_delay} || 0.2);
	}

	raw_write($ctx->{socket}, $buf);
done:
	return $ctx->{last_stream};
}

sub h2_read {
	my ($sess, %extra) = @_;
	my (@got);
	my $s = $sess->{socket};
	my $buf = '';

	local $Data::Dumper::Terse = 1;

	while (1) {
		$buf = raw_read($s, $buf, 9);
		last if length $buf < 9;

		my $length = unpack_length($buf);
		my $type = unpack('x3C', $buf);
		my $flags = unpack('x4C', $buf);

		my $stream = unpack "x5 B32", $buf;
		substr($stream, 0, 1) = 0;
		$stream = unpack("N", pack("B32", $stream));

		$buf = raw_read($s, $buf, $length + 9);
		last if length($buf) < $length + 9;

		$buf = substr($buf, 9);

		my $frame = $cframe{$type}{value}($sess, $buf, $length, $flags,
			$stream);
		$frame->{length} = $length;
		$frame->{type} = $cframe{$type}{name};
		$frame->{flags} = $flags;
		$frame->{sid} = $stream;
		push @got, $frame;

		Test::Nginx::log_core('||', $_) for split "\n", Dumper $frame;

		$buf = substr($buf, $length);

		last unless $extra{all} && test_fin($got[-1], $extra{all});
	};
	return \@got;
}

sub test_fin {
	my ($frame, $all) = @_;
	my @test = @{$all};

	# wait for the specified DATA length

	for (@test) {
		if ($_->{length} && $frame->{type} eq 'DATA') {
			# check also for StreamID if needed

			if (!$_->{sid} || $_->{sid} == $frame->{sid}) {
				$_->{length} -= $frame->{length};
			}
		}
	}
	@test = grep { !(defined $_->{length} && $_->{length} == 0) } @test;

	# wait for the fin flag

	@test = grep { !(defined $_->{fin}
		&& $_->{sid} == $frame->{sid} && $_->{fin} & $frame->{flags})
	} @test if defined $frame->{flags};

	# wait for the specified frame

	@test = grep { !($_->{type} && $_->{type} eq $frame->{type}) } @test;

	@{$all} = @test;
}

sub headers {
	my ($ctx, $buf, $len, $flags) = @_;
	$ctx->{headers} .= substr($buf, 0, $len);
	return unless $flags & 0x4;
	{ headers => hunpack($ctx, $ctx->{headers}, length($ctx->{headers})) };
}

sub data {
	my ($ctx, $buf, $len) = @_;
	return { data => substr($buf, 0, $len) };
}

sub settings {
	my ($ctx, $buf, $len) = @_;
	my %payload;
	my $skip = 0;

	for (1 .. $len / 6) {
		my $id = hex unpack "\@$skip n", $buf; $skip += 2;
		$payload{$id} = unpack "\@$skip N", $buf; $skip += 4;

		$ctx->{iws} = $payload{$id} if $id == 4;
	}
	return \%payload;
}

sub ping {
	my ($ctx, $buf, $len) = @_;
	return { value => unpack "A$len", $buf };
}

sub rst_stream {
	my ($ctx, $buf, $len) = @_;
	return { code => unpack "N", $buf };
}

sub goaway {
	my ($ctx, $buf, $len) = @_;
	my %payload;

	my $stream = unpack "B32", $buf;
	substr($stream, 0, 1) = 0;
	$stream = unpack("N", pack("B32", $stream));
	$payload{last_sid} = $stream;

	$len -= 4;
	$payload{code} = unpack "x4 N", $buf;
	$payload{debug} = unpack "x8 A$len", $buf;
	return \%payload;
}

sub window_update {
	my ($ctx, $buf, $len, $flags, $sid) = @_;
	my $value = unpack "B32", $buf;
	substr($value, 0, 1) = 0;
	$value = unpack("N", pack("B32", $value));

	unless ($sid) {
		$ctx->{conn_window} += $value;

	} else {
		$ctx->{streams}{$sid} = $ctx->{iws}
			unless defined $ctx->{streams}{$sid};
		$ctx->{streams}{$sid} += $value;
	}

	return { wdelta => $value };
}

sub pack_length {
	pack 'c3', unpack 'xc3', pack 'N', $_[0];
}

sub unpack_length {
	unpack 'N', pack 'xc3', unpack 'c3', $_[0];
}

sub raw_read {
	my ($s, $buf, $len, $log) = @_;
	$log = \&log_in unless defined $log;
	my $got = '';

	while (length($buf) < $len && IO::Select->new($s)->can_read(1))  {
		$s->sysread($got, 16384) or last;
		$log->($got);
		$buf .= $got;
	}
	return $buf;
}

sub raw_write {
	my ($s, $message) = @_;

	local $SIG{PIPE} = 'IGNORE';

	while (IO::Select->new($s)->can_write(0.4)) {
		log_out($message);
		my $n = $s->syswrite($message);
		last unless $n;
		$message = substr($message, $n);
		last unless length $message;
	}
}

sub new_session {
	my ($port, %extra) = @_;

	my $s = $extra{socket} || new_socket($port, %extra);
	my $preface = $extra{preface}
		|| 'PRI * HTTP/2.0' . CRLF . CRLF . 'SM' . CRLF . CRLF;

	if ($extra{proxy}) {
		raw_write($s, $extra{proxy});
	}

	# preface

	raw_write($s, $preface);

	my $ctx = { socket => $s, last_stream => -1,
		dynamic_encode => [ static_table() ],
		dynamic_decode => [ static_table() ],
		static_table_size => scalar @{[static_table()]},
		iws => 65535, conn_window => 65535, streams => {}};

	return $ctx if $extra{pure};

	# update windows, if any

	my $frames = h2_read($ctx, all => [
		{ type => 'WINDOW_UPDATE' },
		{ type => 'SETTINGS'}
	]);

	# 6.5.3.  Settings Synchronization

	if (grep { $_->{type} eq "SETTINGS" && $_->{flags} == 0 } @$frames) {
		h2_settings($ctx, 1);
	}

	return $ctx;
}

sub new_socket {
	my ($port, %extra) = @_;
	my $npn = $extra{'npn'};
	my $alpn = $extra{'alpn'};
	my $s;

	$port = 8080 unless defined $port;

	eval {
		local $SIG{ALRM} = sub { die "timeout\n" };
		local $SIG{PIPE} = sub { die "sigpipe\n" };
		alarm(2);
		$s = IO::Socket::INET->new(
			Proto => 'tcp',
			PeerAddr => "127.0.0.1:$port",
		);
		require IO::Socket::SSL if $extra{'SSL'};
		IO::Socket::SSL->start_SSL($s,
			SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_NONE(),
			SSL_npn_protocols => $npn ? [ $npn ] : undef,
			SSL_alpn_protocols => $alpn ? [ $alpn ] : undef,
			SSL_error_trap => sub { die $_[1] }
		) if $extra{'SSL'};
		alarm(0);
	};
	alarm(0);

	if ($@) {
		log_in("died: $@");
		return undef;
	}

	return $s;
}

sub static_table {
	[ '',			''		], # unused
	[ ':authority',		''		],
	[ ':method',		'GET'		],
	[ ':method',		'POST'		],
	[ ':path',		'/'		],
	[ ':path',		'/index.html'	],
	[ ':scheme',		'http'		],
	[ ':scheme',		'https'		],
	[ ':status',		'200'		],
	[ ':status',		'204'		],
	[ ':status',		'206'		],
	[ ':status',		'304'		],
	[ ':status',		'400'		],
	[ ':status',		'404'		],
	[ ':status',		'500'		],
	[ 'accept-charset',	''		],
	[ 'accept-encoding',	'gzip, deflate'	],
	[ 'accept-language',	''		],
	[ 'accept-ranges',	''		],
	[ 'accept',		''		],
	[ 'access-control-allow-origin',
				''		],
	[ 'age',		''		],
	[ 'allow',		''		],
	[ 'authorization',	''		],
	[ 'cache-control',	''		],
	[ 'content-disposition',
				''		],
	[ 'content-encoding',	''		],
	[ 'content-language',	''		],
	[ 'content-length',	''		],
	[ 'content-location',	''		],
	[ 'content-range',	''		],
	[ 'content-type',	''		],
	[ 'cookie',		''		],
	[ 'date',		''		],
	[ 'etag',		''		],
	[ 'expect',		''		],
	[ 'expires',		''		],
	[ 'from',		''		],
	[ 'host',		''		],
	[ 'if-match',		''		],
	[ 'if-modified-since',	''		],
	[ 'if-none-match',	''		],
	[ 'if-range',		''		],
	[ 'if-unmodified-since',
				''		],
	[ 'last-modified',	''		],
	[ 'link',		''		],
	[ 'location',		''		],
	[ 'max-forwards',	''		],
	[ 'proxy-authenticate',	''		],
	[ 'proxy-authorization',
				''		],
	[ 'range',		''		],
	[ 'referer',		''		],
	[ 'refresh',		''		],
	[ 'retry-after',	''		],
	[ 'server',		''		],
	[ 'set-cookie',		''		],
	[ 'strict-transport-security',
				''		],
	[ 'transfer-encoding',	''		],
	[ 'user-agent',		''		],
	[ 'vary',		''		],
	[ 'via',		''		],
	[ 'www-authenticate',	''		],
}

# RFC 7541, 5.1.  Integer Representation

sub ipack {
	my ($base, $d) = @_;
	return sprintf("%.*b", $base, $d) if $d < 2**$base - 1;

	my $o = sprintf("%${base}b", 2**$base - 1);
	$d -= 2**$base - 1;
	while ($d >= 128) {
		$o .= sprintf("%8b", $d % 128 + 128);
		$d /= 128;
	}
	$o .= sprintf("%08b", $d);
	return $o;
}

sub iunpack {
	my ($base, $b, $s) = @_;

	my $len = unpack("\@$s B8", $b); $s++;
	my $prefix = substr($len, 0, 8 - $base);
	$len = '0' x (8 - $base) . substr($len, 8 - $base);
	$len = unpack("C", pack("B8", $len));

	return ($len, $s, $prefix) if $len < 2**$base - 1;

	my $m = 0;
	my $d;

	do {
		$d = unpack("\@$s C", $b); $s++;
		$len += ($d & 127) * 2**$m;
		$m += $base;
	} while (($d & 128) == 128);

	return ($len, $s, $prefix);
}

sub hpack {
	my ($ctx, $name, $value, %extra) = @_;
	my $table = $ctx->{dynamic_encode};
	my $mode = defined $extra{mode} ? $extra{mode} : 1;
	my $huff = $extra{huff};

	my ($index, $buf) = 0;

	# 6.1.  Indexed Header Field Representation

	if ($mode == 0) {
		++$index until $index > $#$table
			or $table->[$index][0] eq $name
			and $table->[$index][1] eq $value;
		$buf = pack('B*', '1' . ipack(7, $index));
	}

	# 6.2.1.  Literal Header Field with Incremental Indexing

	if ($mode == 1) {
		splice @$table, $ctx->{static_table_size}, 0, [ $name, $value ];

		++$index until $index > $#$table
			or $table->[$index][0] eq $name;
		my $value = $huff ? huff($value) : $value;

		$buf = pack('B*', '01' . ipack(6, $index)
			. ($huff ? '1' : '0') . ipack(7, length($value)));
		$buf .= $value;
	}

	# 6.2.1.  Literal Header Field with Incremental Indexing -- New Name

	if ($mode == 2) {
		splice @$table, $ctx->{static_table_size}, 0, [ $name, $value ];

		my $name = $huff ? huff($name) : $name;
		my $value = $huff ? huff($value) : $value;
		my $hbit = ($huff ? '1' : '0');

		$buf = pack('B*', '01000000');
		$buf .= pack('B*', $hbit . ipack(7, length($name)));
		$buf .= $name;
		$buf .= pack('B*', $hbit . ipack(7, length($value)));
		$buf .= $value;
	}

	# 6.2.2.  Literal Header Field without Indexing

	if ($mode == 3) {
		++$index until $index > $#$table
			or $table->[$index][0] eq $name;
		my $value = $huff ? huff($value) : $value;

		$buf = pack('B*', '0000' . ipack(4, $index)
			. ($huff ? '1' : '0') . ipack(7, length($value)));
		$buf .= $value;
	}

	# 6.2.2.  Literal Header Field without Indexing -- New Name

	if ($mode == 4) {
		my $name = $huff ? huff($name) : $name;
		my $value = $huff ? huff($value) : $value;
		my $hbit = ($huff ? '1' : '0');

		$buf = pack('B*', '00000000');
		$buf .= pack('B*', $hbit . ipack(7, length($name)));
		$buf .= $name;
		$buf .= pack('B*', $hbit . ipack(7, length($value)));
		$buf .= $value;
	}

	# 6.2.3.  Literal Header Field Never Indexed

	if ($mode == 5) {
		++$index until $index > $#$table
			or $table->[$index][0] eq $name;
		my $value = $huff ? huff($value) : $value;

		$buf = pack('B*', '0001' . ipack(4, $index)
			. ($huff ? '1' : '0') . ipack(7, length($value)));
		$buf .= $value;
	}

	# 6.2.3.  Literal Header Field Never Indexed -- New Name

	if ($mode == 6) {
		my $name = $huff ? huff($name) : $name;
		my $value = $huff ? huff($value) : $value;
		my $hbit = ($huff ? '1' : '0');

		$buf = pack('B*', '00010000');
		$buf .= pack('B*', $hbit . ipack(7, length($name)));
		$buf .= $name;
		$buf .= pack('B*', $hbit . ipack(7, length($value)));
		$buf .= $value;
	}

	return $buf;
}

sub hunpack {
	my ($ctx, $data, $length) = @_;
	my $table = $ctx->{dynamic_decode};
	my %headers;
	my $skip = 0;
	my ($index, $name, $value);

	my $field = sub {
		my ($b) = @_;
		my ($len, $s, $huff) = iunpack(7, @_);

		my $field = substr($b, $s, $len);
		$field = $huff ? dehuff($field) : $field;
		$s += $len;
		return ($field, $s);
	};

	my $add = sub {
		my ($h, $n, $v) = @_;
		return $h->{$n} = $v unless exists $h->{$n};
		$h->{$n} = [ $h->{$n} ] unless ref $h->{$n};
		push @{$h->{$n}}, $v;
	};

	while ($skip < $length) {
		my $ib = unpack("\@$skip B8", $data);

		if (substr($ib, 0, 1) eq '1') {
			($index, $skip) = iunpack(7, $data, $skip);
			$add->(\%headers,
				$table->[$index][0], $table->[$index][1]);
			next;
		}

		if (substr($ib, 0, 2) eq '01') {
			($index, $skip) = iunpack(6, $data, $skip);
			$name = $table->[$index][0];

			($name, $skip) = $field->($data, $skip) unless $name;
			($value, $skip) = $field->($data, $skip);

			splice @$table,
				$ctx->{static_table_size}, 0, [ $name, $value ];
			$add->(\%headers, $name, $value);
			next;
		}

		if (substr($ib, 0, 4) eq '0000') {
			($index, $skip) = iunpack(4, $data, $skip);
			$name = $table->[$index][0];

			($name, $skip) = $field->($data, $skip) unless $name;
			($value, $skip) = $field->($data, $skip);

			$add->(\%headers, $name, $value);
			next;
		}
		last;
	}

	return \%headers;
}

sub huff_code { scalar {
	pack('C', 0)	=> '1111111111000',
	pack('C', 1)	=> '11111111111111111011000',
	pack('C', 2)	=> '1111111111111111111111100010',
	pack('C', 3)	=> '1111111111111111111111100011',
	pack('C', 4)	=> '1111111111111111111111100100',
	pack('C', 5)	=> '1111111111111111111111100101',
	pack('C', 6)	=> '1111111111111111111111100110',
	pack('C', 7)	=> '1111111111111111111111100111',
	pack('C', 8)	=> '1111111111111111111111101000',
	pack('C', 9)	=> '111111111111111111101010',
	pack('C', 10)	=> '111111111111111111111111111100',
	pack('C', 11)	=> '1111111111111111111111101001',
	pack('C', 12)	=> '1111111111111111111111101010',
	pack('C', 13)	=> '111111111111111111111111111101',
	pack('C', 14)	=> '1111111111111111111111101011',
	pack('C', 15)	=> '1111111111111111111111101100',
	pack('C', 16)	=> '1111111111111111111111101101',
	pack('C', 17)	=> '1111111111111111111111101110',
	pack('C', 18)	=> '1111111111111111111111101111',
	pack('C', 19)	=> '1111111111111111111111110000',
	pack('C', 20)	=> '1111111111111111111111110001',
	pack('C', 21)	=> '1111111111111111111111110010',
	pack('C', 22)	=> '111111111111111111111111111110',
	pack('C', 23)	=> '1111111111111111111111110011',
	pack('C', 24)	=> '1111111111111111111111110100',
	pack('C', 25)	=> '1111111111111111111111110101',
	pack('C', 26)	=> '1111111111111111111111110110',
	pack('C', 27)	=> '1111111111111111111111110111',
	pack('C', 28)	=> '1111111111111111111111111000',
	pack('C', 29)	=> '1111111111111111111111111001',
	pack('C', 30)	=> '1111111111111111111111111010',
	pack('C', 31)	=> '1111111111111111111111111011',
	pack('C', 32)	=> '010100',
	pack('C', 33)	=> '1111111000',
	pack('C', 34)	=> '1111111001',
	pack('C', 35)	=> '111111111010',
	pack('C', 36)	=> '1111111111001',
	pack('C', 37)	=> '010101',
	pack('C', 38)	=> '11111000',
	pack('C', 39)	=> '11111111010',
	pack('C', 40)	=> '1111111010',
	pack('C', 41)	=> '1111111011',
	pack('C', 42)	=> '11111001',
	pack('C', 43)	=> '11111111011',
	pack('C', 44)	=> '11111010',
	pack('C', 45)	=> '010110',
	pack('C', 46)	=> '010111',
	pack('C', 47)	=> '011000',
	pack('C', 48)	=> '00000',
	pack('C', 49)	=> '00001',
	pack('C', 50)	=> '00010',
	pack('C', 51)	=> '011001',
	pack('C', 52)	=> '011010',
	pack('C', 53)	=> '011011',
	pack('C', 54)	=> '011100',
	pack('C', 55)	=> '011101',
	pack('C', 56)	=> '011110',
	pack('C', 57)	=> '011111',
	pack('C', 58)	=> '1011100',
	pack('C', 59)	=> '11111011',
	pack('C', 60)	=> '111111111111100',
	pack('C', 61)	=> '100000',
	pack('C', 62)	=> '111111111011',
	pack('C', 63)	=> '1111111100',
	pack('C', 64)	=> '1111111111010',
	pack('C', 65)	=> '100001',
	pack('C', 66)	=> '1011101',
	pack('C', 67)	=> '1011110',
	pack('C', 68)	=> '1011111',
	pack('C', 69)	=> '1100000',
	pack('C', 70)	=> '1100001',
	pack('C', 71)	=> '1100010',
	pack('C', 72)	=> '1100011',
	pack('C', 73)	=> '1100100',
	pack('C', 74)	=> '1100101',
	pack('C', 75)	=> '1100110',
	pack('C', 76)	=> '1100111',
	pack('C', 77)	=> '1101000',
	pack('C', 78)	=> '1101001',
	pack('C', 79)	=> '1101010',
	pack('C', 80)	=> '1101011',
	pack('C', 81)	=> '1101100',
	pack('C', 82)	=> '1101101',
	pack('C', 83)	=> '1101110',
	pack('C', 84)	=> '1101111',
	pack('C', 85)	=> '1110000',
	pack('C', 86)	=> '1110001',
	pack('C', 87)	=> '1110010',
	pack('C', 88)	=> '11111100',
	pack('C', 89)	=> '1110011',
	pack('C', 90)	=> '11111101',
	pack('C', 91)	=> '1111111111011',
	pack('C', 92)	=> '1111111111111110000',
	pack('C', 93)	=> '1111111111100',
	pack('C', 94)	=> '11111111111100',
	pack('C', 95)	=> '100010',
	pack('C', 96)	=> '111111111111101',
	pack('C', 97)	=> '00011',
	pack('C', 98)	=> '100011',
	pack('C', 99)	=> '00100',
	pack('C', 100)	=> '100100',
	pack('C', 101)	=> '00101',
	pack('C', 102)	=> '100101',
	pack('C', 103)	=> '100110',
	pack('C', 104)	=> '100111',
	pack('C', 105)	=> '00110',
	pack('C', 106)	=> '1110100',
	pack('C', 107)	=> '1110101',
	pack('C', 108)	=> '101000',
	pack('C', 109)	=> '101001',
	pack('C', 110)	=> '101010',
	pack('C', 111)	=> '00111',
	pack('C', 112)	=> '101011',
	pack('C', 113)	=> '1110110',
	pack('C', 114)	=> '101100',
	pack('C', 115)	=> '01000',
	pack('C', 116)	=> '01001',
	pack('C', 117)	=> '101101',
	pack('C', 118)	=> '1110111',
	pack('C', 119)	=> '1111000',
	pack('C', 120)	=> '1111001',
	pack('C', 121)	=> '1111010',
	pack('C', 122)	=> '1111011',
	pack('C', 123)	=> '111111111111110',
	pack('C', 124)	=> '11111111100',
	pack('C', 125)	=> '11111111111101',
	pack('C', 126)	=> '1111111111101',
	pack('C', 127)	=> '1111111111111111111111111100',
	pack('C', 128)	=> '11111111111111100110',
	pack('C', 129)	=> '1111111111111111010010',
	pack('C', 130)	=> '11111111111111100111',
	pack('C', 131)	=> '11111111111111101000',
	pack('C', 132)	=> '1111111111111111010011',
	pack('C', 133)	=> '1111111111111111010100',
	pack('C', 134)	=> '1111111111111111010101',
	pack('C', 135)	=> '11111111111111111011001',
	pack('C', 136)	=> '1111111111111111010110',
	pack('C', 137)	=> '11111111111111111011010',
	pack('C', 138)	=> '11111111111111111011011',
	pack('C', 139)	=> '11111111111111111011100',
	pack('C', 140)	=> '11111111111111111011101',
	pack('C', 141)	=> '11111111111111111011110',
	pack('C', 142)	=> '111111111111111111101011',
	pack('C', 143)	=> '11111111111111111011111',
	pack('C', 144)	=> '111111111111111111101100',
	pack('C', 145)	=> '111111111111111111101101',
	pack('C', 146)	=> '1111111111111111010111',
	pack('C', 147)	=> '11111111111111111100000',
	pack('C', 148)	=> '111111111111111111101110',
	pack('C', 149)	=> '11111111111111111100001',
	pack('C', 150)	=> '11111111111111111100010',
	pack('C', 151)	=> '11111111111111111100011',
	pack('C', 152)	=> '11111111111111111100100',
	pack('C', 153)	=> '111111111111111011100',
	pack('C', 154)	=> '1111111111111111011000',
	pack('C', 155)	=> '11111111111111111100101',
	pack('C', 156)	=> '1111111111111111011001',
	pack('C', 157)	=> '11111111111111111100110',
	pack('C', 158)	=> '11111111111111111100111',
	pack('C', 159)	=> '111111111111111111101111',
	pack('C', 160)	=> '1111111111111111011010',
	pack('C', 161)	=> '111111111111111011101',
	pack('C', 162)	=> '11111111111111101001',
	pack('C', 163)	=> '1111111111111111011011',
	pack('C', 164)	=> '1111111111111111011100',
	pack('C', 165)	=> '11111111111111111101000',
	pack('C', 166)	=> '11111111111111111101001',
	pack('C', 167)	=> '111111111111111011110',
	pack('C', 168)	=> '11111111111111111101010',
	pack('C', 169)	=> '1111111111111111011101',
	pack('C', 170)	=> '1111111111111111011110',
	pack('C', 171)	=> '111111111111111111110000',
	pack('C', 172)	=> '111111111111111011111',
	pack('C', 173)	=> '1111111111111111011111',
	pack('C', 174)	=> '11111111111111111101011',
	pack('C', 175)	=> '11111111111111111101100',
	pack('C', 176)	=> '111111111111111100000',
	pack('C', 177)	=> '111111111111111100001',
	pack('C', 178)	=> '1111111111111111100000',
	pack('C', 179)	=> '111111111111111100010',
	pack('C', 180)	=> '11111111111111111101101',
	pack('C', 181)	=> '1111111111111111100001',
	pack('C', 182)	=> '11111111111111111101110',
	pack('C', 183)	=> '11111111111111111101111',
	pack('C', 184)	=> '11111111111111101010',
	pack('C', 185)	=> '1111111111111111100010',
	pack('C', 186)	=> '1111111111111111100011',
	pack('C', 187)	=> '1111111111111111100100',
	pack('C', 188)	=> '11111111111111111110000',
	pack('C', 189)	=> '1111111111111111100101',
	pack('C', 190)	=> '1111111111111111100110',
	pack('C', 191)	=> '11111111111111111110001',
	pack('C', 192)	=> '11111111111111111111100000',
	pack('C', 193)	=> '11111111111111111111100001',
	pack('C', 194)	=> '11111111111111101011',
	pack('C', 195)	=> '1111111111111110001',
	pack('C', 196)	=> '1111111111111111100111',
	pack('C', 197)	=> '11111111111111111110010',
	pack('C', 198)	=> '1111111111111111101000',
	pack('C', 199)	=> '1111111111111111111101100',
	pack('C', 200)	=> '11111111111111111111100010',
	pack('C', 201)	=> '11111111111111111111100011',
	pack('C', 202)	=> '11111111111111111111100100',
	pack('C', 203)	=> '111111111111111111111011110',
	pack('C', 204)	=> '111111111111111111111011111',
	pack('C', 205)	=> '11111111111111111111100101',
	pack('C', 206)	=> '111111111111111111110001',
	pack('C', 207)	=> '1111111111111111111101101',
	pack('C', 208)	=> '1111111111111110010',
	pack('C', 209)	=> '111111111111111100011',
	pack('C', 210)	=> '11111111111111111111100110',
	pack('C', 211)	=> '111111111111111111111100000',
	pack('C', 212)	=> '111111111111111111111100001',
	pack('C', 213)	=> '11111111111111111111100111',
	pack('C', 214)	=> '111111111111111111111100010',
	pack('C', 215)	=> '111111111111111111110010',
	pack('C', 216)	=> '111111111111111100100',
	pack('C', 217)	=> '111111111111111100101',
	pack('C', 218)	=> '11111111111111111111101000',
	pack('C', 219)	=> '11111111111111111111101001',
	pack('C', 220)	=> '1111111111111111111111111101',
	pack('C', 221)	=> '111111111111111111111100011',
	pack('C', 222)	=> '111111111111111111111100100',
	pack('C', 223)	=> '111111111111111111111100101',
	pack('C', 224)	=> '11111111111111101100',
	pack('C', 225)	=> '111111111111111111110011',
	pack('C', 226)	=> '11111111111111101101',
	pack('C', 227)	=> '111111111111111100110',
	pack('C', 228)	=> '1111111111111111101001',
	pack('C', 229)	=> '111111111111111100111',
	pack('C', 230)	=> '111111111111111101000',
	pack('C', 231)	=> '11111111111111111110011',
	pack('C', 232)	=> '1111111111111111101010',
	pack('C', 233)	=> '1111111111111111101011',
	pack('C', 234)	=> '1111111111111111111101110',
	pack('C', 235)	=> '1111111111111111111101111',
	pack('C', 236)	=> '111111111111111111110100',
	pack('C', 237)	=> '111111111111111111110101',
	pack('C', 238)	=> '11111111111111111111101010',
	pack('C', 239)	=> '11111111111111111110100',
	pack('C', 240)	=> '11111111111111111111101011',
	pack('C', 241)	=> '111111111111111111111100110',
	pack('C', 242)	=> '11111111111111111111101100',
	pack('C', 243)	=> '11111111111111111111101101',
	pack('C', 244)	=> '111111111111111111111100111',
	pack('C', 245)	=> '111111111111111111111101000',
	pack('C', 246)	=> '111111111111111111111101001',
	pack('C', 247)	=> '111111111111111111111101010',
	pack('C', 248)	=> '111111111111111111111101011',
	pack('C', 249)	=> '1111111111111111111111111110',
	pack('C', 250)	=> '111111111111111111111101100',
	pack('C', 251)	=> '111111111111111111111101101',
	pack('C', 252)	=> '111111111111111111111101110',
	pack('C', 253)	=> '111111111111111111111101111',
	pack('C', 254)	=> '111111111111111111111110000',
	pack('C', 255)	=> '11111111111111111111101110',
	'_eos'		=> '111111111111111111111111111111',
}};

sub huff {
	my ($string) = @_;
	my $code = &huff_code;

	my $ret = join '', map { $code->{$_} } (split //, $string);
	my $len = length($ret) + (8 - length($ret) % 8);
	$ret .= $code->{_eos};

	return pack("B$len", $ret);
}

sub dehuff {
	my ($string) = @_;
	my $code = &huff_code;
	my %decode = reverse %$code;

	my $ret = ''; my $c = '';
	for (split //, unpack('B*', $string)) {
		$c .= $_;
		next unless exists $decode{$c};
		last if $decode{$c} eq '_eos';

		$ret .= $decode{$c};
		$c = '';
	}

	return $ret;
}

###############################################################################

1;

###############################################################################