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