New test file that exercises Perl's DTrace support

1 files changed, 94 insertions, 0 deletions

diff --git a/t/run/dtrace.t b/t/run/dtrace.t
new file mode 100644
index 0000000000..746f9ae978
--- /dev/null
+++ b/t/run/dtrace.t
@@ -0,0 +1,94 @@
+#!./perl
+use strict;
+use warnings;
+use IPC::Open2;
+
+my $Perl;
+my $dtrace;
+
+BEGIN {
+    chdir 't';
+    @INC = '../lib';
+    require './test.pl';
+
+    skip_all_without_config("usedtrace");
+
+    $dtrace = $Config::Config{dtrace};
+
+    $Perl = which_perl();
+
+    `$dtrace -V` or skip_all("$dtrace unavailable");
+
+    my $result = `$dtrace -qnBEGIN -c'$Perl -e 1' 2>&1`;
+    $? && skip_all("Apparently can't probe using $dtrace (perhaps you need root?): $result");
+}
+
+plan(tests => 2);
+
+dtrace_like(
+    '1',
+    'BEGIN { trace(42+666) }',
+    qr/708/,
+    'really running DTrace',
+);
+
+dtrace_like(
+    'package My;
+        sub outer { Your::inner() }
+     package Your;
+        sub inner { }
+     package Other;
+        My::outer();
+        Your::inner();',
+
+    'sub-entry { printf("-> %s::%s at %s line %d!\n", copyinstr(arg3), copyinstr(arg0), copyinstr(arg1), arg2) }
+     sub-return { printf("<- %s::%s at %s line %d!\n", copyinstr(arg3), copyinstr(arg0), copyinstr(arg1), arg2) }',
+
+     qr/-> My::outer at - line 2!
+-> Your::inner at - line 4!
+<- Your::inner at - line 4!
+<- My::outer at - line 2!
+-> Your::inner at - line 4!
+<- Your::inner at - line 4!/,
+
+    'traced multiple function calls',
+);
+
+sub dtrace_like {
+    my $perl     = shift;
+    my $probes   = shift;
+    my $expected = shift;
+    my $name     = shift;
+
+    my ($reader, $writer);
+
+    my $pid = open2($reader, $writer,
+        $dtrace,
+        '-q',
+        '-n', 'BEGIN { trace("ready!\n") }', # necessary! see below
+        '-n', $probes,
+        '-c', $Perl,
+    );
+
+    # wait until DTrace tells us that it is initialized
+    # otherwise our probes won't properly fire
+    chomp(my $throwaway = <$reader>);
+    $throwaway eq "ready!" or die "Unexpected 'ready!' result from DTrace: $throwaway";
+
+    # now we can start executing our perl
+    print $writer $perl;
+    close $writer;
+
+    # read all the dtrace results back in
+    local $/;
+    my $result = <$reader>;
+
+    # make sure that dtrace is all done and successful
+    waitpid($pid, 0);
+    my $child_exit_status = $? >> 8;
+    die "Unexpected error from DTrace: $result"
+        if $child_exit_status != 0;
+
+    like($result, $expected, $name);
+}
+