src/util/def-check.pl

   1 #!/usr/athena/bin/perl -w
   2
   3 # Code initially generated by s2p
   4 # Code modified to use strict and IO::File
   5
   6 eval 'exec /usr/athena/bin/perl -S $0 ${1+"$@"}'
   7     if 0; # line above evaluated when running under some shell (i.e., not perl)
   8
   9 use strict;
  10 use IO::File;
  11
  12 my $verbose = 0;
  13 my $error = 0;
  14 if ( $ARGV[0] eq "-v" ) { $verbose = 1; shift @ARGV; }
  15 my $h_filename = shift @ARGV || die "usage: $0 [-v] header-file [def-file]\n";
  16 my $d_filename = shift @ARGV;
  17
  18 my $h = open_always($h_filename);
  19 my $d = open_always($d_filename) if $d_filename;
  20
  21 sub 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
  29 my @convW = ();
  30 my @convC = ();
  31 my @convK = ();
  32 my @convD = ();
  33 my @vararg = ();
  34
  35 my $len1;
  36 my %conv;
  37 my $printit;
  38 my $vararg;
  39
  40 LINE:
  41 while (! $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
 190 if ( $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 = ();
 199 map { $conv{$_} = "default"; } @convD;
 200 map { $conv{$_} = "KRB5_CALLCONV"; } @convK;
 201 map { $conv{$_} = "KRB5_CALLCONV_C"; } @convC;
 202 map { $conv{$_} = "KRB5_CALLCONV_WRONG"; } @convW;
 203
 204 my %vararg = ();
 205 map { $vararg{$_} = 1; } @vararg;
 206
 207 if (!$d) {
 208     print "No .DEF file specified\n" if $verbose;
 209     exit 0;
 210 }
 211
 212 LINE2:
 213 while (! $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);
 265 exit $error;