widl: Make output unique pointers into object pointers in object interfaces.
[wine] / 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);