utils/h2ph.PL

   1 #!/usr/local/bin/perl
   2
   3 use Config;
   4 use File::Basename qw(basename dirname);
   5
   6 # List explicitly here the variables you want Configure to
   7 # generate.  Metaconfig only looks for shell variables, so you
   8 # have to mention them as if they were shell variables, not
   9 # %Config entries.  Thus you write
  10 #  $startperl
  11 # to ensure Configure will look for $Config{startperl}.
  12 # Wanted:  $archlibexp
  13
  14 # This forces PL files to create target in same directory as PL file.
  15 # This is so that make depend always knows where to find PL derivatives.
  16 chdir dirname($0);
  17 $file = basename($0, '.PL');
  18 $file .= '.com' if $^O eq 'VMS';
  19
  20 open OUT,">$file" or die "Can't create $file: $!";
  21
  22 print "Extracting $file (with variable substitutions)\n";
  23
  24 # In this section, perl variables will be expanded during extraction.
  25 # You can use $Config{...} to use Configure variables.
  26
  27 print OUT <<"!GROK!THIS!";
  28 $Config{startperl}
  29     eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
  30         if \$running_under_some_shell;
  31 !GROK!THIS!
  32
  33 # In the following, perl variables are not expanded during extraction.
  34
  35 print OUT <<'!NO!SUBS!';
  36
  37 use Config;
  38 use File::Path qw(mkpath);
  39 use Getopt::Std;
  40
  41 getopts('Dd:rlh');
  42
  43 my $Exit = 0;
  44
  45 my $Dest_dir = $opt_d || $Config{installsitearch};
  46 die "Destination directory $Dest_dir doesn't exist or isn't a directory\n"
  47     unless -d $Dest_dir;
  48
  49 @isatype = split(' ',<<END);
  50         char    uchar   u_char
  51         short   ushort  u_short
  52         int     uint    u_int
  53         long    ulong   u_long
  54         FILE    key_t   caddr_t
  55 END
  56
  57 @isatype{@isatype} = (1) x @isatype;
  58 $inif = 0;
  59
  60 @ARGV = ('-') unless @ARGV;
  61
  62 while (defined ($file = next_file())) {
  63     if (-l $file and -d $file) {
  64         link_if_possible($file) if ($opt_l);
  65         next;
  66     }
  67
  68     # Recover from header files with unbalanced cpp directives
  69     $t = '';
  70     $tab = 0;
  71
  72     # $eval_index goes into ``#line'' directives, to help locate syntax errors:
  73     $eval_index = 1;
  74
  75     if ($file eq '-') {
  76         open(IN, "-");
  77         open(OUT, ">-");
  78     } else {
  79         ($outfile = $file) =~ s/\.h$/.ph/ || next;
  80         print "$file -> $outfile\n";
  81         if ($file =~ m|^(.*)/|) {
  82             $dir = $1;
  83             mkpath "$Dest_dir/$dir";
  84         }
  85         open(IN,"$file") || (($Exit = 1),(warn "Can't open $file: $!\n"),next);
  86         open(OUT,">$Dest_dir/$outfile") || die "Can't create $outfile: $!\n";
  87     }
  88     while (<IN>) {
  89         chop;
  90         while (/\\$/) {
  91             chop;
  92             $_ .= <IN>;
  93             chop;
  94         }
  95         print OUT "# $_\n" if $opt_D;
  96         if (s:/\*:\200:g) {
  97             s:\*/:\201:g;
  98             s/\200[^\201]*\201//g;      # delete single line comments
  99             if (s/\200.*//) {           # begin multi-line comment?
 100                 $_ .= '/*';
 101                 $_ .= <IN>;
 102                 redo;
 103             }
 104         }
 105         if (s/^\s*#\s*//) {
 106             if (s/^define\s+(\w+)//) {
 107                 $name = $1;
 108                 $new = '';
 109                 s/\s+$//;
 110                 if (s/^\(([\w,\s]*)\)//) {
 111                     $args = $1;
 112                     my $proto = '() ';
 113                     if ($args ne '') {
 114                         $proto = '';
 115                         foreach $arg (split(/,\s*/,$args)) {
 116                             $arg =~ s/^\s*([^\s].*[^\s])\s*$/$1/;
 117                             $curargs{$arg} = 1;
 118                         }
 119                         $args =~ s/\b(\w)/\$$1/g;
 120                         $args = "local($args) = \@_;\n$t    ";
 121                     }
 122                     s/^\s+//;
 123                     expr();
 124                     $new =~ s/(["\\])/\\$1/g;       #"]);
 125                     $new = reindent($new);
 126                     $args = reindent($args);
 127                     if ($t ne '') {
 128                         $new =~ s/(['\\])/\\$1/g;   #']);
 129                         if ($opt_h) {
 130                             print OUT $t,
 131                             "eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name $proto\{\n$t    ${args}eval q($new);\n$t}' unless defined(\&$name);\n";
 132                             $eval_index++;
 133                         } else {
 134                             print OUT $t,
 135                             "eval 'sub $name $proto\{\n$t    ${args}eval q($new);\n$t}' unless defined(\&$name);\n";
 136                         }
 137                     } else {
 138                       print OUT "unless(defined(\&$name)) {\n    sub $name $proto\{\n\t${args}eval q($new);\n    }\n}\n";
 139                     }
 140                     %curargs = ();
 141                 } else {
 142                     s/^\s+//;
 143                     expr();
 144                     $new = 1 if $new eq '';
 145                     $new = reindent($new);
 146                     $args = reindent($args);
 147                     if ($t ne '') {
 148                         $new =~ s/(['\\])/\\$1/g;        #']);
 149                         if ($opt_h) {
 150                             print OUT $t,"eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name () {",$new,";}' unless defined(\&$name);\n";
 151                             $eval_index++;
 152                         } else {
 153                             print OUT $t,"eval 'sub $name () {",$new,";}' unless defined(\&$name);\n";
 154                         }
 155                     } else {
 156                       print OUT $t,"unless(defined(\&$name)) {\n    sub $name () {\t",$new,";}\n}\n";
 157                     }
 158                 }
 159             } elsif (/^(include|import)\s*[<"](.*)[>"]/) {
 160                 ($incl = $2) =~ s/\.h$/.ph/;
 161                 print OUT $t,"require '$incl';\n";
 162             } elsif(/^include_next\s*[<"](.*)[>"]/) {
 163                 ($incl = $1) =~ s/\.h$/.ph/;
 164                 # should've read up on #include_next properly before attempting
 165                 # to implement it...
 166                 #
 167                 #print OUT $t, "{\n";
 168                 #$tab += 4;
 169                 #$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
 170                 #print OUT $t, "my(\$INC) = shift(\@INC);\n";
 171                 #print OUT $t, "require '$incl';\n";
 172                 #print OUT $t, "unshift(\@INC, \$INC);}\n";
 173                 #$tab -= 4;
 174                 #$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
 175                 #print OUT $t, "}\n";
 176                 #
 177                 # try this instead:
 178                 print OUT ($t, "my(\$i) = 0;\n");
 179                 print OUT ($t, "if(exists(\$INC{$incl})) {\n");
 180                 $tab += 4;
 181                 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
 182                 print OUT ($t, "++\$i while (\$i <= \$#INC",
 183                            " and \$INC[\$i].'/$incl' ne \$INC{'$incl'});\n");
 184                 print OUT ($t, "\$i = 0 if \$INC[\$i].'/$incl' ne",
 185                            " \$INC{'$incl'};\n");
 186                 $tab -= 4;
 187                 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
 188                 print OUT ($t, "}\n");
 189                 print OUT ($t,
 190                            "eval(\"require '\" . ",
 191                            "(\$i ? \$INC[\$i].'/' : '') . \"\$incl';\");");
 192                 # any better? require is smart enough not to try and include a
 193                 # file twice, i believe, so require-ing the same actual file
 194                 # should end up just being a null operation...
 195             } elsif (/^ifdef\s+(\w+)/) {
 196                 print OUT $t,"if(defined(&$1)) {\n";
 197                 $tab += 4;
 198                 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
 199             } elsif (/^ifndef\s+(\w+)/) {
 200                 print OUT $t,"unless(defined(&$1)) {\n";
 201                 $tab += 4;
 202                 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
 203             } elsif (s/^if\s+//) {
 204                 $new = '';
 205                 $inif = 1;
 206                 expr();
 207                 $inif = 0;
 208                 print OUT $t,"if($new) {\n";
 209                 $tab += 4;
 210                 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
 211             } elsif (s/^elif\s+//) {
 212                 $new = '';
 213                 $inif = 1;
 214                 expr();
 215                 $inif = 0;
 216                 $tab -= 4;
 217                 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
 218                 print OUT $t,"}\n elsif($new) {\n";
 219                 $tab += 4;
 220                 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
 221             } elsif (/^else/) {
 222                 $tab -= 4;
 223                 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
 224                 print OUT $t,"} else {\n";
 225                 $tab += 4;
 226                 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
 227             } elsif (/^endif/) {
 228                 $tab -= 4;
 229                 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
 230                 print OUT $t,"}\n";
 231             } elsif(/^undef\s+(\w+)/) {
 232                 print OUT $t, "undef(&$1) if defined(&$1);\n";
 233             } elsif(/^error\s+(.*)/) {
 234                 print OUT $t, "die(\"$1\");\n";
 235             } elsif(/^warning\s+(.*)/) {
 236                 print OUT $t, "warn(\"$1\");\n";
 237             } elsif(/^ident\s+(.*)/) {
 238                 print OUT $t, "# $1\n";
 239             }
 240         }
 241     }
 242     print OUT "1;\n";
 243 }
 244
 245 exit $Exit;
 246
 247 sub reindent($) {
 248     my($text) = shift;
 249     $text =~ s/\n/\n    /g;
 250     $text =~ s/        /\t/g;
 251     $text;
 252 }
 253
 254 sub expr {
 255     if(keys(%curargs)) {
 256         my($joined_args) = join('|', keys(%curargs));
 257     }
 258     while ($_ ne '') {
 259         s/^\&\&// && do { $new .= " &&"; next;}; # handle && operator
 260         s/^\&([\(a-z\)]+)/$1/i; # hack for things that take the address of
 261         s/^(\s+)//              && do {$new .= ' '; next;};
 262         s/^(0X[0-9A-F]+)[UL]*//i        && do {$new .= lc($1); next;};
 263         s/^(-?\d+\.\d+E[-+]\d+)F?//i    && do {$new .= $1; next;};
 264         s/^(\d+)\s*[LU]*//i     && do {$new .= $1; next;};
 265         s/^("(\\"|[^"])*")//    && do {$new .= $1; next;};
 266         s/^'((\\"|[^"])*)'//    && do {
 267             if ($curargs{$1}) {
 268                 $new .= "ord('\$$1')";
 269             } else {
 270                 $new .= "ord('$1')";
 271             }
 272             next;
 273         };
 274         # replace "sizeof(foo)" with "{foo}"
 275         # also, remove * (C dereference operator) to avoid perl syntax
 276         # problems.  Where the %sizeof array comes from is anyone's
 277         # guess (c2ph?), but this at least avoids fatal syntax errors.
 278         # Behavior is undefined if sizeof() delimiters are unbalanced.
 279         # This code was modified to able to handle constructs like this:
 280         #   sizeof(*(p)), which appear in the HP-UX 10.01 header files.
 281         s/^sizeof\s*\(// && do {
 282             $new .= '$sizeof';
 283             my $lvl = 1;  # already saw one open paren
 284             # tack { on the front, and skip it in the loop
 285             $_ = "{" . "$_";
 286             my $index = 1;
 287             # find balanced closing paren
 288             while ($index <= length($_) && $lvl > 0) {
 289                 $lvl++ if substr($_, $index, 1) eq "(";
 290                 $lvl-- if substr($_, $index, 1) eq ")";
 291                 $index++;
 292             }
 293             # tack } on the end, replacing )
 294             substr($_, $index - 1, 1) = "}";
 295             # remove pesky * operators within the sizeof argument
 296             substr($_, 0, $index - 1) =~ s/\*//g;
 297             next;
 298         };
 299         # Eliminate typedefs
 300         /\(([\w\s]+)[\*\s]*\)\s*[\w\(]/ && do {
 301             foreach (split /\s+/, $1) {  # Make sure all the words are types,
 302                 last unless ($isatype{$_} or $_ eq 'struct');
 303             }
 304             s/\([\w\s]+[\*\s]*\)// && next;      # then eliminate them.
 305         };
 306         # struct/union member, including arrays:
 307         s/^([_A-Z]\w*(\[[^\]]+\])?((\.|->)[_A-Z]\w*(\[[^\]]+\])?)+)//i && do {
 308             $id = $1;
 309             $id =~ s/(\.|(->))([^\.\-]*)/->\{$3\}/g;
 310             $id =~ s/\b([^\$])($joined_args)/$1\$$2/g if length($joined_args);
 311             while($id =~ /\[\s*([^\$\&\d\]]+)\]/) {
 312                 my($index) = $1;
 313                 $index =~ s/\s//g;
 314                 if(exists($curargs{$index})) {
 315                     $index = "\$$index";
 316                 } else {
 317                     $index = "&$index";
 318                 }
 319                 $id =~ s/\[\s*([^\$\&\d\]]+)\]/[$index]/;
 320             }
 321             $new .= " (\$$id)";
 322         };
 323         s/^([_a-zA-Z]\w*)//     && do {
 324             $id = $1;
 325             if ($id eq 'struct') {
 326                 s/^\s+(\w+)//;
 327                 $id .= ' ' . $1;
 328                 $isatype{$id} = 1;
 329             } elsif ($id =~ /^((un)?signed)|(long)|(short)$/) {
 330                 while (s/^\s+(\w+)//) { $id .= ' ' . $1; }
 331                 $isatype{$id} = 1;
 332             }
 333             if ($curargs{$id}) {
 334                 $new .= "\$$id";
 335                 $new .= '->' if /^[\[\{]/;
 336             } elsif ($id eq 'defined') {
 337                 $new .= 'defined';
 338             } elsif (/^\(/) {
 339                 s/^\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/i;     # cheat
 340                 $new .= " &$id";
 341             } elsif ($isatype{$id}) {
 342                 if ($new =~ /{\s*$/) {
 343                     $new .= "'$id'";
 344                 } elsif ($new =~ /\(\s*$/ && /^[\s*]*\)/) {
 345                     $new =~ s/\(\s*$//;
 346                     s/^[\s*]*\)//;
 347                 } else {
 348                     $new .= q(').$id.q(');
 349                 }
 350             } else {
 351                 if ($inif && $new !~ /defined\s*\($/) {
 352                     $new .= '(defined(&' . $id . ') ? &' . $id . ' : 0)';
 353                 } elsif (/^\[/) {
 354                     $new .= " \$$id";
 355                 } else {
 356                     $new .= ' &' . $id;
 357                 }
 358             }
 359             next;
 360         };
 361         s/^(.)// && do { if ($1 ne '#') { $new .= $1; } next;};
 362     }
 363 }
 364
 365
 366 # Handle recursive subdirectories without getting a grotesquely big stack.
 367 # Could this be implemented using File::Find?
 368 sub next_file
 369 {
 370     my $file;
 371
 372     while (@ARGV) {
 373         $file = shift @ARGV;
 374
 375         if ($file eq '-' or -f $file or -l $file) {
 376             return $file;
 377         } elsif (-d $file) {
 378             if ($opt_r) {
 379                 expand_glob($file);
 380             } else {
 381                 print STDERR "Skipping directory `$file'\n";
 382             }
 383         } else {
 384             print STDERR "Skipping `$file':  not a file or directory\n";
 385         }
 386     }
 387
 388     return undef;
 389 }
 390
 391
 392 # Put all the files in $directory into @ARGV for processing.
 393 sub expand_glob
 394 {
 395     my ($directory)  = @_;
 396
 397     $directory =~ s:/$::;
 398
 399     opendir DIR, $directory;
 400         foreach (readdir DIR) {
 401             next if ($_ eq '.' or $_ eq '..');
 402
 403             # expand_glob() is going to be called until $ARGV[0] isn't a
 404             # directory; so push directories, and unshift everything else.
 405             if (-d "$directory/$_") {
 406                 push    @ARGV, "$directory/$_";
 407             } else {
 408                 unshift @ARGV, "$directory/$_";
 409             }
 410         }
 411     closedir DIR;
 412 }
 413
 414
 415 # Given $file, a symbolic link to a directory in the C include directory,
 416 # make an equivalent symbolic link in $Dest_dir, if we can figure out how.
 417 # Otherwise, just duplicate the file or directory.
 418 sub link_if_possible
 419 {
 420     my ($dirlink)  = @_;
 421     my $target  = eval 'readlink($dirlink)';
 422
 423     if ($target =~ m:^\.\./: or $target =~ m:^/:) {
 424         # The target of a parent or absolute link could leave the $Dest_dir
 425         # hierarchy, so let's put all of the contents of $dirlink (actually,
 426         # the contents of $target) into @ARGV; as a side effect down the
 427         # line, $dirlink will get created as an _actual_ directory.
 428         expand_glob($dirlink);
 429     } else {
 430         if (-l "$Dest_dir/$dirlink") {
 431             unlink "$Dest_dir/$dirlink" or
 432                 print STDERR "Could not remove link $Dest_dir/$dirlink:  $!\n";
 433         }
 434         if (eval 'symlink($target, "$Dest_dir/$dirlink")') {
 435             print "Linking $target -> $Dest_dir/$dirlink\n";
 436
 437             # Make sure that the link _links_ to something:
 438             if (! -e "$Dest_dir/$target") {
 439                 mkdir("$Dest_dir/$target", 0755) or
 440                     print STDERR "Could not create $Dest_dir/$target/\n";
 441             }
 442         } else {
 443             print STDERR "Could not symlink $target -> $Dest_dir/$dirlink:  $!\n";
 444         }
 445     }
 446 }
 447
 448
 449 1;
 450
 451 ##############################################################################
 452 __END__
 453
 454 =head1 NAME
 455
 456 h2ph - convert .h C header files to .ph Perl header files
 457
 458 =head1 SYNOPSIS
 459
 460 B<h2ph [-d destination directory] [-r] [-l] [headerfiles]>
 461
 462 =head1 DESCRIPTION
 463
 464 I<h2ph>
 465 converts any C header files specified to the corresponding Perl header file
 466 format.
 467 It is most easily run while in /usr/include:
 468
 469         cd /usr/include; h2ph * sys/*
 470
 471 or
 472
 473         cd /usr/include; h2ph -r -l .
 474
 475 The output files are placed in the hierarchy rooted at Perl's
 476 architecture dependent library directory.  You can specify a different
 477 hierarchy with a B<-d> switch.
 478
 479 If run with no arguments, filters standard input to standard output.
 480
 481 =head1 OPTIONS
 482
 483 =over 4
 484
 485 =item -d destination_dir
 486
 487 Put the resulting B<.ph> files beneath B<destination_dir>, instead of
 488 beneath the default Perl library location (C<$Config{'installsitsearch'}>).
 489
 490 =item -r
 491
 492 Run recursively; if any of B<headerfiles> are directories, then run I<h2ph>
 493 on all files in those directories (and their subdirectories, etc.).
 494
 495 =item -l
 496
 497 Symbolic links will be replicated in the destination directory.  If B<-l>
 498 is not specified, then links are skipped over.
 499
 500 =item -h
 501
 502 Put ``hints'' in the .ph files which will help in locating problems with
 503 I<h2ph>.  In those cases when you B<require> a B<.ph> file containing syntax
 504 errors, instead of the cryptic
 505
 506         [ some error condition ] at (eval mmm) line nnn
 507
 508 you will see the slightly more helpful
 509
 510         [ some error condition ] at filename.ph line nnn
 511
 512 However, the B<.ph> files almost double in size when built using B<-h>.
 513
 514 =back
 515
 516 =head1 ENVIRONMENT
 517
 518 No environment variables are used.
 519
 520 =head1 FILES
 521
 522  /usr/include/*.h
 523  /usr/include/sys/*.h
 524
 525 etc.
 526
 527 =head1 AUTHOR
 528
 529 Larry Wall
 530
 531 =head1 SEE ALSO
 532
 533 perl(1)
 534
 535 =head1 DIAGNOSTICS
 536
 537 The usual warnings if it can't read or write the files involved.
 538
 539 =head1 BUGS
 540
 541 Doesn't construct the %sizeof array for you.
 542
 543 It doesn't handle all C constructs, but it does attempt to isolate
 544 definitions inside evals so that you can get at the definitions
 545 that it can translate.
 546
 547 It's only intended as a rough tool.
 548 You may need to dicker with the files produced.
 549
 550 =cut
 551
 552 !NO!SUBS!
 553
 554 close OUT or die "Can't close $file: $!";
 555 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
 556 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';