1#!/usr/athena/bin/perl -w 2 3# Code initially generated by s2p 4# Code modified to use strict and IO::File 5 6eval 'exec /usr/athena/bin/perl -S $0 ${1+"$@"}' 7 if 0; # line above evaluated when running under some shell (i.e., not perl) 8 9use strict; 10use IO::File; 11 12my $verbose = 0; 13my $error = 0; 14if ( $ARGV[0] eq "-v" ) { $verbose = 1; shift @ARGV; } 15my $h_filename = shift @ARGV || die "usage: $0 [-v] header-file [def-file]\n"; 16my $d_filename = shift @ARGV; 17 18my $h = open_always($h_filename); 19my $d = open_always($d_filename) if $d_filename; 20 21sub open_always 22{ 23 my $file = shift || die; 24 my $handle = new IO::File "<$file"; 25 die "Could not open $file\n" if !$handle; 26 return $handle; 27} 28 29my @convW = (); 30my @convC = (); 31my @convK = (); 32my @convD = (); 33my @vararg = (); 34 35my $len1; 36my %conv; 37my $printit; 38my $vararg; 39 40LINE: 41while (! $h->eof()) { 42 $_ = $h->getline(); 43 chop; 44 # get calling convention info for function decls 45 # what about function pointer typedefs? 46 # need to verify unhandled syntax actually triggers a report, not ignored 47 # blank lines 48 if (/^[ \t]*$/) { 49 next LINE; 50 } 51 Top: 52 # drop KRB5INT_BEGIN_DECLS and KRB5INT_END_DECLS 53 if (/^ *(KRB5INT|GSSAPI[A-Z]*)_(BEGIN|END)_DECLS/) { 54 next LINE; 55 } 56 # drop preprocessor directives 57 if (/^ *#/) { 58 while (/\\$/) { $_ .= $h->getline(); } 59 next LINE; 60 } 61 if (/^ *\?==/) { 62 next LINE; 63 } 64 s/#.*$//; 65 if (/^\} *$/) { 66 next LINE; 67 } 68 # strip comments 69 Cloop1: 70 if (/\/\*./) { 71 s;/\*[^*]*;/*;; 72 s;/\*\*([^/]);/*$1;; 73 s;/\*\*$;/*;; 74 s;/\*\*/; ;g; 75 goto Cloop1; 76 } 77 # multi-line comments? 78 if (/\/\*$/) { 79 $_ .= " "; 80 $len1 = length; 81 $_ .= $h->getline(); 82 chop if $len1 < length; 83 goto Cloop1 if /\/\*./; 84 } 85 # blank lines 86 if (/^[ \t]*$/) { 87 next LINE; 88 } 89 if (/^ *extern "C" \{/) { 90 next LINE; 91 } 92 s/KRB5_ATTR_DEPRECATED//; 93 # elide struct definitions 94 Struct1: 95 if (/\{[^}]*\}/) { 96 s/\{[^}]*\}/ /g; 97 goto Struct1; 98 } 99 # multi-line defs 100 if (/\{/) { 101 $_ .= "\n"; 102 $len1 = length; 103 $_ .= $h->getline(); 104 chop if $len1 < length; 105 goto Struct1; 106 } 107 Semi: 108 unless (/;/) { 109 $_ .= "\n"; 110 $len1 = length; 111 $_ .= $h->getline(); 112 chop if $len1 < length; 113 s/\n/ /g; 114 s/[ \t]+/ /g; 115 s/^[ \t]*//; 116 goto Top; 117 } 118 if (/^typedef[^;]*;/) { 119 s/^typedef[^;]*;//g; 120 goto Semi; 121 } 122 if (/^struct[^\(\)]*;/) { 123 s/^struct[^\(\)]*;//g; 124 goto Semi; 125 } 126 # should just have simple decls now; split lines at semicolons 127 s/ *;[ \t]*$//; 128 s/ *;/\n/g; 129 if (/^[ \t]*$/) { 130 next LINE; 131 } 132 s/[ \t]*$//; 133 goto Notfunct unless /\(.*\)/; 134 # Get rid of KRB5_PROTOTYPE 135 s/KRB5_PROTOTYPE//; 136 s/KRB5_STDARG_P//; 137 # here, is probably function decl 138 # strip simple arg list - parens, no parens inside; discard, iterate. 139 # the iteration should deal with function pointer args. 140 $vararg = /\.\.\./; 141 Striparg: 142 if (/ *\([^\(\)]*\)/) { 143 s/ *\([^\(\)]*\)//g; 144 goto Striparg; 145 } 146 # Also strip out attributes, or what's left over of them. 147 if (/__attribute__/) { 148 s/[ \t]*__attribute__[ \t]*//g; 149 goto Striparg; 150 } 151 # replace return type etc with one token indicating calling convention 152 if (/CALLCONV/) { 153 if (/\bKRB5_CALLCONV_WRONG\b/) { 154 s/^.*KRB5_CALLCONV_WRONG *//; 155 die "Invalid function name: '$_'" if (!/^[A-Za-z0-9_]+$/); 156 push @convW, $_; 157 push @vararg, $_ if $vararg; 158 } elsif (/\bKRB5_CALLCONV_C\b/) { 159 s/^.*KRB5_CALLCONV_C *//; 160 die "Invalid function name: '$_'" if (!/^[A-Za-z0-9_]+$/); 161 push @convC, $_; 162 push @vararg, $_ if $vararg; 163 } elsif (/\bKRB5_CALLCONV\b/) { 164 s/^.*KRB5_CALLCONV *//; 165 die "Invalid function name: '$_'" if (!/^[A-Za-z0-9_]+$/); 166 push @convK, $_; 167 push @vararg, $_ if $vararg; 168 } else { 169 die "Unrecognized calling convention while parsing: '$_'\n"; 170 } 171 goto Hadcallc; 172 } 173 # deal with no CALLCONV indicator 174 s/^.* \**(\w+) *$/$1/; 175 die "Invalid function name: '$_'" if (!/^[A-Za-z0-9_]+$/); 176 push @convD, $_; 177 push @vararg, $_ if $vararg; 178 Hadcallc: 179 goto Skipnotf; 180 Notfunct: 181 # probably a variable 182 s/^/VARIABLE_DECL /; 183 Skipnotf: 184 # toss blank lines 185 if (/^[ \t]*$/) { 186 next LINE; 187 } 188} 189 190if ( $verbose ) { 191 print join("\n\t", "Using default calling convention:", sort(@convD)); 192 print join("\n\t", "\nUsing KRB5_CALLCONV:", sort(@convK)); 193 print join("\n\t", "\nUsing KRB5_CALLCONV_C:", sort(@convC)); 194 print join("\n\t", "\nUsing KRB5_CALLCONV_WRONG:", sort(@convW)); 195 print "\n","-"x70,"\n"; 196} 197 198%conv = (); 199map { $conv{$_} = "default"; } @convD; 200map { $conv{$_} = "KRB5_CALLCONV"; } @convK; 201map { $conv{$_} = "KRB5_CALLCONV_C"; } @convC; 202map { $conv{$_} = "KRB5_CALLCONV_WRONG"; } @convW; 203 204my %vararg = (); 205map { $vararg{$_} = 1; } @vararg; 206 207if (!$d) { 208 print "No .DEF file specified\n" if $verbose; 209 exit 0; 210} 211 212LINE2: 213while (! $d->eof()) { 214 $_ = $d->getline(); 215 chop; 216 # 217 if (/^;/) { 218 $printit = 0; 219 next LINE2; 220 } 221 if (/^[ \t]*$/) { 222 $printit = 0; 223 next LINE2; 224 } 225 if (/^EXPORTS/ || /^DESCRIPTION/ || /^HEAPSIZE/) { 226 $printit = 0; 227 next LINE2; 228 } 229 s/[ \t]*//g; 230 s/@[0-9]+//; 231 my($xconv); 232 if (/PRIVATE/ || /INTERNAL/) { 233 $xconv = "PRIVATE"; 234 } elsif (/DATA/) { 235 $xconv = "DATA"; 236 } elsif (/!CALLCONV/ || /KRB5_CALLCONV_WRONG/) { 237 $xconv = "KRB5_CALLCONV_WRONG"; 238 } elsif ($vararg{$_}) { 239 $xconv = "KRB5_CALLCONV_C"; 240 } else { 241 $xconv = "KRB5_CALLCONV"; 242 } 243 s/;.*$//; 244 245 if ($xconv eq "PRIVATE") { 246 print "\t private $_\n" if $verbose; 247 next LINE2; 248 } 249 if ($xconv eq "DATA") { 250 print "\t data $_\n" if $verbose; 251 next LINE2; 252 } 253 if (!defined($conv{$_})) { 254 print "No calling convention specified for $_!\n"; 255 $error = 1; 256 } elsif (! ($conv{$_} eq $xconv)) { 257 print "Function $_ should have calling convention '$xconv', but has '$conv{$_}' instead.\n"; 258 $error = 1; 259 } else { 260# print "Function $_ is okay.\n"; 261 } 262} 263 264#print "Calling conventions defined for: ", keys(%conv); 265exit $error; 266