t/op/dump.t

   1 #!./perl
   2
   3 # Minimally test if dump() behaves as expected
   4
   5 BEGIN {
   6     chdir 't' if -d 't';
   7     require './test.pl';
   8     set_up_inc( qw(. ../lib) );
   9     skip_all_if_miniperl();
  10 }
  11
  12 use Config;
  13 use File::Temp qw(tempdir);
  14 use Cwd qw(getcwd);
  15 use File::Spec;
  16
  17 skip_all("only tested on devel builds")
  18   unless $Config{usedevel};
  19
  20 # there may be other operating systems where it makes sense, but
  21 # there are some where it isn't, so limit the platforms we test
  22 # this on. Also this needs to be a platform that fully supports
  23 # fork() and waitpid().
  24
  25 skip_all("no point in dumping on $^O")
  26   unless $^O =~ /^(linux|.*bsd|solaris|darwin)$/;
  27
  28 skip_all("avoid coredump under ASan")
  29   if  $Config{ccflags} =~ /-fsanitize=/;
  30
  31 # execute in a work directory so File::Temp can clean up core dumps
  32 my $tmp = tempdir(CLEANUP => 1);
  33
  34 my $start = getcwd;
  35
  36 # on systems which don't make $^X absolute which_perl() in test.pl won't
  37 # return an absolute path, so once we change directories it can't
  38 # find ./perl, resulting in test failures
  39 $^X = File::Spec->rel2abs($^X);
  40
  41 chdir $tmp
  42   or skip_all("Cannot chdir to work directory");
  43
  44 plan(2);
  45
  46 # Depending on how perl is built, there may be extraneous stuff on stderr
  47 # such as "Aborted", which isn't caught by the '2>&1' that
  48 # fresh_perl_like() does. So execute each dump() in a sub-process.
  49 #
  50 # In detail:
  51 # fresh_perl_like() ends up doing a `` which invokes a shell with 2 args:
  52 #
  53 #   "sh", "-c", "perl /tmp/foo 2>&1"
  54 #
  55 # When the perl process coredumps after calling dump(), the parent
  56 # sh sees that the exit of the child flags a coredump and so prints
  57 # something like the following to stderr:
  58 #
  59 #    sh: line 1: 17605 Aborted (core dumped)
  60 #
  61 # Note that the '2>&1' only applies to the perl process, not to the sh
  62 # command itself.
  63 # By do the dump in a child, the parent perl process exits back to sh with
  64 # a normal exit value, so sh won't complain.
  65
  66 fresh_perl_like(<<'PROG', qr/\AA(?!B\z)/, {}, "plain dump quits");
  67 ++$|;
  68 my $pid = fork;
  69 die "fork: $!\n" unless defined $pid;
  70 if ($pid) {
  71     # parent
  72     waitpid($pid, 0);
  73 }
  74 else {
  75     # child
  76     print qq(A);
  77     dump;
  78     print qq(B);
  79 }
  80 PROG
  81
  82 fresh_perl_like(<<'PROG', qr/A(?!B\z)/, {}, "dump with label quits");
  83 ++$|;
  84 my $pid = fork;
  85 die "fork: $!\n" unless defined $pid;
  86 if ($pid) {
  87     # parent
  88     waitpid($pid, 0);
  89 }
  90 else {
  91     print qq(A);
  92     dump foo;
  93     foo:
  94     print qq(B);
  95 }
  96 PROG
  97
  98 END {
  99   chdir $start if defined $start;
 100 }