--- /dev/null
+#!./perl
+
+# Check for presence and correctness of .ph files; for now,
+# just socket.ph and pals.
+# -- Kurt Starsinic <kstar@isinet.com>
+
+use lib '../lib';
+
+
+# All the constants which Socket.pm tries to make available:
+my @possibly_defined = qw(
+ INADDR_ANY INADDR_LOOPBACK INADDR_NONE AF_802 AF_APPLETALK AF_CCITT
+ AF_CHAOS AF_DATAKIT AF_DECnet AF_DLI AF_ECMA AF_GOSIP AF_HYLINK AF_IMPLINK
+ AF_INET AF_LAT AF_MAX AF_NBS AF_NIT AF_NS AF_OSI AF_OSINET AF_PUP
+ AF_SNA AF_UNIX AF_UNSPEC AF_X25 MSG_DONTROUTE MSG_MAXIOVLEN MSG_OOB
+ MSG_PEEK PF_802 PF_APPLETALK PF_CCITT PF_CHAOS PF_DATAKIT PF_DECnet PF_DLI
+ PF_ECMA PF_GOSIP PF_HYLINK PF_IMPLINK PF_INET PF_LAT PF_MAX PF_NBS PF_NIT
+ PF_NS PF_OSI PF_OSINET PF_PUP PF_SNA PF_UNIX PF_UNSPEC PF_X25 SOCK_DGRAM
+ SOCK_RAW SOCK_RDM SOCK_SEQPACKET SOCK_STREAM SOL_SOCKET SOMAXCONN
+ SO_ACCEPTCONN SO_BROADCAST SO_DEBUG SO_DONTLINGER SO_DONTROUTE SO_ERROR
+ SO_KEEPALIVE SO_LINGER SO_OOBINLINE SO_RCVBUF SO_RCVLOWAT SO_RCVTIMEO
+ SO_REUSEADDR SO_SNDBUF SO_SNDLOWAT SO_SNDTIMEO SO_TYPE SO_USELOOPBACK
+);
+
+
+# The libraries which I'm going to require:
+my @libs = qw(Socket "sys/types.ph" "sys/socket.ph" "netinet/in.ph");
+
+
+# These are defined by Socket.pm even if the C header files don't define them:
+my %ok_to_miss = (
+ INADDR_NONE => 1,
+ INADDR_LOOPBACK => 1,
+);
+
+
+my $total_tests = scalar @libs + scalar @possibly_defined;
+my $i = 0;
+
+print "1..$total_tests\n";
+
+
+foreach (@libs) {
+ $i++;
+
+ if (eval "require $_" ) {
+ print "ok $i\n";
+ } else {
+ print "# Skipping tests; $_ may be missing\n";
+ foreach ($i .. $total_tests) { print "ok $_\n" }
+ exit;
+ }
+}
+
+
+foreach (@possibly_defined) {
+ $i++;
+
+ $pm_val = eval "Socket::$_()";
+ $ph_val = eval "main::$_()";
+
+ if (defined $pm_val and !defined $ph_val) {
+ if ($ok_to_miss{$_}) { print "ok $i\n" }
+ else { print "not ok $i\n" }
+ next;
+ } elsif (defined $ph_val and !defined $pm_val) {
+ print "not ok $i\n";
+ next;
+ }
+
+ # Socket.pm converts these to network byte order, so we convert the
+ # socket.ph version to match; note that these cases skip the following
+ # `elsif', which is only applied to _numeric_ values, not literal
+ # bitmasks.
+ if ($_ eq 'INADDR_ANY'
+ or $_ eq 'INADDR_LOOPBACK'
+ or $_ eq 'INADDR_NONE') {
+ $ph_val = pack("N*", $ph_val); # htonl(3) equivalent
+ }
+
+ # Since Socket.pm and socket.ph wave their hands over macros differently,
+ # they could return functionally equivalent bitmaps with different numeric
+ # interpretations (due to sign extension). The only apparent case of this
+ # is SO_DONTLINGER (only on Solaris, and deprecated, at that):
+ elsif ($pm_val != $ph_val) {
+ $pm_val = oct(sprintf "0x%lx", $pm_val);
+ $ph_val = oct(sprintf "0x%lx", $ph_val);
+ }
+
+ if ($pm_val == $ph_val) { print "ok $i\n" }
+ else { print "not ok $i\n" }
+}
+
+
use Config;
use File::Path qw(mkpath);
+use Getopt::Std;
+
+getopts('d:rlh');
+
my $Exit = 0;
-my $Dest_dir = (@ARGV && $ARGV[0] =~ s/^-d//)
- ? shift || shift
- : $Config{installsitearch};
+my $Dest_dir = $opt_d || $Config{installsitearch};
die "Destination directory $Dest_dir doesn't exist or isn't a directory\n"
unless -d $Dest_dir;
@ARGV = ('-') unless @ARGV;
-foreach $file (@ARGV) {
+while (defined ($file = next_file())) {
+ if (-l $file and -d $file) {
+ link_if_possible($file) if ($opt_l);
+ next;
+ }
+
# Recover from header files with unbalanced cpp directives
$t = '';
$tab = 0;
+ # $eval_index goes into ``#line'' directives, to help locate syntax errors:
+ $eval_index = 1;
+
if ($file eq '-') {
open(IN, "-");
open(OUT, ">-");
$new =~ s/(["\\])/\\$1/g;
if ($t ne '') {
$new =~ s/(['\\])/\\$1/g;
- print OUT $t,
- "eval 'sub $name $proto\{\n$t ${args}eval \"$new\";\n$t}' unless defined(\&$name);\n";
+ if ($opt_h) {
+ print OUT $t,
+ "eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name $proto\{\n$t ${args}eval \"$new\";\n$t}' unless defined(\&$name);\n";
+ $eval_index++;
+ } else {
+ print OUT $t,
+ "eval 'sub $name $proto\{\n$t ${args}eval \"$new\";\n$t}' unless defined(\&$name);\n";
+ }
}
else {
print OUT "unless defined(\&$name) {\nsub $name $proto\{\n ${args}eval \"$new\";\n}\n}\n";
$new = 1 if $new eq '';
if ($t ne '') {
$new =~ s/(['\\])/\\$1/g;
- print OUT $t,"eval 'sub $name () {",$new,";}' unless defined(\&$name);\n";
+ if ($opt_h) {
+ print OUT $t,"eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name () {",$new,";}' unless defined(\&$name);\n";
+ $eval_index++;
+ } else {
+ print OUT $t,"eval 'sub $name () {",$new,";}' unless defined(\&$name);\n";
+ }
}
else {
print OUT $t,"unless(defined(\&$name)) {\nsub $name () {",$new,";}\n}\n";
sub expr {
while ($_ ne '') {
+ s/^\&\&// && do { $new .= "&&"; next;}; # handle && operator
s/^\&//; # hack for things that take the address of
s/^(\s+)// && do {$new .= ' '; next;};
- s/^(0x[0-9a-fA-F]+)// && do {$new .= $1; next;};
- s/^(\d+)\s*[LlUu]*// && do {$new .= $1; next;};
+ s/^(0X[0-9A-F]+)[UL]*//i && do {$new .= lc($1); next;};
+ s/^(-?\d+\.\d+E[-+]\d+)F?//i && do {$new .= $1; next;};
+ s/^(\d+)\s*[LU]*//i && do {$new .= $1; next;};
s/^("(\\"|[^"])*")// && do {$new .= $1; next;};
s/^'((\\"|[^"])*)'// && do {
if ($curargs{$1}) {
substr($_, 0, $index - 1) =~ s/\*//g;
next;
};
+ # Eliminate typedefs
+ /\(([\w\s]+)[\*\s]*\)\s*[\w\(]/ && do {
+ foreach (split /\s+/, $1) { # Make sure all the words are types,
+ last unless ($isatype{$_} or $_ eq 'struct');
+ }
+ s/\([\w\s]+[\*\s]*\)// && next; # then eliminate them.
+ };
+ # struct/union member:
+ s/^([_A-Z]\w*((\.|->)[_A-Z]\w*)+)//i && do {
+ $id = $1;
+ $id =~ s/(\.|(->))([^\.-]*)/->\{$3\}/g;
+ $new .= ' ($' . $id . ')';
+ };
s/^([_a-zA-Z]\w*)// && do {
$id = $1;
if ($id eq 'struct') {
$id .= ' ' . $1;
$isatype{$id} = 1;
}
- elsif ($id eq 'unsigned' || $id eq 'long') {
- s/^\s+(\w+)//;
- $id .= ' ' . $1;
+ elsif ($id =~ /^((un)?signed)|(long)|(short)$/) {
+ while (s/^\s+(\w+)//) { $id .= ' ' . $1; }
$isatype{$id} = 1;
}
if ($curargs{$id}) {
s/^(.)// && do { if ($1 ne '#') { $new .= $1; } next;};
}
}
+
+
+# Handle recursive subdirectories without getting a grotesquely big stack.
+# Could this be implemented using File::Find?
+sub next_file
+{
+ my $file;
+
+ while (@ARGV) {
+ $file = shift @ARGV;
+
+ if ($file eq '-' or -f $file or -l $file) {
+ return $file;
+ } elsif (-d $file) {
+ if ($opt_r) {
+ expand_glob($file);
+ } else {
+ print STDERR "Skipping directory `$file'\n";
+ }
+ } else {
+ print STDERR "Skipping `$file': not a file or directory\n";
+ }
+ }
+
+ return undef;
+}
+
+
+# Put all the files in $directory into @ARGV for processing.
+sub expand_glob
+{
+ my ($directory) = @_;
+
+ $directory =~ s:/$::;
+
+ opendir DIR, $directory;
+ foreach (readdir DIR) {
+ next if ($_ eq '.' or $_ eq '..');
+
+ # expand_glob() is going to be called until $ARGV[0] isn't a
+ # directory; so push directories, and unshift everything else.
+ if (-d "$directory/$_") { push @ARGV, "$directory/$_" }
+ else { unshift @ARGV, "$directory/$_" }
+ }
+ closedir DIR;
+}
+
+
+# Given $file, a symbolic link to a directory in the C include directory,
+# make an equivalent symbolic link in $Dest_dir, if we can figure out how.
+# Otherwise, just duplicate the file or directory.
+sub link_if_possible
+{
+ my ($dirlink) = @_;
+ my $target = eval 'readlink($dirlink)';
+
+ if ($target =~ m:^\.\./: or $target =~ m:^/:) {
+ # The target of a parent or absolute link could leave the $Dest_dir
+ # hierarchy, so let's put all of the contents of $dirlink (actually,
+ # the contents of $target) into @ARGV; as a side effect down the
+ # line, $dirlink will get created as an _actual_ directory.
+ expand_glob($dirlink);
+ } else {
+ if (-l "$Dest_dir/$dirlink") {
+ unlink "$Dest_dir/$dirlink" or
+ print STDERR "Could not remove link $Dest_dir/$dirlink: $!\n";
+ }
+
+ if (eval 'symlink($target, "$Dest_dir/$dirlink")') {
+ print "Linking $target -> $Dest_dir/$dirlink\n";
+
+ # Make sure that the link _links_ to something:
+ if (! -e "$Dest_dir/$target") {
+ mkdir("$Dest_dir/$target", 0755) or
+ print STDERR "Could not create $Dest_dir/$target/\n";
+ }
+ } else {
+ print STDERR "Could not symlink $target -> $Dest_dir/$dirlink: $!\n";
+ }
+ }
+}
+
+
+1;
+
##############################################################################
__END__
=head1 SYNOPSIS
-B<h2ph [headerfiles]>
+B<h2ph [-d destination directory] [-r] [-l] [headerfiles]>
=head1 DESCRIPTION
cd /usr/include; h2ph * sys/*
+or
+
+ cd /usr/include; h2ph -r -l .
+
The output files are placed in the hierarchy rooted at Perl's
architecture dependent library directory. You can specify a different
hierarchy with a B<-d> switch.
If run with no arguments, filters standard input to standard output.
+=head1 OPTIONS
+
+=over 4
+
+=item -d destination_dir
+
+Put the resulting B<.ph> files beneath B<destination_dir>, instead of
+beneath the default Perl library location (C<$Config{'installsitsearch'}>).
+
+=item -r
+
+Run recursively; if any of B<headerfiles> are directories, then run I<h2ph>
+on all files in those directories (and their subdirectories, etc.).
+
+=item -l
+
+Symbolic links will be replicated in the destination directory. If B<-l>
+is not specified, then links are skipped over.
+
+=item -h
+
+Put ``hints'' in the .ph files which will help in locating problems with
+I<h2ph>. In those cases when you B<require> a B<.ph> file containing syntax
+errors, instead of the cryptic
+
+ [ some error condition ] at (eval mmm) line nnn
+
+you will see the slightly more helpful
+
+ [ some error condition ] at filename.ph line nnn
+
+However, the B<.ph> files almost double in size when built using B<-h>.
+
+=back
+
=head1 ENVIRONMENT
No environment variables are used.
projects / p5sagit/p5-mst-13.2.git / commitdiff