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
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 => 5);
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 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