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