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