#!/usr/athena/bin/perl -w
# Code initially generated by s2p
# Code modified to use strict and IO::File
eval 'exec /usr/athena/bin/perl -S $0 ${1+"$@"}'
if 0; # line above evaluated when running under some shell (i.e., not perl)
use strict;
use IO::File;
my $verbose = 0;
my $error = 0;
if ( $ARGV[0] eq "-v" ) { $verbose = 1; shift @ARGV; }
my $h_filename = shift @ARGV || die "usage: $0 [-v] header-file [def-file]\n";
my $d_filename = shift @ARGV;
my $h = open_always($h_filename);
my $d = open_always($d_filename) if $d_filename;
sub open_always
{
my $file = shift || die;
my $handle = new IO::File "<$file";
die "Could not open $file\n" if !$handle;
return $handle;
}
my @convW = ();
my @convC = ();
my @convK = ();
my @convD = ();
my @vararg = ();
my $len1;
my %conv;
my $printit;
my $vararg;
LINE:
while (! $h->eof()) {
$_ = $h->getline();
chop;
# get calling convention info for function decls
# what about function pointer typedefs?
# need to verify unhandled syntax actually triggers a report, not ignored
# blank lines
if (/^[ \t]*$/) {
next LINE;
}
Top:
# drop KRB5INT_BEGIN_DECLS and KRB5INT_END_DECLS
if (/^ *(KRB5INT|GSSAPI[A-Z]*)_(BEGIN|END)_DECLS/) {
next LINE;
}
# drop preprocessor directives
if (/^ *#/) {
while (/\\$/) { $_ .= $h->getline(); }
next LINE;
}
if (/^ *\?==/) {
next LINE;
}
s/#.*$//;
if (/^\} *$/) {
next LINE;
}
# strip comments
Cloop1:
if (/\/\*./) {
s;/\*[^*]*;/*;;
s;/\*\*([^/]);/*$1;;
s;/\*\*$;/*;;
s;/\*\*/; ;g;
goto Cloop1;
}
# multi-line comments?
if (/\/\*$/) {
$_ .= " ";
$len1 = length;
$_ .= $h->getline();
chop if $len1 < length;
goto Cloop1 if /\/\*./;
}
# blank lines
if (/^[ \t]*$/) {
next LINE;
}
if (/^ *extern "C" \{/) {
next LINE;
}
s/KRB5_ATTR_DEPRECATED//;
# elide struct definitions
Struct1:
if (/\{[^}]*\}/) {
s/\{[^}]*\}/ /g;
goto Struct1;
}
# multi-line defs
if (/\{/) {
$_ .= "\n";
$len1 = length;
$_ .= $h->getline();
chop if $len1 < length;
goto Struct1;
}
Semi:
unless (/;/) {
$_ .= "\n";
$len1 = length;
$_ .= $h->getline();
chop if $len1 < length;
s/\n/ /g;
s/[ \t]+/ /g;
s/^[ \t]*//;
goto Top;
}
if (/^typedef[^;]*;/) {
s/^typedef[^;]*;//g;
goto Semi;
}
if (/^struct[^\(\)]*;/) {
s/^struct[^\(\)]*;//g;
goto Semi;
}
# should just have simple decls now; split lines at semicolons
s/ *;[ \t]*$//;
s/ *;/\n/g;
if (/^[ \t]*$/) {
next LINE;
}
s/[ \t]*$//;
goto Notfunct unless /\(.*\)/;
# Get rid of KRB5_PROTOTYPE
s/KRB5_PROTOTYPE//;
s/KRB5_STDARG_P//;
# here, is probably function decl
# strip simple arg list - parens, no parens inside; discard, iterate.
# the iteration should deal with function pointer args.
$vararg = /\.\.\./;
Striparg:
if (/ *\([^\(\)]*\)/) {
s/ *\([^\(\)]*\)//g;
goto Striparg;
}
# Also strip out attributes, or what's left over of them.
if (/__attribute__/) {
s/[ \t]*__attribute__[ \t]*//g;
goto Striparg;
}
# replace return type etc with one token indicating calling convention
if (/CALLCONV/) {
if (/\bKRB5_CALLCONV_WRONG\b/) {
s/^.*KRB5_CALLCONV_WRONG *//;
die "Invalid function name: '$_'" if (!/^[A-Za-z0-9_]+$/);
push @convW, $_;
push @vararg, $_ if $vararg;
} elsif (/\bKRB5_CALLCONV_C\b/) {
s/^.*KRB5_CALLCONV_C *//;
die "Invalid function name: '$_'" if (!/^[A-Za-z0-9_]+$/);
push @convC, $_;
push @vararg, $_ if $vararg;
} elsif (/\bKRB5_CALLCONV\b/) {
s/^.*KRB5_CALLCONV *//;
die "Invalid function name: '$_'" if (!/^[A-Za-z0-9_]+$/);
push @convK, $_;
push @vararg, $_ if $vararg;
} else {
die "Unrecognized calling convention while parsing: '$_'\n";
}
goto Hadcallc;
}
# deal with no CALLCONV indicator
s/^.* \**(\w+) *$/$1/;
die "Invalid function name: '$_'" if (!/^[A-Za-z0-9_]+$/);
push @convD, $_;
push @vararg, $_ if $vararg;
Hadcallc:
goto Skipnotf;
Notfunct:
# probably a variable
s/^/VARIABLE_DECL /;
Skipnotf:
# toss blank lines
if (/^[ \t]*$/) {
next LINE;
}
}
if ( $verbose ) {
print join("\n\t", "Using default calling convention:", sort(@convD));
print join("\n\t", "\nUsing KRB5_CALLCONV:", sort(@convK));
print join("\n\t", "\nUsing KRB5_CALLCONV_C:", sort(@convC));
print join("\n\t", "\nUsing KRB5_CALLCONV_WRONG:", sort(@convW));
print "\n","-"x70,"\n";
}
%conv = ();
map { $conv{$_} = "default"; } @convD;
map { $conv{$_} = "KRB5_CALLCONV"; } @convK;
map { $conv{$_} = "KRB5_CALLCONV_C"; } @convC;
map { $conv{$_} = "KRB5_CALLCONV_WRONG"; } @convW;
my %vararg = ();
map { $vararg{$_} = 1; } @vararg;
if (!$d) {
print "No .DEF file specified\n" if $verbose;
exit 0;
}
LINE2:
while (! $d->eof()) {
$_ = $d->getline();
chop;
#
if (/^;/) {
$printit = 0;
next LINE2;
}
if (/^[ \t]*$/) {
$printit = 0;
next LINE2;
}
if (/^EXPORTS/ || /^DESCRIPTION/ || /^HEAPSIZE/) {
$printit = 0;
next LINE2;
}
s/[ \t]*//g;
s/@[0-9]+//;
my($xconv);
if (/PRIVATE/ || /INTERNAL/) {
$xconv = "PRIVATE";
} elsif (/DATA/) {
$xconv = "DATA";
} elsif (/!CALLCONV/ || /KRB5_CALLCONV_WRONG/) {
$xconv = "KRB5_CALLCONV_WRONG";
} elsif ($vararg{$_}) {
$xconv = "KRB5_CALLCONV_C";
} else {
$xconv = "KRB5_CALLCONV";
}
s/;.*$//;
if ($xconv eq "PRIVATE") {
print "\t private $_\n" if $verbose;
next LINE2;
}
if ($xconv eq "DATA") {
print "\t data $_\n" if $verbose;
next LINE2;
}
if (!defined($conv{$_})) {
print "No calling convention specified for $_!\n";
$error = 1;
} elsif (! ($conv{$_} eq $xconv)) {
print "Function $_ should have calling convention '$xconv', but has '$conv{$_}' instead.\n";
$error = 1;
} else {
# print "Function $_ is okay.\n";
}
}
#print "Calling conventions defined for: ", keys(%conv);
exit $error;