Sweden-Number/tools/examine-relay

172 lines
5.0 KiB
Perl
Executable File

#!/usr/bin/perl -w
# -----------------------------------------------------------------------------
#
# Relay-checker.
#
# This program will inspect a log file with relay information and tell you
# whether calls and returns match. If not, this suggests that the parameter
# list might be incorrect. (It could be something else also.)
#
# This program now accepts a second command line parameter, which will enable
# a "full" listing format; otherwise a trimmed down simplified listing is
# generated. It does not matter what the second command line parameter is;
# anything will enable the full listing.
#
# Copyright 1997-1998 Morten Welinder (terra@diku.dk)
# 2001 Eric Pouech
#
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Lesser General Public
# License as published by the Free Software Foundation; either
# version 2.1 of the License, or (at your option) any later version.
#
# This library is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# Lesser General Public License for more details.
#
# You should have received a copy of the GNU Lesser General Public
# License along with this library; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA
# -----------------------------------------------------------------------------
use strict;
my $srcfile = $ARGV[0];
my $fullformat = $ARGV[1];
my %tid_callstack = ();
my $newlineerror = 0;
my $indentp = 1;
my $lasttid = 0;
open (IN, "<$srcfile") || die "Cannot open $srcfile for reading: $!\n";
LINE:
while (<IN>) {
if (/^([0-9a-f]+):Call ([A-Za-z0-9_]+\.[A-Za-z0-9_.]+)\((.*\)) .*/) {
my $tid = $1;
my $func = $2;
if (defined $fullformat) {
if ($lasttid ne $tid) {
print "******** thread change\n"
}
$lasttid = $tid;
print ($indentp ? (' ' x 2 x (1 + $#{$tid_callstack{$tid}})) : '');
print "$_";
}
# print "have call func=$func $_";
if (/ ret=(........)$/ ||
/ ret=(....:....) (ds=....)$/ ||
/ ret=(........) fs=....$/) {
my $retaddr = $1;
my $segreg = $2;
$segreg = "none" unless defined $segreg;
push @{$tid_callstack{$tid}}, [$func, $retaddr, $segreg];
next;
} elsif (not eof IN) {
# Assume a line got cut by a line feed in a string.
$_ .= scalar (<IN>);
if (!$newlineerror) {
print "Err[$tid] string probably cut by newline at line $. .\n";
$newlineerror = 1;
}
# print "[$_]";
redo;
}
}
elsif (/^([0-9a-f]+):Call (window proc) ([0-9a-fx]+) .*/) {
my $tid = $1;
my $func = $2;
my $retaddr = $3;
my $segreg = "none";
if (defined $fullformat) {
if ($lasttid ne $tid) {
print "******** thread change\n"
}
$lasttid = $tid;
print ($indentp ? (' ' x 2 x (1 + $#{$tid_callstack{$tid}})) : '');
print "$_";
}
push @{$tid_callstack{$tid}}, [$func, $retaddr, $segreg];
}
elsif (/^([0-9a-f]+):Ret ([A-Za-z0-9_]+\.[A-Za-z0-9_.]+)\(.*\) .* ret=(........)$/ ||
/^([0-9a-f]+):Ret ([A-Za-z0-9_]+\.[A-Za-z0-9_.]+)\(.*\) .* ret=(....:....) (ds=....)$/ ||
/^([0-9a-f]+):Ret ([A-Za-z0-9_]+\.[A-Za-z0-9_.]+)\(.*\) .* ret=(........) fs=....$/ ||
/^([0-9a-f]+):RET ([A-Za-z0-9_]+\.[A-Za-z0-9_.]+: [A-Za-z0-9]+)\(.*\) .* ret=(........)$/ ||
/^([0-9a-f]+):Ret (window proc) ([0-9a-fx]+) .*/) {
my $tid = $1;
my $func = $2;
my $retaddr = $3;
my $segreg = $4;
my ($topfunc,$topaddr,$topseg);
if (defined $fullformat) {
if ($lasttid ne $tid) {
print "******** thread change\n"
}
$lasttid = $tid;
}
# print "have ret func=$func <$_>\n";
if (!defined($tid_callstack{$tid}))
{
print "Err[$tid]: unknown tid\n";
next;
}
$segreg = "none" unless defined $segreg;
POP:
while (1) {
if ($#{$tid_callstack{$tid}} == -1) {
print "Err[$tid]: Return from $func to $retaddr with empty stack.\n";
next LINE;
}
($topfunc,$topaddr,$topseg) = @{pop @{$tid_callstack{$tid}}};
if ($topfunc ne $func) {
print "Err[$tid]: Return from $topfunc, but call from $func.\n";
next POP;
}
last POP;
}
my $addrok = ($topaddr eq $retaddr);
my $segok = ($topseg eq $segreg);
if ($addrok && $segok) {
if (defined $fullformat) {
print ($indentp ? (' ' x 2 x (1 + $#{$tid_callstack{$tid}})) : '');
print "$_";
} else {
print "Ok [$tid]: ", ($indentp ? (' ' x (1 + $#{$tid_callstack{$tid}})) : '');
print "$func from $retaddr with $segreg.\n";
}
} else {
print "Err[$tid]: Return from $func is to $retaddr, not $topaddr.\n"
if !$addrok;
print "Err[$tid]: Return from $func with segreg $segreg, not $topseg.\n"
if !$segok;
}
}
else {
print "$_";
}
}
foreach my $tid (keys %tid_callstack) {
while ($#{$tid_callstack{$tid}} != -1) {
my ($topfunc,$topaddr,$topseg) = @{pop @{$tid_callstack{$tid}}};
print "Err[$tid]: leftover call to $topfunc from $topaddr.\n";
}
}
close (IN);