This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
0992cd5eb4de45ca783bde707540f73a7155209c
[perl5.git] / t / run / dtrace.t
1 #!./perl
2
3 my $Perl;
4 my $dtrace;
5
6 BEGIN {
7     chdir 't';
8     @INC = '../lib';
9     require './test.pl';
10
11     skip_all_without_config("usedtrace");
12
13     $dtrace = $Config::Config{dtrace};
14
15     $Perl = which_perl();
16
17     `$dtrace -V` or skip_all("$dtrace unavailable");
18
19     my $result = `$dtrace -qnBEGIN -c'$Perl -e 1' 2>&1`;
20     $? && skip_all("Apparently can't probe using $dtrace (perhaps you need root?): $result");
21 }
22
23 use strict;
24 use warnings;
25 use IPC::Open2;
26
27 plan(tests => 9);
28
29 dtrace_like(
30     '1',
31     'BEGIN { trace(42+666) }',
32     qr/708/,
33     'really running DTrace',
34 );
35
36 dtrace_like(
37     'package My;
38         sub outer { Your::inner() }
39      package Your;
40         sub inner { }
41      package Other;
42         My::outer();
43         Your::inner();',
44
45     'sub-entry { printf("-> %s::%s at %s line %d!\n", copyinstr(arg3), copyinstr(arg0), copyinstr(arg1), arg2) }
46      sub-return { printf("<- %s::%s at %s line %d!\n", copyinstr(arg3), copyinstr(arg0), copyinstr(arg1), arg2) }',
47
48      qr/-> My::outer at - line 2!
49 -> Your::inner at - line 4!
50 <- Your::inner at - line 4!
51 <- My::outer at - line 2!
52 -> Your::inner at - line 4!
53 <- Your::inner at - line 4!/,
54
55     'traced multiple function calls',
56 );
57
58 dtrace_like(
59     '1',
60     'phase-change { printf("%s -> %s; ", copyinstr(arg1), copyinstr(arg0)) }',
61     qr/START -> RUN; RUN -> DESTRUCT;/,
62     'phase changes of a simple script',
63 );
64
65 # this code taken from t/opbasic/magic_phase.t which tests all of the
66 # transitions of ${^GLOBAL_PHASE}. instead of printing (which will
67 # interact nondeterministically with the DTrace output), we increment
68 # an unused variable for side effects
69 dtrace_like(<< 'MAGIC_OP',
70     my $x = 0;
71     BEGIN { $x++ }
72     CHECK { $x++ }
73     INIT  { $x++ }
74     sub Moo::DESTROY { $x++ }
75
76     my $tiger = bless {}, Moo::;
77
78     sub Kooh::DESTROY { $x++ }
79
80     our $affe = bless {}, Kooh::;
81
82     END { $x++ }
83 MAGIC_OP
84
85     'phase-change { printf("%s -> %s; ", copyinstr(arg1), copyinstr(arg0)) }',
86
87      qr/START -> CHECK; CHECK -> INIT; INIT -> RUN; RUN -> END; END -> DESTRUCT;/,
88
89      'phase-changes in a script that exercises all of ${^GLOBAL_PHASE}',
90 );
91
92 dtrace_like(<< 'PHASES',
93     my $x = 0;
94     sub foo { $x++ }
95     sub bar { $x++ }
96     sub baz { $x++ }
97
98     INIT { foo() }
99     bar();
100     END { baz() }
101 PHASES
102
103     '
104     BEGIN { starting = 1 }
105
106     phase-change                            { phase    = arg0 }
107     phase-change /copyinstr(arg0) == "RUN"/ { starting = 0 }
108     phase-change /copyinstr(arg0) == "END"/ { ending   = 1 }
109
110     sub-entry /copyinstr(arg0) != copyinstr(phase) && (starting || ending)/ {
111         printf("%s during %s; ", copyinstr(arg0), copyinstr(phase));
112     }
113     ',
114
115      qr/foo during INIT; baz during END;/,
116
117      'make sure sub-entry and phase-change interact well',
118 );
119
120 dtrace_like(<< 'PERL_SCRIPT',
121     my $tmp = "foo";
122     $tmp =~ s/f/b/;
123     chop $tmp;
124 PERL_SCRIPT
125     << 'D_SCRIPT',
126     op-entry { printf("op-entry <%s>\n", copyinstr(arg0)) }
127 D_SCRIPT
128     [
129         qr/op-entry <subst>/,
130         qr/op-entry <schop>/,
131     ],
132     'basic op probe',
133 );
134
135 dtrace_like(<< 'PERL_SCRIPT',
136     BEGIN {@INC = '../lib'}
137     use strict;
138     require HTTP::Tiny;
139     do "run/dtrace.pl";
140 PERL_SCRIPT
141     << 'D_SCRIPT',
142     loading-file { printf("loading-file <%s>\n", copyinstr(arg0)) }
143     loaded-file  { printf("loaded-file <%s>\n", copyinstr(arg0)) }
144 D_SCRIPT
145     [
146         # the original test made sure that each file generated a loading-file then a loaded-file,
147         # but that had a race condition when the kernel would push the perl process onto a different
148         # CPU, so the DTrace output would appear out of order
149         qr{loading-file <strict\.pm>.*loading-file <HTTP/Tiny\.pm>.*loading-file <run/dtrace\.pl>}s,
150         qr{loaded-file <strict\.pm>.*loaded-file <HTTP/Tiny\.pm>.*loaded-file <run/dtrace\.pl>}s,
151     ],
152     'loading-file, loaded-file probes',
153 );
154
155 sub dtrace_like {
156     my $perl     = shift;
157     my $probes   = shift;
158     my $expected = shift;
159     my $name     = shift;
160
161     my ($reader, $writer);
162
163     my $pid = open2($reader, $writer,
164         $dtrace,
165         '-q',
166         '-n', 'BEGIN { trace("ready!\n") }', # necessary! see below
167         '-n', $probes,
168         '-c', $Perl,
169     );
170
171     # wait until DTrace tells us that it is initialized
172     # otherwise our probes won't properly fire
173     chomp(my $throwaway = <$reader>);
174     $throwaway eq "ready!" or die "Unexpected 'ready!' result from DTrace: $throwaway";
175
176     # now we can start executing our perl
177     print $writer $perl;
178     close $writer;
179
180     # read all the dtrace results back in
181     local $/;
182     my $result = <$reader>;
183
184     # make sure that dtrace is all done and successful
185     waitpid($pid, 0);
186     my $child_exit_status = $? >> 8;
187     die "Unexpected error from DTrace: $result"
188         if $child_exit_status != 0;
189
190     if (ref($expected) eq 'ARRAY') {
191         like($result, $_, $name) for @$expected;
192     }
193     else {
194         like($result, $expected, $name);
195     }
196 }
197