wehub-resource-sync
110 lines
3.2 KiB
Perl
110 lines
3.2 KiB
Perl
#!/usr/bin/perl
|
|
# Unit tests for byte-copying helpers in web-lib-funcs.pl.
|
|
|
|
use strict;
|
|
use warnings;
|
|
use Test::More;
|
|
use File::Basename qw(dirname);
|
|
use File::Spec;
|
|
use bytes ();
|
|
|
|
my $script = File::Spec->rel2abs(
|
|
File::Spec->catfile(dirname(__FILE__), '..', 'web-lib-funcs.pl'));
|
|
require $script;
|
|
|
|
subtest 'copydata_len to file handle' => sub {
|
|
my $source = "abcdef";
|
|
my $dest = "";
|
|
open(my $in, '<', \$source) or die "open input scalar: $!";
|
|
open(my $out, '>', \$dest) or die "open output scalar: $!";
|
|
|
|
is(main::copydata_len($in, $out, 4, 2), 4,
|
|
'reports copied byte count');
|
|
is($dest, 'abcd', 'copies only the requested bytes');
|
|
|
|
my $left = <$in>;
|
|
is($left, 'ef', 'leaves bytes past the requested length unread');
|
|
};
|
|
|
|
subtest 'copydata_len to writer callback' => sub {
|
|
my $source = "0123456789";
|
|
my @chunks;
|
|
open(my $in, '<', \$source) or die "open input scalar: $!";
|
|
|
|
is(main::copydata_len($in, sub { push(@chunks, $_[0]); 1 }, 7, 3),
|
|
7, 'reports bytes copied through callback');
|
|
is(join('', @chunks), '0123456', 'callback receives requested data');
|
|
is_deeply([ map { length($_) } @chunks ], [ 3, 3, 1 ],
|
|
'callback receives bounded chunks');
|
|
};
|
|
|
|
subtest 'copydata_len short input and write failure' => sub {
|
|
my $short = "abc";
|
|
my $dest = "";
|
|
open(my $in, '<', \$short) or die "open input scalar: $!";
|
|
open(my $out, '>', \$dest) or die "open output scalar: $!";
|
|
|
|
is(main::copydata_len($in, $out, 5, 2), 3,
|
|
'short input returns actual copied byte count');
|
|
is($dest, 'abc', 'short input copies available bytes');
|
|
|
|
my $source = "abcdef";
|
|
open(my $fail_in, '<', \$source) or die "open input scalar: $!";
|
|
is(main::copydata_len($fail_in, sub { 0 }, 4, 2), undef,
|
|
'writer callback failure returns undef');
|
|
};
|
|
|
|
subtest 'write_http_connection retries partial SSL writes' => sub {
|
|
my @writes;
|
|
{
|
|
no warnings 'redefine';
|
|
local *Net::SSLeay::write = sub {
|
|
my ($ssl, $data) = @_;
|
|
push(@writes, $data);
|
|
return length($data) > 2 ? 2 : length($data);
|
|
};
|
|
|
|
ok(main::write_http_connection(
|
|
{ ssl_ctx => 1, ssl_con => 'ssl' }, 'abcde'),
|
|
'partial SSL writes eventually succeed');
|
|
}
|
|
is_deeply(\@writes, [ 'abcde', 'cde', 'e' ],
|
|
'remaining bytes are retried after each partial write');
|
|
};
|
|
|
|
subtest 'write_http_connection uses byte offsets for UTF-8 strings' => sub {
|
|
my $source = "\x{100}\x{101}\x{102}";
|
|
my @accepted;
|
|
{
|
|
no warnings 'redefine';
|
|
local *Net::SSLeay::write = sub {
|
|
my ($ssl, $data) = @_;
|
|
my $len = bytes::length($data);
|
|
my $wrote = $len > 3 ? 3 : $len;
|
|
push(@accepted,
|
|
unpack('H*', bytes::substr($data, 0, $wrote)));
|
|
return $wrote;
|
|
};
|
|
|
|
ok(main::write_http_connection(
|
|
{ ssl_ctx => 1, ssl_con => 'ssl' }, $source),
|
|
'partial SSL writes preserve a UTF-8-flagged scalar');
|
|
}
|
|
is(join('', @accepted),
|
|
unpack('H*', bytes::substr($source, 0, bytes::length($source))),
|
|
'byte-count return values are applied as byte offsets');
|
|
};
|
|
|
|
subtest 'write_http_connection fails on SSL write error' => sub {
|
|
{
|
|
no warnings 'redefine';
|
|
local *Net::SSLeay::write = sub { return 0; };
|
|
|
|
ok(!main::write_http_connection(
|
|
{ ssl_ctx => 1, ssl_con => 'ssl' }, 'abc'),
|
|
'zero-byte SSL write is reported as failure');
|
|
}
|
|
};
|
|
|
|
done_testing();
|