This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
183868d5d3c35957f55af6f38f60c3195013468b
[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 => 7);
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/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
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 sub dtrace_like {
136     my $perl     = shift;
137     my $probes   = shift;
138     my $expected = shift;
139     my $name     = shift;
140
141     my ($reader, $writer);
142
143     my $pid = open2($reader, $writer,
144         $dtrace,
145         '-q',
146         '-n', 'BEGIN { trace("ready!\n") }', # necessary! see below
147         '-n', $probes,
148         '-c', $Perl,
149     );
150
151     # wait until DTrace tells us that it is initialized
152     # otherwise our probes won't properly fire
153     chomp(my $throwaway = <$reader>);
154     $throwaway eq "ready!" or die "Unexpected 'ready!' result from DTrace: $throwaway";
155
156     # now we can start executing our perl
157     print $writer $perl;
158     close $writer;
159
160     # read all the dtrace results back in
161     local $/;
162     my $result = <$reader>;
163
164     # make sure that dtrace is all done and successful
165     waitpid($pid, 0);
166     my $child_exit_status = $? >> 8;
167     die "Unexpected error from DTrace: $result"
168         if $child_exit_status != 0;
169
170     if (ref($expected) eq 'ARRAY') {
171         like($result, $_, $name) for @$expected;
172     }
173     else {
174         like($result, $expected, $name);
175     }
176 }
177