• Home
  • Line#
  • Scopes#
  • Navigate#
  • Raw
  • Download
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@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
37use strict;
38use warnings;
39
40my %unfinished;
41my $floatform;
42
43# Scales for strace slowdown.  Make configurable!
44my $scale_factor = 3.5;
45my %running_fqname;
46
47while (<>) {
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
110display_trace();
111
112exit 0;
113
114sub 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
134sub 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
155sub 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
212my $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
223my %pr;
224
225sub 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
268sub handle_killed {
269    my ($pid, $time) = @_;
270    $pr{$pid}{end} = $time if defined $time and not defined $pr{$pid}{end};
271}
272
273sub 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
289sub 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
301sub 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
352sub 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