Wine source

a0b2b1d0f… Alex*0001 #!/usr/bin/perl -w
                0002 # -----------------------------------------------------------------------------
c7c217b31… Alex*0003 #
                0004 # Relay-checker.
                0005 #
                0006 # This program will inspect a log file with relay information and tell you
                0007 # whether calls and returns match.  If not, this suggests that the parameter
                0008 # list might be incorrect.  (It could be something else also.)
                0009 #
3377a9c8e… Duan*0010 # This program now accepts a second command line parameter, which will enable
                0011 # a "full" listing format; otherwise a trimmed down simplified listing is
                0012 # generated. It does not matter what the second command line parameter is;
                0013 # anything will enable the full listing.
                0014 #
c7c217b31… Alex*0015 # Copyright 1997-1998 Morten Welinder (terra@diku.dk)
1055481a7… Eric*0016 #           2001      Eric Pouech
c7c217b31… Alex*0017 #
0799c1a78… Alex*0018 # This library is free software; you can redistribute it and/or
                0019 # modify it under the terms of the GNU Lesser General Public
                0020 # License as published by the Free Software Foundation; either
                0021 # version 2.1 of the License, or (at your option) any later version.
                0022 #
                0023 # This library is distributed in the hope that it will be useful,
                0024 # but WITHOUT ANY WARRANTY; without even the implied warranty of
                0025 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
                0026 # Lesser General Public License for more details.
                0027 #
                0028 # You should have received a copy of the GNU Lesser General Public
                0029 # License along with this library; if not, write to the Free Software
360a3f914… Jona*0030 # Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA
c7c217b31… Alex*0031 # -----------------------------------------------------------------------------
a0b2b1d0f… Alex*0032
1055481a7… Eric*0033 use strict;
                0034
a0b2b1d0f… Alex*0035 my $srcfile = $ARGV[0];
3377a9c8e… Duan*0036 my $fullformat = $ARGV[1];
1055481a7… Eric*0037 my %tid_callstack = ();
c7c217b31… Alex*0038 my $newlineerror = 0;
                0039 my $indentp = 1;
