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