Commit | Line | Data |
---|---|---|
b9a2454e | 1 | #!./perl |
b9a2454e SM |
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 | ||
a39b8056 FR |
23 | use strict; |
24 | use warnings; | |
25 | use IPC::Open2; | |
26 | ||
2b679393 | 27 | plan(tests => 5); |
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 | ||
65 | # this code taken from t/op/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 | ||
b9a2454e SM |
120 | sub dtrace_like { |
121 | my $perl = shift; | |
122 | my $probes = shift; | |
123 | my $expected = shift; | |
124 | my $name = shift; | |
125 | ||
126 | my ($reader, $writer); | |
127 | ||
128 | my $pid = open2($reader, $writer, | |
129 | $dtrace, | |
130 | '-q', | |
131 | '-n', 'BEGIN { trace("ready!\n") }', # necessary! see below | |
132 | '-n', $probes, | |
133 | '-c', $Perl, | |
134 | ); | |
135 | ||
136 | # wait until DTrace tells us that it is initialized | |
137 | # otherwise our probes won't properly fire | |
138 | chomp(my $throwaway = <$reader>); | |
139 | $throwaway eq "ready!" or die "Unexpected 'ready!' result from DTrace: $throwaway"; | |
140 | ||
141 | # now we can start executing our perl | |
142 | print $writer $perl; | |
143 | close $writer; | |
144 | ||
145 | # read all the dtrace results back in | |
146 | local $/; | |
147 | my $result = <$reader>; | |
148 | ||
149 | # make sure that dtrace is all done and successful | |
150 | waitpid($pid, 0); | |
151 | my $child_exit_status = $? >> 8; | |
152 | die "Unexpected error from DTrace: $result" | |
153 | if $child_exit_status != 0; | |
154 | ||
155 | like($result, $expected, $name); | |
156 | } | |
157 |