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";
123 print OUT "require '_h2ph_pre.ph';\n\n";
125 while (defined (local $_ = next_line($file))) {
127 if (s/^define\s+(\w+)//) {
131 s/\(\w+\s*\(\*\)\s*\(\w*\)\)\s*(-?\d+)/$1/; # (int (*)(foo_t))0
132 if (s/^\(([\w,\s]*)\)//) {
137 foreach my $arg (split(/,\s*/,$args)) {
138 $arg =~ s/^\s*([^\s].*[^\s])\s*$/$1/;
141 $args =~ s/\b(\w)/\$$1/g;
142 $args = "local($args) = \@_;\n$t ";
146 $new =~ s/(["\\])/\\$1/g; #"]);
147 $new = reindent($new);
148 $args = reindent($args);
150 $new =~ s/(['\\])/\\$1/g; #']);
153 "eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name $proto\{\n$t ${args}eval q($new);\n$t}' unless defined(\&$name);\n";
157 "eval 'sub $name $proto\{\n$t ${args}eval q($new);\n$t}' unless defined(\&$name);\n";
160 print OUT "unless(defined(\&$name)) {\n sub $name $proto\{\n\t${args}eval q($new);\n }\n}\n";
166 $new = 1 if $new eq '';
167 $new = reindent($new);
168 $args = reindent($args);
170 $new =~ s/(['\\])/\\$1/g; #']);
173 print OUT $t,"eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name () {",$new,";}' unless defined(\&$name);\n";
176 print OUT $t,"eval 'sub $name () {",$new,";}' unless defined(\&$name);\n";
179 # Shunt around such directives as `#define FOO FOO':
180 next if " \&$name" eq $new;
182 print OUT $t,"unless(defined(\&$name)) {\n sub $name () {\t",$new,";}\n}\n";
185 } elsif (/^(include|import|include_next)\s*[<\"](.*)[>\"]/) {
188 if (($incl_type eq 'include_next') ||
189 ($opt_e && exists($bad_file{$incl}))) {
190 $incl =~ s/\.h$/.ph/;
194 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
195 print OUT ($t, "my(\@REM);\n");
196 if ($incl_type eq 'include_next') {
198 "my(\%INCD) = map { \$INC{\$_} => 1 } ",
199 "(grep { \$_ eq \"$incl\" } ",
202 "\@REM = map { \"\$_/$incl\" } ",
203 "(grep { not exists(\$INCD{\"\$_/$incl\"})",
204 " and -f \"\$_/$incl\" } \@INC);\n");
207 "\@REM = map { \"\$_/$incl\" } ",
208 "(grep {-r \"\$_/$incl\" } \@INC);\n");
211 "require \"\$REM[0]\" if \@REM;\n");
213 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
217 "warn(\$\@) if \$\@;\n");
219 $incl =~ s/\.h$/.ph/;
220 print OUT $t,"require '$incl';\n";
222 } elsif (/^ifdef\s+(\w+)/) {
223 print OUT $t,"if(defined(&$1)) {\n";
225 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
226 } elsif (/^ifndef\s+(\w+)/) {
227 print OUT $t,"unless(defined(&$1)) {\n";
229 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
230 } elsif (s/^if\s+//) {
235 print OUT $t,"if($new) {\n";
237 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
238 } elsif (s/^elif\s+//) {
244 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
245 print OUT $t,"}\n elsif($new) {\n";
247 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
250 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
251 print OUT $t,"} else {\n";
253 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
256 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
258 } elsif(/^undef\s+(\w+)/) {
259 print OUT $t, "undef(&$1) if defined(&$1);\n";
260 } elsif(/^error\s+(".*")/) {
261 print OUT $t, "die($1);\n";
262 } elsif(/^error\s+(.*)/) {
263 print OUT $t, "die(\"", quotemeta($1), "\");\n";
264 } elsif(/^warning\s+(.*)/) {
265 print OUT $t, "warn(\"", quotemeta($1), "\");\n";
266 } elsif(/^ident\s+(.*)/) {
267 print OUT $t, "# $1\n";
269 } elsif(/^\s*(typedef\s*)?enum\s*(\s+[a-zA-Z_]\w*\s*)?/) {
270 until(/\{[^}]*\}.*;/ || /;/) {
271 last unless defined ($next = next_line($file));
273 # drop "#define FOO FOO" in enums
274 $next =~ s/^\s*#\s*define\s+(\w+)\s+\1\s*$//;
276 print OUT "# $next\n" if $opt_D;
278 s/#\s*if.*?#\s*endif//g; # drop #ifdefs
281 next unless /^\s?(typedef\s?)?enum\s?([a-zA-Z_]\w*)?\s?\{(.*)\}\s?([a-zA-Z_]\w*)?\s?;/;
282 (my $enum_subs = $3) =~ s/\s//g;
283 my @enum_subs = split(/,/, $enum_subs);
285 foreach my $enum (@enum_subs) {
286 my ($enum_name, $enum_value) = $enum =~ /^([a-zA-Z_]\w*)(=.+)?$/;
287 $enum_value =~ s/^=//;
288 $enum_val = (length($enum_value) ? $enum_value : $enum_val + 1);
291 "eval(\"\\n#line $eval_index $outfile\\n",
292 "sub $enum_name () \{ $enum_val; \}\") ",
293 "unless defined(\&$enum_name);\n");
297 "eval(\"sub $enum_name () \{ $enum_val; \}\") ",
298 "unless defined(\&$enum_name);\n");
303 $Is_converted{$file} = 1;
304 if ($opt_e && exists($bad_file{$file})) {
305 unlink($Dest_dir . '/' . $outfile);
309 queue_includes_from($file) if ($opt_a);
313 if ($opt_e && (scalar(keys %bad_file) > 0)) {
314 warn "Was unable to convert the following files:\n";
315 warn "\t" . join("\n\t",sort(keys %bad_file)) . "\n";
323 $joined_args = join('|', keys(%curargs));
326 s/^\&\&// && do { $new .= " &&"; next;}; # handle && operator
327 s/^\&([\(a-z\)]+)/$1/i; # hack for things that take the address of
328 s/^(\s+)// && do {$new .= ' '; next;};
329 s/^0X([0-9A-F]+)[UL]*//i
332 if (length $hex > 8 && !$Config{use64bitint}) {
333 # Croak if nv_preserves_uv_bits < 64 ?
334 $new .= hex(substr($hex, -8)) +
335 2**32 * hex(substr($hex, 0, -8));
336 # The above will produce "errorneus" code
337 # if the hex constant was e.g. inside UINT64_C
338 # macro, but then again, h2ph is an approximation.
340 $new .= lc("0x$hex");
343 s/^(-?\d+\.\d+E[-+]?\d+)[FL]?//i && do {$new .= $1; next;};
344 s/^(\d+)\s*[LU]*//i && do {$new .= $1; next;};
345 s/^("(\\"|[^"])*")// && do {$new .= $1; next;};
346 s/^'((\\"|[^"])*)'// && do {
348 $new .= "ord('\$$1')";
354 # replace "sizeof(foo)" with "{foo}"
355 # also, remove * (C dereference operator) to avoid perl syntax
356 # problems. Where the %sizeof array comes from is anyone's
357 # guess (c2ph?), but this at least avoids fatal syntax errors.
358 # Behavior is undefined if sizeof() delimiters are unbalanced.
359 # This code was modified to able to handle constructs like this:
360 # sizeof(*(p)), which appear in the HP-UX 10.01 header files.
361 s/^sizeof\s*\(// && do {
363 my $lvl = 1; # already saw one open paren
364 # tack { on the front, and skip it in the loop
367 # find balanced closing paren
368 while ($index <= length($_) && $lvl > 0) {
369 $lvl++ if substr($_, $index, 1) eq "(";
370 $lvl-- if substr($_, $index, 1) eq ")";
373 # tack } on the end, replacing )
374 substr($_, $index - 1, 1) = "}";
375 # remove pesky * operators within the sizeof argument
376 substr($_, 0, $index - 1) =~ s/\*//g;
380 /\(([\w\s]+)[\*\s]*\)\s*[\w\(]/ && do {
381 foreach (split /\s+/, $1) { # Make sure all the words are types,
382 last unless ($isatype{$_} or $_ eq 'struct' or $_ eq 'union');
384 s/\([\w\s]+[\*\s]*\)// && next; # then eliminate them.
386 # struct/union member, including arrays:
387 s/^([_A-Z]\w*(\[[^\]]+\])?((\.|->)[_A-Z]\w*(\[[^\]]+\])?)+)//i && do {
389 $id =~ s/(\.|(->))([^\.\-]*)/->\{$3\}/g;
390 $id =~ s/\b([^\$])($joined_args)/$1\$$2/g if length($joined_args);
391 while($id =~ /\[\s*([^\$\&\d\]]+)\]/) {
394 if(exists($curargs{$index})) {
399 $id =~ s/\[\s*([^\$\&\d\]]+)\]/[$index]/;
403 s/^([_a-zA-Z]\w*)// && do {
405 if ($id eq 'struct' || $id eq 'union') {
409 } elsif ($id =~ /^((un)?signed)|(long)|(short)$/) {
410 while (s/^\s+(\w+)//) { $id .= ' ' . $1; }
415 $new .= '->' if /^[\[\{]/;
416 } elsif ($id eq 'defined') {
419 s/^\s*\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/i; # cheat
421 } elsif ($isatype{$id}) {
422 if ($new =~ /{\s*$/) {
424 } elsif ($new =~ /\(\s*$/ && /^[\s*]*\)/) {
428 $new .= q(').$id.q(');
431 if ($inif && $new !~ /defined\s*\($/) {
432 $new .= '(defined(&' . $id . ') ? &' . $id . ' : 0)';
441 s/^(.)// && do { if ($1 ne '#') { $new .= $1; } next;};
450 my $pre_sub_tri_graphs = 1;
452 READ: while (not eof IN) {
455 next unless length $in;
458 if ($pre_sub_tri_graphs) {
459 # Preprocess all tri-graphs
460 # including things stuck in quoted string constants.
461 $in =~ s/\?\?=/#/g; # | ??=| #|
462 $in =~ s/\?\?\!/|/g; # | ??!| ||
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; # | ??>| }|
471 if ($in =~ /^\#ifdef __LANGUAGE_PASCAL__/) {
472 # Tru64 disassembler.h evilness: mixed C and Pascal.
478 if ($in =~ /^extern inline / && # Inlined assembler.
479 $^O eq 'linux' && $file =~ m!(?:^|/)asm/[^/]+\.h$!) {
485 if ($in =~ s/\\$//) { # \-newline
488 } elsif ($in =~ s/^([^"'\\\/]+)//) { # Passthrough
490 } elsif ($in =~ s/^(\\.)//) { # \...
492 } elsif ($in =~ /^'/) { # '...
493 if ($in =~ s/^('(\\.|[^'\\])*')//) {
498 } elsif ($in =~ /^"/) { # "...
499 if ($in =~ s/^("(\\.|[^"\\])*")//) {
504 } elsif ($in =~ s/^\/\/.*//) { # //...
506 } elsif ($in =~ m/^\/\*/) { # /*...
507 # C comment removal adapted from perlfaq6:
508 if ($in =~ s/^\/\*[^*]*\*+([^\/*][^*]*\*+)*\///) {
510 } else { # Incomplete /* */
513 } elsif ($in =~ s/^(\/)//) { # /...
515 } elsif ($in =~ s/^([^\'\"\\\/]+)//) {
517 } elsif ($^O eq 'linux' &&
518 $file =~ m!(?:^|/)linux/byteorder/pdp_endian\.h$! &&
519 $in =~ s!\'T KNOW!!) {
520 $out =~ s!I DON$!I_DO_NOT_KNOW!;
523 warn "Cannot parse $file:\n$in\n";
524 $bad_file{$file} = 1;
529 die "Cannot parse:\n$in\n";
534 last READ if $out =~ /\S/;
541 # Handle recursive subdirectories without getting a grotesquely big stack.
542 # Could this be implemented using File::Find?
550 if ($file eq '-' or -f $file or -l $file) {
556 print STDERR "Skipping directory `$file'\n";
561 print STDERR "Skipping `$file': not a file or directory\n";
569 # Put all the files in $directory into @ARGV for processing.
572 my ($directory) = @_;
574 $directory =~ s:/$::;
576 opendir DIR, $directory;
577 foreach (readdir DIR) {
578 next if ($_ eq '.' or $_ eq '..');
580 # expand_glob() is going to be called until $ARGV[0] isn't a
581 # directory; so push directories, and unshift everything else.
582 if (-d "$directory/$_") { push @ARGV, "$directory/$_" }
583 else { unshift @ARGV, "$directory/$_" }
589 # Given $file, a symbolic link to a directory in the C include directory,
590 # make an equivalent symbolic link in $Dest_dir, if we can figure out how.
591 # Otherwise, just duplicate the file or directory.
595 my $target = eval 'readlink($dirlink)';
597 if ($target =~ m:^\.\./: or $target =~ m:^/:) {
598 # The target of a parent or absolute link could leave the $Dest_dir
599 # hierarchy, so let's put all of the contents of $dirlink (actually,
600 # the contents of $target) into @ARGV; as a side effect down the
601 # line, $dirlink will get created as an _actual_ directory.
602 expand_glob($dirlink);
604 if (-l "$Dest_dir/$dirlink") {
605 unlink "$Dest_dir/$dirlink" or
606 print STDERR "Could not remove link $Dest_dir/$dirlink: $!\n";
609 if (eval 'symlink($target, "$Dest_dir/$dirlink")') {
610 print "Linking $target -> $Dest_dir/$dirlink\n";
612 # Make sure that the link _links_ to something:
613 if (! -e "$Dest_dir/$target") {
614 mkpath("$Dest_dir/$target", 0755) or
615 print STDERR "Could not create $Dest_dir/$target/\n";
618 print STDERR "Could not symlink $target -> $Dest_dir/$dirlink: $!\n";
624 # Push all #included files in $file onto our stack, except for STDIN
625 # and files we've already processed.
626 sub queue_includes_from
631 return if ($file eq "-");
633 open HEADER, $file or return;
634 while (defined($line = <HEADER>)) {
635 while (/\\$/) { # Handle continuation lines
640 if ($line =~ /^#\s*include\s+<(.*?)>/) {
641 push(@ARGV, $1) unless $Is_converted{$1};
648 # Determine include directories; $Config{usrinc} should be enough for (all
649 # non-GCC?) C compilers, but gcc uses an additional include directory.
652 my $from_gcc = `$Config{cc} -v 2>&1`;
653 $from_gcc =~ s:^Reading specs from (.*?)/specs\b.*:$1/include:s;
655 length($from_gcc) ? ($from_gcc, $Config{usrinc}) : ($Config{usrinc});
659 # Create "_h2ph_pre.ph", if it doesn't exist or was built by a different
661 sub build_preamble_if_necessary
663 # Increment $VERSION every time this function is modified:
665 my $preamble = "$Dest_dir/_h2ph_pre.ph";
667 # Can we skip building the preamble file?
669 # Extract version number from first line of preamble:
670 open PREAMBLE, $preamble or die "Cannot open $preamble: $!";
671 my $line = <PREAMBLE>;
672 $line =~ /(\b\d+\b)/;
673 close PREAMBLE or die "Cannot close $preamble: $!";
675 # Don't build preamble if a compatible preamble exists:
676 return if $1 == $VERSION;
679 my (%define) = _extract_cc_defines();
681 open PREAMBLE, ">$preamble" or die "Cannot open $preamble: $!";
682 print PREAMBLE "# This file was created by h2ph version $VERSION\n";
684 foreach (sort keys %define) {
686 print PREAMBLE "# $_=$define{$_}\n";
689 if ($define{$_} =~ /^(\d+)U?L{0,2}$/i) {
691 "unless (defined &$_) { sub $_() { $1 } }\n\n";
692 } elsif ($define{$_} =~ /^\w+$/) {
694 "unless (defined &$_) { sub $_() { &$define{$_} } }\n\n";
697 "unless (defined &$_) { sub $_() { \"",
698 quotemeta($define{$_}), "\" } }\n\n";
701 close PREAMBLE or die "Cannot close $preamble: $!";
705 # %Config contains information on macros that are pre-defined by the
706 # system's compiler. We need this information to make the .ph files
707 # function with perl as the .h files do with cc.
708 sub _extract_cc_defines
711 my $allsymbols = join " ",
712 @Config{'ccsymbols', 'cppsymbols', 'cppccsymbols'};
714 # Split compiler pre-definitions into `key=value' pairs:
715 foreach (split /\s+/, $allsymbols) {
716 /(.+?)=(.+)/ and $define{$1} = $2;
719 print STDERR "$_: $1 -> $2\n";
729 ##############################################################################
734 h2ph - convert .h C header files to .ph Perl header files
738 B<h2ph [-d destination directory] [-r | -a] [-l] [headerfiles]>
743 converts any C header files specified to the corresponding Perl header file
745 It is most easily run while in /usr/include:
747 cd /usr/include; h2ph * sys/*
751 cd /usr/include; h2ph * sys/* arpa/* netinet/*
755 cd /usr/include; h2ph -r -l .
757 The output files are placed in the hierarchy rooted at Perl's
758 architecture dependent library directory. You can specify a different
759 hierarchy with a B<-d> switch.
761 If run with no arguments, filters standard input to standard output.
767 =item -d destination_dir
769 Put the resulting B<.ph> files beneath B<destination_dir>, instead of
770 beneath the default Perl library location (C<$Config{'installsitsearch'}>).
774 Run recursively; if any of B<headerfiles> are directories, then run I<h2ph>
775 on all files in those directories (and their subdirectories, etc.). B<-r>
776 and B<-a> are mutually exclusive.
780 Run automagically; convert B<headerfiles>, as well as any B<.h> files
781 which they include. This option will search for B<.h> files in all
782 directories which your C compiler ordinarily uses. B<-a> and B<-r> are
787 Symbolic links will be replicated in the destination directory. If B<-l>
788 is not specified, then links are skipped over.
792 Put ``hints'' in the .ph files which will help in locating problems with
793 I<h2ph>. In those cases when you B<require> a B<.ph> file containing syntax
794 errors, instead of the cryptic
796 [ some error condition ] at (eval mmm) line nnn
798 you will see the slightly more helpful
800 [ some error condition ] at filename.ph line nnn
802 However, the B<.ph> files almost double in size when built using B<-h>.
806 Include the code from the B<.h> file as a comment in the B<.ph> file.
807 This is primarily used for debugging I<h2ph>.
811 ``Quiet'' mode; don't print out the names of the files being converted.
817 No environment variables are used.
836 The usual warnings if it can't read or write the files involved.
840 Doesn't construct the %sizeof array for you.
842 It doesn't handle all C constructs, but it does attempt to isolate
843 definitions inside evals so that you can get at the definitions
844 that it can translate.
846 It's only intended as a rough tool.
847 You may need to dicker with the files produced.
849 You have to run this program by hand; it's not run as part of the Perl
852 Doesn't handle complicated expressions built piecemeal, a la:
862 Doesn't necessarily locate all of your C compiler's internally-defined
869 close OUT or die "Can't close $file: $!";
870 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
871 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';