1#!/usr/local/bin/perl 2 3use Config; 4use File::Basename qw(basename dirname); 5use Cwd; 6 7# List explicitly here the variables you want Configure to 8# generate. Metaconfig only looks for shell variables, so you 9# have to mention them as if they were shell variables, not 10# %Config entries. Thus you write 11# $startperl 12# to ensure Configure will look for $Config{startperl}. 13# Wanted: $archlibexp 14 15# This forces PL files to create target in same directory as PL file. 16# This is so that make depend always knows where to find PL derivatives. 17$origdir = cwd; 18chdir dirname($0); 19$file = basename($0, '.PL'); 20$file .= '.com' if $^O eq 'VMS'; 21 22open OUT,">$file" or die "Can't create $file: $!"; 23 24print "Extracting $file (with variable substitutions)\n"; 25 26# In this section, perl variables will be expanded during extraction. 27# You can use $Config{...} to use Configure variables. 28 29print OUT <<"!GROK!THIS!"; 30$Config{startperl} 31 eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' 32 if \$running_under_some_shell; 33!GROK!THIS! 34 35# In the following, perl variables are not expanded during extraction. 36 37print OUT <<'!NO!SUBS!'; 38 39use strict; 40 41use Config; 42use File::Path qw(mkpath); 43use Getopt::Std; 44 45# Make sure read permissions for all are set: 46if (defined umask && (umask() & 0444)) { 47 umask (umask() & ~0444); 48} 49 50getopts('Dd:rlhaQe'); 51use vars qw($opt_D $opt_d $opt_r $opt_l $opt_h $opt_a $opt_Q $opt_e); 52die "-r and -a options are mutually exclusive\n" if ($opt_r and $opt_a); 53my @inc_dirs = inc_dirs() if $opt_a; 54 55my $Exit = 0; 56 57my $Dest_dir = $opt_d || $Config{installsitearch}; 58die "Destination directory $Dest_dir doesn't exist or isn't a directory\n" 59 unless -d $Dest_dir; 60 61my @isatype = split(' ',<<END); 62 char uchar u_char 63 short ushort u_short 64 int uint u_int 65 long ulong u_long 66 FILE key_t caddr_t 67END 68 69my %isatype; 70@isatype{@isatype} = (1) x @isatype; 71my $inif = 0; 72my %Is_converted; 73my %bad_file = (); 74 75@ARGV = ('-') unless @ARGV; 76 77build_preamble_if_necessary(); 78 79sub reindent($) { 80 my($text) = shift; 81 $text =~ s/\n/\n /g; 82 $text =~ s/ /\t/g; 83 $text; 84} 85 86my ($t, $tab, %curargs, $new, $eval_index, $dir, $name, $args, $outfile); 87my ($incl, $incl_type, $next); 88while (defined (my $file = next_file())) { 89 if (-l $file and -d $file) { 90 link_if_possible($file) if ($opt_l); 91 next; 92 } 93 94 # Recover from header files with unbalanced cpp directives 95 $t = ''; 96 $tab = 0; 97 98 # $eval_index goes into ``#line'' directives, to help locate syntax errors: 99 $eval_index = 1; 100 101 if ($file eq '-') { 102 open(IN, "-"); 103 open(OUT, ">-"); 104 } else { 105 ($outfile = $file) =~ s/\.h$/.ph/ || next; 106 print "$file -> $outfile\n" unless $opt_Q; 107 if ($file =~ m|^(.*)/|) { 108 $dir = $1; 109 mkpath "$Dest_dir/$dir"; 110 } 111 112 if ($opt_a) { # automagic mode: locate header file in @inc_dirs 113 foreach (@inc_dirs) { 114 chdir $_; 115 last if -f $file; 116 } 117 } 118 119 open(IN,"$file") || (($Exit = 1),(warn "Can't open $file: $!\n"),next); 120 open(OUT,">$Dest_dir/$outfile") || die "Can't create $outfile: $!\n"; 121 } 122 123 print OUT 124 "require '_h2ph_pre.ph';\n\n", 125 "no warnings 'redefine';\n\n"; 126 127 while (defined (local $_ = next_line($file))) { 128 if (s/^\s*\#\s*//) { 129 if (s/^define\s+(\w+)//) { 130 $name = $1; 131 $new = ''; 132 s/\s+$//; 133 s/\(\w+\s*\(\*\)\s*\(\w*\)\)\s*(-?\d+)/$1/; # (int (*)(foo_t))0 134 if (s/^\(([\w,\s]*)\)//) { 135 $args = $1; 136 my $proto = '() '; 137 if ($args ne '') { 138 $proto = ''; 139 foreach my $arg (split(/,\s*/,$args)) { 140 $arg =~ s/^\s*([^\s].*[^\s])\s*$/$1/; 141 $curargs{$arg} = 1; 142 } 143 $args =~ s/\b(\w)/\$$1/g; 144 $args = "local($args) = \@_;\n$t "; 145 } 146 s/^\s+//; 147 expr(); 148 $new =~ s/(["\\])/\\$1/g; #"]); 149 $new = reindent($new); 150 $args = reindent($args); 151 if ($t ne '') { 152 $new =~ s/(['\\])/\\$1/g; #']); 153 if ($opt_h) { 154 print OUT $t, 155 "eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name $proto\{\n$t ${args}eval q($new);\n$t}' unless defined(\&$name);\n"; 156 $eval_index++; 157 } else { 158 print OUT $t, 159 "eval 'sub $name $proto\{\n$t ${args}eval q($new);\n$t}' unless defined(\&$name);\n"; 160 } 161 } else { 162 print OUT "unless(defined(\&$name)) {\n sub $name $proto\{\n\t${args}eval q($new);\n }\n}\n"; 163 } 164 %curargs = (); 165 } else { 166 s/^\s+//; 167 expr(); 168 $new = 1 if $new eq ''; 169 $new = reindent($new); 170 $args = reindent($args); 171 if ($t ne '') { 172 $new =~ s/(['\\])/\\$1/g; #']); 173 174 if ($opt_h) { 175 print OUT $t,"eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name () {",$new,";}' unless defined(\&$name);\n"; 176 $eval_index++; 177 } else { 178 print OUT $t,"eval 'sub $name () {",$new,";}' unless defined(\&$name);\n"; 179 } 180 } else { 181 # Shunt around such directives as `#define FOO FOO': 182 next if " \&$name" eq $new; 183 184 print OUT $t,"unless(defined(\&$name)) {\n sub $name () {\t",$new,";}\n}\n"; 185 } 186 } 187 } elsif (/^(include|import|include_next)\s*[<\"](.*)[>\"]/) { 188 $incl_type = $1; 189 $incl = $2; 190 if (($incl_type eq 'include_next') || 191 ($opt_e && exists($bad_file{$incl}))) { 192 $incl =~ s/\.h$/.ph/; 193 print OUT ($t, 194 "eval {\n"); 195 $tab += 4; 196 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); 197 print OUT ($t, "my(\@REM);\n"); 198 if ($incl_type eq 'include_next') { 199 print OUT ($t, 200 "my(\%INCD) = map { \$INC{\$_} => 1 } ", 201 "(grep { \$_ eq \"$incl\" } ", 202 "keys(\%INC));\n"); 203 print OUT ($t, 204 "\@REM = map { \"\$_/$incl\" } ", 205 "(grep { not exists(\$INCD{\"\$_/$incl\"})", 206 " and -f \"\$_/$incl\" } \@INC);\n"); 207 } else { 208 print OUT ($t, 209 "\@REM = map { \"\$_/$incl\" } ", 210 "(grep {-r \"\$_/$incl\" } \@INC);\n"); 211 } 212 print OUT ($t, 213 "require \"\$REM[0]\" if \@REM;\n"); 214 $tab -= 4; 215 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); 216 print OUT ($t, 217 "};\n"); 218 print OUT ($t, 219 "warn(\$\@) if \$\@;\n"); 220 } else { 221 $incl =~ s/\.h$/.ph/; 222 print OUT $t,"require '$incl';\n"; 223 } 224 } elsif (/^ifdef\s+(\w+)/) { 225 print OUT $t,"if(defined(&$1)) {\n"; 226 $tab += 4; 227 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); 228 } elsif (/^ifndef\s+(\w+)/) { 229 print OUT $t,"unless(defined(&$1)) {\n"; 230 $tab += 4; 231 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); 232 } elsif (s/^if\s+//) { 233 $new = ''; 234 $inif = 1; 235 expr(); 236 $inif = 0; 237 print OUT $t,"if($new) {\n"; 238 $tab += 4; 239 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); 240 } elsif (s/^elif\s+//) { 241 $new = ''; 242 $inif = 1; 243 expr(); 244 $inif = 0; 245 $tab -= 4; 246 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); 247 print OUT $t,"}\n elsif($new) {\n"; 248 $tab += 4; 249 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); 250 } elsif (/^else/) { 251 $tab -= 4; 252 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); 253 print OUT $t,"} else {\n"; 254 $tab += 4; 255 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); 256 } elsif (/^endif/) { 257 $tab -= 4; 258 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); 259 print OUT $t,"}\n"; 260 } elsif(/^undef\s+(\w+)/) { 261 print OUT $t, "undef(&$1) if defined(&$1);\n"; 262 } elsif(/^error\s+(".*")/) { 263 print OUT $t, "die($1);\n"; 264 } elsif(/^error\s+(.*)/) { 265 print OUT $t, "die(\"", quotemeta($1), "\");\n"; 266 } elsif(/^warning\s+(.*)/) { 267 print OUT $t, "warn(\"", quotemeta($1), "\");\n"; 268 } elsif(/^ident\s+(.*)/) { 269 print OUT $t, "# $1\n"; 270 } 271 } elsif(/^\s*(typedef\s*)?enum\s*(\s+[a-zA-Z_]\w*\s*)?/) { 272 until(/\{[^}]*\}.*;/ || /;/) { 273 last unless defined ($next = next_line($file)); 274 chomp $next; 275 # drop "#define FOO FOO" in enums 276 $next =~ s/^\s*#\s*define\s+(\w+)\s+\1\s*$//; 277 $_ .= $next; 278 print OUT "# $next\n" if $opt_D; 279 } 280 s/#\s*if.*?#\s*endif//g; # drop #ifdefs 281 s@/\*.*?\*/@@g; 282 s/\s+/ /g; 283 next unless /^\s?(typedef\s?)?enum\s?([a-zA-Z_]\w*)?\s?\{(.*)\}\s?([a-zA-Z_]\w*)?\s?;/; 284 (my $enum_subs = $3) =~ s/\s//g; 285 my @enum_subs = split(/,/, $enum_subs); 286 my $enum_val = -1; 287 foreach my $enum (@enum_subs) { 288 my ($enum_name, $enum_value) = $enum =~ /^([a-zA-Z_]\w*)(=.+)?$/; 289 $enum_value =~ s/^=//; 290 $enum_val = (length($enum_value) ? $enum_value : $enum_val + 1); 291 if ($opt_h) { 292 print OUT ($t, 293 "eval(\"\\n#line $eval_index $outfile\\n", 294 "sub $enum_name () \{ $enum_val; \}\") ", 295 "unless defined(\&$enum_name);\n"); 296 ++ $eval_index; 297 } else { 298 print OUT ($t, 299 "eval(\"sub $enum_name () \{ $enum_val; \}\") ", 300 "unless defined(\&$enum_name);\n"); 301 } 302 } 303 } 304 } 305 $Is_converted{$file} = 1; 306 if ($opt_e && exists($bad_file{$file})) { 307 unlink($Dest_dir . '/' . $outfile); 308 $next = ''; 309 } else { 310 print OUT "1;\n"; 311 queue_includes_from($file) if ($opt_a); 312 } 313} 314 315if ($opt_e && (scalar(keys %bad_file) > 0)) { 316 warn "Was unable to convert the following files:\n"; 317 warn "\t" . join("\n\t",sort(keys %bad_file)) . "\n"; 318} 319 320exit $Exit; 321 322sub expr { 323 my $joined_args; 324 if(keys(%curargs)) { 325 $joined_args = join('|', keys(%curargs)); 326 } 327 while ($_ ne '') { 328 s/^\&\&// && do { $new .= " &&"; next;}; # handle && operator 329 s/^\&([\(a-z\)]+)/$1/i; # hack for things that take the address of 330 s/^(\s+)// && do {$new .= ' '; next;}; 331 s/^0X([0-9A-F]+)[UL]*//i 332 && do {my $hex = $1; 333 $hex =~ s/^0+//; 334 if (length $hex > 8 && !$Config{use64bitint}) { 335 # Croak if nv_preserves_uv_bits < 64 ? 336 $new .= hex(substr($hex, -8)) + 337 2**32 * hex(substr($hex, 0, -8)); 338 # The above will produce "errorneus" code 339 # if the hex constant was e.g. inside UINT64_C 340 # macro, but then again, h2ph is an approximation. 341 } else { 342 $new .= lc("0x$hex"); 343 } 344 next;}; 345 s/^(-?\d+\.\d+E[-+]?\d+)[FL]?//i && do {$new .= $1; next;}; 346 s/^(\d+)\s*[LU]*//i && do {$new .= $1; next;}; 347 s/^("(\\"|[^"])*")// && do {$new .= $1; next;}; 348 s/^'((\\"|[^"])*)'// && do { 349 if ($curargs{$1}) { 350 $new .= "ord('\$$1')"; 351 } else { 352 $new .= "ord('$1')"; 353 } 354 next; 355 }; 356 # replace "sizeof(foo)" with "{foo}" 357 # also, remove * (C dereference operator) to avoid perl syntax 358 # problems. Where the %sizeof array comes from is anyone's 359 # guess (c2ph?), but this at least avoids fatal syntax errors. 360 # Behavior is undefined if sizeof() delimiters are unbalanced. 361 # This code was modified to able to handle constructs like this: 362 # sizeof(*(p)), which appear in the HP-UX 10.01 header files. 363 s/^sizeof\s*\(// && do { 364 $new .= '$sizeof'; 365 my $lvl = 1; # already saw one open paren 366 # tack { on the front, and skip it in the loop 367 $_ = "{" . "$_"; 368 my $index = 1; 369 # find balanced closing paren 370 while ($index <= length($_) && $lvl > 0) { 371 $lvl++ if substr($_, $index, 1) eq "("; 372 $lvl-- if substr($_, $index, 1) eq ")"; 373 $index++; 374 } 375 # tack } on the end, replacing ) 376 substr($_, $index - 1, 1) = "}"; 377 # remove pesky * operators within the sizeof argument 378 substr($_, 0, $index - 1) =~ s/\*//g; 379 next; 380 }; 381 # Eliminate typedefs 382 /\(([\w\s]+)[\*\s]*\)\s*[\w\(]/ && do { 383 foreach (split /\s+/, $1) { # Make sure all the words are types, 384 last unless ($isatype{$_} or $_ eq 'struct' or $_ eq 'union'); 385 } 386 s/\([\w\s]+[\*\s]*\)// && next; # then eliminate them. 387 }; 388 # struct/union member, including arrays: 389 s/^([_A-Z]\w*(\[[^\]]+\])?((\.|->)[_A-Z]\w*(\[[^\]]+\])?)+)//i && do { 390 my $id = $1; 391 $id =~ s/(\.|(->))([^\.\-]*)/->\{$3\}/g; 392 $id =~ s/\b([^\$])($joined_args)/$1\$$2/g if length($joined_args); 393 while($id =~ /\[\s*([^\$\&\d\]]+)\]/) { 394 my($index) = $1; 395 $index =~ s/\s//g; 396 if(exists($curargs{$index})) { 397 $index = "\$$index"; 398 } else { 399 $index = "&$index"; 400 } 401 $id =~ s/\[\s*([^\$\&\d\]]+)\]/[$index]/; 402 } 403 $new .= " (\$$id)"; 404 }; 405 s/^([_a-zA-Z]\w*)// && do { 406 my $id = $1; 407 if ($id eq 'struct' || $id eq 'union') { 408 s/^\s+(\w+)//; 409 $id .= ' ' . $1; 410 $isatype{$id} = 1; 411 } elsif ($id =~ /^((un)?signed)|(long)|(short)$/) { 412 while (s/^\s+(\w+)//) { $id .= ' ' . $1; } 413 $isatype{$id} = 1; 414 } 415 if ($curargs{$id}) { 416 $new .= "\$$id"; 417 $new .= '->' if /^[\[\{]/; 418 } elsif ($id eq 'defined') { 419 $new .= 'defined'; 420 } elsif (/^\s*\(/) { 421 s/^\s*\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/i; # cheat 422 $new .= " &$id"; 423 } elsif ($isatype{$id}) { 424 if ($new =~ /{\s*$/) { 425 $new .= "'$id'"; 426 } elsif ($new =~ /\(\s*$/ && /^[\s*]*\)/) { 427 $new =~ s/\(\s*$//; 428 s/^[\s*]*\)//; 429 } else { 430 $new .= q(').$id.q('); 431 } 432 } else { 433 if ($inif && $new !~ /defined\s*\($/) { 434 $new .= '(defined(&' . $id . ') ? &' . $id . ' : 0)'; 435 } elsif (/^\[/) { 436 $new .= " \$$id"; 437 } else { 438 $new .= ' &' . $id; 439 } 440 } 441 next; 442 }; 443 s/^(.)// && do { if ($1 ne '#') { $new .= $1; } next;}; 444 } 445} 446 447 448sub next_line 449{ 450 my $file = shift; 451 my ($in, $out); 452 my $pre_sub_tri_graphs = 1; 453 454 READ: while (not eof IN) { 455 $in .= <IN>; 456 chomp $in; 457 next unless length $in; 458 459 while (length $in) { 460 if ($pre_sub_tri_graphs) { 461 # Preprocess all tri-graphs 462 # including things stuck in quoted string constants. 463 $in =~ s/\?\?=/#/g; # | ??=| #| 464 $in =~ s/\?\?\!/|/g; # | ??!| || 465 $in =~ s/\?\?'/^/g; # | ??'| ^| 466 $in =~ s/\?\?\(/[/g; # | ??(| [| 467 $in =~ s/\?\?\)/]/g; # | ??)| ]| 468 $in =~ s/\?\?\-/~/g; # | ??-| ~| 469 $in =~ s/\?\?\//\\/g; # | ??/| \| 470 $in =~ s/\?\?</{/g; # | ??<| {| 471 $in =~ s/\?\?>/}/g; # | ??>| }| 472 } 473 if ($in =~ /^\#ifdef __LANGUAGE_PASCAL__/) { 474 # Tru64 disassembler.h evilness: mixed C and Pascal. 475 while (<IN>) { 476 last if /^\#endif/; 477 } 478 next READ; 479 } 480 if ($in =~ /^extern inline / && # Inlined assembler. 481 $^O eq 'linux' && $file =~ m!(?:^|/)asm/[^/]+\.h$!) { 482 while (<IN>) { 483 last if /^}/; 484 } 485 next READ; 486 } 487 if ($in =~ s/\\$//) { # \-newline 488 $out .= ' '; 489 next READ; 490 } elsif ($in =~ s/^([^"'\\\/]+)//) { # Passthrough 491 $out .= $1; 492 } elsif ($in =~ s/^(\\.)//) { # \... 493 $out .= $1; 494 } elsif ($in =~ /^'/) { # '... 495 if ($in =~ s/^('(\\.|[^'\\])*')//) { 496 $out .= $1; 497 } else { 498 next READ; 499 } 500 } elsif ($in =~ /^"/) { # "... 501 if ($in =~ s/^("(\\.|[^"\\])*")//) { 502 $out .= $1; 503 } else { 504 next READ; 505 } 506 } elsif ($in =~ s/^\/\/.*//) { # //... 507 # fall through 508 } elsif ($in =~ m/^\/\*/) { # /*... 509 # C comment removal adapted from perlfaq6: 510 if ($in =~ s/^\/\*[^*]*\*+([^\/*][^*]*\*+)*\///) { 511 $out .= ' '; 512 } else { # Incomplete /* */ 513 next READ; 514 } 515 } elsif ($in =~ s/^(\/)//) { # /... 516 $out .= $1; 517 } elsif ($in =~ s/^([^\'\"\\\/]+)//) { 518 $out .= $1; 519 } elsif ($^O eq 'linux' && 520 $file =~ m!(?:^|/)linux/byteorder/pdp_endian\.h$! && 521 $in =~ s!\'T KNOW!!) { 522 $out =~ s!I DON$!I_DO_NOT_KNOW!; 523 } else { 524 if ($opt_e) { 525 warn "Cannot parse $file:\n$in\n"; 526 $bad_file{$file} = 1; 527 $in = ''; 528 $out = undef; 529 last READ; 530 } else { 531 die "Cannot parse:\n$in\n"; 532 } 533 } 534 } 535 536 last READ if $out =~ /\S/; 537 } 538 539 return $out; 540} 541 542 543# Handle recursive subdirectories without getting a grotesquely big stack. 544# Could this be implemented using File::Find? 545sub next_file 546{ 547 my $file; 548 549 while (@ARGV) { 550 $file = shift @ARGV; 551 552 if ($file eq '-' or -f $file or -l $file) { 553 return $file; 554 } elsif (-d $file) { 555 if ($opt_r) { 556 expand_glob($file); 557 } else { 558 print STDERR "Skipping directory `$file'\n"; 559 } 560 } elsif ($opt_a) { 561 return $file; 562 } else { 563 print STDERR "Skipping `$file': not a file or directory\n"; 564 } 565 } 566 567 return undef; 568} 569 570 571# Put all the files in $directory into @ARGV for processing. 572sub expand_glob 573{ 574 my ($directory) = @_; 575 576 $directory =~ s:/$::; 577 578 opendir DIR, $directory; 579 foreach (readdir DIR) { 580 next if ($_ eq '.' or $_ eq '..'); 581 582 # expand_glob() is going to be called until $ARGV[0] isn't a 583 # directory; so push directories, and unshift everything else. 584 if (-d "$directory/$_") { push @ARGV, "$directory/$_" } 585 else { unshift @ARGV, "$directory/$_" } 586 } 587 closedir DIR; 588} 589 590 591# Given $file, a symbolic link to a directory in the C include directory, 592# make an equivalent symbolic link in $Dest_dir, if we can figure out how. 593# Otherwise, just duplicate the file or directory. 594sub link_if_possible 595{ 596 my ($dirlink) = @_; 597 my $target = eval 'readlink($dirlink)'; 598 599 if ($target =~ m:^\.\./: or $target =~ m:^/:) { 600 # The target of a parent or absolute link could leave the $Dest_dir 601 # hierarchy, so let's put all of the contents of $dirlink (actually, 602 # the contents of $target) into @ARGV; as a side effect down the 603 # line, $dirlink will get created as an _actual_ directory. 604 expand_glob($dirlink); 605 } else { 606 if (-l "$Dest_dir/$dirlink") { 607 unlink "$Dest_dir/$dirlink" or 608 print STDERR "Could not remove link $Dest_dir/$dirlink: $!\n"; 609 } 610 611 if (eval 'symlink($target, "$Dest_dir/$dirlink")') { 612 print "Linking $target -> $Dest_dir/$dirlink\n"; 613 614 # Make sure that the link _links_ to something: 615 if (! -e "$Dest_dir/$target") { 616 mkpath("$Dest_dir/$target", 0755) or 617 print STDERR "Could not create $Dest_dir/$target/\n"; 618 } 619 } else { 620 print STDERR "Could not symlink $target -> $Dest_dir/$dirlink: $!\n"; 621 } 622 } 623} 624 625 626# Push all #included files in $file onto our stack, except for STDIN 627# and files we've already processed. 628sub queue_includes_from 629{ 630 my ($file) = @_; 631 my $line; 632 633 return if ($file eq "-"); 634 635 open HEADER, $file or return; 636 while (defined($line = <HEADER>)) { 637 while (/\\$/) { # Handle continuation lines 638 chop $line; 639 $line .= <HEADER>; 640 } 641 642 if ($line =~ /^#\s*include\s+<(.*?)>/) { 643 push(@ARGV, $1) unless $Is_converted{$1}; 644 } 645 } 646 close HEADER; 647} 648 649 650# Determine include directories; $Config{usrinc} should be enough for (all 651# non-GCC?) C compilers, but gcc uses an additional include directory. 652sub inc_dirs 653{ 654 my $from_gcc = `$Config{cc} -v 2>&1`; 655 $from_gcc =~ s:^Reading specs from (.*?)/specs\b.*:$1/include:s; 656 657 length($from_gcc) ? ($from_gcc, $Config{usrinc}) : ($Config{usrinc}); 658} 659 660 661# Create "_h2ph_pre.ph", if it doesn't exist or was built by a different 662# version of h2ph. 663sub build_preamble_if_necessary 664{ 665 # Increment $VERSION every time this function is modified: 666 my $VERSION = 2; 667 my $preamble = "$Dest_dir/_h2ph_pre.ph"; 668 669 # Can we skip building the preamble file? 670 if (-r $preamble) { 671 # Extract version number from first line of preamble: 672 open PREAMBLE, $preamble or die "Cannot open $preamble: $!"; 673 my $line = <PREAMBLE>; 674 $line =~ /(\b\d+\b)/; 675 close PREAMBLE or die "Cannot close $preamble: $!"; 676 677 # Don't build preamble if a compatible preamble exists: 678 return if $1 == $VERSION; 679 } 680 681 my (%define) = _extract_cc_defines(); 682 683 open PREAMBLE, ">$preamble" or die "Cannot open $preamble: $!"; 684 print PREAMBLE "# This file was created by h2ph version $VERSION\n"; 685 686 foreach (sort keys %define) { 687 if ($opt_D) { 688 print PREAMBLE "# $_=$define{$_}\n"; 689 } 690 691 if ($define{$_} =~ /^(\d+)U?L{0,2}$/i) { 692 print PREAMBLE 693 "unless (defined &$_) { sub $_() { $1 } }\n\n"; 694 } elsif ($define{$_} =~ /^\w+$/) { 695 print PREAMBLE 696 "unless (defined &$_) { sub $_() { &$define{$_} } }\n\n"; 697 } else { 698 print PREAMBLE 699 "unless (defined &$_) { sub $_() { \"", 700 quotemeta($define{$_}), "\" } }\n\n"; 701 } 702 } 703 close PREAMBLE or die "Cannot close $preamble: $!"; 704} 705 706 707# %Config contains information on macros that are pre-defined by the 708# system's compiler. We need this information to make the .ph files 709# function with perl as the .h files do with cc. 710sub _extract_cc_defines 711{ 712 my %define; 713 my $allsymbols = join " ", 714 @Config{'ccsymbols', 'cppsymbols', 'cppccsymbols'}; 715 716 # Split compiler pre-definitions into `key=value' pairs: 717 foreach (split /\s+/, $allsymbols) { 718 /(.+?)=(.+)/ and $define{$1} = $2; 719 720 if ($opt_D) { 721 print STDERR "$_: $1 -> $2\n"; 722 } 723 } 724 725 return %define; 726} 727 728 7291; 730 731############################################################################## 732__END__ 733 734=head1 NAME 735 736h2ph - convert .h C header files to .ph Perl header files 737 738=head1 SYNOPSIS 739 740B<h2ph [-d destination directory] [-r | -a] [-l] [headerfiles]> 741 742=head1 DESCRIPTION 743 744I<h2ph> 745converts any C header files specified to the corresponding Perl header file 746format. 747It is most easily run while in /usr/include: 748 749 cd /usr/include; h2ph * sys/* 750 751or 752 753 cd /usr/include; h2ph * sys/* arpa/* netinet/* 754 755or 756 757 cd /usr/include; h2ph -r -l . 758 759The output files are placed in the hierarchy rooted at Perl's 760architecture dependent library directory. You can specify a different 761hierarchy with a B<-d> switch. 762 763If run with no arguments, filters standard input to standard output. 764 765=head1 OPTIONS 766 767=over 4 768 769=item -d destination_dir 770 771Put the resulting B<.ph> files beneath B<destination_dir>, instead of 772beneath the default Perl library location (C<$Config{'installsitsearch'}>). 773 774=item -r 775 776Run recursively; if any of B<headerfiles> are directories, then run I<h2ph> 777on all files in those directories (and their subdirectories, etc.). B<-r> 778and B<-a> are mutually exclusive. 779 780=item -a 781 782Run automagically; convert B<headerfiles>, as well as any B<.h> files 783which they include. This option will search for B<.h> files in all 784directories which your C compiler ordinarily uses. B<-a> and B<-r> are 785mutually exclusive. 786 787=item -l 788 789Symbolic links will be replicated in the destination directory. If B<-l> 790is not specified, then links are skipped over. 791 792=item -h 793 794Put ``hints'' in the .ph files which will help in locating problems with 795I<h2ph>. In those cases when you B<require> a B<.ph> file containing syntax 796errors, instead of the cryptic 797 798 [ some error condition ] at (eval mmm) line nnn 799 800you will see the slightly more helpful 801 802 [ some error condition ] at filename.ph line nnn 803 804However, the B<.ph> files almost double in size when built using B<-h>. 805 806=item -D 807 808Include the code from the B<.h> file as a comment in the B<.ph> file. 809This is primarily used for debugging I<h2ph>. 810 811=item -Q 812 813``Quiet'' mode; don't print out the names of the files being converted. 814 815=back 816 817=head1 ENVIRONMENT 818 819No environment variables are used. 820 821=head1 FILES 822 823 /usr/include/*.h 824 /usr/include/sys/*.h 825 826etc. 827 828=head1 AUTHOR 829 830Larry Wall 831 832=head1 SEE ALSO 833 834perl(1) 835 836=head1 DIAGNOSTICS 837 838The usual warnings if it can't read or write the files involved. 839 840=head1 BUGS 841 842Doesn't construct the %sizeof array for you. 843 844It doesn't handle all C constructs, but it does attempt to isolate 845definitions inside evals so that you can get at the definitions 846that it can translate. 847 848It's only intended as a rough tool. 849You may need to dicker with the files produced. 850 851You have to run this program by hand; it's not run as part of the Perl 852installation. 853 854Doesn't handle complicated expressions built piecemeal, a la: 855 856 enum { 857 FIRST_VALUE, 858 SECOND_VALUE, 859 #ifdef ABC 860 THIRD_VALUE 861 #endif 862 }; 863 864Doesn't necessarily locate all of your C compiler's internally-defined 865symbols. 866 867=cut 868 869!NO!SUBS! 870 871close OUT or die "Can't close $file: $!"; 872chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; 873exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; 874chdir $origdir; 875