Fabre

#1028275 perl: Return value of system() #1028275

Package:: perl

Source:: perl

Description:: Larry Wall's Practical Extraction and Report Language

Submitter:: David Christensen

Date:: 2023-01-16 00:27:03 UTC

Severity:: normal

#1028275#5

Date:: 2023-01-09 04:49:49 UTC

From:

To:

Dear Maintainer,

I am working on some Perl code with child processes and signals.


'perldoc -f system' says:

    The return value is the exit status of the program as returned
    by the "wait" call.


Reading further, if the child died due to a signal, the signal number
is supposed to be in the bottom 7 bits of $? ($CHILD_ERROR).


Testing shows that system() returns the same value as the value of the
Perl global child error variable $? ($CHILD_ERROR) when the child dies
due to a signal.


Here is a test script:

2023-01-08 20:12:49 dpchrist@laalaa ~/sandbox/perl/signal-child_error
$ nl signal-child_error-system.t
     1	#!/usr/bin/env perl
     2	# $Id: signal-child_error-system.t,v 1.4 2023/01/09 04:07:32 dpchrist Exp $
     3	# by David Paul Christensen dpchrist@holgerdanske.com
     4	# Public Domain
     5	#
     6	# Demonstrates Perl child SIGHUP and $? ($CHILD_ERROR) using system().
     7
     8	use strict;
     9	use warnings;
    10	use POSIX			qw( SIGHUP );
    11	use Test::More;
    12
    13	isnt $$, 0, join $", __FILE__, __LINE__,
    14	    sprintf '$$(%i) != 0', $$;
    15
    16	isnt SIGHUP, 0, join $", __FILE__, __LINE__,
    17	    sprintf 'SIGHUP(%i) != 0', SIGHUP;
    18
    19	my $system = system(q( perl -e 'kill "HUP", $$' ));
    20
    21	is $system, $?, join $", __FILE__, __LINE__,
    22	    sprintf '$system(%i) == $?(%i)', $system, $?;
    23
    24	is $?, SIGHUP, join $", __FILE__, __LINE__,
    25	    sprintf "\$?(%i) == SIGHUP(%i)", $?, SIGHUP;
    26
    27	my $b15	  = ($? >> 15) &   1;
    28	my $b14_8 = ($? >>  8) & 127;
    29	my $b7    = ($? >>  7) &   1;
    30	my $b6_0  =  $?        & 127;
    31
    32	is $b15,   0,      join $", __FILE__, __LINE__,
    33	    sprintf "\$b15(%i) == 0",   $b15;
    34
    35	is $b14_8, 0,      join $", __FILE__, __LINE__,
    36	    sprintf "\$b14_8(%i) == 0", $b14_8;
    37
    38	is $b7,    0,      join $", __FILE__, __LINE__,
    39	    sprintf "\$b7(%i) == 0",    $b7;
    40
    41	is $b6_0,  SIGHUP, join $", __FILE__, __LINE__,
    42	    sprintf "\$b6_0(%i) == SIGHUP(%i)",  $b6_0, SIGHUP;
    43
    44	done_testing;


If I run the test script on Debian:

2023-01-08 20:17:31 dpchrist@laalaa ~/sandbox/perl/signal-child_error
$ cat /etc/debian_version ; uname -a ; perl -v | head -n 2 | tail -n 1
11.6
Linux laalaa 5.10.0-20-amd64 #1 SMP Debian 5.10.158-2 (2022-12-13) x86_64 GNU/Linux
This is perl 5, version 32, subversion 1 (v5.32.1) built for x86_64-linux-gnu-thread-multi

2023-01-08 20:17:41 dpchrist@laalaa ~/sandbox/perl/signal-child_error
$ perl signal-child_error-system.t
ok 1 - signal-child_error-system.t 13 $$(17280) != 0
ok 2 - signal-child_error-system.t 16 SIGHUP(1) != 0
Hangup
ok 3 - signal-child_error-system.t 21 $system(33024) == $?(33024)
not ok 4 - signal-child_error-system.t 24 $?(33024) == SIGHUP(1)
#   Failed test 'signal-child_error-system.t 24 $?(33024) == SIGHUP(1)'
#   at signal-child_error-system.t line 24.
#          got: '33024'
#     expected: '1'
not ok 5 - signal-child_error-system.t 32 $b15(1) == 0
#   Failed test 'signal-child_error-system.t 32 $b15(1) == 0'
#   at signal-child_error-system.t line 32.
#          got: '1'
#     expected: '0'
not ok 6 - signal-child_error-system.t 35 $b14_8(1) == 0
#   Failed test 'signal-child_error-system.t 35 $b14_8(1) == 0'
#   at signal-child_error-system.t line 35.
#          got: '1'
#     expected: '0'
ok 7 - signal-child_error-system.t 38 $b7(0) == 0
not ok 8 - signal-child_error-system.t 41 $b6_0(0) == SIGHUP(1)
#   Failed test 'signal-child_error-system.t 41 $b6_0(0) == SIGHUP(1)'
#   at signal-child_error-system.t line 41.
#          got: '0'
#     expected: '1'
1..8
# Looks like you failed 4 tests of 8.


Please note:

- The return value of system() is identical to $? ($CHILD_ERROR)
 (line 21).

- This value does not correspond to the signal number (line 24).

- Bit 15 is 1, when it should be 0 (line 32)

- Bits 14-8 contain the signal number, when they should be 0 (line 35).

- Bits 6-0 are 0, when they should contain the signal number (line 41).


If I run the same script on FreeBSD with the same version of Perl:

2023-01-08 20:19:57 dpchrist@f3 ~/sandbox/perl/signal-child_error
$ freebsd-version ; uname -a ; perl -v | head -n 2 | tail -n 1
12.3-RELEASE-p10
FreeBSD f3.tracy.holgerdanske.com 12.3-RELEASE-p6 FreeBSD 12.3-RELEASE-p6 GENERIC  amd64
This is perl 5, version 32, subversion 1 (v5.32.1) built for amd64-freebsd-thread-multi

2023-01-08 20:20:00 dpchrist@f3 ~/sandbox/perl/signal-child_error
$ grep Id signal-child_error-system.t
# $Id: signal-child_error-system.t,v 1.4 2023/01/09 04:07:32 dpchrist Exp $

