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