#!./perl
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");
}
use strict;
use warnings;
use IPC::Open2;
plan(tests => 5);
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',
);
dtrace_like(
'1',
'phase-change { printf("%s -> %s; ", copyinstr(arg1), copyinstr(arg0)) }',
qr/START -> RUN; RUN -> DESTRUCT;/,
'phase changes of a simple script',
);
# this code taken from t/op/magic_phase.t which tests all of the
# transitions of ${^GLOBAL_PHASE}. instead of printing (which will
# interact nondeterministically with the DTrace output), we increment
# an unused variable for side effects
dtrace_like(<< 'MAGIC_OP',
my $x = 0;
BEGIN { $x++ }
CHECK { $x++ }
INIT { $x++ }
sub Moo::DESTROY { $x++ }
my $tiger = bless {}, Moo::;
sub Kooh::DESTROY { $x++ }
our $affe = bless {}, Kooh::;
END { $x++ }
MAGIC_OP
'phase-change { printf("%s -> %s; ", copyinstr(arg1), copyinstr(arg0)) }',
qr/START -> CHECK; CHECK -> INIT; INIT -> RUN; RUN -> END; END -> DESTRUCT;/,
'phase-changes in a script that exercises all of ${^GLOBAL_PHASE}',
);
dtrace_like(<< 'PHASES',
my $x = 0;
sub foo { $x++ }
sub bar { $x++ }
sub baz { $x++ }
INIT { foo() }
bar();
END { baz() }
PHASES
'
BEGIN { starting = 1 }
phase-change { phase = arg0 }
phase-change /copyinstr(arg0) == "RUN"/ { starting = 0 }
phase-change /copyinstr(arg0) == "END"/ { ending = 1 }
sub-entry /copyinstr(arg0) != copyinstr(phase) && (starting || ending)/ {
printf("%s during %s; ", copyinstr(arg0), copyinstr(phase));
}
',
qr/foo during INIT; baz during END;/,
'make sure sub-entry and phase-change interact well',
);
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);
}