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