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
  45 while (<>) {
  46     my ($pid, $call, $args, $result, $time);
  47     chop;
  48     $floatform = 0;
  49
  50     s/^(\d+)\s+//;
  51     $pid = $1;
  52
  53     if (s/^(\d\d):(\d\d):(\d\d)(?:\.(\d\d\d\d\d\d))? //) {
  54         $time = $1 * 3600 + $2 * 60 + $3;
  55         if (defined $4) {
  56             $time = $time + $4 / 1000000;
  57             $floatform = 1;
  58         }
  59     } elsif (s/^(\d+)\.(\d\d\d\d\d\d) //) {
  60         $time = $1 + ($2 / 1000000);
  61         $floatform = 1;
  62     }
  63
  64     if (s/ <unfinished ...>$//) {
  65         $unfinished{$pid} = $_;
  66         next;
  67     }
  68
  69     if (s/^<... \S+ resumed> //) {
  70         unless (exists $unfinished{$pid}) {
  71             print STDERR "$0: $ARGV: cannot find start of resumed call on line $.";
  72             next;
  73         }
  74         $_ = $unfinished{$pid} . $_;
  75         delete $unfinished{$pid};
  76     }
  77
  78     if (/^--- SIG(\S+) \(.*\) ---$/) {
  79         # $pid received signal $1
  80         # currently we don't do anything with this
  81         next;
  82     }
  83
  84     if (/^\+\+\+ killed by SIG(\S+) \+\+\+$/) {
  85         # $pid received signal $1
  86         handle_killed($pid, $time);
  87         next;
  88     }
  89
  90     ($call, $args, $result) = /(\S+)\((.*)\)\s+= (.*)$/;
  91     unless (defined $result) {
  92         print STDERR "$0: $ARGV: $.: cannot parse line.\n";
  93         next;
  94     }
  95
  96     handle_trace($pid, $call, $args, $result, $time);
  97 }
  98
  99 display_trace();
 100
 101 exit 0;
 102
 103 sub parse_str {
 104     my ($in) = @_;
 105     my $result = "";
 106
 107     while (1) {
 108         if ($in =~ s/^\\(.)//) {
 109             $result .= $1;
 110         } elsif ($in =~ s/^\"//) {
 111             if ($in =~ s/^\.\.\.//) {
 112                 return ("$result...", $in);
 113             }
 114             return ($result, $in);
 115         } elsif ($in =~ s/([^\\\"]*)//) {
 116             $result .= $1;
 117         } else {
 118             return (undef, $in);
 119         }
 120     }
 121 }
 122
 123 sub parse_one {
 124     my ($in) = @_;
 125
 126     if ($in =~ s/^\"//) {
 127         my $tmp;
 128         ($tmp, $in) = parse_str($in);
 129         if (not defined $tmp) {
 130             print STDERR "$0: $ARGV: $.: cannot parse string.\n";
 131             return (undef, $in);
 132         }
 133         return ($tmp, $in);
 134     } elsif ($in =~ s/^0x([[:xdigit:]]+)//) {
 135         return (hex $1, $in);
 136     } elsif ($in =~ s/^(\d+)//) {
 137         return (int $1, $in);
 138     } else {
 139         print STDERR "$0: $ARGV: $.: unrecognized element.\n";
 140         return (undef, $in);
 141     }
 142 }
 143
 144 sub parseargs {
 145     my ($in) = @_;
 146     my @args = ();
 147     my $tmp;
 148
 149     while (length $in) {
 150         if ($in =~ s/^\[//) {
 151             my @subarr = ();
 152             if ($in =~ s,^/\* (\d+) vars \*/\],,) {
 153                 push @args, $1;
 154             } else {
 155                 while ($in !~ s/^\]//) {
 156                     ($tmp, $in) = parse_one($in);
 157                     defined $tmp or return undef;
 158                     push @subarr, $tmp;
 159                     unless ($in =~ /^\]/ or $in =~ s/^, //) {
 160                         print STDERR "$0: $ARGV: $.: missing comma in array.\n";
 161                         return undef;
 162                     }
 163                     if ($in =~ s/^\.\.\.//) {
 164                         push @subarr, "...";
 165                     }
 166                 }
 167                 push @args, \@subarr;
 168             }
 169         } elsif ($in =~ s/^\{//) {
 170             my %subhash = ();
 171             while ($in !~ s/^\}//) {
 172                 my $key;
 173                 unless ($in =~ s/^(\w+)=//) {
 174                     print STDERR "$0: $ARGV: $.: struct field expected.\n";
 175                     return undef;
 176                 }
 177                 $key = $1;
 178                 ($tmp, $in) = parse_one($in);
 179                 defined $tmp or return undef;
 180                 $subhash{$key} = $tmp;
 181                 unless ($in =~ s/, //) {
 182                     print STDERR "$0: $ARGV: $.: missing comma in struct.\n";
 183                     return undef;
 184                 }
 185             }
 186             push @args, \%subhash;
 187         } else {
 188             ($tmp, $in) = parse_one($in);
 189             defined $tmp or return undef;
 190             push @args, $tmp;
 191         }
 192         unless (length($in) == 0 or $in =~ s/^, //) {
 193             print STDERR "$0: $ARGV: $.: missing comma.\n";
 194             return undef;
 195         }
 196     }
 197     return @args;
 198 }
 199
 200
 201 my $depth = "";
 202
 203 # process info, indexed by pid.
 204 # fields:
 205 #    parent         pid number
 206 #    seq            forks and execs for this pid, in sequence  (array)
 207
 208 #  filename and argv (from latest exec)
 209 #  basename (derived from filename)
 210 # argv[0] is modified to add the basename if it differs from the 0th argument.
 211
 212 my %pr;
 213
 214 sub handle_trace {
 215     my ($pid, $call, $args, $result, $time) = @_;
 216     my $p;
 217
 218     if (defined $time and not defined $pr{$pid}{start}) {
 219         $pr{$pid}{start} = $time;
 220     }
 221
 222     if ($call eq 'execve') {
 223         return if $result ne '0';
 224
 225         my ($filename, $argv) = parseargs($args);
 226         my ($basename) = $filename =~ m/([^\/]*)$/;
 227         if ($basename ne $$argv[0]) {
 228             $$argv[0] = "$basename($$argv[0])";
 229         }
 230         my $seq = $pr{$pid}{seq};
 231         $seq = [] if not defined $seq;
 232
 233         push @$seq, ['EXEC', $filename, $argv];
 234
 235         $pr{$pid}{seq} = $seq;
 236     } elsif ($call eq 'fork' || $call eq 'clone' || $call eq 'vfork') {
 237         return if $result == 0;
 238
 239         my $seq = $pr{$pid}{seq};
 240         $seq = [] if not defined $seq;
 241         push @$seq, ['FORK', $result];
 242         $pr{$pid}{seq} = $seq;
 243         $pr{$result}{parent} = $pid;
 244     } elsif ($call eq '_exit') {
 245         $pr{$pid}{end} = $time if defined $time;
 246     }
 247 }
 248
 249 sub handle_killed {
 250     my ($pid, $time) = @_;
 251     $pr{$pid}{end} = $time if defined $time;
 252 }
 253
 254 sub straight_seq {
 255     my ($pid) = @_;
 256     my $seq = $pr{$pid}{seq};
 257
 258     for my $elem (@$seq) {
 259         if ($$elem[0] eq 'EXEC') {
 260             my $argv = $$elem[2];
 261             print "$$elem[0] $$elem[1] @$argv\n";
 262         } elsif ($$elem[0] eq 'FORK') {
 263             print "$$elem[0] $$elem[1]\n";
 264         } else {
 265             print "$$elem[0]\n";
 266         }
 267     }
 268 }
 269
 270 sub first_exec {
 271     my ($pid) = @_;
 272     my $seq = $pr{$pid}{seq};
 273
 274     for my $elem (@$seq) {
 275         if ($$elem[0] eq 'EXEC') {
 276             return $elem;
 277         }
 278     }
 279     return undef;
 280 }
 281
 282 sub display_pid_trace {
 283     my ($pid, $lead) = @_;
 284     my $i = 0;
 285     my @seq = @{$pr{$pid}{seq}};
 286     my $elapsed;
 287
 288     if (not defined first_exec($pid)) {
 289         unshift @seq, ['EXEC', '', ['(anon)'] ];
 290     }
 291
 292     if (defined $pr{$pid}{start} and defined $pr{$pid}{end}) {
 293         $elapsed = $pr{$pid}{end} - $pr{$pid}{start};
 294         $elapsed /= $scale_factor;
 295         if ($floatform) {
 296             $elapsed = sprintf("%0.02f", $elapsed);
 297         } else {
 298             $elapsed = int $elapsed;
 299         }
 300     }
 301
 302     for my $elem (@seq) {
 303         $i++;
 304         if ($$elem[0] eq 'EXEC') {
 305             my $argv = $$elem[2];
 306             if (defined $elapsed) {
 307                 print "$lead [$elapsed] @$argv\n";
 308                 undef $elapsed;
 309             } else {
 310                 print "$lead @$argv\n";
 311             }
 312         } elsif ($$elem[0] eq 'FORK') {
 313             if ($i == 1) {
 314                 if ($lead =~ /-$/) {
 315                     display_pid_trace($$elem[1], "$lead--+--");
 316                 } else {
 317                     display_pid_trace($$elem[1], "$lead  +--");
 318                 }
 319             } elsif ($i == @seq) {
 320                 display_pid_trace($$elem[1], "$lead  `--");
 321             } else {
 322                 display_pid_trace($$elem[1], "$lead  +--");
 323             }
 324         }
 325         if ($i == 1) {
 326             $lead =~ s/\`--/   /g;
 327             $lead =~ s/-/ /g;
 328             $lead =~ s/\+/|/g;
 329         }
 330     }
 331 }
 332
 333 sub display_trace {
 334     my ($startpid) = @_;
 335
 336     $startpid = (keys %pr)[0];
 337     while ($pr{$startpid}{parent}) {
 338         $startpid = $pr{$startpid}{parent};
 339     }
 340
 341     display_pid_trace($startpid, "");
 342 }