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("avoid coredump under ASan") 29 if $Config{ccflags} =~ /-fsanitize=/; 30 31# execute in a work directory so File::Temp can clean up core dumps 32my $tmp = tempdir(CLEANUP => 1); 33 34my $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 41chdir $tmp 42 or skip_all("Cannot chdir to work directory"); 43 44plan(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 CORE::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 CORE::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# An unqualified dump() will give a deprecation warning. Usually, we'd 67# do a "no warnings 'deprecated'" to shut this off, but since we have 68# chdirred to /tmp, a 'no' won't find the pragma. Hence the fiddling with 69# $SIG{__WARN__}. 70 71fresh_perl_like(<<'PROG', qr/\AA(?!B\z)/, {}, "plain dump quits"); 72BEGIN {$SIG {__WARN__} = sub {1;}} 73++$|; 74my $pid = fork; 75die "fork: $!\n" unless defined $pid; 76if ($pid) { 77 # parent 78 waitpid($pid, 0); 79} 80else { 81 # child 82 print qq(A); 83 CORE::dump; 84 print qq(B); 85} 86PROG 87 88fresh_perl_like(<<'PROG', qr/A(?!B\z)/, {}, "CORE::dump with label quits"); BEGIN {$SIG {__WARN__} = sub {1;}} 89++$|; 90my $pid = fork; 91die "fork: $!\n" unless defined $pid; 92if ($pid) { 93 # parent 94 waitpid($pid, 0); 95} 96else { 97 print qq(A); 98 CORE::dump foo; 99 foo: 100 print qq(B); 101} 102PROG 103 104END { 105 chdir $start if defined $start; 106} 107