очередь процессов Perl

Question

У меня есть Perl-скрипт, который разветвляется на несколько подпроцессов.Мне бы хотелось иметь какую-то функциональность, такую ​​как xargs --max-procs=4 --max-args=1 или make -j 4, где Perl будет поддерживать заданное количество процессов, пока не закончится работа.

Легко сказать, что процесс ветвления четыре и ждать, пока они все завершатся, а затем разветвить еще четыре, но я бы хотел, чтобы четыре или n процессов работали одновременно, разветвляя новый процесс,по завершении.

Есть ли в Perl простой способ реализовать такой пул процессов?

Answer 1

Forks::Super может удовлетворить это требование.

use Forks::Super MAX_PROC => 5, ON_BUSY => [ block | queue ];

Вызовы fork() могут блокироваться до тех пор, пока число активных подпроцессов не упадет ниже 5, или вы можете передать дополнительные параметры для вызова fork и задачи, которые нужно выполнить, могут поставить в очередь:

fork { sub => sub { ... task to run in subprocess ... } }

Когда один подпроцесс завершается, запускается другое задание в очереди.

(я автор этого модуля).

Answer 2

Проверьте Parallel :: ForkManager - он делает многое из того, что вы описываете. Вы можете установить максимальное количество процессов, и функция обратного вызова может запустить нового дочернего элемента, как только он завершится (пока есть работа).

Answer 3

Хотя я почти всегда использовал бы модуль CPAN или писал что-то с фантастическими модулями AnyEvent, я считаю важным понять, как эти вещи работают под капотом.Вот пример, который не имеет никаких зависимостей, кроме perl.Тот же самый подход может быть написан на C без особых проблем.

#!/usr/bin/env perl

use strict;

## run a function in a forked process
sub background (&) {
  my $code = shift;

  my $pid = fork;
  if ($pid) {
    return $pid;
  } elsif ($pid == 0) {
    $code->();
    exit;
  } else{
    die "cant fork: $!"
  }
}

my @work = ('sleep 30') x 8;
my %pids = ();
for (1..4) {
  my $w = shift @work;
  my $pid = background {
    exec $w;
  };
  $pids{$pid} = $w; 
}

while (my $pid = waitpid(-1,0)) {
  if ($?) {
    if ($? & 127) {
      warn "child died with signal " . ($? & 127);
    } else {
      warn "chiled exited with value " . ($? >> 8);
    }

    ## redo work that died or got killed
    my $npid = background {
      exec $pids{$pid};
    };
    $pids{$npid} = delete $pids{$pid};
  } else {
    delete $pids{$pid};

    ## send more work if there is any
    if (my $w = shift @work) {
      my $pid = background {
        exec shift @work;
      };
      $pids{$pid} = $w;
    }
  }
}