Home | History | Annotate | Download | only in strace 
      1 #!/usr/bin/perl
      2 
      3 # This script processes strace -f output.  It displays a graph of invoked
      4 # subprocesses, and is useful for finding out what complex commands do.
      5 
      6 # You will probably want to invoke strace with -q as well, and with
      7 # -s 100 to get complete filenames.
      8 
      9 # The script can also handle the output with strace -t, -tt, or -ttt.
     10 # It will add elapsed time for each process in that case.
     11 
     12 # Copyright (c) 1998 by Richard Braakman <dark (at] xs4all.nl>.
     13 # Copyright (c) 1998-2017 The strace developers.
     14 
     15 # Redistribution and use in source and binary forms, with or without
     16 # modification, are permitted provided that the following conditions
     17 # are met:
     18 # 1. Redistributions of source code must retain the above copyright
     19 #    notice, this list of conditions and the following disclaimer.
     20 # 2. Redistributions in binary form must reproduce the above copyright
     21 #    notice, this list of conditions and the following disclaimer in the
     22 #    documentation and/or other materials provided with the distribution.
     23 # 3. The name of the author may not be used to endorse or promote products
     24 #    derived from this software without specific prior written permission.
     25 #
     26 # THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
     27 # IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
     28 # OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
     29 # IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
     30 # INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
     31 # NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
     32 # DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
     33 # THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
     34 # (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
     35 # THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
     36 
     37 use strict;
     38 use warnings;
     39 
     40 my %unfinished;
     41 my $floatform;
     42 
     43 # Scales for strace slowdown.  Make configurable!
     44 my $scale_factor = 3.5;
     45 my %running_fqname;
     46 
     47 while (<>) {
     48     my ($pid, $call, $args, $result, $time, $time_spent);
     49     chop;
     50     $floatform = 0;
     51 
     52     s/^(\d+)\s+//;
     53     $pid = $1;
     54 
     55     if (s/^(\d\d):(\d\d):(\d\d)(?:\.(\d\d\d\d\d\d))? //) {
     56 	$time = $1 * 3600 + $2 * 60 + $3;
     57 	if (defined $4) {
     58 	    $time = $time + $4 / 1000000;
     59 	    $floatform = 1;
     60 	}
     61     } elsif (s/^(\d+)\.(\d\d\d\d\d\d) //) {
     62 	$time = $1 + ($2 / 1000000);
     63 	$floatform = 1;
     64     }
     65 
     66     if (s/ <unfinished ...>$//) {
     67 	$unfinished{$pid} = $_;
     68 	next;
     69     }
     70 
     71     if (s/^<... \S+ resumed> //) {
     72 	unless (exists $unfinished{$pid}) {
     73 	    print STDERR "$0: $ARGV: cannot find start of resumed call on line $.";
     74 	    next;
     75 	}
     76 	$_ = $unfinished{$pid} . $_;
     77 	delete $unfinished{$pid};
     78     }
     79 
     80     if (/^--- SIG(\S+) (.*) ---$/) {
     81 	# $pid received signal $1
     82 	# currently we don't do anything with this
     83 	next;
     84     }
     85 
     86     if (/^\+\+\+ killed by SIG(\S+) \+\+\+$/) {
     87 	# $pid received signal $1
     88 	handle_killed($pid, $time);
     89 	next;
     90     }
     91 
     92     if (/^\+\+\+ exited with (\d+) \+\+\+$/) {
     93 	# $pid exited $1
     94 	# currently we don't do anything with this
     95 	next;
     96     }
     97 
     98     ($call, $args, $result) = /(\S+)\((.*)\)\s+= (.*)$/;
     99     if ($result =~ /^(.*) <([0-9.]*)>$/) {
    100 	($result, $time_spent) = ($1, $2);
    101     }
    102     unless (defined $result) {
    103 	print STDERR "$0: $ARGV: $.: cannot parse line.\n";
    104 	next;
    105     }
    106 
    107     handle_trace($pid, $call, $args, $result, $time);
    108 }
    109 
    110 display_trace();
    111 
    112 exit 0;
    113 
    114 sub parse_str {
    115     my ($in) = @_;
    116     my $result = "";
    117 
    118     while (1) {
    119 	if ($in =~ s/^\\(.)//) {
    120 	    $result .= $1;
    121 	} elsif ($in =~ s/^\"//) {
    122 	    if ($in =~ s/^\.\.\.//) {
    123 		return ("$result...", $in);
    124 	    }
    125 	    return ($result, $in);
    126 	} elsif ($in =~ s/([^\\\"]*)//) {
    127 	    $result .= $1;
    128 	} else {
    129 	    return (undef, $in);
    130 	}
    131     }
    132 }
    133 
    134 sub parse_one {
    135     my ($in) = @_;
    136 
    137     if ($in =~ s/^\"//) {
    138 	my $tmp;
    139 	($tmp, $in) = parse_str($in);
    140 	if (not defined $tmp) {
    141 	    print STDERR "$0: $ARGV: $.: cannot parse string.\n";
    142 	    return (undef, $in);
    143 	}
    144 	return ($tmp, $in);
    145     } elsif ($in =~ s/^0x([[:xdigit:]]+)//) {
    146 	return (hex $1, $in);
    147     } elsif ($in =~ s/^(\d+)//) {
    148 	return (int $1, $in);
    149     } else {
    150 	print STDERR "$0: $ARGV: $.: unrecognized element.\n";
    151 	return (undef, $in);
    152     }
    153 }
    154 
    155 sub parseargs {
    156     my ($in) = @_;
    157     my @args = ();
    158     my $tmp;
    159 
    160     while (length $in) {
    161 	if ($in =~ s/^\[//) {
    162 	    my @subarr = ();
    163 	    if ($in =~ s,^/\* (\d+) vars \*/\],,) {
    164 		push @args, $1;
    165 	    } else {
    166 		while ($in !~ s/^\]//) {
    167 		    ($tmp, $in) = parse_one($in);
    168 		    defined $tmp or return undef;
    169 		    push @subarr, $tmp;
    170 		    unless ($in =~ /^\]/ or $in =~ s/^, //) {
    171 			print STDERR "$0: $ARGV: $.: missing comma in array.\n";
    172 			return undef;
    173 		    }
    174 		    if ($in =~ s/^\.\.\.//) {
    175 			push @subarr, "...";
    176 		    }
    177 		}
    178 		push @args, \@subarr;
    179 	    }
    180 	} elsif ($in =~ s/^\{//) {
    181 	    my %subhash = ();
    182 	    while ($in !~ s/^\}//) {
    183 		my $key;
    184 		unless ($in =~ s/^(\w+)=//) {
    185 		    print STDERR "$0: $ARGV: $.: struct field expected.\n";
    186 		    return undef;
    187 		}
    188 		$key = $1;
    189 		($tmp, $in) = parse_one($in);
    190 		defined $tmp or return undef;
    191 		$subhash{$key} = $tmp;
    192 		unless ($in =~ s/, //) {
    193 		    print STDERR "$0: $ARGV: $.: missing comma in struct.\n";
    194 		    return undef;
    195 		}
    196 	    }
    197 	    push @args, \%subhash;
    198 	} else {
    199 	    ($tmp, $in) = parse_one($in);
    200 	    defined $tmp or return undef;
    201 	    push @args, $tmp;
    202 	}
    203 	unless (length($in) == 0 or $in =~ s/^, //) {
    204 	    print STDERR "$0: $ARGV: $.: missing comma.\n";
    205 	    return undef;
    206 	}
    207     }
    208     return @args;
    209 }
    210 
    211 
    212 my $depth = "";
    213 
    214 # process info, indexed by pid.
    215 # fields:
    216 #    parent         pid number
    217 #    seq            clones, forks and execs for this pid, in sequence  (array)
    218 
    219 #  filename and argv (from latest exec)
    220 #  basename (derived from filename)
    221 # argv[0] is modified to add the basename if it differs from the 0th argument.
    222 
    223 my %pr;
    224 
    225 sub handle_trace {
    226     my ($pid, $call, $args, $result, $time) = @_;
    227     my $pid_fqname = $pid . "-" . $time;
    228 
    229     if (defined $time and not defined $running_fqname{$pid}) {
    230 	$pr{$pid_fqname}{start} = $time;
    231 	$running_fqname{$pid} = $pid_fqname;
    232     }
    233 
    234     $pid_fqname = $running_fqname{$pid};
    235 
    236     if ($call eq 'execve') {
    237 	return if $result ne '0';
    238 
    239 	my ($filename, $argv) = parseargs($args);
    240 	my ($basename) = $filename =~ m/([^\/]*)$/;
    241 	if ($basename ne $$argv[0]) {
    242 	    $$argv[0] = "$basename($$argv[0])";
    243 	}
    244 	my $seq = $pr{$pid_fqname}{seq};
    245 	$seq = [] if not defined $seq;
    246 
    247 	push @$seq, ['EXEC', $filename, $argv];
    248 
    249 	$pr{$pid_fqname}{seq} = $seq;
    250     } elsif ($call eq 'fork' || $call eq 'clone' || $call eq 'vfork') {
    251 	return if $result == 0;
    252 
    253 	my $seq = $pr{$pid_fqname}{seq};
    254 	my $result_fqname= $result . "-" . $time;
    255 	$seq = [] if not defined $seq;
    256 	push @$seq, ['FORK', $result_fqname];
    257 	$pr{$pid_fqname}{seq} = $seq;
    258 	$pr{$result_fqname}{start} = $time;
    259 	$pr{$result_fqname}{parent} = $pid_fqname;
    260 	$pr{$result_fqname}{seq} = [];
    261 	$running_fqname{$result} = $result_fqname;
    262     } elsif ($call eq '_exit' || $call eq 'exit_group') {
    263 	$pr{$running_fqname{$pid}}{end} = $time if defined $time and not defined $pr{$running_fqname{$pid}}{end};
    264 	delete $running_fqname{$pid};
    265     }
    266 }
    267 
    268 sub handle_killed {
    269     my ($pid, $time) = @_;
    270     $pr{$pid}{end} = $time if defined $time and not defined $pr{$pid}{end};
    271 }
    272 
    273 sub straight_seq {
    274     my ($pid) = @_;
    275     my $seq = $pr{$pid}{seq};
    276 
    277     for my $elem (@$seq) {
    278 	if ($$elem[0] eq 'EXEC') {
    279 	    my $argv = $$elem[2];
    280 	    print "$$elem[0] $$elem[1] @$argv\n";
    281 	} elsif ($$elem[0] eq 'FORK') {
    282 	    print "$$elem[0] $$elem[1]\n";
    283 	} else {
    284 	    print "$$elem[0]\n";
    285 	}
    286     }
    287 }
    288 
    289 sub first_exec {
    290     my ($pid) = @_;
    291     my $seq = $pr{$pid}{seq};
    292 
    293     for my $elem (@$seq) {
    294 	if ($$elem[0] eq 'EXEC') {
    295 	    return $elem;
    296 	}
    297     }
    298     return undef;
    299 }
    300 
    301 sub display_pid_trace {
    302     my ($pid, $lead) = @_;
    303     my $i = 0;
    304     my @seq = @{$pr{$pid}{seq}};
    305     my $elapsed;
    306 
    307     if (not defined first_exec($pid)) {
    308 	unshift @seq, ['EXEC', '', ['(anon)'] ];
    309     }
    310 
    311     if (defined $pr{$pid}{start} and defined $pr{$pid}{end}) {
    312 	$elapsed = $pr{$pid}{end} - $pr{$pid}{start};
    313 	$elapsed /= $scale_factor;
    314 	if ($floatform) {
    315 	    $elapsed = sprintf("%0.02f", $elapsed);
    316 	} else {
    317 	    $elapsed = int $elapsed;
    318 	}
    319     }
    320 
    321     for my $elem (@seq) {
    322 	$i++;
    323 	if ($$elem[0] eq 'EXEC') {
    324 	    my $argv = $$elem[2];
    325 	    if (defined $elapsed) {
    326 		print "$lead [$elapsed] $pid @$argv\n";
    327 		undef $elapsed;
    328 	    } else {
    329 		print "$lead $pid @$argv\n";
    330 	    }
    331 	} elsif ($$elem[0] eq 'FORK') {
    332 	    if ($i == 1) {
    333 		if ($lead =~ /-$/) {
    334 		    display_pid_trace($$elem[1], "$lead--+--");
    335 		} else {
    336 		    display_pid_trace($$elem[1], "$lead  +--");
    337 		}
    338 	    } elsif ($i == @seq) {
    339 		display_pid_trace($$elem[1], "$lead  `--");
    340 	    } else {
    341 		display_pid_trace($$elem[1], "$lead  +--");
    342 	    }
    343 	}
    344 	if ($i == 1) {
    345 	    $lead =~ s/\`--/   /g;
    346 	    $lead =~ s/-/ /g;
    347 	    $lead =~ s/\+/|/g;
    348 	}
    349     }
    350 }
    351 
    352 sub display_trace {
    353     my ($startpid) = @_;
    354 
    355     $startpid = (keys %pr)[0];
    356     while ($pr{$startpid}{parent}) {
    357 	$startpid = $pr{$startpid}{parent};
    358     }
    359 
    360     display_pid_trace($startpid, "");
    361 }
    362