Выполнение неблокирующих операций ввода-вывода на сокете TCP в ограниченной среде

Question

Я пытаюсь написать несколько относительно простых библиотечных функций для эмуляции метода LWP::UserAgent get, потому что LWP и связанные библиотеки недоступны на некоторых наших хостингах. Все, на что я могу положиться - это основные функции Perl, и даже некоторые из них ограничены, но у меня, похоже, есть доступ к сокетам, разветвлениям, сигналам и т. П.

Мне уже удалось создать простой клиент и сервер (сервер только для тестирования), который может отправлять и получать данные. Проблема в том, что я хочу установить тайм-аут на всю операцию get, как в LWP, но мои первоначальные попытки были безрезультатными. Следующее не работает, и я не верю, что это может работать, но я опубликую это только в случае, если это может быть исправлено:

sub grab {
    my($addr, $port, $timeout) = @_;
    my $it;

    eval {
        local $SIG{ALRM} = sub {
            die "alarm\n";
        };

        alarm $timeout if $timeout;

        my $iaddr = inet_aton($addr)
        or die "client no host: $!";
        my $paddr = sockaddr_in($port, $iaddr)
        or die "client sockaddr_in: $!";
        my $proto = getprotobyname("tcp");

        socket(Client, PF_INET, SOCK_STREAM, $proto)
        or die "Client socket: $!";

        local $SIG{ALRM} = sub {
            close(Client);
            die "alarm\n";
        };

        connect(Client, $paddr)
        or die "Client connect: $!";
        while(my $line = <Client>) {
            $it .= $line;
        }

        print alarm(0), " seconds left \n";
        close(Client) or die "Client close: $!";
    };
    if($@) {
        die unless $@ eq "alarm\n";
    }

    return $it;
}

Сигнал тревоги, кажется, игнорируется подобными соединениями, чтением и, возможно, некоторыми другими. Я прибег к чтению исходного кода LWP после того, как это не сработало - потому что я чувствовал, что я лаю не на том дереве - и обнаружил следующее, среди других драгоценных камней, в strawberry/perl/vendor/lib/LWP/Protocol/http.pm:

sub sysread {
    my $self = shift;
    if (my $timeout = ${*$self}{io_socket_timeout}) {
        die "read timeout" unless $self->can_read($timeout);
    }
    else {
        # since we have made the socket non-blocking we
        # use select to wait for some data to arrive
        $self->can_read(undef) || die "Assert";
    }
    sysread($self, $_[0], $_[1], $_[2] || 0);
}

sub can_read {
    my($self, $timeout) = @_;
    my $fbits = '';
    vec($fbits, fileno($self), 1) = 1;
    SELECT:
    {
        my $before;
        $before = time if $timeout;
        my $nfound = select($fbits, undef, undef, $timeout);
        if ($nfound < 0) {
            if ($!{EINTR} || $!{EAGAIN}) {
                # don't really think EAGAIN can happen here
                if ($timeout) {
                    $timeout -= time - $before;
                    $timeout = 0 if $timeout < 0;
                }
                redo SELECT;
            }
            die "select failed: $!";
        }
        return $nfound > 0;
    }
}

Так что похоже, что он работает вокруг некоторых ограничений других подпрограмм при использовании select? Он также, кажется, не разветвляется и не использует сигналы, и, строго говоря, время от времени блокирует, но пытается убедиться, что он не будет блокироваться долго? Я чувствую, что должен скопировать суть этого кода и создать упрощенную версию для своих конкретных нужд, но я начинаю довольно осторожно сталкиваться с минными полями. Также обратите внимание, что я занимаюсь разработкой под Windows, но в будущем буду развертывать на Linux / nix *, а также, возможно, на Windows.

Answer 1

Похоже, что вы мало что можете упростить: его ядро ​​использует 5-аргументную версию select, поскольку perldoc -f аккуратно объясняет select (аннотация внизу ответа).

Но мне не удаетсяпонимайте свои усилия, если только они не предназначены для целей обучения: вы можете взять LWP и упаковать его с другими вашими пользовательскими библиотеками практически без усилий, запретив «использовать lib qw (foo / bar)» вверху вашей программы.Я сомневаюсь, что вы можете придумать что-то значительно более простое, но при этом быть правильным с точки зрения протокола.

Если вы не хотите использовать select (), то вы можете получить ответвление на клиенте и заставить родителя уничтожить ребенка по таймауту (вы даже можете использовать потоки, если вы так склонны), ноэто странно, не говоря уже о ненужности.

Приветствия,

-

perldoc -f select

   select RBITS,WBITS,EBITS,TIMEOUT
           This calls the select(2) system call with the bit masks specified, 
           which can be constructed using "fileno" and "vec", along these lines:

               $rin = $win = $ein = ’’;
               vec($rin,fileno(STDIN),1) = 1;
               vec($win,fileno(STDOUT),1) = 1;
               $ein = $rin │ $win;

           If you want to select on many filehandles you might wish to write a subroutine:

               sub fhbits {
                   my(@fhlist) = split(’ ’,$_[0]);
                   my($bits);
                   for (@fhlist) {
                       vec($bits,fileno($_),1) = 1;
                   }
                   $bits;
               }
               $rin = fhbits(’STDIN TTY SOCK’);

           The usual idiom is:

               ($nfound,$timeleft) =