Commit | Line | Data |
---|---|---|
b9a2454e | 1 | #!./perl |
b9a2454e SM |
2 | |
3 | my $Perl; | |
4 | my $dtrace; | |
5 | ||
6 | BEGIN { | |
a817e89d | 7 | chdir 't' if -d 't'; |
b9a2454e SM |
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 | ||
a39b8056 FR |
23 | use strict; |
24 | use warnings; | |
25 | use IPC::Open2; | |
26 | ||
32aeab29 | 27 | plan(tests => 9); |
b9a2454e SM |
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 | ||
2b679393 SM |
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 | ||
bb52f720 | 65 | # this code taken from t/opbasic/magic_phase.t which tests all of the |
2b679393 SM |
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 | ||
fe83c362 SM |
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 | ||
32aeab29 | 135 | dtrace_like(<< 'PERL_SCRIPT', |
35e3dd03 | 136 | BEGIN {@INC = '../lib'} |
32aeab29 SM |
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 | ||
b9a2454e SM |
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 | ||
fe83c362 SM |
190 | if (ref($expected) eq 'ARRAY') { |
191 | like($result, $_, $name) for @$expected; | |
192 | } | |
193 | else { | |
194 | like($result, $expected, $name); | |
195 | } | |
b9a2454e SM |
196 | } |
197 |