X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/dccff43d435d574843d33f7c32cc7d8d1a628596..ddfca5da10590b8934c0a4e6b1f77a03901648cf:/utils/h2ph.PL

diff --git a/utils/h2ph.PL b/utils/h2ph.PL
index e99df44..5fe2e9f 100644
--- a/utils/h2ph.PL
+++ b/utils/h2ph.PL
@@ -42,8 +42,13 @@ use Config;
 use File::Path qw(mkpath);
 use Getopt::Std;
 
-getopts('Dd:rlhaQ');
-use vars qw($opt_D $opt_d $opt_r $opt_l $opt_h $opt_a $opt_Q);
+# Make sure read permissions for all are set:
+if (defined umask && (umask() & 0444)) {
+    umask (umask() & ~0444);
+}
+
+getopts('Dd:rlhaQe');
+use vars qw($opt_D $opt_d $opt_r $opt_l $opt_h $opt_a $opt_Q $opt_e);
 die "-r and -a options are mutually exclusive\n" if ($opt_r and $opt_a);
 my @inc_dirs = inc_dirs() if $opt_a;
 
@@ -53,25 +58,34 @@ 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;
 
-my @isatype = split(' ',<<END);
+my @isatype = qw(
 	char	uchar	u_char
 	short	ushort	u_short
 	int	uint	u_int
 	long	ulong	u_long
 	FILE	key_t	caddr_t
-END
+	float	double	size_t
+);
 
 my %isatype;
 @isatype{@isatype} = (1) x @isatype;
 my $inif = 0;
 my %Is_converted;
+my %bad_file = ();
 
 @ARGV = ('-') unless @ARGV;
 
 build_preamble_if_necessary();
 
+sub reindent($) {
+    my($text) = shift;
+    $text =~ s/\n/\n    /g;
+    $text =~ s/        /\t/g;
+    $text;
+}
+
 my ($t, $tab, %curargs, $new, $eval_index, $dir, $name, $args, $outfile);
