[MERGE] fix PERL_GLOBAL_STRUCT builds
[perl.git] / 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 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
71 fresh_perl_like(<<'PROG', qr/\AA(?!B\z)/, {}, "plain dump quits");
72 BEGIN {$SIG {__WARN__} = sub {1;}}
73 ++$|;
74 my $pid = fork;
75 die "fork: $!\n" unless defined $pid;
76 if ($pid) {
77     # parent
78     waitpid($pid, 0);
79 }
80 else {
81     # child
82     print qq(A);
83     CORE::dump;
84     print qq(B);
85 }
86 PROG
87
88 fresh_perl_like(<<'PROG', qr/A(?!B\z)/, {}, "CORE::dump with label quits"); BEGIN {$SIG {__WARN__} = sub {1;}}
89 ++$|;
90 my $pid = fork;
91 die "fork: $!\n" unless defined $pid;
92 if ($pid) {
93     # parent
94     waitpid($pid, 0);
95 }
96 else {
97     print qq(A);
98     CORE::dump foo;
99     foo:
100     print qq(B);
101 }
102 PROG
103
104 END {
105   chdir $start if defined $start;
106 }