└── gdbperl.pl /gdbperl.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | # vim:sw=2:ts=8:ai 4 | 5 | # gdbperl.pl - shows the call trace of a running perl process 6 | # 7 | # Copyright (c) Akira Higuchi 8 | # All rights reserved. 9 | # 10 | # Redistribution and use in source and binary forms, with or without 11 | # modification, are permitted provided that the following conditions are met: 12 | # 13 | # Redistributions of source code must retain the above copyright notice, 14 | # this list of conditions and the following disclaimer. 15 | # Redistributions in binary form must reproduce the above copyright notice, 16 | # this list of conditions and the following disclaimer in the 17 | # documentation and/or other materials provided with the distribution. 18 | # Neither the name of the author nor the names of its contributors 19 | # may be used to endorse or promote products derived from this software 20 | # without specific prior written permission. 21 | # 22 | # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 23 | # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 24 | # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 25 | # ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE 26 | # LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 27 | # CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 28 | # SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 29 | # INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 30 | # CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 31 | # ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 32 | # POSSIBILITY OF SUCH DAMAGE. 33 | # 34 | # Usage: gdbperl.pl PROCESS_ID [PERL_EXECUTABLE] [OPTION=VALUE [...]] 35 | # gdbperl.pl CORE_FILE PERL_EXECUTABLE [OPTION=VALUE [...]] 36 | 37 | use strict; 38 | use warnings; 39 | use IPC::Open2; 40 | 41 | my $core_or_pid = get_config(0); 42 | my $exe = get_config(1, undef); 43 | my $gdb_rh; 44 | my $gdb_wh; 45 | my $thread_prefix = ''; 46 | my $my_perl_prefix = ''; 47 | my $perl_version = 0; 48 | 49 | if (!$core_or_pid) { 50 | my $mess = 51 | "Usage: $0 PROCESS_ID [PERL_EXECUTABLE] [OPTION=VALUE [...]]\n" . 52 | "Usage: $0 CORE_FILE PERL_EXECUTABLE [OPTION=VALUE [...]]\n"; 53 | die "$mess"; 54 | } 55 | my $is_pid = ($core_or_pid =~ /^\d+$/); 56 | if ($is_pid && !defined($exe)) { 57 | $exe = readlink("/proc/$core_or_pid/exe") # linux 58 | } 59 | if ($is_pid && !defined($exe)) { 60 | $exe = `which perl`; 61 | chomp($exe); 62 | } 63 | die "failed to detect perl executable" if !$exe; 64 | 65 | trace_one($core_or_pid, $exe); 66 | exit 0; 67 | 68 | sub trace_one { 69 | my ($core_or_pid, $exe) = @_; 70 | my $cmd = "gdb -silent -nw $exe $core_or_pid"; 71 | print "command:\n$cmd\n\n"; 72 | my $pid = open2($gdb_rh, $gdb_wh, "$cmd 2>&1") or die "$cmd"; 73 | eval { 74 | show_trace(); 75 | }; 76 | my $err = $@; 77 | if ($is_pid) { 78 | system("kill -CONT $core_or_pid 2>/dev/null"); 79 | } 80 | close($gdb_rh); 81 | close($gdb_wh); 82 | die $err if $err; 83 | } 84 | 85 | sub log_gdb { 86 | my ($pre, $mess) = @_; 87 | return if (!get_config('verbose_gdb', 0)); 88 | my @lines = split(/\n/, $mess); 89 | for my $line (@lines) { 90 | print "$pre: $line\n"; 91 | } 92 | } 93 | 94 | sub cmd_exec { 95 | my $cmd = $_[0]; 96 | log_gdb('C', $cmd); 97 | if ($cmd) { 98 | my $r = syswrite($gdb_wh, $cmd); 99 | if ($r < length($cmd)) { 100 | die "failed to send: [$cmd]\n"; 101 | } 102 | } 103 | my $resp = ''; 104 | while (1) { 105 | my $buf = ''; 106 | my $r = sysread($gdb_rh, $buf, 1024); 107 | if ($r <= 0) { 108 | last; 109 | } 110 | $resp .= $buf; 111 | if ($resp =~ /\(gdb\) $/) { 112 | last; 113 | } 114 | } 115 | log_gdb('R', $resp); 116 | return $resp; 117 | } 118 | 119 | sub cmd_get_value { 120 | my $cmd = $_[0]; 121 | my $resp = cmd_exec($cmd); 122 | return '' if ($resp !~ / =\s+(.+)/); 123 | my $v = $1; 124 | if ($resp =~ /0x\w+\s+\"(.+)\"/) { 125 | return $1; 126 | } 127 | return $v; 128 | } 129 | 130 | sub show_environ { 131 | my $resp = ''; 132 | my $i = 0; 133 | print "environ:\n"; 134 | while (1) { 135 | my $resp = cmd_get_value("p ((char **)environ)[$i]\n"); 136 | last if ($resp eq '' || $resp eq '0x0'); 137 | print "$resp\n"; 138 | ++$i; 139 | } 140 | print "\n"; 141 | } 142 | 143 | sub get_hvname { 144 | my $hvstr = $_[0]; 145 | if ($perl_version <= 8) { 146 | return cmd_get_value("p $hvstr->sv_any->xhv_name\n"); 147 | } 148 | my $hvmax = cmd_get_value("p $hvstr->sv_any->xhv_max\n"); 149 | if ($hvmax =~ /\d+/) { 150 | my $hvauxstr = 151 | "(struct xpvhv_aux *)($hvstr->sv_u.svu_hash+$hvmax+1)"; 152 | if ($perl_version >= 14) { 153 | my $hvnamestr = "(char *)($hvauxstr)->xhv_name_u.xhvnameu_name"; 154 | return cmd_get_value("p $hvnamestr->hek_key\n"); 155 | } else { 156 | return cmd_get_value("p (char *)($hvauxstr)->xhv_name->hek_key\n"); 157 | } 158 | } 159 | return ''; 160 | } 161 | 162 | sub get_perl_cop { 163 | my $base = $_[0]; 164 | my $cop_file; 165 | if ($thread_prefix eq '') { 166 | if ($perl_version >= 10) { 167 | $cop_file = "$base->cop_filegv->sv_u.svu_gp->gp_sv->sv_u.svu_pv"; 168 | } else { 169 | $cop_file = "((XPV *)($base->cop_filegv->sv_any->xgv_gp->gp_sv->sv_any))" 170 | . "->xpv_pv"; 171 | } 172 | } else { 173 | $cop_file = "$base->cop_file"; 174 | } 175 | my $file = cmd_get_value("p $cop_file\n"); 176 | my $line = cmd_get_value("p $base->cop_line\n"); 177 | if (get_config('perl_package', 1)) { 178 | my $ns; 179 | if ($thread_prefix eq '') { 180 | $ns = get_hvname("$base->cop_stash"); 181 | } else { 182 | $ns = cmd_get_value("p $base->cop_stashpv\n"); 183 | } 184 | return "$file:$line($ns)"; 185 | } 186 | return "$file:$line"; 187 | } 188 | 189 | sub get_perl_value { 190 | my ($estr) = @_; 191 | my $svt = cmd_get_value("p $estr.sv_flags\n"); 192 | if (!defined($svt) || $svt !~ /^\d+$/) { 193 | return '?'; 194 | } 195 | my $typ = $svt & 0xff; 196 | return 'undef' if $typ == 0; 197 | if ($perl_version >= 12) { 198 | return 'ref' if ($svt & 0x0800) != 0 && $typ == 2; 199 | return cmd_get_value("p ((XPVIV*)$estr.sv_any)->xiv_u.xivu_iv\n") 200 | if $typ == 2; 201 | return cmd_get_value("p ((XPVNV*)$estr.sv_any)->xnv_u.xnv_nv\n") 202 | if $typ == 3; 203 | return '"' . cmd_get_value("p $estr.sv_u.svu_pv\n") . '"' if $typ >= 4; 204 | } elsif ($perl_version >= 10) { 205 | return cmd_get_value("p ((XPVIV*)$estr.sv_any)->xiv_u.xivu_iv\n") 206 | if $typ == 2; 207 | return cmd_get_value("p ((XPVNV*)$estr.sv_any)->xnv_u.xnv_nv\n") 208 | if $typ == 3; 209 | return 'ref' if $typ == 4; 210 | return '"' . cmd_get_value("p $estr.sv_u.svu_pv\n") . '"' if $typ >= 5; 211 | } else { 212 | return cmd_get_value("p ((XPVIV*)$estr.sv_any)->xiv_iv\n") if $typ == 1; 213 | return cmd_get_value("p ((XPVNV*)$estr.sv_any)->xnv_nv\n") if $typ == 2; 214 | return 'ref' if $typ == 3; 215 | return '"' . cmd_get_value("p ((XPV*)$estr.sv_any)->xpv_pv\n") . '"' 216 | if $typ >= 4; 217 | } 218 | return '?'; 219 | } 220 | 221 | sub get_sub_args { 222 | my ($copstr) = @_; 223 | my $avstr = "$copstr.cx_u.cx_blk.blk_u.blku_sub.argarray"; 224 | my $avfill = cmd_get_value("p $avstr->sv_any->xav_fill\n"); 225 | return '' if (!defined($avfill) || $avfill < 0); 226 | $avfill = 100 if $avfill > 100; 227 | my $rstr = ''; 228 | for (my $i = 0; $i <= $avfill; ++$i) { 229 | $rstr .= ', ' if ($i != 0); 230 | my $estr = ''; 231 | if ($perl_version >= 10) { 232 | $estr = "($avstr->sv_u.svu_array[$i])"; 233 | } else { 234 | $estr = "(*((SV**)($avstr->sv_any)->xav_array)[$i])"; 235 | } 236 | $rstr .= get_perl_value($estr); 237 | } 238 | return $rstr; 239 | } 240 | 241 | sub get_cxtype_str { 242 | my ($typ) = @_; 243 | return 'unknown' if (!defined($typ) || $typ !~ /\d+/); 244 | if ($perl_version >= 12) { 245 | return 'sub' if $typ == 8; 246 | return 'eval' if $typ == 10; 247 | return 'loop' if ($typ & 0xc) == 0x4; 248 | } else { 249 | return 'sub' if $typ == 1; 250 | return 'eval' if $typ == 2; 251 | return 'loop' if $typ == 3; 252 | } 253 | return 'other'; 254 | } 255 | 256 | sub get_perl_frame { 257 | my ($i) = @_; 258 | my $copstr = "${my_perl_prefix}curstackinfo->si_cxstack[$i]"; 259 | my $pos = get_perl_cop("$copstr.cx_u.cx_blk.blku_oldcop"); 260 | if (get_config('perl_func', 1)) { 261 | my ($typ, $ns, $func, $callee) = (-1, '', '', '(unknown)'); 262 | if ($perl_version >= 12) { 263 | $typ = cmd_get_value("p $copstr.cx_u.cx_subst.sbu_type & 0xf\n"); 264 | } elsif ($perl_version >= 10) { 265 | $typ = cmd_get_value("p $copstr.cx_u.cx_subst.sbu_type & 0xff\n"); 266 | } else { 267 | $typ = cmd_get_value("p $copstr.cx_type & 0xff\n"); 268 | } 269 | my $typstr = get_cxtype_str($typ); 270 | if ($typstr eq 'sub') { 271 | my $gvstr = "$copstr.cx_u.cx_blk.blk_u.blku_sub.cv->sv_any" 272 | . "->xcv_gv->sv_any"; 273 | if ($perl_version >= 10) { 274 | my $hvstr = "$gvstr.xnv_u.xgv_stash"; 275 | $ns = get_hvname($hvstr); 276 | $func = cmd_get_value( 277 | "p (char *)$gvstr.xiv_u.xivu_namehek->hek_key\n"); 278 | } else { 279 | $ns = cmd_get_value("p $gvstr->xgv_stash->sv_any->xhv_name\n"); 280 | $func = cmd_get_value("p $gvstr->xgv_name\n"); 281 | } 282 | $ns = '' if $ns eq '0x0'; 283 | $func = '' if $func eq '0x0'; 284 | my $sargs = get_config('perl_args', 1) ? get_sub_args($copstr) : ''; 285 | $callee = ($ns || $func) ? ($ns . '::' . $func . '(' . $sargs . ')') 286 | : '(unknown)'; 287 | } else { 288 | $callee = "($typstr)"; 289 | } 290 | return "[$i] $callee <- $pos"; 291 | } else { 292 | return "[$i] <- $pos"; 293 | } 294 | } 295 | 296 | sub check_perl_version { 297 | $perl_version = cmd_get_value("p PL_version\n"); 298 | $perl_version =~ s/ .+//g; 299 | $perl_version = 8 if !$perl_version; 300 | my $p; 301 | $p = cmd_get_value("p PL_curcop->cop_line\n"); 302 | if ($p) { 303 | $thread_prefix = ''; 304 | $my_perl_prefix = 'PL_'; 305 | return; 306 | } 307 | $p = cmd_get_value("p my_perl->Tcurcop->cop_line\n"); 308 | if ($p) { 309 | $thread_prefix = 'T'; # perl 5.8 with ithreads 310 | $my_perl_prefix = 'my_perl->T'; 311 | return; 312 | } 313 | $p = cmd_get_value("p my_perl->Icurcop->cop_line\n"); 314 | if ($p) { 315 | $thread_prefix = 'I'; # perl >= 5.10 with ithreads 316 | $my_perl_prefix = 'my_perl->I'; 317 | return; 318 | } 319 | die "unknown perl version"; 320 | } 321 | 322 | sub show_trace { 323 | my ($resp, $fr, $depth) = ('', -1, -1); 324 | $resp = cmd_exec(''); 325 | $resp = cmd_exec("set pagination off\n"); 326 | show_environ() if get_config('env', 1); 327 | $resp = cmd_exec("bt\n"); 328 | my $show_c_trace = get_config('c_trace', 1); 329 | print "c_backtrace:\n" if $show_c_trace; 330 | for my $line (split(/\n/, $resp)) { 331 | if ($line =~ /\#(\d+) .+my_perl/) { 332 | $fr = $1; 333 | } 334 | last if ($line eq '(gdb) '); 335 | print "$line\n" if $show_c_trace; 336 | } 337 | print "\n" if $show_c_trace; 338 | $resp = cmd_exec("fr $fr\n"); 339 | check_perl_version(); 340 | print "perl5_version:\n$perl_version$thread_prefix\n\n"; 341 | my $cur_op = get_perl_cop("${my_perl_prefix}curcop"); 342 | print "perl_cur_op:\n$cur_op\n\n"; 343 | $depth = cmd_get_value("p ${my_perl_prefix}curstackinfo->si_cxix\n"); 344 | if ($depth !~ /\d+/) { 345 | $depth = 0; 346 | } elsif ($depth > 1000) { 347 | $depth = 1000; 348 | } 349 | print "perl_backtrace:\n"; 350 | for (my $i = $depth; $i > 0; --$i) { 351 | my $pfr = get_perl_frame($i); 352 | print "$pfr\n"; 353 | } 354 | print "\n"; 355 | cmd_get_value("detach\n"); 356 | cmd_get_value("quit\n"); 357 | } 358 | 359 | sub get_config { 360 | our $confmap; 361 | our $confarr; 362 | if (!defined($confmap)) { 363 | $confmap = +{}; 364 | $confarr = +[]; 365 | my $arridx = 0; 366 | for my $kv (@ARGV) { 367 | if ($kv =~ /^(\w+)=(.+)$/) { 368 | $confmap->{$1} = $2; 369 | } else { 370 | $confarr->[$arridx++] = $kv; 371 | } 372 | } 373 | } 374 | my $key = $_[0]; 375 | my $v = ($key =~ /^\d+$/) ? $confarr->[$key] : $confmap->{$key}; 376 | return defined($v) ? $v : $_[1]; 377 | } 378 | 379 | --------------------------------------------------------------------------------