Upgrade to Devel::PPPort 3.06_01
[p5sagit/p5-mst-13.2.git] / utils / h2ph.PL
index c6cd99a..e46ac20 100644 (file)
@@ -58,13 +58,14 @@ 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;
@@ -141,11 +142,12 @@ while (defined (my $file = next_file())) {
                            $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 '') {
@@ -274,6 +276,8 @@ while (defined (my $file = next_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;
            }
@@ -286,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) {
@@ -300,20 +305,26 @@ while (defined (my $file = next_file())) {
                               "unless defined(\&$enum_name);\n");
                }
            }
-       } elsif (/^(?:__extension__\s+)?extern\s+__inline(?:__)?\s+/) { # { for vi
+       } 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.
+           # 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*;/;
+               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|__inline(?:__)?)\b//g;
+           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 {
@@ -330,30 +341,39 @@ while (defined (my $file = next_file())) {
            }
            $args = (
                @args
-               ? "local(" . (join ',', map "\$$_", @args) . ") = \@_;\n$t    "
+               ? "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['
+                 (?:(?:un)?signed\s+)?
+                 (?:long\s+)?
+                 (?:$typelist)\s+
+                 (\w+)
+                 (?{ push @local_variables, $1 })
+                 ']
+                [my \$$1]gx;
+               $new =~ 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;       #"]);
-           $new = reindent($new);
-           $args = reindent($args);
-           if ($t ne '') {
-               $new =~ s/(['\\])/\\$1/g;   #']);
-               if ($opt_h) {
-                   print OUT $t,
-                   "eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name $proto\{\n$t    ${args}eval q($new);\n$t}' unless defined(\&$name);\n";
-                   $eval_index++;
-               } else {
-                   print OUT $t,
-                   "eval 'sub $name $proto\{\n$t    ${args}eval q($new);\n$t}' unless defined(\&$name);\n";
-               }
-           } else {
-               print OUT "unless(defined(\&$name)) {\n    sub $name $proto\{\n\t${args}eval q($new);\n    }\n}\n";
-           }
-           %curargs = ();
+           # now that's almost like a macro (we hope)
+           goto EMIT;
        }
     }
     $Is_converted{$file} = 1;
@@ -374,6 +394,7 @@ if ($opt_e && (scalar(keys %bad_file) > 0)) {
 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));
@@ -382,7 +403,7 @@ 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 
+       s/^0X([0-9A-F]+)[UL]*//i
            && do {my $hex = $1;
                   $hex =~ s/^0+//;
                   if (length $hex > 8 && !$Config{use64bitint}) {
@@ -518,7 +539,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;                        # | ??!|  ||
@@ -531,17 +552,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 / && # Inlined assembler.
                $^O eq 'linux' && $file =~ m!(?:^|/)asm/[^/]+\.h$!) {
-               while (<IN>) {
-                   last if /^}/; 
+               while (<IN>) {
+                   last if /^}/;
                }
+               $in = "";
                next READ;
            }
             if ($in =~ s/\\$//) {                           # \-newline
@@ -711,9 +734,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});
 }