package Configure;
use strict;
use vars qw(@EXPORT @ISA);
use Carp;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw( CPP
Compile
Link
Execute
FindHeader
FindLib
Apply
ApplyHeaders
ApplyLibs
ApplyHeadersAndLibs
ApplyHeadersAndLibsAndExecute
CheckHeader
CheckStructure
CheckField
CheckHSymbol
CheckSymbol
CheckLSymbol
GetSymbol
GetTextSymbol
GetNumericSymbol
GetConstants);
use Cwd;
use Config;
my ($C_usrinc, $C_libpth, $C_cppstdin, $C_cppflags, $C_cppminus,
$C_ccflags,$C_ldflags,$C_cc,$C_libs) =
@Config{qw( usrinc libpth cppstdin cppflags cppminus
ccflags ldflags cc libs)};
my $Verbose = 0;
=head1 NAME
Configure.pm - provide auto-configuration utilities
=head1 SUMMARY
This perl module provides tools to figure out what is present in the C
compilation environment. This is intended mostly for perl extensions to use
to configure themselves. There are a number of functions, with widely varying
levels of specificity, so here is a summary of what the functions can do:
CheckHeader: Look for headers.
CheckStructure: Look for a structure.
CheckField: Look for a field in a structure.
CheckHSymbol: Look for a symbol in a header.
CheckLSymbol: Look for a symbol in a library.
CheckSymbol: Look for a symbol in a header and library.
GetTextSymbol: Get the contents of a symbol as text.
GetNumericSymbol: Get the contents of a symbol as a number.
Apply: Try compiling code with a set of headers and libs.
ApplyHeaders: Try compiling code with a set of headers.
ApplyLibraries: Try linking code with a set of libraries.
ApplyHeadersAndLibaries: You get the idea.
ApplyHeadersAndLibariesAnExecute: You get the idea.
CPP: Feed some code through the C preproccessor.
Compile: Try to compile some C code.
Link: Try to compile & link some C code.
Execute: Try to compile, link, & execute some C code.
=head1 FUNCTIONS
=cut
=head2 CPP
Takes one or more arguments. The first is a string containing a C program.
Embedded newlines are legal, the text simply being stuffed into a temporary
file. The result is then fed to the C preproccessor (that preproccessor being
previously determined by perl's Configure script.) Any additional arguments
provided are passed to the preprocessing command.
In a scalar context, the return value is either undef, if something went wrong,
or the text returned by the preprocessor. In an array context, two values are
returned: the numeric exit status and the output of the preproccessor.
=cut
sub CPP {
my($code,@options) = @_;
my($options) = join(" ",@options);
my($file) = "tmp$$";
my($in,$out) = ($file.".c",$file.".o");
open(F,">$in");
print F $code;
close(F);
print "Preprocessing |$code|\n" if $Verbose;
my($result) = scalar(`$C_cppstdin $C_cppflags $C_cppminus $options < $in 2>/dev/null`);
print "Executing '$C_cppstdin $C_cppflags $C_cppminus $options < $in 2>/dev/null'\n" if $Verbose;
my($error) = $?;
print "Returned |$result|\n" if $Verbose;
unlink($in,$out);
return ($error ? undef : $result) unless wantarray;
($error,$result);
}
=head2 Compile
Takes one or more arguments. The first is a string containing a C program.
Embedded newlines are legal, the text simply being stuffed into a temporary
file. The result is then fed to the C compiler (that compiler being
previously determined by perl's Configure script.) Any additional arguments
provided are passed to the compiler command.
In a scalar context, either 0 or 1 will be returned, with 1 indicating a
successful compilation. In an array context, three values are returned: the
numeric exit status of the compiler, a string consisting of the output
generated by the compiler, and a numeric value that is false if a ".o" file
wasn't produced by the compiler, error status or no.
=cut
sub Compile { my($code,@options) = @_;
my($options)=join(" ",@options);
my($file) = "tmp$$";
my($in,$out) = ($file.".c",$file.".o");
open(F,">$in");
print F $code;
close(F);
print "Compiling |$code|\n" if $Verbose;
my($result) = scalar(`$C_cc $C_ccflags -c $in $C_ldflags $C_libs $options 2>&1`);
print "Executing '$C_cc $C_ccflags -c $in $C_ldflags $C_libs $options 2>&1'\n" if $Verbose;
my($error) = $?;
my($error2) = ! -e $out;
unlink($in,$out);
return (($error || $error2) ? 0 : 1) unless wantarray;
($error,$result,$error2);
}
=head2 Link
Takes one or more arguments. The first is a string containing a C program.
Embedded newlines are legal, the text simply being stuffed into a temporary
file. The result is then fed to the C compiler and linker (that compiler and
linker being previously determined by perl's Configure script.) Any
additional arguments provided are passed to the compilation/link command.
In a scalar context, either 0 or 1 is returned, with 1 indicating a
successful compilation. In an array context, two values are returned: the
numeric exit status of the compiler/linker, and a string consisting of the
output generated by the compiler/linker.
Note that this command I<only> compiles and links the C code. It does not
attempt to execute it.
=cut
sub Link { my($code,@options) = @_;
my($options) = join(" ",@options);
my($file) = "tmp$$";
my($in,$out) = $file.".c",$file.".o";
open(F,">$in");
print F $code;
close(F);
print "Linking |$code|\n" if $Verbose;
my($result) = scalar(`$C_cc $C_ccflags -o $file $in $C_ldflags $C_libs $options 2>&1`);
print "Executing '$C_cc $C_ccflags -o $file $in $C_ldflags $C_libs $options 2>&1'\n" if $Verbose;
my($error)=$?;
print "Error linking: $error, |$result|\n" if $Verbose;
unlink($in,$out,$file);
return (($error || $result ne "")?0:1) unless wantarray;
($error,$result);
}
=head2 Execute
Takes one or more arguments. The first is a string containing a C program.
Embedded newlines are legal, the text simply being stuffed into a temporary
file. The result is then fed to the C compiler and linker (that compiler and
linker being previously determined by perl's metaconfig script.) and then
executed. Any additional arguments provided are passed to the
compilation/link command. (There is no way to feed arguments to the program
being executed.)
In a scalar context, the return value is either undef, indicating the
compilation or link failed, or that the executed program returned a nonzero
status. Otherwise, the return value is the text output by the program.
In an array context, an array consisting of three values is returned: the
first value is 0 or 1, 1 if the compile/link succeeded. The second value either
the exist status of the compiler or program, and the third is the output text.
=cut
sub Execute {
my($code,@options) = @_;
my($options)=join(" ",@options);
my($file) = "tmp$$";
my($in,$out) = $file.".c",$file.".o";
open(F,">$in");
print F $code;
close(F);
print "Executing |$code|\n" if $Verbose;
my($result) = scalar(`$C_cc $C_ccflags -o $file $in $C_ldflags $C_libs $options 2>&1`);
print "Executing '$C_cc $C_ccflags -o $file $in $C_ldflags $C_libs $options 2>&1'\n" if $Verbose;
my($error) = $?;
unlink($in,$out);
if(!$error) {
my($result2) = scalar(`./$file`);
$error = $?;
unlink($file);
return ($error?undef:$result2) unless wantarray;
print "Executed successfully, status $error, link $result, exec |$result2|\n" if $Verbose;
(1,$error,$result2);
} else {
print "Link failed, status $error, message |$result|\n" if $Verbose;
return undef unless wantarray;
(0,$error,$result);
}
}
=head2 FindHeader
Takes an unlimited number of arguments, consisting of both header names in
the form "header.h", or directory specifications such as "-I/usr/include/bsd".
For each supplied header, FindHeader will attempt to find the complete path.
The return value is an array consisting of all the headers that were located.
=cut
sub FindHeader { my(@headers) = grep(!/^-I/,@_);
my(@I) = grep(/^-I/,@_);
my($h);
for $h (@headers) {
print "Searching for $h... " if $Verbose;
if($h eq "") {$h=undef; next}
if( -f $h) {next}
if( -f $Config{"usrinc"}."/".$h) {
$h = $Config{"usrinc"}."/".$h;
print "Found as $h.\n" if $Verbose;
} else {
my $text;
if($text = CPP("#include <$h>",join(" ",@I))) {
grepcpp:
for (split(/\s+/,(grep(/^\s* if(/$h/) {
s/^\"(.*)\"$/$1/;
s/^\'(.*)\'$/$1/;
$h = $_;
print "Found as $h.\n" if $Verbose;
last grepcpp;
}
}
} else {
$h = undef; print "Not found.\n" if $Verbose;
}
}
}
grep($_,@headers);
}
=head2 FindLib
Takes an unlimited number of arguments, consisting of both library names in
the form "-llibname", "/usr/lib/libxyz.a" or "dld", or directory
specifications such as "-L/usr/lib/foo". For each supplied library, FindLib
will attempt to find the complete path. The return value is an array
consisting of the full paths to all of the libraries that were located.
=cut
sub FindLib { my(@libs) = grep(!/^-L/,@_);
my(@L) = (grep(/^-L/,@_),split(" ",$Config{"libpth"}));
grep(s/^-L//,@L);
my($l);
my($so) = $Config{"so"};
my($found);
my $lib;
for $lib (@libs) {
print "Searching for $lib... " if $Verbose;
$found=0;
$lib =~ s/^-l//;
if($lib eq "") {$lib=undef; next}
next if -f $lib;
my $path;
for $path (@L) {
my ( $fullname, @fullname );
print "Searching $path for $lib...\n" if $Verbose;
if (@fullname=<${path}/lib${lib}.${so}.[0-9]*>){
$fullname=$fullname[-1]; } elsif (-f ($fullname="$path/lib$lib.$so")){
} elsif (-f ($fullname="$path/lib${lib}_s.a")
&& ($lib .= "_s") ){ } elsif (-f ($fullname="$path/lib$lib.a")){
} elsif (-f ($fullname="$path/Slib$lib.a")){
} else {
warn "$lib not found in $path\n" if $Verbose;
next;
}
warn "'-l$lib' found at $fullname\n" if $Verbose;
$lib = $fullname;
$found=1;
}
if(!$found) {
$lib = undef; print "Not found.\n" if $Verbose;
}
}
grep($_,@libs);
}
=head2
Apply takes a chunk of code, a series of libraries and headers, and attempts
to apply them, in series, to a given perl command. In a scalar context, the
return value of the first set of headers and libraries that produces a
non-zero return value from the command is returned. In an array context, the
header and library set it returned.
This is best explained by some examples:
Apply(\&Compile,"main(){}","sgtty.h","");
In a scalar context either C<undef> or C<1>. In an array context,
this returns C<()> or C<("sgtty.h","")>.
Apply(\&Link,"main(){int i=COLOR_PAIRS;}","curses.h","-lcurses",
"ncurses.h","-lncurses","ncurses/ncurses.h","-lncurses");
In a scalar context, this returns either C<undef>, C<1>. In an array context,
this returns C<("curses.h","-lcurses")>, C<("ncurses.h","-lncurses")>,
C<("ncurses/ncurses.h","-lncurses")>, or C<()>.
If we had instead said
C<Apply(\&Execute,'main(){printf("%d",(int)COLOR_PAIRS)',...)> then in a scalar
context either C<undef> or the value of COLOR_PAIRS would be returned.
Note that you can also supply multiple headers and/or libraries at one time,
like this:
Apply(\&Compile,"main(){fcntl(0,F_GETFD);}","fcntl.h","",
"ioctl.h fcntl.h","","sys/ioctl.h fcntl.h"","");
So if fcntl needs ioctl or sys/ioctl loaded first, this will catch it. In an
array context, C<()>, C<("fcntl.h","")>, C<("ioctl.h fcntl.h","")>, or
C<("sys/ioctl.h fcntl.h","")> could be returned.
You can also use nested arrays to get exactly the same effect. The returned
array will always consist of a string, though, with elements separated by
spaces.
Apply(\&Compile,"main(){fcntl(0,F_GETFD);}",["fcntl.h"],"",
["ioctl.h","fcntl.h"],"",["sys/ioctl.h","fcntl.h"],"");
Note that there are many functions that provide simpler ways of doing these
things, from GetNumericSymbol to get the value of a symbol, to ApplyHeaders
which doesn't ask for libraries.
=cut
sub Apply { my($cmd,$code,@lookup) = @_;
my(@l,@h,$i,$ret);
for ($i=0;$i<@lookup;$i+=2) {
if( ref($lookup[$i]) eq "ARRAY" ) {
@h = @{$lookup[$i]};
} else {
@h = split(/\s+/,$lookup[$i]);
}
if( ref($lookup[$i+1]) eq "ARRAY" ) {
@l = @{$lookup[$i+1]};
} else {
@l = split(/\s+/,$lookup[$i+1]);
}
if($ret=&{$cmd == \&Link && !@l?\&Compile:$cmd}(join("",map($_?"#include <$_>\n":"",grep(!/^-I/,@h))).
$code,grep(/^-I/,@h),@l)) {
print "Ret=|$ret|\n" if $Verbose;
return $ret unless wantarray;
return (join(" ",@h),join(" ",@l));
}
}
return 0 unless wantarray;
();
}
=head2 ApplyHeadersAndLibs
This function takes the same sort of arguments as Apply, it just sends them
directly to Link.
=cut
sub ApplyHeadersAndLibs { my($code,@lookup) = @_;
Apply \&Link,$code,@lookup;
}
=head2 ApplyHeadersAndLibsAndExecute
This function is similar to Apply and ApplyHeadersAndLibs, but it always
uses Execute.
=cut
sub ApplyHeadersAndLibsAndExecute { my($code,@lookup) = @_;
Apply \&Execute,$code,@lookup;
}
=head2 ApplyHeaders
If you are only checking headers, and don't need to look at libs, then
you will probably want to use ApplyHeaders. The return value is the same
in a scalar context, but in an array context the returned array will only
consists of the headers, spread out.
=cut
sub ApplyHeaders {
my($code,@headers) = @_;
return scalar(ApplyHeadersAndLibs $code, map(($_,""),@headers))
unless wantarray;
split(/\s+/,(ApplyHeadersAndLibs $code, map(($_,""),@headers))[0]);
}
=head2 ApplyLibs
If you are only checking libraries, and don't need to look at headers, then
you will probably want to use ApplyLibs. The return value is the same
in a scalar context, but in an array context the returned array will only
consists of the libraries, spread out.
=cut
sub ApplyLibs {
my($code,@libs) = @_;
return scalar(ApplyHeadersAndLibs $code, map(("",$_),@libs))
unless wantarray;
split(/\s+/,(ApplyHeadersAndLibs $code, map(("",$_),@libs))[0]);
}
=head2 CheckHeader
Takes an unlimited number of arguments, consiting of headers in the
Apply style. The first set that is fully accepted
by the compiler is returned.
=cut
sub CheckHeader { ApplyHeaders("main(){}",@_);
}
=head2 CheckStructure
Takes the name of a structure, and an unlimited number of further arguments
consisting of header groups. The first group that defines that structure
properly will be returned. B<undef> will be returned if nothing succeeds.
=cut
sub CheckStructure { my($structname,@headers) = @_;
ApplyHeaders("main(){ struct $structname s;}",@headers);
}
=head2 CheckField
Takes the name of a structure, the name of a field, and an unlimited number
of further arguments consisting of header groups. The first group that
defines a structure that contains the field will be returned. B<undef> will
be returned if nothing succeeds.
=cut
sub CheckField { my($structname,$fieldname,@headers) = @_;
ApplyHeaders("main(){ struct $structname s1; struct $structname s2;
s1.$fieldname = s2.$fieldname; }",@headers);
}
=head2 CheckLSymbol
Takes the name of a symbol, and an unlimited number of further arguments
consisting of library groups. The first group of libraries that defines
that symbol will be returned. B<undef> will be returned if nothing succeeds.
=cut
sub CheckLSymbol { my($symbol,@libs) = @_;
ApplyLibs("main() { void * f = (void *)($symbol); }",@libs);
}
=head2 CheckSymbol
Takes the name of a symbol, and an unlimited number of further arguments
consisting of header and library groups, in the Apply format. The first
group of headers and libraries that defines that symbol will be returned.
B<undef> will be returned if nothing succeeds.
=cut
sub CheckSymbol { my($symbol,@lookup) = @_;
ApplyHeadersAndLibs("main() { void * f = (void *)($symbol); }",@lookup);
}
=head2 CheckHSymbol
Takes the name of a symbol, and an unlimited number of further arguments
consisting of header groups. The first group of headers that defines
that symbol will be returned. B<undef> will be returned if nothing succeeds.
=cut
sub CheckHSymbol { my($symbol,@headers) = @_;
ApplyHeaders("main() { void * f = (void *)($symbol); }",@headers);
}
=head2 CheckHPrototype (unexported)
An experimental routine that takes a name of a function, a nested array
consisting of the prototype, and then the normal header groups. It attempts
to deduce whether the given prototype matches what the header supplies.
Basically, it doesn't work. Or maybe it does. I wouldn't reccomend it,
though.
=cut
sub CheckHPrototype { my($function,$proto,@headers) = @_;
my(@proto) = @{$proto};
ApplyHeaders("main() { extern ".$proto[0]." $function(".
join(",",@proto[1..$}
=head2 GetSymbol
Takes the name of a symbol, a printf command, a cast, and an unlimited
number of further arguments consisting of header and library groups, in the
Apply. The first group of headers and libraries that defines that symbol
will be used to get the contents of the symbol in the format, and return it.
B<undef> will be returned if nothing defines that symbol.
Example:
GetSymbol("__LINE__","ld","long","","");
=cut
sub GetSymbol { my($symbol,$printf,$cast,@lookup) = @_,"","";
scalar(ApplyHeadersAndLibsAndExecute(
"main(){ printf(\"\%$printf\",($cast)($symbol));exit(0);}",@lookup));
}
=head2 GetTextSymbol
Takes the name of a symbol, and an unlimited number of further arguments
consisting of header and library groups, in the ApplyHeadersAndLibs format.
The first group of headers and libraries that defines that symbol will be
used to get the contents of the symbol in text format, and return it.
B<undef> will be returned if nothing defines that symbol.
Note that the symbol I<must> actually be text, either a char* or a constant
string. Otherwise, the results are undefined.
=cut
sub GetTextSymbol { my($symbol,@lookup) = @_,"","";
my($result) = GetSymbol($symbol,"s","char*",@lookup);
$result .= "" if defined($result);
$result;
}
=head2 GetNumericSymbol
Takes the name of a symbol, and an unlimited number of further arguments
consisting of header and library groups, in the ApplyHeadersAndLibs format.
The first group of headers and libraries that defines that symbol will be
used to get the contents of the symbol in numeric format, and return it.
B<undef> will be returned if nothing defines that symbol.
Note that the symbol I<must> actually be numeric, in a format compatible
with a float. Otherwise, the results are undefined.
=cut
sub GetNumericSymbol { my($symbol,@lookup) = @_,"","";
my($result) = GetSymbol($symbol,"f","float",@lookup);
$result += 0 if defined($result);
$result;
}
=head2 GetConstants
Takes a list of header names (possibly including -I directives) and attempts
to grep the specified files for constants, a constant being something #defined
with a name that matches /[A-Z0-9_]+/. Returns the list of names.
=cut
sub GetConstants { my(@headers) = @_;
@headers = FindHeader(@headers);
my %seen;
my(%results);
map($seen{$_}=1,@headers);
while(@headers) {
$_=shift(@headers);
next if !defined($_);
open(SEARCHHEADER,"<$_");
while(<SEARCHHEADER>) {
if(/^\s* $results{$1} = 1;
} elsif(/^\s* my(@include) = FindHeader($1);
@include = grep(!$seen{$_},map(defined($_)?$_:(),@include));
push(@headers,@include);
map($seen{$_}=1,@include);
}
}
close(SEARCHHEADER);
}
keys %results;
}
=head2 DeducePrototype (unexported)
This one is B<really> experimental. The idea is to figure out some basic
characteristics of the compiler, and then attempt to "feel out" the prototype
of a function. Eventually, it may work. It is guaranteed to be very slow,
and it may simply not be capable of working on some systems.
=cut
my $firstdeduce = 1;
sub DeducePrototype {
my (@types, $checkreturn, $checknilargs, $checkniletcargs, $checkreturnnil);
if($firstdeduce) {
$firstdeduce=0;
my $checknumber=!Compile("extern int func(int a,int b);
extern int func(int a,int b,int c);
main(){}");
$checkreturn=!Compile("extern int func(int a,int b);
extern long func(int a,int b);
main(){}");
my $checketc= !Compile("extern int func(int a,int b);
extern long func(int a,...);
main(){}");
my $checknumberetc=!Compile("extern int func(int a,int b);
extern int func(int a,int b,...);
main(){}");
my $checketcnumber=!Compile("extern int func(int a,int b,int c,...);
extern int func(int a,int b,...);
main(){}");
my $checkargtypes=!Compile("extern int func(int a);
extern int func(long a);
main(){}");
my $checkargsnil=!Compile("extern int func();
extern int func(int a,int b,int c);
main(){}");
$checknilargs=!Compile("extern int func(int a,int b,int c);
extern int func();
main(){}");
my $checkargsniletc=!Compile("extern int func(...);
extern int func(int a,int b,int c);
main(){}");
$checkniletcargs=!Compile("extern int func(int a,int b,int c);
extern int func(...);
main(){}");
my $checkconst=!Compile("extern int func(const int * a);
extern int func(int * a);
main(){ }");
my $checksign=!Compile("extern int func(int a);
extern int func(unsigned int a);
main(){ }");
$checkreturnnil=!Compile("extern func(int a);
extern void func(int a);
main(){ }");
@types = sort grep(Compile("main(){$_ a;}"),
"void","int","long int","unsigned int","unsigned long int","long long int",
"long long","unsigned long long",
"unsigned long long int","float","long float",
"double","long double",
"char","unsigned char","short int","unsigned short int");
if(Compile("main(){flurfie a;}")) { @types = (); }
$Verbose=0;
my ( $i, $j );
if($checkargtypes) {
for ($i=0;$i<=$ for ($j=$i+1;$j<=$ next if $j==$i;
if(Compile("extern void func($types[$i]);
extern void func($types[$j]); main(){}")) {
print "Removing type $types[$j] because it equals $types[$i]\n";
splice(@types,$j,1);
$j--;
}
}
}
} elsif($checkreturn) {
for ($i=0;$i<=$ for ($j=$i+1;$j<=$ next if $j==$i;
if(Compile("$types[$i] func(void);
extern $types[$j] func(void); main(){}")) {
print "Removing type $types[$j] because it equals $types[$i]\n";
splice(@types,$j,1);
$j--;
}
}
}
}
$Verbose=1;
print "Detect differing numbers of arguments: $checknumber\n";
print "Detect differing return types: $checkreturn\n";
print "Detect differing argument types if one is ...: $checketc\n";
print "Detect differing numbers of arguments if ... is involved: $checknumberetc\n";
print "Detect differing numbers of arguments if ... is involved #2: $checketcnumber\n";
print "Detect differing argument types: $checkargtypes\n";
print "Detect differing argument types if first has no defined args: $checkargsnil\n";
print "Detect differing argument types if second has no defined args: $checknilargs\n";
print "Detect differing argument types if first has only ...: $checkargsniletc\n";
print "Detect differing argument types if second has only ...: $checkniletcargs\n";
print "Detect differing argument types by constness: $checkconst\n";
print "Detect differing argument types by signedness: $checksign\n";
print "Detect differing return types if one is not defined: $checkreturnnil\n";
print "Types known: ",join(",",@types),"\n";
}
my($function,@headers) = @_;
@headers = CheckHSymbol($function,@headers);
return undef if !@headers;
my $rettype = undef;
my @args = ();
my @validcount = ();
if($checkreturn and (!$checknilargs or !$checkniletcargs)) {
for (@types) {
if(ApplyHeaders("extern $_ $function(". ($checknilargs?"...":"").");main(){}",[@headers])) {
$rettype = $_; last;
}
}
}
if(!defined($rettype) and $checkreturnnil) {
die "No way to deduce function prototype in a rational amount of time";
}
my $numargs=-1;
my $varargs=0;
for (0..32) {
if(ApplyHeaders("main(){ $function(".join(",",("0") x $_).");}",@headers)) {
$numargs=$_;
if(ApplyHeaders("main(){ $function(".join(",",("0") x ($_+1)).");}",@headers)) {
$varargs=1;
}
last
}
}
die "Unable to deduce number of arguments" if $numargs==-1;
if($varargs) { $args[$numargs]="..."; }
if(@args>0 and !defined($rettype)) {
for (@types) {
if(defined(ApplyHeaders("extern $_ $function(".join(",",@args).");main(){}",[@headers]))) {
$rettype = $_; last;
}
}
}
print "Return type: $rettype\nArguments: ",join(",",@args),"\n";
print "Valid number of arguments: $numargs\n";
print "Accepts variable number of args: $varargs\n";
}