2023-01-08 20:20:26 dpchrist@f3 ~/sandbox/perl/signal-child_error
$ perl signal-child_error-system.t
ok 1 - signal-child_error-system.t 13 $$(22264) != 0
ok 2 - signal-child_error-system.t 16 SIGHUP(1) != 0
ok 3 - signal-child_error-system.t 21 $system(1) == $?(1)
ok 4 - signal-child_error-system.t 24 $?(1) == SIGHUP(1)
ok 5 - signal-child_error-system.t 32 $b15(0) == 0
ok 6 - signal-child_error-system.t 35 $b14_8(0) == 0
ok 7 - signal-child_error-system.t 38 $b7(0) == 0
ok 8 - signal-child_error-system.t 41 $b6_0(1) == SIGHUP(1)
1..8


If I run the same script on Windows 7 Pro with Cygwin and the same
version of Perl:

2023-01-08 20:39:13 dpchrist@win7 ~/sandbox/perl/signal-child_error
$ uname -a; perl -v | head -n 2 | tail -n 1
CYGWIN_NT-6.1-7601 win7 3.3.6-341.x86_64 2022-09-05 11:15 UTC x86_64 Cygwin
This is perl 5, version 32, subversion 1 (v5.32.1) built for x86_64-cygwin-threads-multi

2023-01-08 20:39:24 dpchrist@win7 ~/sandbox/perl/signal-child_error
$ grep Id signal-child_error-system.t
# $Id: signal-child_error-system.t,v 1.4 2023/01/09 04:07:32 dpchrist Exp $

2023-01-08 20:39:29 dpchrist@win7 ~/sandbox/perl/signal-child_error
$ perl signal-child_error-system.t
ok 1 - signal-child_error-system.t 13 $$(1000) != 0
ok 2 - signal-child_error-system.t 16 SIGHUP(1) != 0
ok 3 - signal-child_error-system.t 21 $system(1) == $?(1)
ok 4 - signal-child_error-system.t 24 $?(1) == SIGHUP(1)
ok 5 - signal-child_error-system.t 32 $b15(0) == 0
ok 6 - signal-child_error-system.t 35 $b14_8(0) == 0
ok 7 - signal-child_error-system.t 38 $b7(0) == 0
ok 8 - signal-child_error-system.t 41 $b6_0(1) == SIGHUP(1)
1..8


If I run the same script on macOS and an earlier version of Perl:

2023-01-08 20:44:21 dpchrist@dpchrist-mbp ~/sandbox/perl/signal-child_error
$ uname -a ; perl -v | head -n 2 | tail -n 1
Darwin dpchrist-mbp 21.6.0 Darwin Kernel Version 21.6.0: Mon Aug 22 20:17:10 PDT 2022; root:xnu-8020.140.49~2/RELEASE_X86_64 x86_64
This is perl 5, version 30, subversion 3 (v5.30.3) built for darwin-thread-multi-2level

2023-01-08 20:44:38 dpchrist@dpchrist-mbp ~/sandbox/perl/signal-child_error
$ grep Id signal-child_error-system.t
# $Id: signal-child_error-system.t,v 1.4 2023/01/09 04:07:32 dpchrist Exp $

2023-01-08 20:44:42 dpchrist@dpchrist-mbp ~/sandbox/perl/signal-child_error
$ perl signal-child_error-system.t
ok 1 - signal-child_error-system.t 13 $$(2002) != 0
ok 2 - signal-child_error-system.t 16 SIGHUP(1) != 0
ok 3 - signal-child_error-system.t 21 $system(1) == $?(1)
ok 4 - signal-child_error-system.t 24 $?(1) == SIGHUP(1)
ok 5 - signal-child_error-system.t 32 $b15(0) == 0
ok 6 - signal-child_error-system.t 35 $b14_8(0) == 0
ok 7 - signal-child_error-system.t 38 $b7(0) == 0
ok 8 - signal-child_error-system.t 41 $b6_0(1) == SIGHUP(1)
1..8


David

#1028275#10

Date:: 2023-01-09 19:35:52 UTC

From:

To:

Control: forwarded -1 https://github.com/Perl/perl5/issues/19020
Control: block -1 with 436466

Hi, this is about a difference in bash vs. dash as /bin/sh.

Perl runs the single arg form of system() through /bin/sh, and when that
shell is dash (as it is by default on Debian), the child perl gets forked
rather than execed in the shell process (like bash does.)

The signal information is then consumed by dash and never reaches the
parent perl process.

There's a Perl upstream discussion about this in
https://github.com/Perl/perl5/issues/19020
and it looks like dash upstream is nowadays doing the exec() thing
but Debian dash is carrying a patch to disable that. See #436466.

Not much we can do about this on the perl side apart from configuring
perl to always use /bin/bash as the intermediate shell. I'm not thrilled
about that option and would much rather see the dash behaviour changed.

Workarounds I can see are calling system() in list form so the shell
doesn't get invoked, or locally changing /bin/sh to point to bash.

#1028275#19

Date:: 2023-01-11 03:54:33 UTC

From:

To:


Thank you for the prompt and detailed reply.  I agree that fixing Dash
seems like the correct solution.  I will investigate the alternatives
you suggest.


David

#1028275#24

Date:: 2023-01-15 05:05:33 UTC

From:

To:

Debian bug 1028275:

Below please find a more sophisticated test script for Perl system()
using one argument and sample runs on Debian and FreeBSD.


HTH,

David



2023-01-14 20:55:10 dpchrist@laalaa /samba/dpchrist/sandbox/perl
$ cat system-one-argument.t
#!/usr/bin/env perl
# $Id: system-one-argument.t,v 1.1 2023/01/15 04:48:26 dpchrist Exp $
# by David Paul Christensen dpchrist@holgerdanske.com
# Public Domain
#
# Test Perl's system() built-in function w.r.t.:
# - Failure to execute
# - Child dying due to signal
# - Child exit value

use strict;
use warnings;
use Capture::Tiny		qw( capture );
use POSIX			qw( SIGHUP SIGUSR2 );
use Test::More;
use Test::Warn;

isnt $$, 0, join $", __FILE__, __LINE__,
     sprintf 'Parent PID == %i is non-zero', $$;

isnt SIGHUP, 0, join $", __FILE__, __LINE__,
     sprintf 'Signal SIGHUP == %i is non-zero', SIGHUP;

sub _debian_dash
{
     my $sub = shift;
     if (-e '/etc/debian_version') {
	TODO: {
	    local $TODO =
"https://bugs.debian.org/cgi-bin/bugreport.cgi?bug=1028275";
	    $sub->();
	}
     }
     else { $sub->() }
}

