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