1#!./perl
2
3my $Perl;
4my $dtrace;
5
6BEGIN {
7    chdir 't' if -d '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
23use strict;
24use warnings;
25use IPC::Open2;
26
27plan(tests => 9);
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
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/opbasic/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
120dtrace_like(<< 'PERL_SCRIPT',
121    my $tmp = "foo";
122    $tmp =~ s/f/b/;
123    chop $tmp;
124PERL_SCRIPT
125    << 'D_SCRIPT',
126    op-entry { printf("op-entry <%s>\n", copyinstr(arg0)) }
127D_SCRIPT
128    [
129        qr/op-entry <subst>/,
130        qr/op-entry <schop>/,
131    ],
132    'basic op probe',
133);
134
135dtrace_like(<< 'PERL_SCRIPT',
136    BEGIN {@INC = '../lib'}
137    use strict;
138    require HTTP::Tiny;
139    do "./run/dtrace.pl";
140PERL_SCRIPT
141    << 'D_SCRIPT',
142    loading-file { printf("loading-file <%s>\n", copyinstr(arg0)) }
143    loaded-file  { printf("loaded-file <%s>\n", copyinstr(arg0)) }
144D_SCRIPT
145    [
146        # the original test made sure that each file generated a loading-file then a loaded-file,
147        # but that had a race condition when the kernel would push the perl process onto a different
148        # CPU, so the DTrace output would appear out of order
149        qr{loading-file <strict\.pm>.*loading-file <HTTP/Tiny\.pm>.*loading-file <run/dtrace\.pl>}s,
150        qr{loaded-file <strict\.pm>.*loaded-file <HTTP/Tiny\.pm>.*loaded-file <run/dtrace\.pl>}s,
151    ],
152    'loading-file, loaded-file probes',
153);
154
155sub dtrace_like {
156    my $perl     = shift;
157    my $probes   = shift;
158    my $expected = shift;
159    my $name     = shift;
160
161    my ($reader, $writer);
162
163    my $pid = open2($reader, $writer,
164        $dtrace,
165        '-q',
166        '-n', 'BEGIN { trace("ready!\n") }', # necessary! see below
167        '-n', $probes,
168        '-c', $Perl,
169    );
170
171    # wait until DTrace tells us that it is initialized
172    # otherwise our probes won't properly fire
173    chomp(my $throwaway = <$reader>);
174    $throwaway eq "ready!" or die "Unexpected 'ready!' result from DTrace: $throwaway";
175
176    # now we can start executing our perl
177    print $writer $perl;
178    close $writer;
179
180    # read all the dtrace results back in
181    local $/;
182    my $result = <$reader>;
183
184    # make sure that dtrace is all done and successful
185    waitpid($pid, 0);
186    my $child_exit_status = $? >> 8;
187    die "Unexpected error from DTrace: $result"
188        if $child_exit_status != 0;
189
190    if (ref($expected) eq 'ARRAY') {
191        like($result, $_, $name) for @$expected;
192    }
193    else {
194        like($result, $expected, $name);
195    }
196}
197
198