| 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/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 |
| 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 | BEGIN {@INC = '../lib'} |
| 137 | use strict; |
| 138 | require HTTP::Tiny; |
| 139 | do "run/dtrace.pl"; |
| 140 | PERL_SCRIPT |
| 141 | << 'D_SCRIPT', |
| 142 | loading-file { printf("loading-file <%s>\n", copyinstr(arg0)) } |
| 143 | loaded-file { printf("loaded-file <%s>\n", copyinstr(arg0)) } |
| 144 | D_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 | |
| 155 | sub 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 | |