Канал заблокирован подпроцессом в Perl

Это значительно усложняется, потому что и open my $fh, "date |", и system("perl child.pl") запускают дочерние процессы, а также явный fork.

Итак, fork запускает дочерний процесс, который system("perl child.pl") запускает свой собственный дочерний процесс, который, в свою очередь, выполняет open my $fh, "date |", который открывает еще один дочерний процесс, который теперь является правнуком основного родительского процесса.

Тем временем основной процесс выполняет свой собственный open my $fh, "date |", который запускает другой дочерний процесс. В итоге у основного процесса есть двое детей, внук и правнук.

К сожалению, дочерние элементы, которые запускаются с использованием open или system, имеют прикрепленный к ним implcit wait, поэтому они будут запускать сигнал CHLD по завершении, но когда обработчик будет выполнен, ждать нечего, поэтому он будет зависать, как вы видели .

perldoc perlipc говорит следующее

Будьте осторожны: qx (), system () и некоторые модули для вызова внешних команд выполняют fork (), а затем wait () для получения результата. Таким образом, будет вызван ваш обработчик сигнала. Поскольку wait () уже был вызван системой () или qx (), wait () в обработчике сигнала больше не увидит зомби и, следовательно, заблокируется.

Вы можете добиться успеха, оставив только один родительский и единственный дочерний процесс, как это.

use strict;
use warnings;

use POSIX ':sys_wait_h';

STDOUT->autoflush;

$SIG{CHLD} = sub {
  while(waitpid(-1, WNOHANG) > 0) {
    print "child process exit\n";
  }   
};

my $pid = fork();

if ($pid == 0) {
  while(1) {
    printf " child: %s\n", scalar localtime;
    sleep(2);
  }
}
else {
  while(1) {
    printf "parent: %s\n", scalar localtime;
    sleep(2);
  }
}

Опция 1

Один из способов сделать то, что вы хотите, - это синхронизация с парой полудуплексных каналов, созданных с помощью pipe < / a> и open. Использование полнодуплексного socketpair может упростить бухгалтерский учет.

Открытие дескриптора на "|-" неявно forks дочерний процесс, стандартный ввод которого является концом чтения канала, а конец записи - дескриптором файла, возвращаемым родительскому процессу. Родитель освобождает дочерний элемент с помощью этого неявного канала и использует явно созданный канал в качестве обратного канала.

#! /usr/bin/env perl

use strict;
use warnings;

use Fcntl qw/ F_GETFD F_SETFD FD_CLOEXEC /;
use IO::Handle;

pipe my $fromchild, my $toparent or die "$0: pipe: $!";
$_->autoflush(1) for $toparent, $fromchild;

my $flags = fcntl $toparent, F_GETFD, 0        or die "$0: fcntl: $!";
fcntl $toparent, F_SETFD, $flags & ~FD_CLOEXEC or die "$0: fcntl: $!";

my $pid = open my $tochild, "|-";
$tochild->autoflush(1);
die "$0: fork: $!" unless defined $pid;

if ($pid != 0) {
  while (1) {
    print "parent: ", scalar localtime, "\n";
    sleep 1;
    print $tochild "over\n";

    chomp($_ = <$fromchild>);
    exit 0 if $_ eq "over and out";
  }
}
else {
  exec "child.pl", fileno $toparent
    or die "$0: exec: $!";
}

Код в child.pl ниже. Обратите внимание, что родительский элемент передает дескриптор файла, который дочерний элемент должен dup для связи с родительским элементом в другом направлении.

#! /usr/bin/env perl

use strict;
use warnings;

use IO::Handle;

my($fd) = @ARGV or die "Usage: $0 to-parent-fd\n";
open my $toparent, ">&=", $fd or die "$0: dup: $!";
$toparent->autoflush(1);

my $rounds = 5;
for (1 .. $rounds) {
  my $over = <STDIN>;
  print " child: ", scalar localtime, "\n";
  sleep 1;
  print $toparent ($_ < $rounds ? "over\n" : "over and out\n");
}

exit 0;

На концерте они выглядят как

parent: Mon Jan 21 18:10:39 2013
 child: Mon Jan 21 18:10:40 2013
parent: Mon Jan 21 18:10:41 2013
 child: Mon Jan 21 18:10:42 2013
parent: Mon Jan 21 18:10:43 2013
 child: Mon Jan 21 18:10:44 2013
parent: Mon Jan 21 18:10:45 2013
 child: Mon Jan 21 18:10:46 2013
parent: Mon Jan 21 18:10:47 2013
 child: Mon Jan 21 18:10:48 2013

Вариант 2

Немного более экзотический вариант - это расположение подпроцессов, чередующихся друг с другом в кольце или цикле. Переход между родительскими и дочерними процессами - это просто цикл длиной два.

#! /usr/bin/env perl

use strict;
use warnings;

use IPC::SysV qw/ IPC_CREAT IPC_PRIVATE S_IRUSR S_IWUSR /;
use IPC::Semaphore;

my $WORKERS = 3;

Данный рабочий процесс берет свой собственный семафор из набора, но по завершении освобождает следующий рабочий процесс.

sub take {
  my($id,$sem) = @_;
  $sem->op($id, -1, 0) or die "$0: semop: $!";
}

sub release {
  my($id,$sem) = @_;
  my $next = ($id + 1) % $WORKERS;
  $sem->op($next, 1, 0) or die "$0: semop: $!";
}

sub worker {
  my($id,$sem) = @_;

  for (1 .. 3) {
    take $id, $sem;

    print "[worker $id]: ", scalar localtime, "\n";
    sleep 1;

    release $id, $sem;
  }
}

Создайте набор семафоров и оставьте первый готовым к запуску.

my $sem = IPC::Semaphore->new(
  IPC_PRIVATE,
  $WORKERS,
  IPC_CREAT | S_IRUSR | S_IWUSR)
    or die "$0: semget: $!";

$sem->setall((0) x $WORKERS);
$sem->setval(0, 1);  # unblock first only

Теперь мы готовы fork подпроцессы, и пусть они выполнятся.

foreach my $id (0 .. $WORKERS - 1) {
  my $pid = fork;
  die "$0: fork: $!" unless defined $pid;

  if ($pid == 0) {
    worker $id, $sem;
    exit 0;
  }
}

# wait on all workers to finish
my $pid;
do {
  $pid = waitpid -1, 0;
} while $pid > 0;

Пример вывода:

[worker 0]: Mon Jan 21 18:13:27 2013
[worker 1]: Mon Jan 21 18:13:28 2013
[worker 2]: Mon Jan 21 18:13:29 2013
[worker 0]: Mon Jan 21 18:13:30 2013
[worker 1]: Mon Jan 21 18:13:31 2013
[worker 2]: Mon Jan 21 18:13:32 2013
[worker 0]: Mon Jan 21 18:13:33 2013
[worker 1]: Mon Jan 21 18:13:34 2013
[worker 2]: Mon Jan 21 18:13:35 2013