granicus.if.org Git - strace/blob - strace-graph

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