-my ($incl, $next);
+my ($incl, $incl_type, $next);
 while (defined (my $file = next_file())) {
     if (-l $file and -d $file) {
         link_if_possible($file) if ($opt_l);
@@ -107,7 +121,9 @@ while (defined (my $file = next_file())) {
 	open(OUT,">$Dest_dir/$outfile") || die "Can't create $outfile: $!\n";
     }
 
-    print OUT "require '_h2ph_pre.ph';\n\n";
+    print OUT
+        "require '_h2ph_pre.ph';\n\n",
+        "no warnings 'redefine';\n\n";
 
     while (defined (local $_ = next_line($file))) {
 	if (s/^\s*\#\s*//) {
@@ -115,21 +131,23 @@ while (defined (my $file = next_file())) {
 		$name = $1;
 		$new = '';
 		s/\s+$//;
+		s/\(\w+\s*\(\*\)\s*\(\w*\)\)\s*(-?\d+)/$1/; # (int (*)(foo_t))0
 		if (s/^\(([\w,\s]*)\)//) {
 		    $args = $1;
-    	    	    my $proto = '() ';
+		    my $proto = '() ';
 		    if ($args ne '') {
-    	    	    	$proto = '';
+			$proto = '';
 			foreach my $arg (split(/,\s*/,$args)) {
 			    $arg =~ s/^\s*([^\s].*[^\s])\s*$/$1/;
 			    $curargs{$arg} = 1;
 			}
 			$args =~ s/\b(\w)/\$$1/g;
-			$args = "local($args) = \@_;\n$t    ";
+			$args = "my($args) = \@_;\n$t    ";
 		    }
 		    s/^\s+//;
 		    expr();
 		    $new =~ s/(["\\])/\\$1/g;       #"]);
+		  EMIT:
 		    $new = reindent($new);
 		    $args = reindent($args);
 		    if ($t ne '') {
@@ -168,22 +186,31 @@ while (defined (my $file = next_file())) {
                       print OUT $t,"unless(defined(\&$name)) {\n    sub $name () {\t",$new,";}\n}\n";
 		    }
 		}
-	    } elsif (/^(include|import)\s*[<"](.*)[>"]/) {
-		($incl = $2) =~ s/\.h$/.ph/;
-		print OUT $t,"require '$incl';\n";
-	    } elsif(/^include_next\s*[<"](.*)[>"]/) {
-		($incl = $1) =~ s/\.h$/.ph/;
+	    } elsif (/^(include|import|include_next)\s*[<\"](.*)[>\"]/) {
+                $incl_type = $1;
+                $incl = $2;
+                if (($incl_type eq 'include_next') ||
+                    ($opt_e && exists($bad_file{$incl}))) {
+                    $incl =~ s/\.h$/.ph/;
 		print OUT ($t,
 			   "eval {\n");
                 $tab += 4;
                 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
+                    print OUT ($t, "my(\@REM);\n");
+                    if ($incl_type eq 'include_next') {
 		print OUT ($t,
 			   "my(\%INCD) = map { \$INC{\$_} => 1 } ",
-			   "(grep { \$_ eq \"$incl\" } keys(\%INC));\n");
+			           "(grep { \$_ eq \"$incl\" } ",
+                                   "keys(\%INC));\n");
 		print OUT ($t,
-			   "my(\@REM) = map { \"\$_/$incl\" } ",
+			           "\@REM = map { \"\$_/$incl\" } ",
 			   "(grep { not exists(\$INCD{\"\$_/$incl\"})",
-			   "and -f \"\$_/$incl\" } \@INC);\n");
+			           " and -f \"\$_/$incl\" } \@INC);\n");
+                    } else {
+                        print OUT ($t,
+                                   "\@REM = map { \"\$_/$incl\" } ",
+                                   "(grep {-r \"\$_/$incl\" } \@INC);\n");
+                    }
 		print OUT ($t,
 			   "require \"\$REM[0]\" if \@REM;\n");
                 $tab -= 4;
@@ -192,6 +219,10 @@ while (defined (my $file = next_file())) {
 			   "};\n");
 		print OUT ($t,
 			   "warn(\$\@) if \$\@;\n");
+                } else {
+                    $incl =~ s/\.h$/.ph/;
+		    print OUT $t,"require '$incl';\n";
+                }
 	    } elsif (/^ifdef\s+(\w+)/) {
 		print OUT $t,"if(defined(&$1)) {\n";
 		$tab += 4;
@@ -239,12 +270,14 @@ while (defined (my $file = next_file())) {
 	    } elsif(/^ident\s+(.*)/) {
 		print OUT $t, "# $1\n";
 	    }
-	} elsif(/^\s*(typedef\s*)?enum\s*(\s+[a-zA-Z_]\w*\s*)?/) {
+	} elsif (/^\s*(typedef\s*)?enum\s*(\s+[a-zA-Z_]\w*\s*)?/) { # { for vi
 	    until(/\{[^}]*\}.*;/ || /;/) {
 		last unless defined ($next = next_line($file));
 		chomp $next;
 		# drop "#define FOO FOO" in enums
 		$next =~ s/^\s*#\s*define\s+(\w+)\s+\1\s*$//;
+		# #defines in enums (aliases)
+		$next =~ s/^\s*#\s*define\s+(\w+)\s+(\w+)\s*$/$1 = $2,/;
 		$_ .= $next;
 		print OUT "# $next\n" if $opt_D;
 	    }
@@ -257,6 +290,7 @@ while (defined (my $file = next_file())) {
 	    my $enum_val = -1;
 	    foreach my $enum (@enum_subs) {
 		my ($enum_name, $enum_value) = $enum =~ /^([a-zA-Z_]\w*)(=.+)?$/;
+		$enum_name or next;
 		$enum_value =~ s/^=//;
 		$enum_val = (length($enum_value) ? $enum_value : $enum_val + 1);
 		if ($opt_h) {
@@ -271,26 +305,98 @@ while (defined (my $file = next_file())) {
 			       "unless defined(\&$enum_name);\n");
 		}
 	    }
+	} elsif (/^(?:__extension__\s+)?(?:extern|static)\s+(?:__)?inline(?:__)?\s+/
+	    and !/;\s*$/ and !/{\s*}\s*$/)
+	{ # { for vi
+	    # This is a hack to parse the inline functions in the glibc headers.
+	    # Warning: massive kludge ahead. We suppose inline functions
+	    # are mainly constructed like macros.
+	    while (1) {
+		last unless defined ($next = next_line($file));
+		chomp $next;
+		undef $_, last if $next =~ /__THROW\s*;/
+			       or $next =~ /^(__extension__|extern|static)\b/;
+		$_ .= " $next";
+		print OUT "# $next\n" if $opt_D;
+		last if $next =~ /^}|^{.*}\s*$/;
+	    }
+	    next if not defined; # because it's only a prototype
+	    s/\b(__extension__|extern|static|(?:__)?inline(?:__)?)\b//g;
+	    # violently drop #ifdefs
+	    s/#\s*if.*?#\s*endif//g
+		and print OUT "# some #ifdef were dropped here -- fill in the blanks\n";
+	    if (s/^(?:\w|\s|\*)*\s(\w+)\s*//) {
+		$name = $1;
+	    } else {
+		warn "name not found"; next; # shouldn't occur...
+	    }
+	    my @args;
+	    if (s/^\(([^()]*)\)\s*(\w+\s*)*//) {
+		for my $arg (split /,/, $1) {
+		    if ($arg =~ /(\w+)\s*$/) {
+			$curargs{$1} = 1;
+			push @args, $1;
+		    }
+		}
+	    }
+	    $args = (
+		@args
+		? "my(" . (join ',', map "\$$_", @args) . ") = \@_;\n$t    "
+		: ""
+	    );
+	    my $proto = @args ? '' : '() ';
+	    $new = '';
+	    s/\breturn\b//g; # "return" doesn't occur in macros usually...
+	    expr();
+	    # try to find and perlify local C variables
+	    our @local_variables = (); # needs to be a our(): (?{...}) bug workaround
+	    {
+		use re "eval";
+		my $typelist = join '|', keys %isatype;
+		$new =~ s['
+		  (?:(?:__)?const(?:__)?\s+)?
+		  (?:(?:un)?signed\s+)?
+		  (?:long\s+)?
+		  (?:$typelist)\s+
+		  (\w+)
+		  (?{ push @local_variables, $1 })
+		  ']
+		 [my \$$1]gx;
+		$new =~ s['
+		  (?:(?:__)?const(?:__)?\s+)?
+		  (?:(?:un)?signed\s+)?
+		  (?:long\s+)?
+		  (?:$typelist)\s+
+		  ' \s+ &(\w+) \s* ;
+		  (?{ push @local_variables, $1 })
+		  ]
+		 [my \$$1;]gx;
+	     }
+	    $new =~ s/&$_\b/\$$_/g for @local_variables;
+	    $new =~ s/(["\\])/\\$1/g;       #"]);
+	    # now that's almost like a macro (we hope)
+	    goto EMIT;
 	}
     }
-    print OUT "1;\n";
-
     $Is_converted{$file} = 1;
-    queue_includes_from($file) if ($opt_a);
+    if ($opt_e && exists($bad_file{$file})) {
+        unlink($Dest_dir . '/' . $outfile);
+        $next = '';
+    } else {
+        print OUT "1;\n";
+	queue_includes_from($file) if $opt_a;
+    }
 }
 
-exit $Exit;
-
-
-sub reindent($) {
-    my($text) = shift;
-    $text =~ s/\n/\n    /g;
-    $text =~ s/        /\t/g;
-    $text;
+if ($opt_e && (scalar(keys %bad_file) > 0)) {
+    warn "Was unable to convert the following files:\n";
+    warn "\t" . join("\n\t",sort(keys %bad_file)) . "\n";
 }
 
+exit $Exit;
 
 sub expr {
+    $new = '"(assembly code)"' and return if /\b__asm__\b/; # freak out.
     my $joined_args;
     if(keys(%curargs)) {
 	$joined_args = join('|', keys(%curargs));
@@ -299,7 +405,20 @@ sub expr {
 	s/^\&\&// && do { $new .= " &&"; next;}; # handle && operator
 	s/^\&([\(a-z\)]+)/$1/i;	# hack for things that take the address of
 	s/^(\s+)//		&& do {$new .= ' '; next;};
-	s/^(0X[0-9A-F]+)[UL]*//i		&& do {$new .= lc($1); next;};
+	s/^0X([0-9A-F]+)[UL]*//i
+	    && do {my $hex = $1;
+		   $hex =~ s/^0+//;
+		   if (length $hex > 8 && !$Config{use64bitint}) {
+		       # Croak if nv_preserves_uv_bits < 64 ?
+		       $new .=         hex(substr($hex, -8)) +
+			       2**32 * hex(substr($hex,  0, -8));
+		       # The above will produce "errorneus" code
+		       # if the hex constant was e.g. inside UINT64_C
+		       # macro, but then again, h2ph is an approximation.
+		   } else {
+		       $new .= lc("0x$hex");
+		   }
+		   next;};
 	s/^(-?\d+\.\d+E[-+]?\d+)[FL]?//i	&& do {$new .= $1; next;};
 	s/^(\d+)\s*[LU]*//i	&& do {$new .= $1; next;};
 	s/^("(\\"|[^"])*")//	&& do {$new .= $1; next;};
@@ -338,10 +457,16 @@ sub expr {
         };
 	# Eliminate typedefs
 	/\(([\w\s]+)[\*\s]*\)\s*[\w\(]/ && do {
+	    my $doit = 1;
 	    foreach (split /\s+/, $1) {  # Make sure all the words are types,
-		last unless ($isatype{$_} or $_ eq 'struct' or $_ eq 'union');
+	        unless($isatype{$_} or $_ eq 'struct' or $_ eq 'union'){
+		    $doit = 0;
+		    last;
+		}
+	    }
+	    if( $doit ){
+		s/\([\w\s]+[\*\s]*\)// && next;      # then eliminate them.
 	    }
-	    s/\([\w\s]+[\*\s]*\)// && next;      # then eliminate them.
 	};
 	# struct/union member, including arrays:
 	s/^([_A-Z]\w*(\[[^\]]+\])?((\.|->)[_A-Z]\w*(\[[^\]]+\])?)+)//i && do {
@@ -416,7 +541,7 @@ sub next_line
 
         while (length $in) {
             if ($pre_sub_tri_graphs) {
-                # Preprocess all tri-graphs 
+                # Preprocess all tri-graphs
                 # including things stuck in quoted string constants.
                 $in =~ s/\?\?=/#/g;                         # | ??=|  #|
                 $in =~ s/\?\?\!/|/g;                        # | ??!|  ||
@@ -429,17 +554,19 @@ sub next_line
                 $in =~ s/\?\?>/}/g;                         # | ??>|  }|
             }
 	    if ($in =~ /^\#ifdef __LANGUAGE_PASCAL__/) {
-                # Tru64 disassembler.h evilness: mixed C and Pascal.
+		# Tru64 disassembler.h evilness: mixed C and Pascal.
 		while (<IN>) {
-		    last if /^\#endif/; 
+		    last if /^\#endif/;
 		}
+		$in = "";
 		next READ;
 	    }
-	    if ($in =~ /^extern inline / &&
+	    if ($in =~ /^extern inline / && # Inlined assembler.
 		$^O eq 'linux' && $file =~ m!(?:^|/)asm/[^/]+\.h$!) {
- 		while (<IN>) {
-		    last if /^}/; 
+		while (<IN>) {
+		    last if /^}/;
 		}
+		$in = "";
 		next READ;
 	    }
             if ($in =~ s/\\$//) {                           # \-newline
@@ -449,10 +576,18 @@ sub next_line
                 $out    .= $1;
             } elsif ($in =~ s/^(\\.)//) {                   # \...
                 $out    .= $1;
-            } elsif ($in =~ s/^('(\\.|[^'\\])*')//) {       # '...
-                $out    .= $1;
-            } elsif ($in =~ s/^("(\\.|[^"\\])*")//) {       # "...
-                $out    .= $1;
+            } elsif ($in =~ /^'/) {                         # '...
+                if ($in =~ s/^('(\\.|[^'\\])*')//) {
+                    $out    .= $1;
+                } else {
+                    next READ;
+                }
+            } elsif ($in =~ /^"/) {                         # "...
+                if ($in =~ s/^("(\\.|[^"\\])*")//) {
+                    $out    .= $1;
+                } else {
+                    next READ;
+                }
             } elsif ($in =~ s/^\/\/.*//) {                  # //...
                 # fall through
             } elsif ($in =~ m/^\/\*/) {                     # /*...
@@ -466,8 +601,20 @@ sub next_line
                 $out    .= $1;
             } elsif ($in =~ s/^([^\'\"\\\/]+)//) {
                 $out    .= $1;
+            } elsif ($^O eq 'linux' &&
+                     $file =~ m!(?:^|/)linux/byteorder/pdp_endian\.h$! &&
+                     $in   =~ s!\'T KNOW!!) {
+                $out    =~ s!I DON$!I_DO_NOT_KNOW!;
             } else {
+                if ($opt_e) {
+                    warn "Cannot parse $file:\n$in\n";
+                    $bad_file{$file} = 1;
+                    $in = '';
+                    $out = undef;
+                    last READ;
+                } else {
 		die "Cannot parse:\n$in\n";
+                }
             }
         }
 
@@ -589,9 +736,15 @@ sub queue_includes_from
 # non-GCC?) C compilers, but gcc uses an additional include directory.
 sub inc_dirs
 {
-    my $from_gcc    = `$Config{cc} -v 2>&1`;
-    $from_gcc       =~ s:^Reading specs from (.*?)/specs\b.*:$1/include:s;
-
+    my $from_gcc    = `LC_ALL=C $Config{cc} -v 2>&1`;
+    if( !( $from_gcc =~ s:^Reading specs from (.*?)/specs\b.*:$1/include:s ) )
+    { # gcc-4+ :
+       $from_gcc   = `LC_ALL=C $Config{cc} -print-search-dirs 2>&1`;
+       if ( !($from_gcc =~ s/^install:\s*([^\s]+[^\s\/])([\s\/]*).*$/$1\/include/s) )
+       {
+           $from_gcc = '';
+       };
+    };
     length($from_gcc) ? ($from_gcc, $Config{usrinc}) : ($Config{usrinc});
 }
 
@@ -619,25 +772,33 @@ sub build_preamble_if_necessary
     my (%define) = _extract_cc_defines();
 
     open  PREAMBLE, ">$preamble" or die "Cannot open $preamble:  $!";
-        print PREAMBLE "# This file was created by h2ph version $VERSION\n";
-
-        foreach (sort keys %define) {
-            if ($opt_D) {
-                print PREAMBLE "# $_=$define{$_}\n";
-            }
+	print PREAMBLE "# This file was created by h2ph version $VERSION\n";
 
-            if ($define{$_} =~ /^(\d+)U?L{0,2}$/i) {
-                print PREAMBLE
-                    "unless (defined &$_) { sub $_() { $1 } }\n\n";
-            } elsif ($define{$_} =~ /^\w+$/) {
-                print PREAMBLE
-                    "unless (defined &$_) { sub $_() { &$define{$_} } }\n\n";
-            } else {
-                print PREAMBLE
-                    "unless (defined &$_) { sub $_() { \"",
-                    quotemeta($define{$_}), "\" } }\n\n";
-            }
-        }
+	foreach (sort keys %define) {
+	    if ($opt_D) {
+		print PREAMBLE "# $_=$define{$_}\n";
+	    }
+	    if ($define{$_} =~ /^\((.*)\)$/) {
+		# parenthesized value:  d=(v)
+		$define{$_} = $1;
+	    }
+	    if ($define{$_} =~ /^([+-]?(\d+)?\.\d+([eE][+-]?\d+)?)[FL]?$/) {
+		# float:
+		print PREAMBLE
+		    "unless (defined &$_) { sub $_() { $1 } }\n\n";
+	    } elsif ($define{$_} =~ /^([+-]?\d+)U?L{0,2}$/i) {
+		# integer:
+		print PREAMBLE
+		    "unless (defined &$_) { sub $_() { $1 } }\n\n";
+	    } elsif ($define{$_} =~ /^\w+$/) {
+		print PREAMBLE
+		    "unless (defined &$_) { sub $_() { &$define{$_} } }\n\n";
+	    } else {
+		print PREAMBLE
+		    "unless (defined &$_) { sub $_() { \"",
+		    quotemeta($define{$_}), "\" } }\n\n";
+	    }
+	}
     close PREAMBLE               or die "Cannot close $preamble:  $!";
 }
 
@@ -649,15 +810,14 @@ sub _extract_cc_defines
 {
     my %define;
     my $allsymbols  = join " ",
-        @Config{'ccsymbols', 'cppsymbols', 'cppccsymbols'};
+	@Config{'ccsymbols', 'cppsymbols', 'cppccsymbols'};
 
     # Split compiler pre-definitions into `key=value' pairs:
-    foreach (split /\s+/, $allsymbols) {
-        /(.+?)=(.+)/ and $define{$1} = $2;
-
-        if ($opt_D) {
-            print STDERR "$_:  $1 -> $2\n";
-        }
+    while ($allsymbols =~ /([^\s]+)=((\\\s|[^\s])+)/g) {
+	$define{$1} = $2;
+	if ($opt_D) {
+	    print STDERR "$_:  $1 -> $2\n";
+	}
     }
 
     return %define;
@@ -792,10 +952,10 @@ installation.
 Doesn't handle complicated expressions built piecemeal, a la:
 
     enum {
-        FIRST_VALUE,
-        SECOND_VALUE,
+	FIRST_VALUE,
+	SECOND_VALUE,
     #ifdef ABC
-        THIRD_VALUE
+	THIRD_VALUE
     #endif
     };