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

[David Christensen]

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