note "Child failed to execute";
{
     my ($stdout, $stderr, $system) = capture {
	system(q( nosuchprogram ));
     };

     is $stdout, '', join $", __FILE__, __LINE__,
	sprintf q(STDOUT '%s' is empty string), $stdout;

     my $qr = qr/^Can't exec "nosuchprogram": No such file or directory/;

     like $stderr,
	$qr,
	join $", __FILE__, __LINE__,
	sprintf q(STDERR '%s' is like %s), $stderr, $qr;

     is $system, $?, join $", __FILE__, __LINE__,
	sprintf 'System return value (0x%X) is $CHILD_ERROR (0x%X)',
	    $system,
	    $?;

     is $?, -1, join $", __FILE__, __LINE__,
	sprintf '$CHILD_ERROR (0x%X) is -1',
	    $?;

    is $? & 127, 0x7F, join $", __FILE__, __LINE__,
	sprintf 'Lower 7 bits of $CHILD_ERROR (0x%X) are ones',
	    $? & 127;

     is $? >> 8, (~0) >> 8, join $", __FILE__, __LINE__,
	sprintf 'Upper bytes of $CHILD_ERROR (0x%X) are ones',
	    $? >> 8;
}

note "Child kills itself with signal HUP";
{
     my $system = system(q( perl -e 'kill "HUP", $$' ));

     is $system, $?, join $", __FILE__, __LINE__,
	sprintf 'System return value (0x%X) is $CHILD_ERROR (0x%X)',
	    $system,
	    $?;

     isnt $?, -1, join $", __FILE__, __LINE__,
	sprintf '$CHILD_ERROR (0x%X) isnt -1',
	    $?;

     _debian_dash sub {
	is $? & 127, SIGHUP, join $", __FILE__, __LINE__,
	    sprintf 'Lower 7 bits of $CHILD_ERROR (0x%X) is SIGHUP (0x%X)',
		$? & 127,
		SIGHUP;
     };

     _debian_dash sub {
	is $? >> 8, 0, join $", __FILE__, __LINE__,
	    sprintf 'Upper bytes of $CHILD_ERROR (0x%X) are zeroes',
		$? >> 8;
     };
}

note "Child kills itself with signal USR2";
{
     my $system = system(q( perl -e 'kill "USR2", $$' ));

     is $system, $?, join $", __FILE__, __LINE__,
	sprintf 'System return value (0x%X) is $CHILD_ERROR (0x%X)',
	    $system,
	    $?;

     isnt $?, -1, join $", __FILE__, __LINE__,
	sprintf '$CHILD_ERROR (0x%X) isnt -1',
	    $?;

     _debian_dash sub {
	is $? & 127, SIGUSR2, join $", __FILE__, __LINE__,
	    sprintf 'Lower 7 bits of $CHILD_ERROR (0x%X) is SIGUSR2 (0x%X)',
		$? & 127,
		SIGUSR2;
     };

     _debian_dash sub {
	is $? >> 8, 0, join $", __FILE__, __LINE__,
	    sprintf 'Upper bytes of $CHILD_ERROR (0x%X) are zeroes',
		$? >> 8;
     };
}

note "Child exits with value 0";
{
     my $system = system(q( perl -e 'exit 0' ));

     is $system, $?, join $", __FILE__, __LINE__,
	sprintf 'System return value (0x%X) is $CHILD_ERROR (0x%X)',
	    $system,
	    $?;

     isnt $?, -1, join $", __FILE__, __LINE__,
	sprintf '$CHILD_ERROR (0x%X) isnt -1',
	    $?;

     is $? & 127, 0, join $", __FILE__, __LINE__,
	sprintf 'Lower 7 bits of $CHILD_ERROR (0x%X) are zeroes',
	    $? & 127;

     is $? >> 8, 0, join $", __FILE__, __LINE__,
	sprintf 'Upper bytes of $CHILD_ERROR (0x%X) are zeroes',
	    $? >> 8;
}

note "Child exits with value 0xA5";
{
     my $system = system(qq( perl -e 'exit 0xA5' ));

     is $system, $?, join $", __FILE__, __LINE__,
	sprintf 'System return value (0x%X) is $CHILD_ERROR (0x%X)',
	    $system,
	    $?;

     isnt $?, -1, join $", __FILE__, __LINE__,
	sprintf '$CHILD_ERROR (0x%X) isnt -1',
	    $?;

     is $? & 127, 0, join $", __FILE__, __LINE__,
	sprintf 'Lower 7 bits of $CHILD_ERROR (0x%X) are zeroes',
	    $? & 127;

     is $? >> 8, 0xA5, join $", __FILE__, __LINE__,
	sprintf 'Upper bytes of $CHILD_ERROR (0x%X) are 0xA5',
	    $? >> 8;
}

done_testing;



2023-01-14 21:01:23 dpchrist@laalaa /samba/dpchrist/sandbox/perl
$ cat /etc/debian_version ; uname -a ; perl -v | head -n 2 | tail -n 1
11.6
Linux laalaa 5.10.0-20-amd64 #1 SMP Debian 5.10.158-2 (2022-12-13)
x86_64 GNU/Linux
This is perl 5, version 32, subversion 1 (v5.32.1) built for
x86_64-linux-gnu-thread-multi

