Утечка памяти в программе, которая использует LWP::UserAgent для загрузки файла
Я пытаюсь восстановить Perl-скрипт, который использовал давно. Это для загрузки файлов из облачного хранилища на мой локальный клиент. Я уверен, что тогда все работало нормально, но теперь у меня проблема LWP::UserAgent загружает файл полностью в память перед записью на диск. Ожидаемое и прежнее поведение будет заключаться в том, что во время загрузки он должен записывать куски полученного файла в целевое устройство.
Я пытаюсь в настоящее время на OSX с Perl 5.16.3 и 5.18, а также пробовал на Windows, но я больше не знаю версию Perl. Я довольно уверен, что это связано с версией Perl, но я не знаю, какой я использовал тогда, и я хочу знать, что изменилось.
sub downloadFile {
my $url = shift;
my $filename = shift;
my $temp_filename = shift;
my $expected_size = shift;
( $download_size, $received_size, $avg_speed, $avg_speed_s, $avg_speed_q,
$speed_count, $speed, $byte_offset, $http_status
) = ( 0, 0, 0, 0, 0, 0, 0, 0, 0 );
if ( -e $temp_filename and !$options{'no-resume'} ) {
my @stat = stat($temp_filename);
if ( $expected_size > $stat[7] ) {
$byte_offset = $stat[7];
$received_size = $stat[7];
}
}
open DOWNLOAD, ( $byte_offset > 0 ) ? ">>" : ">", $temp_filename
or die "Unable to create download file: $!";
binmode DOWNLOAD;
$last_tick = time();
my $host = "myhost";
if ( $url =~ m/http:\/\/(.*?)\//gi ) {
$host = $1;
}
$agent->credentials(
$host . ":80",
"Login Required",
$config->{"account_name"},
$config->{"account_password"} );
my $response = $agent->get(
$url,
':content_cb' => \&didReceiveData,
':read_size_hint' => ( 2**14 ) );
close DOWNLOAD;
my @stat = stat($temp_filename);
my $actual_size = $stat[7];
if ( ! $response->is_success() ) {
printfvc( 0,
"\rDownload failed: %s",
'red',
$response->status_line() );
return 0;
}
elsif ( $actual_size != $expected_size ) {
printfvc( 0,
"\rDownloaded file does not have expected size (%s vs. %s)",
'red',
$actual_size, $expected_size );
return 0;
}
else {
rename $temp_filename, $filename;
printfvc( 0,
"\rDownload succeeded ",
'green' );
return 1;
}
}
sub didReceiveData {
my ( $data, $cb_response, $protocol ) = @_;
#my($response, $ua, $h, $data) = @_;
my $data_size = scalar( length($data) );
$received_size += $data_size;
$speed_count += $data_size;
my $now = time();
if ( $last_tick < $now ) {
$speed = $speed_count;
$speed_count = 0;
$last_tick = $now;
$avg_speed_q++;
$avg_speed_s += $speed;
$avg_speed = $avg_speed_s / $avg_speed_q;
}
if ( $download_size > 0 and $http_status eq "200" or $http_status eq "206" ) {
print DOWNLOAD $data;
printf("-> %.1f %% (%s of %s, %s/s) %s ",
( $received_size / $download_size ) * 100,
fsize($received_size),
fsize($download_size),
fsize($speed),
$avg_speed_q > 3
? fduration( ( $download_size - $received_size ) / $avg_speed ) . " remaining"
: ""
) if ( $verbosity >= 0 );
}
else {
printf("-> Initiating transfer...") if ( $verbosity >= 0 );
}
return 1;
}
выход:
mun-m-sele:PutIO-Perl-folder-sync sele$ perl putiosync.pl
Syncing folder 'Test' to '/Users/sele/Downloads/Test'...
1 files queued to download
5MB.zip
Fetching '5MB.zip' [1 of 1]
-> 0.3 % (16.0 kiB of 5.0 MiB, 16.0 kiB/s)
-> 0.6 % (32.0 kiB of 5.0 MiB, 16.0 kiB/s)
-> 0.9 % (48.0 kiB of 5.0 MiB, 16.0 kiB/s)
.
.
.
-> 99.1 % (5.0 MiB of 5.0 MiB, 16.0 kiB/s)
-> 99.4 % (5.0 MiB of 5.0 MiB, 16.0 kiB/s)
-> 99.7 % (5.0 MiB of 5.0 MiB, 16.0 kiB/s)
Download succeeded
Таким образом, выходные данные ожидаются, НО все же эти выходные данные появляются только после загрузки файла в память.
content_cb не вызывается во время загрузки (проверяется простым print("cb") к вершине didReceiveData
Обновить
Я обнаружил, что он работает, как и ожидалось, на Windows Strawberry Perl 5.16.2. Я могу предоставить вам версии пакета, если вы скажете мне, что и как;)
3 ответа
Ваш собственный код содержит много несоответствий, таких как поддержка возобновления, поддержка нескольких серверов, ведение журнала прогресса, учетные данные сайта, временные файлы загрузки, обработка ошибок и вычисления средней скорости. Ни один из них не имеет отношения к основной проблеме, которую вы описали, и именно поэтому я попросил вас создать минимальный, полный и проверяемый пример. Я не понимаю ваш отказ или почему вы, кажется, цепляетесь за идею, что ошибка в Perl, а не в вашем собственном коде
Без этого все, что я могу сделать, это продемонстрировать, что техника работает хорошо. Вот то, что вы должны были сгенерировать как демонстрацию проблемы. Он очень мало отличается от вашего собственного кода и работает нормально. Он загружает официальный ISO-образ дистрибутива Ubuntu для настольных ПК, который содержит около 1,4 ГБ информации. Процесс использует 17 МБ памяти и завершается за 14 минут. Размер результирующего файла точно соответствует Content-Length указано в заголовке HTTP
Помимо этого никто не может помочь вам в дальнейшем. Я призываю вас принять помощь экспертов, когда вы попросили об этом. Также стоит отметить, что проблема часто обнаруживается в процессе создания MCVE из вашей неисправной программы: вы, скорее всего, удалите несущественную часть кода и обнаружите, что проблема исчезла.
use strict;
use warnings 'all';
use LWP;
use constant ISO_URL => 'http://releases.ubuntu.com/16.04/ubuntu-16.04-desktop-amd64.iso';
STDOUT->autoflush;
my $ua = LWP::UserAgent->new;
my $expected;
{
my $res = $ua->head(ISO_URL);
$expected = $res->header('Content-Length');
printf "Expected file size is %.3fMB\n", $expected / 1024**2;
}
my ($iso_file) = ISO_URL =~ m{([^/]+)\z};
open my $iso_fh, '>:raw', $iso_file or die $!;
my $total;
my $pc = 0;
{
my $res = $ua->get(
ISO_URL,
':content_cb' => \&content_cb,
':read_size_hint' => 16 * 1024,
);
close $iso_fh or die $!;
print $res->status_line, "\n";
printf "Final file size is %.3fMB\n", (-s $iso_file) / 1024**2;
}
sub content_cb {
my ( $data, $res ) = @_;
die $res->status_line unless $res->is_success;
print $iso_fh $data;
$total += length $data;
while ( $pc < 100 * $total / $expected ) {
printf "%3d%%\n", $pc++;
}
}
выход
Expected file size is 1417.047MB
0%
1%
2%
3%
4%
5%
:
:
95%
96%
97%
98%
99%
200 OK
Final file size is 1417.047MB
Может быть, проблема в файловом вводе / выводе, а не в LWP? Я предполагаю, что данные не сбрасываются в файл, пока вы не закроете файл.
Ниже приведен пример кода о том, как заставить файл обрабатывать сброс данных на жесткий диск:
{ my $ofh = select LOG;
$| = 1;
select $ofh;
}
Проверять, выписываться perldoc -q flush и эта интересная статья о буферизации " Страдание от буферизации?".
Основная проблема с вашим кодом заключается в том, что $http_status никогда не назначается. Это может быть установлено только обратным вызовом didReceiveData или после завершения всей загрузки, когда get выход из вызова
Но ваш обратный вызов проверяет, $http_status eq "200" (который должен быть $cb_response->is_success) перед печатью на дескриптор файла DOWNLOAD, чтобы ничего не могло быть записано
Я могу поверить, что ваш код увеличивает объем памяти, потому что он бесконечно печатает -> Initiating transfer... в STDOUT, но ничего не будет записано во временный файл из-за непроверенного статуса HTTP. Я уверен, что вы наблюдали за тем, как ваш процесс запускается и умирает с ошибкой "Недостаточно памяти", и сразу обвиняли Perl, даже не пытаясь загрузить файл размером 1 КБ. Ваш код никогда не работал, и ваш вопрос и поддержка тех, кто вам помог бы, возмутителен
"Я почти уверен, что в то время это работало нормально" - не очень хорошее начало, но когда вы тогда отклоняете на этом основании все приложения решения или запроса на информацию, вы становитесь смешным