git.oblomov.eu Git - wine/blob - tools/examine-relay

   1 #!/usr/bin/perl -w
   2 # -----------------------------------------------------------------------------
   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 #
  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 #
  15 # Copyright 1997-1998 Morten Welinder (terra@diku.dk)
  16 #           2001      Eric Pouech
  17 #
  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
  30 # Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA
  31 # -----------------------------------------------------------------------------
  32
  33 use strict;
  34
  35 my $srcfile = $ARGV[0];
  36 my $fullformat = $ARGV[1];
  37 my %tid_callstack = ();
  38 my $newlineerror = 0;
  39 my $indentp = 1;
  40 my $lasttid = 0;
  41
  42 open (IN, "<$srcfile") || die "Cannot open $srcfile for reading: $!\n";
  43 LINE:
  44 while (<IN>) {
  45
  46
  47     if (/^([0-9a-f]+):Call ([A-Za-z0-9]+\.[A-Za-z0-9_.]+)\((.*\)) .*/) {
  48         my $tid = $1;
  49         my $func = $2;
  50         if (defined $fullformat) {
  51             if ($lasttid ne $tid) {
  52                 print "******** thread change\n"
  53             }
  54             $lasttid = $tid;
  55
  56             print ($indentp ? (' ' x 2 x (1 + $#{$tid_callstack{$tid}})) : '');
  57             print "$_";
  58         }
  59 #       print "have call func=$func $_";
  60         if (/ ret=(........)$/ ||
  61             / ret=(....:....) (ds=....)$/ ||
  62             / ret=(........) fs=....$/) {
  63             my $retaddr = $1;
  64             my $segreg = $2;
  65
  66             $segreg = "none" unless defined $segreg;
  67
  68             push @{$tid_callstack{$tid}}, [$func, $retaddr, $segreg];
  69             next;
  70         } elsif (not eof IN) {
  71             # Assume a line got cut by a line feed in a string.
  72             $_ .= scalar (<IN>);
  73             if (!$newlineerror) {
  74                 print "Err[$tid] string probably cut by newline at line $. .\n";
  75                 $newlineerror = 1;
  76             }
  77             # print "[$_]";
  78             redo;
  79         }
  80     }
  81
  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
  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=(........)$/ ||
 103         /^([0-9a-f]+):Ret  (window proc) ([0-9a-fx]+) .*/) {
 104         my $tid = $1;
 105         my $func = $2;
 106         my $retaddr = $3;
 107         my $segreg = $4;
 108         my ($topfunc,$topaddr,$topseg);
 109         if (defined $fullformat) {
 110             if ($lasttid ne $tid) {
 111                 print "******** thread change\n"
 112             }
 113             $lasttid = $tid;
 114         }
 115
 116 #       print "have ret func=$func <$_>\n";
 117         if (!defined($tid_callstack{$tid}))
 118         {
 119             print "Err[$tid]: unknown tid\n";
 120             next;
 121         }
 122
 123         $segreg = "none" unless defined $segreg;
 124
 125       POP:
 126         while (1) {
 127             if ($#{$tid_callstack{$tid}} == -1) {
 128                 print "Err[$tid]: Return from $func to $retaddr with empty stack.\n";
 129                 next LINE;
 130             }
 131
 132             ($topfunc,$topaddr,$topseg) = @{pop @{$tid_callstack{$tid}}};
 133
 134             if ($topfunc ne $func) {
 135                 print "Err[$tid]: Return from $topfunc, but call from $func.\n";
 136                 next POP;
 137             }
 138             last POP;
 139         }
 140
 141         my $addrok = ($topaddr eq $retaddr);
 142         my $segok = ($topseg eq $segreg);
 143         if ($addrok && $segok) {
 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             }
 151         } else {
 152             print "Err[$tid]: Return from $func is to $retaddr, not $topaddr.\n"
 153                 if !$addrok;
 154             print "Err[$tid]: Return from $func with segreg $segreg, not $topseg.\n"
 155                 if !$segok;
 156         }
 157     }
 158
 159     else {
 160         print "$_";
 161     }
 162 }
 163
 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     }
 169 }
 170
 171 close (IN);