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 dpchr...@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
