如何多线程查看Perl中是否存在网页？

Question

我正在写一个Perl脚本,它接收一个URL列表并检查它们是否存在.(请注意,如果存在的话,我只关心,我不关心它们的内容下面是该方案的重要组成部分.

use LWP::Simple qw($ua head);

if (head($url))
{
    $numberAlive ++;
}
else
{
    $numberDead ++;
}

现在该程序运行正常; 但是,我希望它运行得更快.因此我正在考虑将其设为多线程.我假设我的程序的慢速部分是联系服务器的每个URL; 因此,我正在寻找一种方法,在我等待第一个响应时,我可以向我列表中的其他网页的URL发送请求.我怎样才能做到这一点？据我所知,该head例程没有可以在服务器响应后调用的回调.

Answer 1

从熟悉的前方开始.

#! /usr/bin/env perl

use strict;
use warnings;

use 5.10.0;  # for // (defined-or)

use IO::Handle;
use IO::Select;
use LWP::Simple;
use POSIX qw/ :sys_wait_h /;
use Socket;

全局常量控制程序执行.

my $DEBUG = 0;
my $EXIT_COMMAND = "<EXIT>";
my $NJOBS = 10;

要检查的URL在套接字的工作者端到达每行一个.对于每个URL,工作程序调用LWP::Simple::head以确定资源是否可获取.然后工作人员将表单url 的一行写回套接字:*status*其中*status*是"YES"或者"NO"和 代表空间角色.

如果URL是$EXIT_COMMAND,则工作人员立即退出.

sub check_sites {
  my($s) = @_;

  warn "$0: [$$]: waiting for URL" if $DEBUG;

  while (<$s>) {
    chomp;
    warn "$0: [$$]: got '$_'" if $DEBUG;
    exit 0 if $_ eq $EXIT_COMMAND;
    print $s "$_: ", (head($_) ? "YES" : "NO"), "\n";
  }

  die "NOTREACHED";
}

要创建一个worker,我们首先创建一个socketpair.父进程将使用一端,每个worker(子)将使用另一端.我们在两端禁用缓冲并将父端添加到我们的IO :: Select实例.我们还会记下每个孩子的进程ID,以便我们等待所有工作人员完成.

sub create_worker {
  my($sel,$kidpid) = @_;

  socketpair my $parent, my $kid, AF_UNIX, SOCK_STREAM, PF_UNSPEC
    or die "$0: socketpair: $!";
  $_->autoflush(1) for $parent, $kid;

  my $pid = fork // die "$0: fork: $!";
  if ($pid) {
    ++$kidpid->{$pid};
    close $kid or die "$0: close: $!";
    $sel->add($parent);
  }
  else {
    close $parent or die "$0: close: $!";
    check_sites $kid;
    die "NOTREACHED";
  }
}

为了分派URL,父母抓取尽可能多的读者,并从作业队列中分发相同数量的URL.在作业队列之后保留的任何工作人员都将收到退出命令.

请注意,print如果基础工作者已经退出,则会失败.父母必须忽略SIGPIPE以防止立即终止.

sub dispatch_jobs {
  my($sel,$jobs) = @_;

  foreach my $s ($sel->can_write) {
    my $url = @$jobs ? shift @$jobs : $EXIT_COMMAND;
    warn "$0 [$$]: sending '$url' to fd ", fileno $s if $DEBUG;
    print $s $url, "\n" or $sel->remove($s);
  }
}

到控制时间到达时read_results,工人已经创建并接收了工作.现在,父级用于can_read等待结果从一个或多个工作人员到达.定义的结果是当前工作者的答案,未定义的结果表示子项已退出并关闭套接字的另一端.

sub read_results {
  my($sel,$results) = @_;

  warn "$0 [$$]: waiting for readers" if $DEBUG;
  foreach my $s ($sel->can_read) {
    warn "$0: [$$]: reading from fd ", fileno $s if $DEBUG;
    if (defined(my $result = <$s>)) {
      chomp $result;
      push @$results, $result;
      warn "$0 [$$]: got '$result' from fd ", fileno $s if $DEBUG;
    }
    else {
      warn "$0 [$$]: eof from fd ", fileno $s if $DEBUG;
      $sel->remove($s);
    }
  }
}

家长必须跟踪现场工作人员以收集所有结果.

sub reap_workers {
  my($kidpid) = @_;

  while ((my $pid = waitpid -1, WNOHANG) > 0) {
    warn "$0: [$$]: reaped $pid" if $DEBUG;
    delete $kidpid->{$pid};
  }
}

运行池会执行上面的子站点以分派所有URL并返回所有结果.

sub run_pool {
  my($n,@jobs) = @_;

  my $sel = IO::Select->new;
  my %kidpid;
  my @results;

  create_worker $sel, \%kidpid for 1 .. $n;

  local $SIG{PIPE} = "IGNORE";  # writes to dead workers will fail

  while (@jobs || keys %kidpid || $sel->handles) {
    dispatch_jobs $sel, \@jobs;

    read_results $sel, \@results;

    reap_workers \%kidpid;
  }

  warn "$0 [$$]: returning @results" if $DEBUG;
  @results;
}

使用示例主程序

my @jobs = qw(
  bogus
  http://stackoverflow.com/
  http://www.google.com/
  http://www.yahoo.com/
);

my @results = run_pool $NJOBS, @jobs;
print $_, "\n" for @results;

输出是

bogus: NO
http://www.google.com/: YES
http://stackoverflow.com/: YES
http://www.yahoo.com/: YES