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