2023-01-14 21:01:41 dpchrist@laalaa /samba/dpchrist/sandbox/perl
$ perl system-one-argument.t
ok 1 - system-one-argument.t 18 Parent PID == 9384 is non-zero
ok 2 - system-one-argument.t 21 Signal SIGHUP == 1 is non-zero
# Child failed to execute
ok 3 - system-one-argument.t 42 STDOUT '' is empty string
ok 4 - system-one-argument.t 49 STDERR 'Can't exec "nosuchprogram": No
such file or directory at system-one-argument.t line 39.
# ' is like (?^:^Can't exec "nosuchprogram": No such file or directory)
ok 5 - system-one-argument.t 52 System return value (0xFFFFFFFFFFFFFFFF)
is $CHILD_ERROR (0xFFFFFFFFFFFFFFFF)
ok 6 - system-one-argument.t 57 $CHILD_ERROR (0xFFFFFFFFFFFFFFFF) is -1
ok 7 - system-one-argument.t 61 Lower 7 bits of $CHILD_ERROR (0x7F) are ones
ok 8 - system-one-argument.t 65 Upper bytes of $CHILD_ERROR
(0xFFFFFFFFFFFFFF) are ones
# Child kills itself with signal HUP
Hangup
ok 9 - system-one-argument.t 74 System return value (0x8100) is
$CHILD_ERROR (0x8100)
ok 10 - system-one-argument.t 79 $CHILD_ERROR (0x8100) isnt -1
not ok 11 - system-one-argument.t 84 Lower 7 bits of $CHILD_ERROR (0x0)
is SIGHUP (0x1) # TODO
https://bugs.debian.org/cgi-bin/bugreport.cgi?bug=1028275
#   Failed (TODO) test 'system-one-argument.t 84 Lower 7 bits of
$CHILD_ERROR (0x0) is SIGHUP (0x1)'
#   at system-one-argument.t line 84.
#          got: '0'
#     expected: '1'
not ok 12 - system-one-argument.t 91 Upper bytes of $CHILD_ERROR (0x81)
are zeroes # TODO https://bugs.debian.org/cgi-bin/bugreport.cgi?bug=1028275
#   Failed (TODO) test 'system-one-argument.t 91 Upper bytes of
$CHILD_ERROR (0x81) are zeroes'
#   at system-one-argument.t line 91.
#          got: '129'
#     expected: '0'
# Child kills itself with signal USR2
User defined signal 2
ok 13 - system-one-argument.t 101 System return value (0x8C00) is
$CHILD_ERROR (0x8C00)
ok 14 - system-one-argument.t 106 $CHILD_ERROR (0x8C00) isnt -1
not ok 15 - system-one-argument.t 111 Lower 7 bits of $CHILD_ERROR (0x0)
is SIGUSR2 (0xC) # TODO
https://bugs.debian.org/cgi-bin/bugreport.cgi?bug=1028275
#   Failed (TODO) test 'system-one-argument.t 111 Lower 7 bits of
$CHILD_ERROR (0x0) is SIGUSR2 (0xC)'
#   at system-one-argument.t line 111.
#          got: '0'
#     expected: '12'
not ok 16 - system-one-argument.t 118 Upper bytes of $CHILD_ERROR (0x8C)
are zeroes # TODO https://bugs.debian.org/cgi-bin/bugreport.cgi?bug=1028275
#   Failed (TODO) test 'system-one-argument.t 118 Upper bytes of
$CHILD_ERROR (0x8C) are zeroes'
#   at system-one-argument.t line 118.
#          got: '140'
#     expected: '0'
# Child exits with value 0
ok 17 - system-one-argument.t 128 System return value (0x0) is
$CHILD_ERROR (0x0)
ok 18 - system-one-argument.t 133 $CHILD_ERROR (0x0) isnt -1
ok 19 - system-one-argument.t 137 Lower 7 bits of $CHILD_ERROR (0x0) are
zeroes
ok 20 - system-one-argument.t 141 Upper bytes of $CHILD_ERROR (0x0) are
zeroes
# Child exits with value 0xA5
ok 21 - system-one-argument.t 150 System return value (0xA500) is
$CHILD_ERROR (0xA500)
ok 22 - system-one-argument.t 155 $CHILD_ERROR (0xA500) isnt -1
ok 23 - system-one-argument.t 159 Lower 7 bits of $CHILD_ERROR (0x0) are
zeroes
ok 24 - system-one-argument.t 163 Upper bytes of $CHILD_ERROR (0xA5) are
0xA5
1..24




2023-01-14 21:03:16 dpchrist@samba /var/local/samba/dpchrist/sandbox/perl
$ freebsd-version ; uname -a ; perl -v | head -n 2 | tail -n 1
12.3-RELEASE-p10
FreeBSD samba.tracy.holgerdanske.com 12.3-RELEASE-p6 FreeBSD
12.3-RELEASE-p6 GENERIC  amd64
This is perl 5, version 32, subversion 1 (v5.32.1) built for
amd64-freebsd-thread-multi

2023-01-14 21:03:18 dpchrist@samba /var/local/samba/dpchrist/sandbox/perl
$ perl system-one-argument.t
ok 1 - system-one-argument.t 18 Parent PID == 39848 is non-zero
ok 2 - system-one-argument.t 21 Signal SIGHUP == 1 is non-zero
# Child failed to execute
ok 3 - system-one-argument.t 42 STDOUT '' is empty string
ok 4 - system-one-argument.t 49 STDERR 'Can't exec "nosuchprogram": No
such file or directory at system-one-argument.t line 39.
# ' is like (?^:^Can't exec "nosuchprogram": No such file or directory)
ok 5 - system-one-argument.t 52 System return value (0xFFFFFFFFFFFFFFFF)
is $CHILD_ERROR (0xFFFFFFFFFFFFFFFF)
ok 6 - system-one-argument.t 57 $CHILD_ERROR (0xFFFFFFFFFFFFFFFF) is -1
ok 7 - system-one-argument.t 61 Lower 7 bits of $CHILD_ERROR (0x7F) are ones
ok 8 - system-one-argument.t 65 Upper bytes of $CHILD_ERROR
(0xFFFFFFFFFFFFFF) are ones
# Child kills itself with signal HUP
ok 9 - system-one-argument.t 74 System return value (0x1) is
$CHILD_ERROR (0x1)
ok 10 - system-one-argument.t 79 $CHILD_ERROR (0x1) isnt -1
ok 11 - system-one-argument.t 84 Lower 7 bits of $CHILD_ERROR (0x1) is
SIGHUP (0x1)
ok 12 - system-one-argument.t 91 Upper bytes of $CHILD_ERROR (0x0) are
zeroes
# Child kills itself with signal USR2
ok 13 - system-one-argument.t 101 System return value (0x1F) is
$CHILD_ERROR (0x1F)
ok 14 - system-one-argument.t 106 $CHILD_ERROR (0x1F) isnt -1
ok 15 - system-one-argument.t 111 Lower 7 bits of $CHILD_ERROR (0x1F) is
SIGUSR2 (0x1F)
ok 16 - system-one-argument.t 118 Upper bytes of $CHILD_ERROR (0x0) are
zeroes
# Child exits with value 0
ok 17 - system-one-argument.t 128 System return value (0x0) is
$CHILD_ERROR (0x0)
ok 18 - system-one-argument.t 133 $CHILD_ERROR (0x0) isnt -1
ok 19 - system-one-argument.t 137 Lower 7 bits of $CHILD_ERROR (0x0) are
zeroes
ok 20 - system-one-argument.t 141 Upper bytes of $CHILD_ERROR (0x0) are
zeroes
# Child exits with value 0xA5
ok 21 - system-one-argument.t 150 System return value (0xA500) is
$CHILD_ERROR (0xA500)
ok 22 - system-one-argument.t 155 $CHILD_ERROR (0xA500) isnt -1
ok 23 - system-one-argument.t 159 Lower 7 bits of $CHILD_ERROR (0x0) are
zeroes
ok 24 - system-one-argument.t 163 Upper bytes of $CHILD_ERROR (0xA5) are
0xA5
1..24

#1028275#29

Date:: 2023-01-15 21:35:11 UTC

From:

To:

Debian bug 1028275:

I have expanded my test script to test Perl's built-in system() with a
single argument and with a list of arguments.

HTH,

David



