This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Document and test the phase-change probe
[perl5.git] / t / run / dtrace.t
CommitLineData
b9a2454e 1#!./perl
b9a2454e
SM
2
3my $Perl;
4my $dtrace;
5
6BEGIN {
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
23use strict;
24use warnings;
25use IPC::Open2;
26
2b679393 27plan(tests => 5);
b9a2454e
SM
28
29dtrace_like(
30 '1',
31 'BEGIN { trace(42+666) }',
32 qr/708/,
33 'really running DTrace',
34);
35
36dtrace_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
58dtrace_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
69dtrace_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++ }
83MAGIC_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
92dtrace_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() }
101PHASES
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
120sub 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