如果推送线程在 Perl 中有异常，则停止应用程序

Question

我有一个以并行模式运行的应用程序。作业正在使用带有已实现子例程的线程运行。子程序“worker3”有三个参数，一个参数和两个文件路径。此子例程使用系统命令执行 R 脚本。

if ($ENV{"model"} eq "alaef_cy40_5km"){

      sub worker3 {
      my $parameter2 = $_[0];
       print $parameter2, "\n";
      $ENV{"grb_path"} = $models{$model}{"grb"}{"path"}{$parameter2};
      $ENV{"grb_file"} = $models{$model}{"grb"}{"file"}{$parameter2};
      print"FROM sub:", "\n";
      print $ENV{"grb_path"}, "\n";
      print $ENV{"grb_file"}, "\n";
      say "Job  Started\n";
      system("Rscript $root/read_ALAEF.R @_ ");

 
}
      
      for my $param( 'T2m','RH2m'){
      push @threads, my $thr1=threads ->create('worker3', $param ,$ENV{"grb_file"},$ENV{"grb_path"})

      }

      $_->join() for threads->list();
     
   }

问题是当 R 脚本完成并暂停执行时，应用程序最终状态正常。我需要的是当 R 脚本出错时，整个程序需要停止。所以，如果一个线程失败，应用程序需要停止，并显示错误。

这是输出：

T2m
FROM sub:
/data/nwp/products/a-laef_stream
A-LAEF_mem_{MBR2}_{YYYY}{MM}{DD}{HH}_surface.grb
Job  Started

RH2m
FROM sub:
/data/nwp/products/a-laef_stream
A-LAEF_mem_{MBR2}_{YYYY}{MM}{DD}{HH}_surface.grb
Job  Started

-- Attaching packages --------------------------------------- tidyverse 1.3.1 --
v ggplot2 3.3.5     v purrr   0.3.4
v tibble  3.1.6     v dplyr   1.0.7
v tidyr   1.1.4     v stringr 1.4.0
v readr   2.1.0     v forcats 0.5.1
-- Attaching packages --------------------------------------- tidyverse 1.3.1 --
v ggplot2 3.3.5     v purrr   0.3.4
v tibble  3.1.6     v dplyr   1.0.7
v tidyr   1.1.4     v stringr 1.4.0
v readr   2.1.0     v forcats 0.5.1
-- Conflicts ------------------------------------------ tidyverse_conflicts() --
x dplyr::filter() masks stats::filter()
x dplyr::lag()    masks stats::lag()
here() starts at /work/users/p6095/2022-02-19_00/harp.119
Loading required package: harpIO

Attaching package: 'harpIO'

The following object is masked from 'package:purrr':

    accumulate

Loading required package: harpPoint
Loading required package: harpVis
Loading required package: shiny
-- Conflicts ------------------------------------------ tidyverse_conflicts() --
x dplyr::filter() masks stats::filter()
x dplyr::lag()    masks stats::lag()
here() starts at /work/users/p6095/2022-02-19_00/harp.119
Loading required package: harpIO

Attaching package: 'harpIO'

The following object is masked from 'package:purrr':

    accumulate

Loading required package: harpPoint
Loading required package: harpVis
Loading required package: shiny
Loading required package: harpSpatial
Error: unexpected string constant in:
"
'4'"
Execution halted
Loading required package: harpSpatial
Error: unexpected string constant in:
"
'4'"
Execution halted

----------------------------------------------------
Application finished OK at: 21-02-2022  15:46:11 UTC
----------------------------------------------------

如你所见，它表明应用程序完成正常，无论是否是 R 代码中的错误。我需要这个：如果推送线程有异常 -> 停止应用程序 perl

Answer 1

这是一个示例，说明如果给定线程的其中一个可执行文件运行失败，您可以如何使用状态消息停止主程序：

首先，我构建了一个虚拟可执行文件 foo.pl，如下所示：

use feature qw(say);
use strict;
use warnings;
my ($id, $force_fail) = @ARGV;
my $thread1_exit_value = $force_fail ? 2 : 0;
if ($id == 1) {
    sleep 2;
    exit $thread1_exit_value;
}
elsif ($id == 2) {
    sleep 5;
    exit 0;
}

那么主程序是这样的：

use v5.20;            # experimental signatures requires perl >= 5.20
use feature qw(say);
use strict;
use warnings;
use experimental qw(signatures);
use threads;

{
    my @threads;
    my $force_fail = 1;
    my $start_time = time;
    for (1..2) {
        my $thr = threads->create(
            sub {
                my $res = system "foo.pl", $_, $force_fail; $res
            }
        );
        push @threads, $thr;
    }
    my $fail = 0;
    for my $i (0..$#threads) {
        my $thr = $threads[$i];
        if ($fail) {
            say "detaching thread $i..";
            $thr->detach();
        }
        else {
            say "joining thread $i..";
            my $res = $thr->join();
            if (command_failed($res, $i)) {
                $fail = 1;
            }
        }
    }
    my $total_time = time - $start_time;
    say "Program " . ($fail ? "failed" : "succeeded") . " after $total_time seconds";
}
    
sub command_failed( $res, $id ) {
    if ($res == -1) {
        say "thread $id failed to execute: $!";
        return 1;
    }
    elsif ($res & 127) {
        printf "thread $id died from signal %d\n", $res & 127;
        return 1;
    }
    else {
        my $rcode = $res >> 8;
        if ($rcode != 0) {
            say "thread $id exited with return value $rcode";
            return 1;
        }
        return 0;
    }
}

在主脚本第9行设置$force_fail = 1时，输出为：

joining thread 0..
thread 0 exited with return value 2
detaching thread 1..
Program failed after 2 seconds

另一方面，当设置 $force_fail = 0 时，输出为：

joining thread 0..
joining thread 1..
Program succeeded after 5 seconds

如果推送线程在 Perl 中有异常，则停止应用程序

stop application if pushed thread had exception in Perl

r

perl

parallel-processing