2023-01-15 13:07:34 dpchrist@laalaa ~/sandbox/perl
$ cat system.t
#!/usr/bin/env perl
# $Id: system.t,v 1.5 2023/01/15 21:07:33 dpchrist Exp $
# by David Paul Christensen dpchrist@holgerdanske.com
# Public Domain
#
# Test Perl built-in system().

use strict;
use warnings;
use Capture::Tiny		qw( capture );
use POSIX			qw( SIGUSR2 );
use Test::More;
use Test::Warn;

our @args;

our $stdout;
our $stderr;
our $system;
our $ce;

our $TODO;

sub _t
{
   note shift;

   local @args = @{ shift @_ };
   my $a = shift;

   note "\@args='", join("', '", @args), "'";
   ($stdout, $stderr, $system) = capture { system(@args) };
   $ce = $?;
   $_->() for @_;

   local @args = ($a);
   note "\@args='", join("', '", @args), "'";
   ($stdout, $stderr, $system) = capture { system(@args) };
   $ce = $?;
   $_->() for @_;
}

_t(@$_) for (
   [
     "Child failed to execute",
     [qw( nosuchprogram foo bar )],
     q(nosuchprogram foo bar),
     sub {
       eval {
        	is $stdout, '', join $", __FILE__, __LINE__,
	  'STDOUT is empty string';

	like
	  $stderr,
	  qr/^Can't exec "nosuchprogram": No such file or directory/,
	  join $", __FILE__, __LINE__,
	   q(STDERR like /Can't exec "nosuchprogram": No such file or directory/);

	is $system, $ce, join $", __FILE__, __LINE__,
	  sprintf 'System return value (0x%X) is $CHILD_ERROR (0x%X)',
	  $system,
	  $ce;

	is $ce, -1, join $", __FILE__, __LINE__,
	  sprintf '$CHILD_ERROR (0x%X) is -1',
	  $ce;

	is $ce & 127, 0x7F, join $", __FILE__, __LINE__,
	  sprintf 'Lower 7 bits of $CHILD_ERROR (0x%X) are ones',
	    $ce & 127;

	is $ce >> 8, (~0) >> 8, join $", __FILE__, __LINE__,
	  sprintf 'Upper bytes of $CHILD_ERROR (0x%X) are ones',
	    $ce >> 8;
       };
     },
   ],

   [
     "Child kills itself with signal USR2",
     ['perl', '-e', 'kill "USR2", $$'],
     q(perl -e 'kill "USR2", $$'),
     sub {
       eval {
	is $system, $ce, join $", __FILE__, __LINE__,

	sprintf 'System return value (0x%X) is $CHILD_ERROR (0x%X)',
       	  $system,
	  $ce;

	isnt $ce, -1, join $", __FILE__, __LINE__,
	  sprintf '$CHILD_ERROR (0x%X) isnt -1',
	    $ce;
       };
     },
     sub {
       my $code = q{
	is $ce & 127, SIGUSR2, join $", __FILE__, __LINE__,
	  sprintf 'Lower 7 bits of $CHILD_ERROR (0x%X) is SIGUSR2 (0x%X)',
	    $ce & 127,
	    SIGUSR2;

	is $ce >> 8, 0, join $", __FILE__, __LINE__,
	  sprintf 'Upper bytes of $CHILD_ERROR (0x%X) are zeroes',
	    $ce >> 8;
       };
       if (@args == 1 && -e '/etc/debian_version') {
	TODO: {
	  local $TODO =
"https://bugs.debian.org/cgi-bin/bugreport.cgi?bug=1028275";
	  eval $code;
	}
       }
       else {
	eval $code;
       }
     },
   ],

   [
     "Child exits with value 0xA5",
     ['perl', '-e', 'exit 0xA5'],
     q(perl -e 'exit 0xA5'),
     sub {
       eval {
     	is $system, $ce, join $", __FILE__, __LINE__,
   	  sprintf 'System return value (0x%X) is $CHILD_ERROR (0x%X)',
	    $system,
	    $ce;

       	isnt $ce, -1, join $", __FILE__, __LINE__,
   	  sprintf '$CHILD_ERROR (0x%X) isnt -1',
	    $ce;

       	is $ce & 127, 0, join $", __FILE__, __LINE__,
   	  sprintf 'Lower 7 bits of $CHILD_ERROR (0x%X) are zeroes',
	    $ce & 127;

       	is $ce >> 8, 0xA5, join $", __FILE__, __LINE__,
   	  sprintf 'Upper bytes of $CHILD_ERROR (0x%X) is 0xA5',
	    $ce >> 8;
       };
     },
   ],
);

done_testing;



2023-01-15 13:24:04 dpchrist@laalaa ~/sandbox/perl
$ cat /etc/debian_version ; uname -a ; perl -v | head -n 2 | tail -n 1
11.6
Linux laalaa 5.10.0-20-amd64 #1 SMP Debian 5.10.158-2 (2022-12-13)
x86_64 GNU/Linux
This is perl 5, version 32, subversion 1 (v5.32.1) built for
x86_64-linux-gnu-thread-multi


2023-01-15 13:24:09 dpchrist@laalaa ~/sandbox/perl
$ perl system.t
# Child failed to execute
# @args='nosuchprogram', 'foo', 'bar'
ok 1 - system.t 50 STDOUT is empty string
ok 2 - system.t 56 STDERR like /Can't exec "nosuchprogram": No such file
or directory/
ok 3 - system.t 59 System return value (0xFFFFFFFFFFFFFFFF) is
$CHILD_ERROR (0xFFFFFFFFFFFFFFFF)
ok 4 - system.t 64 $CHILD_ERROR (0xFFFFFFFFFFFFFFFF) is -1
ok 5 - system.t 68 Lower 7 bits of $CHILD_ERROR (0x7F) are ones
ok 6 - system.t 72 Upper bytes of $CHILD_ERROR (0xFFFFFFFFFFFFFF) are ones
# @args='nosuchprogram foo bar'
ok 7 - system.t 50 STDOUT is empty string
ok 8 - system.t 56 STDERR like /Can't exec "nosuchprogram": No such file
or directory/
ok 9 - system.t 59 System return value (0xFFFFFFFFFFFFFFFF) is
$CHILD_ERROR (0xFFFFFFFFFFFFFFFF)
ok 10 - system.t 64 $CHILD_ERROR (0xFFFFFFFFFFFFFFFF) is -1
ok 11 - system.t 68 Lower 7 bits of $CHILD_ERROR (0x7F) are ones
ok 12 - system.t 72 Upper bytes of $CHILD_ERROR (0xFFFFFFFFFFFFFF) are ones
# Child kills itself with signal USR2
# @args='perl', '-e', 'kill "USR2", $$'
ok 13 - system.t 85 System return value (0xC) is $CHILD_ERROR (0xC)
ok 14 - system.t 91 $CHILD_ERROR (0xC) isnt -1
ok 15 - (eval 35) 2 Lower 7 bits of $CHILD_ERROR (0xC) is SIGUSR2 (0xC)
ok 16 - (eval 35) 7 Upper bytes of $CHILD_ERROR (0x0) are zeroes
# @args='perl -e 'kill "USR2", $$''
ok 17 - system.t 85 System return value (0x8C00) is $CHILD_ERROR (0x8C00)
ok 18 - system.t 91 $CHILD_ERROR (0x8C00) isnt -1
not ok 19 - (eval 40) 2 Lower 7 bits of $CHILD_ERROR (0x0) is SIGUSR2
(0xC) # TODO https://bugs.debian.org/cgi-bin/bugreport.cgi?bug=1028275
#   Failed (TODO) test '(eval 40) 2 Lower 7 bits of $CHILD_ERROR (0x0)
is SIGUSR2 (0xC)'
#   at (eval 40) line 2.
#          got: '0'
#     expected: '12'
not ok 20 - (eval 40) 7 Upper bytes of $CHILD_ERROR (0x8C) are zeroes #
TODO https://bugs.debian.org/cgi-bin/bugreport.cgi?bug=1028275
#   Failed (TODO) test '(eval 40) 7 Upper bytes of $CHILD_ERROR (0x8C)
are zeroes'
#   at (eval 40) line 7.
#          got: '140'
#     expected: '0'
# Child exits with value 0xA5
# @args='perl', '-e', 'exit 0xA5'
ok 21 - system.t 125 System return value (0xA500) is $CHILD_ERROR (0xA500)
ok 22 - system.t 130 $CHILD_ERROR (0xA500) isnt -1
ok 23 - system.t 134 Lower 7 bits of $CHILD_ERROR (0x0) are zeroes
ok 24 - system.t 138 Upper bytes of $CHILD_ERROR (0xA5) is 0xA5
# @args='perl -e 'exit 0xA5''
ok 25 - system.t 125 System return value (0xA500) is $CHILD_ERROR (0xA500)
ok 26 - system.t 130 $CHILD_ERROR (0xA500) isnt -1
ok 27 - system.t 134 Lower 7 bits of $CHILD_ERROR (0x0) are zeroes
ok 28 - system.t 138 Upper bytes of $CHILD_ERROR (0xA5) is 0xA5
1..28



2023-01-15 13:19:38 dpchrist@samba /var/local/samba/dpchrist/sandbox/perl
$ freebsd-version ; uname -a ; perl -v | head -n 2 | tail -n 1
12.3-RELEASE-p10
FreeBSD samba.tracy.holgerdanske.com 12.3-RELEASE-p6 FreeBSD
12.3-RELEASE-p6 GENERIC  amd64
This is perl 5, version 32, subversion 1 (v5.32.1) built for
amd64-freebsd-thread-multi

2023-01-15 13:31:23 dpchrist@samba /var/local/samba/dpchrist/sandbox/perl
$ perl system.t
# Child failed to execute
# @args='nosuchprogram', 'foo', 'bar'
ok 1 - system.t 50 STDOUT is empty string
ok 2 - system.t 56 STDERR like /Can't exec "nosuchprogram": No such file
or directory/
ok 3 - system.t 59 System return value (0xFFFFFFFFFFFFFFFF) is
$CHILD_ERROR (0xFFFFFFFFFFFFFFFF)
ok 4 - system.t 64 $CHILD_ERROR (0xFFFFFFFFFFFFFFFF) is -1
ok 5 - system.t 68 Lower 7 bits of $CHILD_ERROR (0x7F) are ones
ok 6 - system.t 72 Upper bytes of $CHILD_ERROR (0xFFFFFFFFFFFFFF) are ones
# @args='nosuchprogram foo bar'
ok 7 - system.t 50 STDOUT is empty string
ok 8 - system.t 56 STDERR like /Can't exec "nosuchprogram": No such file
or directory/
ok 9 - system.t 59 System return value (0xFFFFFFFFFFFFFFFF) is
$CHILD_ERROR (0xFFFFFFFFFFFFFFFF)
ok 10 - system.t 64 $CHILD_ERROR (0xFFFFFFFFFFFFFFFF) is -1
ok 11 - system.t 68 Lower 7 bits of $CHILD_ERROR (0x7F) are ones
ok 12 - system.t 72 Upper bytes of $CHILD_ERROR (0xFFFFFFFFFFFFFF) are ones
# Child kills itself with signal USR2
# @args='perl', '-e', 'kill "USR2", $$'
ok 13 - system.t 85 System return value (0x1F) is $CHILD_ERROR (0x1F)
ok 14 - system.t 91 $CHILD_ERROR (0x1F) isnt -1
ok 15 - (eval 35) 2 Lower 7 bits of $CHILD_ERROR (0x1F) is SIGUSR2 (0x1F)
ok 16 - (eval 35) 7 Upper bytes of $CHILD_ERROR (0x0) are zeroes
# @args='perl -e 'kill "USR2", $$''
ok 17 - system.t 85 System return value (0x1F) is $CHILD_ERROR (0x1F)
ok 18 - system.t 91 $CHILD_ERROR (0x1F) isnt -1
ok 19 - (eval 40) 2 Lower 7 bits of $CHILD_ERROR (0x1F) is SIGUSR2 (0x1F)
ok 20 - (eval 40) 7 Upper bytes of $CHILD_ERROR (0x0) are zeroes
# Child exits with value 0xA5
# @args='perl', '-e', 'exit 0xA5'
ok 21 - system.t 125 System return value (0xA500) is $CHILD_ERROR (0xA500)
ok 22 - system.t 130 $CHILD_ERROR (0xA500) isnt -1
ok 23 - system.t 134 Lower 7 bits of $CHILD_ERROR (0x0) are zeroes
ok 24 - system.t 138 Upper bytes of $CHILD_ERROR (0xA5) is 0xA5
# @args='perl -e 'exit 0xA5''
ok 25 - system.t 125 System return value (0xA500) is $CHILD_ERROR (0xA500)
ok 26 - system.t 130 $CHILD_ERROR (0xA500) isnt -1
ok 27 - system.t 134 Lower 7 bits of $CHILD_ERROR (0x0) are zeroes
ok 28 - system.t 138 Upper bytes of $CHILD_ERROR (0xA5) is 0xA5
1..28



2023-01-15 13:31:57 dpchrist@dpchrist-mbp ~/sandbox/perl
$ uname -a ; perl -v | head -n 2 | tail -n 1
Darwin dpchrist-mbp 21.6.0 Darwin Kernel Version 21.6.0: Mon Aug 22
20:17:10 PDT 2022; root:xnu-8020.140.49~2/RELEASE_X86_64 x86_64
This is perl 5, version 30, subversion 3 (v5.30.3) built for
darwin-thread-multi-2level

2023-01-15 13:32:08 dpchrist@dpchrist-mbp ~/sandbox/perl
$ perl system.t
# Child failed to execute
# @args='nosuchprogram', 'foo', 'bar'
ok 1 - system.t 50 STDOUT is empty string
ok 2 - system.t 56 STDERR like /Can't exec "nosuchprogram": No such file
or directory/
ok 3 - system.t 59 System return value (0xFFFFFFFFFFFFFFFF) is
$CHILD_ERROR (0xFFFFFFFFFFFFFFFF)
ok 4 - system.t 64 $CHILD_ERROR (0xFFFFFFFFFFFFFFFF) is -1
ok 5 - system.t 68 Lower 7 bits of $CHILD_ERROR (0x7F) are ones
ok 6 - system.t 72 Upper bytes of $CHILD_ERROR (0xFFFFFFFFFFFFFF) are ones
# @args='nosuchprogram foo bar'
ok 7 - system.t 50 STDOUT is empty string
ok 8 - system.t 56 STDERR like /Can't exec "nosuchprogram": No such file
or directory/
ok 9 - system.t 59 System return value (0xFFFFFFFFFFFFFFFF) is
$CHILD_ERROR (0xFFFFFFFFFFFFFFFF)
ok 10 - system.t 64 $CHILD_ERROR (0xFFFFFFFFFFFFFFFF) is -1
ok 11 - system.t 68 Lower 7 bits of $CHILD_ERROR (0x7F) are ones
ok 12 - system.t 72 Upper bytes of $CHILD_ERROR (0xFFFFFFFFFFFFFF) are ones
# Child kills itself with signal USR2
# @args='perl', '-e', 'kill "USR2", $$'
ok 13 - system.t 85 System return value (0x1F) is $CHILD_ERROR (0x1F)
ok 14 - system.t 91 $CHILD_ERROR (0x1F) isnt -1
ok 15 - (eval 36) 2 Lower 7 bits of $CHILD_ERROR (0x1F) is SIGUSR2 (0x1F)
ok 16 - (eval 36) 7 Upper bytes of $CHILD_ERROR (0x0) are zeroes
# @args='perl -e 'kill "USR2", $$''
ok 17 - system.t 85 System return value (0x1F) is $CHILD_ERROR (0x1F)
ok 18 - system.t 91 $CHILD_ERROR (0x1F) isnt -1
ok 19 - (eval 41) 2 Lower 7 bits of $CHILD_ERROR (0x1F) is SIGUSR2 (0x1F)
ok 20 - (eval 41) 7 Upper bytes of $CHILD_ERROR (0x0) are zeroes
# Child exits with value 0xA5
# @args='perl', '-e', 'exit 0xA5'
ok 21 - system.t 125 System return value (0xA500) is $CHILD_ERROR (0xA500)
ok 22 - system.t 130 $CHILD_ERROR (0xA500) isnt -1
ok 23 - system.t 134 Lower 7 bits of $CHILD_ERROR (0x0) are zeroes
ok 24 - system.t 138 Upper bytes of $CHILD_ERROR (0xA5) is 0xA5
# @args='perl -e 'exit 0xA5''
ok 25 - system.t 125 System return value (0xA500) is $CHILD_ERROR (0xA500)
ok 26 - system.t 130 $CHILD_ERROR (0xA500) isnt -1
ok 27 - system.t 134 Lower 7 bits of $CHILD_ERROR (0x0) are zeroes
ok 28 - system.t 138 Upper bytes of $CHILD_ERROR (0xA5) is 0xA5
1..28



2023-01-15 13:32:40 dpchrist@win7 ~/sandbox/perl
$ uname -a ; perl -v | head -n 2 | tail -n 1
CYGWIN_NT-6.1-7601 win7 3.3.6-341.x86_64 2022-09-05 11:15 UTC x86_64 Cygwin
This is perl 5, version 32, subversion 1 (v5.32.1) built for
x86_64-cygwin-threads-multi

2023-01-15 13:32:52 dpchrist@win7 ~/sandbox/perl
$ perl system.t
# Child failed to execute
# @args='nosuchprogram', 'foo', 'bar'
ok 1 - system.t 50 STDOUT is empty string
ok 2 - system.t 56 STDERR like /Can't exec "nosuchprogram": No such file
or directory/
ok 3 - system.t 59 System return value (0xFFFFFFFFFFFFFFFF) is
$CHILD_ERROR (0xFFFFFFFFFFFFFFFF)
ok 4 - system.t 64 $CHILD_ERROR (0xFFFFFFFFFFFFFFFF) is -1
ok 5 - system.t 68 Lower 7 bits of $CHILD_ERROR (0x7F) are ones
ok 6 - system.t 72 Upper bytes of $CHILD_ERROR (0xFFFFFFFFFFFFFF) are ones
# @args='nosuchprogram foo bar'
ok 7 - system.t 50 STDOUT is empty string
ok 8 - system.t 56 STDERR like /Can't exec "nosuchprogram": No such file
or directory/
ok 9 - system.t 59 System return value (0xFFFFFFFFFFFFFFFF) is
$CHILD_ERROR (0xFFFFFFFFFFFFFFFF)
ok 10 - system.t 64 $CHILD_ERROR (0xFFFFFFFFFFFFFFFF) is -1
ok 11 - system.t 68 Lower 7 bits of $CHILD_ERROR (0x7F) are ones
ok 12 - system.t 72 Upper bytes of $CHILD_ERROR (0xFFFFFFFFFFFFFF) are ones
# Child kills itself with signal USR2
# @args='perl', '-e', 'kill "USR2", $$'
ok 13 - system.t 85 System return value (0x1F) is $CHILD_ERROR (0x1F)
ok 14 - system.t 91 $CHILD_ERROR (0x1F) isnt -1
ok 15 - (eval 35) 2 Lower 7 bits of $CHILD_ERROR (0x1F) is SIGUSR2 (0x1F)
ok 16 - (eval 35) 7 Upper bytes of $CHILD_ERROR (0x0) are zeroes
# @args='perl -e 'kill "USR2", $$''
ok 17 - system.t 85 System return value (0x1F) is $CHILD_ERROR (0x1F)
ok 18 - system.t 91 $CHILD_ERROR (0x1F) isnt -1
ok 19 - (eval 40) 2 Lower 7 bits of $CHILD_ERROR (0x1F) is SIGUSR2 (0x1F)
ok 20 - (eval 40) 7 Upper bytes of $CHILD_ERROR (0x0) are zeroes
# Child exits with value 0xA5
# @args='perl', '-e', 'exit 0xA5'
ok 21 - system.t 125 System return value (0xA500) is $CHILD_ERROR (0xA500)
ok 22 - system.t 130 $CHILD_ERROR (0xA500) isnt -1
ok 23 - system.t 134 Lower 7 bits of $CHILD_ERROR (0x0) are zeroes
ok 24 - system.t 138 Upper bytes of $CHILD_ERROR (0xA5) is 0xA5
# @args='perl -e 'exit 0xA5''
ok 25 - system.t 125 System return value (0xA500) is $CHILD_ERROR (0xA500)
ok 26 - system.t 130 $CHILD_ERROR (0xA500) isnt -1
ok 27 - system.t 134 Lower 7 bits of $CHILD_ERROR (0x0) are zeroes
ok 28 - system.t 138 Upper bytes of $CHILD_ERROR (0xA5) is 0xA5
1..28

#1028275#34

Date:: 2023-01-16 00:25:19 UTC

From:

To:

Debian Bug 1028275:

Here is an updated version of the Perl system() test script per the San
Francisco Perl Mongers Raku Study Group meeting of January 15, 2023.


HTH,

David



2023-01-15 16:21:20 dpchrist@laalaa ~/sandbox/perl
$ cat system.t
#!/usr/bin/env perl
# $Id: system.t,v 1.7 2023/01/16 00:20:21 dpchrist Exp $
# by David Paul Christensen dpchrist@holgerdanske.com
# Public Domain
#
# Test Perl built-in system().
#
# See 'perldoc -f system'.


use strict;
use warnings;
use Capture::Tiny		qw( capture );
use POSIX			qw( SIGUSR2 );
use Test::More;
use Test::Warn;

our @args;

our $stdout;
our $stderr;
our $system;
our $ce;

our $TODO;



### Invoke test_engine() (see below) over list of test sets:

test_engine(@$_) for (

   ### First set of tests -- child failed to execute
   [
     "Child failed to execute",
     [qw( nosuchprogram foo bar )],
     q(nosuchprogram foo bar),
     sub {
       eval {
        	is $stdout, '', join $", __FILE__, __LINE__,
	  'STDOUT is empty string';

	like
	  $stderr,
	  qr/^Can't exec "nosuchprogram": No such file or directory/,
	  join $", __FILE__, __LINE__,
	   q(STDERR like /Can't exec "nosuchprogram": No such file or directory/);

	is $system, $ce, join $", __FILE__, __LINE__,
	  sprintf 'System return value (0x%X) is $CHILD_ERROR (0x%X)',
	  $system,
	  $ce;

	is $ce, -1, join $", __FILE__, __LINE__,
	  sprintf '$CHILD_ERROR (0x%X) is -1',
	  $ce;

	is $ce & 127, 0x7F, join $", __FILE__, __LINE__,
	  sprintf 'Lower 7 bits of $CHILD_ERROR (0x%X) are ones',
	    $ce & 127;

	is $ce >> 8, (~0) >> 8, join $", __FILE__, __LINE__,
	  sprintf 'Upper bytes of $CHILD_ERROR (0x%X) are ones',
	    $ce >> 8;
       };
     },
   ],

   ### Second set of tests -- signals
   [
     "Child kills itself with signal USR2",
     ['perl', '-e', 'kill "USR2", $$'],
     q(perl -e 'kill "USR2", $$'),
     sub {
       eval {
	is $system, $ce, join $", __FILE__, __LINE__,

	sprintf 'System return value (0x%X) is $CHILD_ERROR (0x%X)',
       	  $system,
	  $ce;

	isnt $ce, -1, join $", __FILE__, __LINE__,
	  sprintf '$CHILD_ERROR (0x%X) isnt -1',
	    $ce;
       };
     },
     sub {
       my $code = q{
	is $ce & 127, SIGUSR2, join $", __FILE__, __LINE__,
	  sprintf 'Lower 7 bits of $CHILD_ERROR (0x%X) is SIGUSR2 (0x%X)',
	    $ce & 127,
	    SIGUSR2;

	is $ce >> 8, 0, join $", __FILE__, __LINE__,
	  sprintf 'Upper bytes of $CHILD_ERROR (0x%X) are zeroes',
	    $ce >> 8;
       };
       if (@args == 1 && -e '/etc/debian_version') {
	TODO: {
	  local $TODO =
"https://bugs.debian.org/cgi-bin/bugreport.cgi?bug=1028275";
	  eval $code;
	}
       }
       else {
	eval $code;
       }
     },
   ],

   ### Third set of tests -- exit value
   [
     "Child exits with value 0xA5",
     ['perl', '-e', 'exit 0xA5'],
     q(perl -e 'exit 0xA5'),
     sub {
       eval {
     	is $system, $ce, join $", __FILE__, __LINE__,
   	  sprintf 'System return value (0x%X) is $CHILD_ERROR (0x%X)',
	    $system,
	    $ce;

       	isnt $ce, -1, join $", __FILE__, __LINE__,
   	  sprintf '$CHILD_ERROR (0x%X) isnt -1',
	    $ce;

       	is $ce & 127, 0, join $", __FILE__, __LINE__,
   	  sprintf 'Lower 7 bits of $CHILD_ERROR (0x%X) are zeroes',
	    $ce & 127;

       	is $ce >> 8, 0xA5, join $", __FILE__, __LINE__,
   	  sprintf 'Upper bytes of $CHILD_ERROR (0x%X) is 0xA5',
	    $ce >> 8;
       };
     },
   ],
);

### test_engine()
#
#   test_engine DESCRIPTION,RA_LIST,ARG,RC_TEST...
#
#   DESCRIPTION is an explanatory note for the set of tests
#
#   RA_LIST is a reference to an array containing an argument list to be
passed to Perl system()
#
#   ARG is the single-argument (string) form of the argument list
#
#   RC_TEST... is one or more references to code containing Test::More tests

sub test_engine
{
   note(shift @_);

   local @args = @{ shift(@_) };
   my $a = shift(@_);

   note("\@args='", join("', '", @args), "'");
   ($stdout, $stderr, $system) = capture { system(@args) };
   $ce = $?;
   $_->() for @_;

   local @args = ($a);
   note "\@args='", join("', '", @args), "'";
   ($stdout, $stderr, $system) = capture { system(@args) };
   $ce = $?;
   $_->() for @_;
}

done_testing;

#1028275 perl: Return value of system() #1028275

Just Reply to ...

Reply to submitter ...

Send control command (Silently)

Set Architecture Tags (Silently)