Commit | Line | Data |
---|---|---|
a0b2b1d0 AJ |
1 | #!/usr/bin/perl -w |
2 | # ----------------------------------------------------------------------------- | |
c7c217b3 AJ |
3 | # |
4 | # Relay-checker. | |
5 | # | |
6 | # This program will inspect a log file with relay information and tell you | |
7 | # whether calls and returns match. If not, this suggests that the parameter | |
8 | # list might be incorrect. (It could be something else also.) | |
9 | # | |
3377a9c8 DC |
10 | # This program now accepts a second command line parameter, which will enable |
11 | # a "full" listing format; otherwise a trimmed down simplified listing is | |
12 | # generated. It does not matter what the second command line parameter is; | |
13 | # anything will enable the full listing. | |
14 | # | |
c7c217b3 | 15 | # Copyright 1997-1998 Morten Welinder (terra@diku.dk) |
1055481a | 16 | # 2001 Eric Pouech |
c7c217b3 | 17 | # |
0799c1a7 AJ |
18 | # This library is free software; you can redistribute it and/or |
19 | # modify it under the terms of the GNU Lesser General Public | |
20 | # License as published by the Free Software Foundation; either | |
21 | # version 2.1 of the License, or (at your option) any later version. | |
22 | # | |
23 | # This library is distributed in the hope that it will be useful, | |
24 | # but WITHOUT ANY WARRANTY; without even the implied warranty of | |
25 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
26 | # Lesser General Public License for more details. | |
27 | # | |
28 | # You should have received a copy of the GNU Lesser General Public | |
29 | # License along with this library; if not, write to the Free Software | |
360a3f91 | 30 | # Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA |
c7c217b3 | 31 | # ----------------------------------------------------------------------------- |
a0b2b1d0 | 32 | |
1055481a EP |
33 | use strict; |
34 | ||
a0b2b1d0 | 35 | my $srcfile = $ARGV[0]; |
3377a9c8 | 36 | my $fullformat = $ARGV[1]; |
1055481a | 37 | my %tid_callstack = (); |
c7c217b3 AJ |
38 | my $newlineerror = 0; |
39 | my $indentp = 1; | |
3377a9c8 | 40 | my $lasttid = 0; |
a0b2b1d0 AJ |
41 | |
42 | open (IN, "<$srcfile") || die "Cannot open $srcfile for reading: $!\n"; | |
43 | LINE: | |
44 | while (<IN>) { | |
1055481a | 45 | |
2011fa2d | 46 | |
1df41285 | 47 | if (/^([0-9a-f]+):Call ([A-Za-z0-9]+\.[A-Za-z0-9_.]+)\((.*\)) .*/) { |
1055481a EP |
48 | my $tid = $1; |
49 | my $func = $2; | |
3377a9c8 DC |
50 | if (defined $fullformat) { |
51 | if ($lasttid ne $tid) { | |
52 | print "******** thread change\n" | |
53 | } | |
54 | $lasttid = $tid; | |
1055481a | 55 | |
3377a9c8 DC |
56 | print ($indentp ? (' ' x 2 x (1 + $#{$tid_callstack{$tid}})) : ''); |
57 | print "$_"; | |
58 | } | |
59 | # print "have call func=$func $_"; | |
a0b2b1d0 | 60 | if (/ ret=(........)$/ || |
3a0b3bbd EP |
61 | / ret=(....:....) (ds=....)$/ || |
62 | / ret=(........) fs=....$/) { | |
a0b2b1d0 | 63 | my $retaddr = $1; |
c7c217b3 AJ |
64 | my $segreg = $2; |
65 | ||
66 | $segreg = "none" unless defined $segreg; | |
1055481a EP |
67 | |
68 | push @{$tid_callstack{$tid}}, [$func, $retaddr, $segreg]; | |
a0b2b1d0 | 69 | next; |
3377a9c8 | 70 | } elsif (not eof IN) { |
a0b2b1d0 AJ |
71 | # Assume a line got cut by a line feed in a string. |
72 | $_ .= scalar (<IN>); | |
c7c217b3 | 73 | if (!$newlineerror) { |
3a0b3bbd | 74 | print "Err[$tid] string probably cut by newline at line $. .\n"; |
c7c217b3 | 75 | $newlineerror = 1; |
7cae558b | 76 | } |
c7c217b3 | 77 | # print "[$_]"; |
a0b2b1d0 AJ |
78 | redo; |
79 | } | |
80 | } | |
81 | ||
3377a9c8 DC |
82 | elsif (/^([0-9a-f]+):Call (window proc) ([0-9a-fx]+) .*/) { |
83 | my $tid = $1; | |
84 | my $func = $2; | |
85 | my $retaddr = $3; | |
86 | my $segreg = "none"; | |
87 | if (defined $fullformat) { | |
88 | if ($lasttid ne $tid) { | |
89 | print "******** thread change\n" | |
90 | } | |
91 | $lasttid = $tid; | |
92 | print ($indentp ? (' ' x 2 x (1 + $#{$tid_callstack{$tid}})) : ''); | |
93 | print "$_"; | |
94 | } | |
95 | ||
96 | push @{$tid_callstack{$tid}}, [$func, $retaddr, $segreg]; | |
97 | } | |
98 | ||
1df41285 DC |
99 | elsif (/^([0-9a-f]+):Ret ([A-Za-z0-9]+\.[A-Za-z0-9_.]+)\(.*\) .* ret=(........)$/ || |
100 | /^([0-9a-f]+):Ret ([A-Za-z0-9]+\.[A-Za-z0-9_.]+)\(.*\) .* ret=(....:....) (ds=....)$/ || | |
101 | /^([0-9a-f]+):Ret ([A-Za-z0-9]+\.[A-Za-z0-9_.]+)\(.*\) .* ret=(........) fs=....$/ || | |
102 | /^([0-9a-f]+):RET ([A-Za-z0-9]+\.[A-Za-z0-9_.]+: [A-Za-z0-9]+)\(.*\) .* ret=(........)$/ || | |
3377a9c8 | 103 | /^([0-9a-f]+):Ret (window proc) ([0-9a-fx]+) .*/) { |
1055481a EP |
104 | my $tid = $1; |
105 | my $func = $2; | |
106 | my $retaddr = $3; | |
107 | my $segreg = $4; | |
c7c217b3 | 108 | my ($topfunc,$topaddr,$topseg); |
3377a9c8 DC |
109 | if (defined $fullformat) { |
110 | if ($lasttid ne $tid) { | |
111 | print "******** thread change\n" | |
112 | } | |
113 | $lasttid = $tid; | |
114 | } | |
c7c217b3 | 115 | |
2011fa2d | 116 | # print "have ret func=$func <$_>\n"; |
1055481a EP |
117 | if (!defined($tid_callstack{$tid})) |
118 | { | |
119 | print "Err[$tid]: unknown tid\n"; | |
120 | next; | |
121 | } | |
122 | ||
c7c217b3 | 123 | $segreg = "none" unless defined $segreg; |
a0b2b1d0 AJ |
124 | |
125 | POP: | |
126 | while (1) { | |
1055481a EP |
127 | if ($#{$tid_callstack{$tid}} == -1) { |
128 | print "Err[$tid]: Return from $func to $retaddr with empty stack.\n"; | |
a0b2b1d0 AJ |
129 | next LINE; |
130 | } | |
131 | ||
1055481a | 132 | ($topfunc,$topaddr,$topseg) = @{pop @{$tid_callstack{$tid}}}; |
a0b2b1d0 AJ |
133 | |
134 | if ($topfunc ne $func) { | |
1055481a EP |
135 | print "Err[$tid]: Return from $topfunc, but call from $func.\n"; |
136 | next POP; | |
a0b2b1d0 AJ |
137 | } |
138 | last POP; | |
139 | } | |
140 | ||
c7c217b3 AJ |
141 | my $addrok = ($topaddr eq $retaddr); |
142 | my $segok = ($topseg eq $segreg); | |
143 | if ($addrok && $segok) { | |
3377a9c8 DC |
144 | if (defined $fullformat) { |
145 | print ($indentp ? (' ' x 2 x (1 + $#{$tid_callstack{$tid}})) : ''); | |
146 | print "$_"; | |
147 | } else { | |
148 | print "Ok [$tid]: ", ($indentp ? (' ' x (1 + $#{$tid_callstack{$tid}})) : ''); | |
149 | print "$func from $retaddr with $segreg.\n"; | |
150 | } | |
a0b2b1d0 | 151 | } else { |
1055481a | 152 | print "Err[$tid]: Return from $func is to $retaddr, not $topaddr.\n" |
c7c217b3 | 153 | if !$addrok; |
1055481a | 154 | print "Err[$tid]: Return from $func with segreg $segreg, not $topseg.\n" |
c7c217b3 | 155 | if !$segok; |
7cae558b | 156 | } |
a0b2b1d0 | 157 | } |
3377a9c8 DC |
158 | |
159 | else { | |
160 | print "$_"; | |
161 | } | |
a0b2b1d0 AJ |
162 | } |
163 | ||
1055481a EP |
164 | foreach my $tid (keys %tid_callstack) { |
165 | while ($#{$tid_callstack{$tid}} != -1) { | |
166 | my ($topfunc,$topaddr,$topseg) = @{pop @{$tid_callstack{$tid}}}; | |
167 | print "Err[$tid]: leftover call to $topfunc from $topaddr.\n"; | |
168 | } | |
a0b2b1d0 AJ |
169 | } |
170 | ||
171 | close (IN); |