3377a9c8e… Duan*0040 my $lasttid = 0;
a0b2b1d0f… Alex*0041
                0042 open (IN, "<$srcfile") || die "Cannot open $srcfile for reading: $!\n";
                0043 LINE:
                0044 while (<IN>) {
1055481a7… Eric*0045
2011fa2d3… Guy *0046
4be47ac4a… Eric*0047     if (/^([0-9a-f]+):Call ([A-Za-z0-9_]+\.[A-Za-z0-9_.]+)\((.*\)) .*/) {
1055481a7… Eric*0048     my $tid = $1;
                0049     my $func = $2;
3377a9c8e… Duan*0050         if (defined $fullformat) {
                0051         if ($lasttid ne $tid) {
                0052             print "******** thread change\n"
                0053         }
                0054         $lasttid = $tid;
1055481a7… Eric*0055
3377a9c8e… Duan*0056         print ($indentp ? (' ' x 2 x (1 + $#{$tid_callstack{$tid}})) : '');
                0057         print "$_";
                0058     }
                0059 #   print "have call func=$func $_";
a0b2b1d0f… Alex*0060     if (/ ret=(........)$/ ||
3a0b3bbd6… Eric*0061         / ret=(....:....) (ds=....)$/ ||
                0062         / ret=(........) fs=....$/) {
a0b2b1d0f… Alex*0063         my $retaddr = $1;
c7c217b31… Alex*0064         my $segreg = $2;
                0065
                0066         $segreg = "none" unless defined $segreg;
1055481a7… Eric*0067
                0068         push @{$tid_callstack{$tid}}, [$func, $retaddr, $segreg];
a0b2b1d0f… Alex*0069         next;
3377a9c8e… Duan*0070     } elsif (not eof IN) {
a0b2b1d0f… Alex*0071         # Assume a line got cut by a line feed in a string.
                0072         $_ .= scalar (<IN>);
c7c217b31… Alex*0073         if (!$newlineerror) {
3a0b3bbd6… Eric*0074         print "Err[$tid] string probably cut by newline at line $. .\n";
c7c217b31… Alex*0075         $newlineerror = 1;
7cae558bd… Alex*0076         }
c7c217b31… Alex*0077         # print "[$_]";
a0b2b1d0f… Alex*0078         redo;
                0079     }
                0080     }
                0081
3377a9c8e… Duan*0082     elsif (/^([0-9a-f]+):Call (window proc) ([0-9a-fx]+) .*/) {
                0083     my $tid = $1;
                0084     my $func = $2;
                0085     my $retaddr = $3;
                0086     my $segreg = "none";
                0087         if (defined $fullformat) {
                0088         if ($lasttid ne $tid) {
                0089             print "******** thread change\n"
                0090         }
                0091         $lasttid = $tid;
                0092         print ($indentp ? (' ' x 2 x (1 + $#{$tid_callstack{$tid}})) : '');
                0093         print "$_";
                0094     }
                0095
                0096     push @{$tid_callstack{$tid}}, [$func, $retaddr, $segreg];
                0097     }
                0098
4be47ac4a… Eric*0099     elsif (/^([0-9a-f]+):Ret  ([A-Za-z0-9_]+\.[A-Za-z0-9_.]+)\(.*\) .* ret=(........)$/ ||
                0100     /^([0-9a-f]+):Ret  ([A-Za-z0-9_]+\.[A-Za-z0-9_.]+)\(.*\) .* ret=(....:....) (ds=....)$/ ||
                0101     /^([0-9a-f]+):Ret  ([A-Za-z0-9_]+\.[A-Za-z0-9_.]+)\(.*\) .* ret=(........) fs=....$/ ||
                0102         /^([0-9a-f]+):RET  ([A-Za-z0-9_]+\.[A-Za-z0-9_.]+: [A-Za-z0-9]+)\(.*\) .* ret=(........)$/ ||
3377a9c8e… Duan*0103         /^([0-9a-f]+):Ret  (window proc) ([0-9a-fx]+) .*/) {
1055481a7… Eric*0104     my $tid = $1;
                0105     my $func = $2;
                0106     my $retaddr = $3;
                0107     my $segreg = $4;
c7c217b31… Alex*0108     my ($topfunc,$topaddr,$topseg);
3377a9c8e… Duan*0109         if (defined $fullformat) {
                0110         if ($lasttid ne $tid) {
                0111             print "******** thread change\n"
                0112         }
                0113         $lasttid = $tid;
                0114     }
c7c217b31… Alex*0115
2011fa2d3… Guy *0116 #   print "have ret func=$func <$_>\n";
1055481a7… Eric*0117     if (!defined($tid_callstack{$tid}))
                0118     {
                0119         print "Err[$tid]: unknown tid\n";
                0120         next;
                0121     }
                0122
c7c217b31… Alex*0123     $segreg = "none" unless defined $segreg;
a0b2b1d0f… Alex*0124
                0125       POP:
                0126     while (1) {
1055481a7… Eric*0127         if ($#{$tid_callstack{$tid}} == -1) {
                0128         print "Err[$tid]: Return from $func to $retaddr with empty stack.\n";
a0b2b1d0f… Alex*0129         next LINE;
                0130         }
                0131
1055481a7… Eric*0132         ($topfunc,$topaddr,$topseg) = @{pop @{$tid_callstack{$tid}}};
a0b2b1d0f… Alex*0133
                0134         if ($topfunc ne $func) {
1055481a7… Eric*0135         print "Err[$tid]: Return from $topfunc, but call from $func.\n";
                0136         next POP;
a0b2b1d0f… Alex*0137         }
                0138         last POP;
                0139     }
                0140
c7c217b31… Alex*0141     my $addrok = ($topaddr eq $retaddr);
                0142     my $segok = ($topseg eq $segreg);
                0143     if ($addrok && $segok) {
3377a9c8e… Duan*0144             if (defined $fullformat) {
                0145             print ($indentp ? (' ' x 2 x (1 + $#{$tid_callstack{$tid}})) : '');
                0146             print "$_";
                0147         } else {
                0148             print "Ok [$tid]: ", ($indentp ? (' ' x (1 + $#{$tid_callstack{$tid}})) : '');
                0149             print "$func from $retaddr with $segreg.\n";
                0150         }
a0b2b1d0f… Alex*0151     } else {
1055481a7… Eric*0152         print "Err[$tid]: Return from $func is to $retaddr, not $topaddr.\n"
c7c217b31… Alex*0153         if !$addrok;
1055481a7… Eric*0154         print "Err[$tid]: Return from $func with segreg $segreg, not $topseg.\n"
c7c217b31… Alex*0155         if !$segok;
7cae558bd… Alex*0156     }
a0b2b1d0f… Alex*0157     }
3377a9c8e… Duan*0158
                0159     else {
                0160     print "$_";
                0161     }
a0b2b1d0f… Alex*0162 }
                0163
1055481a7… Eric*0164 foreach my $tid (keys %tid_callstack) {
                0165     while ($#{$tid_callstack{$tid}} != -1) {
                0166     my ($topfunc,$topaddr,$topseg) = @{pop @{$tid_callstack{$tid}}};
                0167     print "Err[$tid]: leftover call to $topfunc from $topaddr.\n";
                0168     }
a0b2b1d0f… Alex*0169 }
                0170
                0171 close (IN);