This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
4ea851e71ba71a5cf94b4919aa3a32a6a22ce94a
[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 => 2);
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 sub dtrace_like {
59     my $perl     = shift;
60     my $probes   = shift;
61     my $expected = shift;
62     my $name     = shift;
63
64     my ($reader, $writer);
65
66     my $pid = open2($reader, $writer,
67         $dtrace,
68         '-q',
69         '-n', 'BEGIN { trace("ready!\n") }', # necessary! see below
70         '-n', $probes,
71         '-c', $Perl,
72     );
73
74     # wait until DTrace tells us that it is initialized
75     # otherwise our probes won't properly fire
76     chomp(my $throwaway = <$reader>);
77     $throwaway eq "ready!" or die "Unexpected 'ready!' result from DTrace: $throwaway";
78
79     # now we can start executing our perl
80     print $writer $perl;
81     close $writer;
82
83     # read all the dtrace results back in
84     local $/;
85     my $result = <$reader>;
86
87     # make sure that dtrace is all done and successful
88     waitpid($pid, 0);
89     my $child_exit_status = $? >> 8;
90     die "Unexpected error from DTrace: $result"
91         if $child_exit_status != 0;
92
93     like($result, $expected, $name);
94 }
95