4 use File::Basename qw(basename dirname);
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
12 # to ensure Configure will look for $Config{startperl}.
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.
19 $file = basename($0, '.PL');
20 $file .= '.com' if $^O eq 'VMS';
22 open OUT,">$file" or die "Can't create $file: $!";
24 print "Extracting $file (with variable substitutions)\n";
26 # In this section, perl variables will be expanded during extraction.
27 # You can use $Config{...} to use Configure variables.
29 print OUT <<"!GROK!THIS!";
31 eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
32 if \$running_under_some_shell;
35 # In the following, perl variables are not expanded during extraction.
37 print OUT <<'!NO!SUBS!';
42 use File::Path qw(mkpath);
45 # Make sure read permissions for all are set:
46 if (defined umask && (umask() & 0444)) {
47 umask (umask() & ~0444);
51 use vars qw($opt_D $opt_d $opt_r $opt_l $opt_h $opt_a $opt_Q $opt_e);
52 die "-r and -a options are mutually exclusive\n" if ($opt_r and $opt_a);
53 my @inc_dirs = inc_dirs() if $opt_a;
57 my $Dest_dir = $opt_d || $Config{installsitearch};
58 die "Destination directory $Dest_dir doesn't exist or isn't a directory\n"
61 my @isatype = split(' ',<<END);
70 @isatype{@isatype} = (1) x @isatype;
75 @ARGV = ('-') unless @ARGV;
77 build_preamble_if_necessary();
86 my ($t, $tab, %curargs, $new, $eval_index, $dir, $name, $args, $outfile);
87 my ($incl, $incl_type, $next);
88 while (defined (my $file = next_file())) {
89 if (-l $file and -d $file) {
90 link_if_possible($file) if ($opt_l);
94 # Recover from header files with unbalanced cpp directives
98 # $eval_index goes into ``#line'' directives, to help locate syntax errors:
105 ($outfile = $file) =~ s/\.h$/.ph/ || next;
106 print "$file -> $outfile\n" unless $opt_Q;
107 if ($file =~ m|^(.*)/|) {
109 mkpath "$Dest_dir/$dir";
112 if ($opt_a) { # automagic mode: locate header file in @inc_dirs
113 foreach (@inc_dirs) {
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";
124 "require '_h2ph_pre.ph';\n\n",
125 "no warnings 'redefine';\n\n";
127 while (defined (local $_ = next_line($file))) {
129 if (s/^define\s+(\w+)//) {
133 s/\(\w+\s*\(\*\)\s*\(\w*\)\)\s*(-?\d+)/$1/; # (int (*)(foo_t))0
134 if (s/^\(([\w,\s]*)\)//) {
139 foreach my $arg (split(/,\s*/,$args)) {
140 $arg =~ s/^\s*([^\s].*[^\s])\s*$/$1/;
143 $args =~ s/\b(\w)/\$$1/g;
144 $args = "local($args) = \@_;\n$t ";
148 $new =~ s/(["\\])/\\$1/g; #"]);
149 $new = reindent($new);
150 $args = reindent($args);
152 $new =~ s/(['\\])/\\$1/g; #']);
155 "eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name $proto\{\n$t ${args}eval q($new);\n$t}' unless defined(\&$name);\n";
159 "eval 'sub $name $proto\{\n$t ${args}eval q($new);\n$t}' unless defined(\&$name);\n";
162 print OUT "unless(defined(\&$name)) {\n sub $name $proto\{\n\t${args}eval q($new);\n }\n}\n";
168 $new = 1 if $new eq '';
169 $new = reindent($new);
170 $args = reindent($args);
172 $new =~ s/(['\\])/\\$1/g; #']);
175 print OUT $t,"eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name () {",$new,";}' unless defined(\&$name);\n";
178 print OUT $t,"eval 'sub $name () {",$new,";}' unless defined(\&$name);\n";
181 # Shunt around such directives as `#define FOO FOO':
182 next if " \&$name" eq $new;
184 print OUT $t,"unless(defined(\&$name)) {\n sub $name () {\t",$new,";}\n}\n";
187 } elsif (/^(include|import|include_next)\s*[<\"](.*)[>\"]/) {
190 if (($incl_type eq 'include_next') ||
191 ($opt_e && exists($bad_file{$incl}))) {
192 $incl =~ s/\.h$/.ph/;
196 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
197 print OUT ($t, "my(\@REM);\n");
198 if ($incl_type eq 'include_next') {
200 "my(\%INCD) = map { \$INC{\$_} => 1 } ",
201 "(grep { \$_ eq \"$incl\" } ",
204 "\@REM = map { \"\$_/$incl\" } ",
205 "(grep { not exists(\$INCD{\"\$_/$incl\"})",
206 " and -f \"\$_/$incl\" } \@INC);\n");
209 "\@REM = map { \"\$_/$incl\" } ",
210 "(grep {-r \"\$_/$incl\" } \@INC);\n");
213 "require \"\$REM[0]\" if \@REM;\n");
215 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
219 "warn(\$\@) if \$\@;\n");
221 $incl =~ s/\.h$/.ph/;
222 print OUT $t,"require '$incl';\n";
224 } elsif (/^ifdef\s+(\w+)/) {
225 print OUT $t,"if(defined(&$1)) {\n";
227 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
228 } elsif (/^ifndef\s+(\w+)/) {
229 print OUT $t,"unless(defined(&$1)) {\n";
231 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
232 } elsif (s/^if\s+//) {
237 print OUT $t,"if($new) {\n";
239 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
240 } elsif (s/^elif\s+//) {
246 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
247 print OUT $t,"}\n elsif($new) {\n";
249 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
252 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
253 print OUT $t,"} else {\n";
255 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
258 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
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";
271 } elsif(/^\s*(typedef\s*)?enum\s*(\s+[a-zA-Z_]\w*\s*)?/) {
272 until(/\{[^}]*\}.*;/ || /;/) {
273 last unless defined ($next = next_line($file));
275 # drop "#define FOO FOO" in enums
276 $next =~ s/^\s*#\s*define\s+(\w+)\s+\1\s*$//;
278 print OUT "# $next\n" if $opt_D;
280 s/#\s*if.*?#\s*endif//g; # drop #ifdefs
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);
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);
293 "eval(\"\\n#line $eval_index $outfile\\n",
294 "sub $enum_name () \{ $enum_val; \}\") ",
295 "unless defined(\&$enum_name);\n");
299 "eval(\"sub $enum_name () \{ $enum_val; \}\") ",
300 "unless defined(\&$enum_name);\n");
305 $Is_converted{$file} = 1;
306 if ($opt_e && exists($bad_file{$file})) {
307 unlink($Dest_dir . '/' . $outfile);
311 queue_includes_from($file) if ($opt_a);
315 if ($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";
325 $joined_args = join('|', keys(%curargs));
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
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.
342 $new .= lc("0x$hex");
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 {
350 $new .= "ord('\$$1')";
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 {
365 my $lvl = 1; # already saw one open paren
366 # tack { on the front, and skip it in the loop
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 ")";
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;
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');
386 s/\([\w\s]+[\*\s]*\)// && next; # then eliminate them.
388 # struct/union member, including arrays:
389 s/^([_A-Z]\w*(\[[^\]]+\])?((\.|->)[_A-Z]\w*(\[[^\]]+\])?)+)//i && do {
391 $id =~ s/(\.|(->))([^\.\-]*)/->\{$3\}/g;
392 $id =~ s/\b([^\$])($joined_args)/$1\$$2/g if length($joined_args);
393 while($id =~ /\[\s*([^\$\&\d\]]+)\]/) {
396 if(exists($curargs{$index})) {
401 $id =~ s/\[\s*([^\$\&\d\]]+)\]/[$index]/;
405 s/^([_a-zA-Z]\w*)// && do {
407 if ($id eq 'struct' || $id eq 'union') {
411 } elsif ($id =~ /^((un)?signed)|(long)|(short)$/) {
412 while (s/^\s+(\w+)//) { $id .= ' ' . $1; }
417 $new .= '->' if /^[\[\{]/;
418 } elsif ($id eq 'defined') {
421 s/^\s*\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/i; # cheat
423 } elsif ($isatype{$id}) {
424 if ($new =~ /{\s*$/) {
426 } elsif ($new =~ /\(\s*$/ && /^[\s*]*\)/) {
430 $new .= q(').$id.q(');
433 if ($inif && $new !~ /defined\s*\($/) {
434 $new .= '(defined(&' . $id . ') ? &' . $id . ' : 0)';
443 s/^(.)// && do { if ($1 ne '#') { $new .= $1; } next;};
452 my $pre_sub_tri_graphs = 1;
454 READ: while (not eof IN) {
457 next unless 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; # | ??>| }|
473 if ($in =~ /^\#ifdef __LANGUAGE_PASCAL__/) {
474 # Tru64 disassembler.h evilness: mixed C and Pascal.
480 if ($in =~ /^extern inline / && # Inlined assembler.
481 $^O eq 'linux' && $file =~ m!(?:^|/)asm/[^/]+\.h$!) {
487 if ($in =~ s/\\$//) { # \-newline
490 } elsif ($in =~ s/^([^"'\\\/]+)//) { # Passthrough
492 } elsif ($in =~ s/^(\\.)//) { # \...
494 } elsif ($in =~ /^'/) { # '...
495 if ($in =~ s/^('(\\.|[^'\\])*')//) {
500 } elsif ($in =~ /^"/) { # "...
501 if ($in =~ s/^("(\\.|[^"\\])*")//) {
506 } elsif ($in =~ s/^\/\/.*//) { # //...
508 } elsif ($in =~ m/^\/\*/) { # /*...
509 # C comment removal adapted from perlfaq6:
510 if ($in =~ s/^\/\*[^*]*\*+([^\/*][^*]*\*+)*\///) {
512 } else { # Incomplete /* */
515 } elsif ($in =~ s/^(\/)//) { # /...
517 } elsif ($in =~ s/^([^\'\"\\\/]+)//) {
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!;
525 warn "Cannot parse $file:\n$in\n";
526 $bad_file{$file} = 1;
531 die "Cannot parse:\n$in\n";
536 last READ if $out =~ /\S/;
543 # Handle recursive subdirectories without getting a grotesquely big stack.
544 # Could this be implemented using File::Find?
552 if ($file eq '-' or -f $file or -l $file) {
558 print STDERR "Skipping directory `$file'\n";
563 print STDERR "Skipping `$file': not a file or directory\n";
571 # Put all the files in $directory into @ARGV for processing.
574 my ($directory) = @_;
576 $directory =~ s:/$::;
578 opendir DIR, $directory;
579 foreach (readdir DIR) {
580 next if ($_ eq '.' or $_ eq '..');
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/$_" }
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.
597 my $target = eval 'readlink($dirlink)';
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);
606 if (-l "$Dest_dir/$dirlink") {
607 unlink "$Dest_dir/$dirlink" or
608 print STDERR "Could not remove link $Dest_dir/$dirlink: $!\n";
611 if (eval 'symlink($target, "$Dest_dir/$dirlink")') {
612 print "Linking $target -> $Dest_dir/$dirlink\n";
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";
620 print STDERR "Could not symlink $target -> $Dest_dir/$dirlink: $!\n";
626 # Push all #included files in $file onto our stack, except for STDIN
627 # and files we've already processed.
628 sub queue_includes_from
633 return if ($file eq "-");
635 open HEADER, $file or return;
636 while (defined($line = <HEADER>)) {
637 while (/\\$/) { # Handle continuation lines
642 if ($line =~ /^#\s*include\s+<(.*?)>/) {
643 push(@ARGV, $1) unless $Is_converted{$1};
650 # Determine include directories; $Config{usrinc} should be enough for (all
651 # non-GCC?) C compilers, but gcc uses an additional include directory.
654 my $from_gcc = `$Config{cc} -v 2>&1`;
655 $from_gcc =~ s:^Reading specs from (.*?)/specs\b.*:$1/include:s;
657 length($from_gcc) ? ($from_gcc, $Config{usrinc}) : ($Config{usrinc});
661 # Create "_h2ph_pre.ph", if it doesn't exist or was built by a different
663 sub build_preamble_if_necessary
665 # Increment $VERSION every time this function is modified:
667 my $preamble = "$Dest_dir/_h2ph_pre.ph";
669 # Can we skip building the preamble file?
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: $!";
677 # Don't build preamble if a compatible preamble exists:
678 return if $1 == $VERSION;
681 my (%define) = _extract_cc_defines();
683 open PREAMBLE, ">$preamble" or die "Cannot open $preamble: $!";
684 print PREAMBLE "# This file was created by h2ph version $VERSION\n";
686 foreach (sort keys %define) {
688 print PREAMBLE "# $_=$define{$_}\n";
691 if ($define{$_} =~ /^(\d+)U?L{0,2}$/i) {
693 "unless (defined &$_) { sub $_() { $1 } }\n\n";
694 } elsif ($define{$_} =~ /^\w+$/) {
696 "unless (defined &$_) { sub $_() { &$define{$_} } }\n\n";
699 "unless (defined &$_) { sub $_() { \"",
700 quotemeta($define{$_}), "\" } }\n\n";
703 close PREAMBLE or die "Cannot close $preamble: $!";
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.
710 sub _extract_cc_defines
713 my $allsymbols = join " ",
714 @Config{'ccsymbols', 'cppsymbols', 'cppccsymbols'};
716 # Split compiler pre-definitions into `key=value' pairs:
717 foreach (split /\s+/, $allsymbols) {
718 /(.+?)=(.+)/ and $define{$1} = $2;
721 print STDERR "$_: $1 -> $2\n";
731 ##############################################################################
736 h2ph - convert .h C header files to .ph Perl header files
740 B<h2ph [-d destination directory] [-r | -a] [-l] [headerfiles]>
745 converts any C header files specified to the corresponding Perl header file
747 It is most easily run while in /usr/include:
749 cd /usr/include; h2ph * sys/*
753 cd /usr/include; h2ph * sys/* arpa/* netinet/*
757 cd /usr/include; h2ph -r -l .
759 The output files are placed in the hierarchy rooted at Perl's
760 architecture dependent library directory. You can specify a different
761 hierarchy with a B<-d> switch.
763 If run with no arguments, filters standard input to standard output.
769 =item -d destination_dir
771 Put the resulting B<.ph> files beneath B<destination_dir>, instead of
772 beneath the default Perl library location (C<$Config{'installsitsearch'}>).
776 Run recursively; if any of B<headerfiles> are directories, then run I<h2ph>
777 on all files in those directories (and their subdirectories, etc.). B<-r>
778 and B<-a> are mutually exclusive.
782 Run automagically; convert B<headerfiles>, as well as any B<.h> files
783 which they include. This option will search for B<.h> files in all
784 directories which your C compiler ordinarily uses. B<-a> and B<-r> are
789 Symbolic links will be replicated in the destination directory. If B<-l>
790 is not specified, then links are skipped over.
794 Put ``hints'' in the .ph files which will help in locating problems with
795 I<h2ph>. In those cases when you B<require> a B<.ph> file containing syntax
796 errors, instead of the cryptic
798 [ some error condition ] at (eval mmm) line nnn
800 you will see the slightly more helpful
802 [ some error condition ] at filename.ph line nnn
804 However, the B<.ph> files almost double in size when built using B<-h>.
808 Include the code from the B<.h> file as a comment in the B<.ph> file.
809 This is primarily used for debugging I<h2ph>.
813 ``Quiet'' mode; don't print out the names of the files being converted.
819 No environment variables are used.
838 The usual warnings if it can't read or write the files involved.
842 Doesn't construct the %sizeof array for you.
844 It doesn't handle all C constructs, but it does attempt to isolate
845 definitions inside evals so that you can get at the definitions
846 that it can translate.
848 It's only intended as a rough tool.
849 You may need to dicker with the files produced.
851 You have to run this program by hand; it's not run as part of the Perl
854 Doesn't handle complicated expressions built piecemeal, a la:
864 Doesn't necessarily locate all of your C compiler's internally-defined
871 close OUT or die "Can't close $file: $!";
872 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
873 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';