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

David Christensen dpchrist at holgerdanske.com
Sun Jan 15 05:05:33 GMT 2023


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 at 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 at 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 at 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 at 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 at 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 at 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




More information about the Perl-maintainers mailing list