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