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);
46 use vars qw($opt_D $opt_d $opt_r $opt_l $opt_h $opt_a $opt_Q $opt_e);
47 die "-r and -a options are mutually exclusive\n" if ($opt_r and $opt_a);
48 my @inc_dirs = inc_dirs() if $opt_a;
52 my $Dest_dir = $opt_d || $Config{installsitearch};
53 die "Destination directory $Dest_dir doesn't exist or isn't a directory\n"
56 my @isatype = split(' ',<<END);
65 @isatype{@isatype} = (1) x @isatype;
70 @ARGV = ('-') unless @ARGV;
72 build_preamble_if_necessary();
81 my ($t, $tab, %curargs, $new, $eval_index, $dir, $name, $args, $outfile);
82 my ($incl, $incl_type, $next);
83 while (defined (my $file = next_file())) {
84 if (-l $file and -d $file) {
85 link_if_possible($file) if ($opt_l);
89 # Recover from header files with unbalanced cpp directives
93 # $eval_index goes into ``#line'' directives, to help locate syntax errors:
100 ($outfile = $file) =~ s/\.h$/.ph/ || next;
101 print "$file -> $outfile\n" unless $opt_Q;
102 if ($file =~ m|^(.*)/|) {
104 mkpath "$Dest_dir/$dir";
107 if ($opt_a) { # automagic mode: locate header file in @inc_dirs
108 foreach (@inc_dirs) {
114 open(IN,"$file") || (($Exit = 1),(warn "Can't open $file: $!\n"),next);
115 open(OUT,">$Dest_dir/$outfile") || die "Can't create $outfile: $!\n";
118 print OUT "require '_h2ph_pre.ph';\n\n";
120 while (defined (local $_ = next_line($file))) {
122 if (s/^define\s+(\w+)//) {
126 s/\(\w+\s*\(\*\)\s*\(\w*\)\)\s*(-?\d+)/$1/; # (int (*)(foo_t))0
127 if (s/^\(([\w,\s]*)\)//) {
132 foreach my $arg (split(/,\s*/,$args)) {
133 $arg =~ s/^\s*([^\s].*[^\s])\s*$/$1/;
136 $args =~ s/\b(\w)/\$$1/g;
137 $args = "local($args) = \@_;\n$t ";
141 $new =~ s/(["\\])/\\$1/g; #"]);
142 $new = reindent($new);
143 $args = reindent($args);
145 $new =~ s/(['\\])/\\$1/g; #']);
148 "eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name $proto\{\n$t ${args}eval q($new);\n$t}' unless defined(\&$name);\n";
152 "eval 'sub $name $proto\{\n$t ${args}eval q($new);\n$t}' unless defined(\&$name);\n";
155 print OUT "unless(defined(\&$name)) {\n sub $name $proto\{\n\t${args}eval q($new);\n }\n}\n";
161 $new = 1 if $new eq '';
162 $new = reindent($new);
163 $args = reindent($args);
165 $new =~ s/(['\\])/\\$1/g; #']);
168 print OUT $t,"eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name () {",$new,";}' unless defined(\&$name);\n";
171 print OUT $t,"eval 'sub $name () {",$new,";}' unless defined(\&$name);\n";
174 # Shunt around such directives as `#define FOO FOO':
175 next if " \&$name" eq $new;
177 print OUT $t,"unless(defined(\&$name)) {\n sub $name () {\t",$new,";}\n}\n";
180 } elsif (/^(include|import|include_next)\s*[<\"](.*)[>\"]/) {
183 if (($incl_type eq 'include_next') ||
184 ($opt_e && exists($bad_file{$incl}))) {
185 $incl =~ s/\.h$/.ph/;
189 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
190 print OUT ($t, "my(\@REM);\n");
191 if ($incl_type eq 'include_next') {
193 "my(\%INCD) = map { \$INC{\$_} => 1 } ",
194 "(grep { \$_ eq \"$incl\" } ",
197 "\@REM = map { \"\$_/$incl\" } ",
198 "(grep { not exists(\$INCD{\"\$_/$incl\"})",
199 " and -f \"\$_/$incl\" } \@INC);\n");
202 "\@REM = map { \"\$_/$incl\" } ",
203 "(grep {-r \"\$_/$incl\" } \@INC);\n");
206 "require \"\$REM[0]\" if \@REM;\n");
208 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
212 "warn(\$\@) if \$\@;\n");
214 $incl =~ s/\.h$/.ph/;
215 print OUT $t,"require '$incl';\n";
217 } elsif (/^ifdef\s+(\w+)/) {
218 print OUT $t,"if(defined(&$1)) {\n";
220 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
221 } elsif (/^ifndef\s+(\w+)/) {
222 print OUT $t,"unless(defined(&$1)) {\n";
224 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
225 } elsif (s/^if\s+//) {
230 print OUT $t,"if($new) {\n";
232 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
233 } elsif (s/^elif\s+//) {
239 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
240 print OUT $t,"}\n elsif($new) {\n";
242 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
245 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
246 print OUT $t,"} else {\n";
248 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
251 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
253 } elsif(/^undef\s+(\w+)/) {
254 print OUT $t, "undef(&$1) if defined(&$1);\n";
255 } elsif(/^error\s+(".*")/) {
256 print OUT $t, "die($1);\n";
257 } elsif(/^error\s+(.*)/) {
258 print OUT $t, "die(\"", quotemeta($1), "\");\n";
259 } elsif(/^warning\s+(.*)/) {
260 print OUT $t, "warn(\"", quotemeta($1), "\");\n";
261 } elsif(/^ident\s+(.*)/) {
262 print OUT $t, "# $1\n";
264 } elsif(/^\s*(typedef\s*)?enum\s*(\s+[a-zA-Z_]\w*\s*)?/) {
265 until(/\{[^}]*\}.*;/ || /;/) {
266 last unless defined ($next = next_line($file));
268 # drop "#define FOO FOO" in enums
269 $next =~ s/^\s*#\s*define\s+(\w+)\s+\1\s*$//;
271 print OUT "# $next\n" if $opt_D;
273 s/#\s*if.*?#\s*endif//g; # drop #ifdefs
276 next unless /^\s?(typedef\s?)?enum\s?([a-zA-Z_]\w*)?\s?\{(.*)\}\s?([a-zA-Z_]\w*)?\s?;/;
277 (my $enum_subs = $3) =~ s/\s//g;
278 my @enum_subs = split(/,/, $enum_subs);
280 foreach my $enum (@enum_subs) {
281 my ($enum_name, $enum_value) = $enum =~ /^([a-zA-Z_]\w*)(=.+)?$/;
282 $enum_value =~ s/^=//;
283 $enum_val = (length($enum_value) ? $enum_value : $enum_val + 1);
286 "eval(\"\\n#line $eval_index $outfile\\n",
287 "sub $enum_name () \{ $enum_val; \}\") ",
288 "unless defined(\&$enum_name);\n");
292 "eval(\"sub $enum_name () \{ $enum_val; \}\") ",
293 "unless defined(\&$enum_name);\n");
298 $Is_converted{$file} = 1;
299 if ($opt_e && exists($bad_file{$file})) {
300 unlink($Dest_dir . '/' . $outfile);
304 queue_includes_from($file) if ($opt_a);
308 if ($opt_e && (scalar(keys %bad_file) > 0)) {
309 warn "Was unable to convert the following files:\n";
310 warn "\t" . join("\n\t",sort(keys %bad_file)) . "\n";
318 $joined_args = join('|', keys(%curargs));
321 s/^\&\&// && do { $new .= " &&"; next;}; # handle && operator
322 s/^\&([\(a-z\)]+)/$1/i; # hack for things that take the address of
323 s/^(\s+)// && do {$new .= ' '; next;};
324 s/^0X([0-9A-F]+)[UL]*//i
327 if (length $hex > 8 && !$Config{use64bitint}) {
328 # Croak if nv_preserves_uv_bits < 64 ?
329 $new .= hex(substr($hex, -8)) +
330 2**32 * hex(substr($hex, 0, -8));
331 # The above will produce "errorneus" code
332 # if the hex constant was e.g. inside UINT64_C
333 # macro, but then again, h2ph is an approximation.
335 $new .= lc("0x$hex");
338 s/^(-?\d+\.\d+E[-+]?\d+)[FL]?//i && do {$new .= $1; next;};
339 s/^(\d+)\s*[LU]*//i && do {$new .= $1; next;};
340 s/^("(\\"|[^"])*")// && do {$new .= $1; next;};
341 s/^'((\\"|[^"])*)'// && do {
343 $new .= "ord('\$$1')";
349 # replace "sizeof(foo)" with "{foo}"
350 # also, remove * (C dereference operator) to avoid perl syntax
351 # problems. Where the %sizeof array comes from is anyone's
352 # guess (c2ph?), but this at least avoids fatal syntax errors.
353 # Behavior is undefined if sizeof() delimiters are unbalanced.
354 # This code was modified to able to handle constructs like this:
355 # sizeof(*(p)), which appear in the HP-UX 10.01 header files.
356 s/^sizeof\s*\(// && do {
358 my $lvl = 1; # already saw one open paren
359 # tack { on the front, and skip it in the loop
362 # find balanced closing paren
363 while ($index <= length($_) && $lvl > 0) {
364 $lvl++ if substr($_, $index, 1) eq "(";
365 $lvl-- if substr($_, $index, 1) eq ")";
368 # tack } on the end, replacing )
369 substr($_, $index - 1, 1) = "}";
370 # remove pesky * operators within the sizeof argument
371 substr($_, 0, $index - 1) =~ s/\*//g;
375 /\(([\w\s]+)[\*\s]*\)\s*[\w\(]/ && do {
376 foreach (split /\s+/, $1) { # Make sure all the words are types,
377 last unless ($isatype{$_} or $_ eq 'struct' or $_ eq 'union');
379 s/\([\w\s]+[\*\s]*\)// && next; # then eliminate them.
381 # struct/union member, including arrays:
382 s/^([_A-Z]\w*(\[[^\]]+\])?((\.|->)[_A-Z]\w*(\[[^\]]+\])?)+)//i && do {
384 $id =~ s/(\.|(->))([^\.\-]*)/->\{$3\}/g;
385 $id =~ s/\b([^\$])($joined_args)/$1\$$2/g if length($joined_args);
386 while($id =~ /\[\s*([^\$\&\d\]]+)\]/) {
389 if(exists($curargs{$index})) {
394 $id =~ s/\[\s*([^\$\&\d\]]+)\]/[$index]/;
398 s/^([_a-zA-Z]\w*)// && do {
400 if ($id eq 'struct' || $id eq 'union') {
404 } elsif ($id =~ /^((un)?signed)|(long)|(short)$/) {
405 while (s/^\s+(\w+)//) { $id .= ' ' . $1; }
410 $new .= '->' if /^[\[\{]/;
411 } elsif ($id eq 'defined') {
414 s/^\s*\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/i; # cheat
416 } elsif ($isatype{$id}) {
417 if ($new =~ /{\s*$/) {
419 } elsif ($new =~ /\(\s*$/ && /^[\s*]*\)/) {
423 $new .= q(').$id.q(');
426 if ($inif && $new !~ /defined\s*\($/) {
427 $new .= '(defined(&' . $id . ') ? &' . $id . ' : 0)';
436 s/^(.)// && do { if ($1 ne '#') { $new .= $1; } next;};
445 my $pre_sub_tri_graphs = 1;
447 READ: while (not eof IN) {
450 next unless length $in;
453 if ($pre_sub_tri_graphs) {
454 # Preprocess all tri-graphs
455 # including things stuck in quoted string constants.
456 $in =~ s/\?\?=/#/g; # | ??=| #|
457 $in =~ s/\?\?\!/|/g; # | ??!| ||
458 $in =~ s/\?\?'/^/g; # | ??'| ^|
459 $in =~ s/\?\?\(/[/g; # | ??(| [|
460 $in =~ s/\?\?\)/]/g; # | ??)| ]|
461 $in =~ s/\?\?\-/~/g; # | ??-| ~|
462 $in =~ s/\?\?\//\\/g; # | ??/| \|
463 $in =~ s/\?\?</{/g; # | ??<| {|
464 $in =~ s/\?\?>/}/g; # | ??>| }|
466 if ($in =~ /^\#ifdef __LANGUAGE_PASCAL__/) {
467 # Tru64 disassembler.h evilness: mixed C and Pascal.
473 if ($in =~ /^extern inline / && # Inlined assembler.
474 $^O eq 'linux' && $file =~ m!(?:^|/)asm/[^/]+\.h$!) {
480 if ($in =~ s/\\$//) { # \-newline
483 } elsif ($in =~ s/^([^"'\\\/]+)//) { # Passthrough
485 } elsif ($in =~ s/^(\\.)//) { # \...
487 } elsif ($in =~ s/^('(\\.|[^'\\])*')//) { # '...
489 } elsif ($in =~ s/^("(\\.|[^"\\])*")//) { # "...
491 } elsif ($in =~ s/^\/\/.*//) { # //...
493 } elsif ($in =~ m/^\/\*/) { # /*...
494 # C comment removal adapted from perlfaq6:
495 if ($in =~ s/^\/\*[^*]*\*+([^\/*][^*]*\*+)*\///) {
497 } else { # Incomplete /* */
500 } elsif ($in =~ s/^(\/)//) { # /...
502 } elsif ($in =~ s/^([^\'\"\\\/]+)//) {
504 } elsif ($^O eq 'linux' &&
505 $file =~ m!(?:^|/)linux/byteorder/pdp_endian\.h$! &&
506 $in =~ s!\'T KNOW!!) {
507 $out =~ s!I DON$!I_DO_NOT_KNOW!;
510 warn "Cannot parse $file:\n$in\n";
511 $bad_file{$file} = 1;
516 die "Cannot parse:\n$in\n";
521 last READ if $out =~ /\S/;
528 # Handle recursive subdirectories without getting a grotesquely big stack.
529 # Could this be implemented using File::Find?
537 if ($file eq '-' or -f $file or -l $file) {
543 print STDERR "Skipping directory `$file'\n";
548 print STDERR "Skipping `$file': not a file or directory\n";
556 # Put all the files in $directory into @ARGV for processing.
559 my ($directory) = @_;
561 $directory =~ s:/$::;
563 opendir DIR, $directory;
564 foreach (readdir DIR) {
565 next if ($_ eq '.' or $_ eq '..');
567 # expand_glob() is going to be called until $ARGV[0] isn't a
568 # directory; so push directories, and unshift everything else.
569 if (-d "$directory/$_") { push @ARGV, "$directory/$_" }
570 else { unshift @ARGV, "$directory/$_" }
576 # Given $file, a symbolic link to a directory in the C include directory,
577 # make an equivalent symbolic link in $Dest_dir, if we can figure out how.
578 # Otherwise, just duplicate the file or directory.
582 my $target = eval 'readlink($dirlink)';
584 if ($target =~ m:^\.\./: or $target =~ m:^/:) {
585 # The target of a parent or absolute link could leave the $Dest_dir
586 # hierarchy, so let's put all of the contents of $dirlink (actually,
587 # the contents of $target) into @ARGV; as a side effect down the
588 # line, $dirlink will get created as an _actual_ directory.
589 expand_glob($dirlink);
591 if (-l "$Dest_dir/$dirlink") {
592 unlink "$Dest_dir/$dirlink" or
593 print STDERR "Could not remove link $Dest_dir/$dirlink: $!\n";
596 if (eval 'symlink($target, "$Dest_dir/$dirlink")') {
597 print "Linking $target -> $Dest_dir/$dirlink\n";
599 # Make sure that the link _links_ to something:
600 if (! -e "$Dest_dir/$target") {
601 mkpath("$Dest_dir/$target", 0755) or
602 print STDERR "Could not create $Dest_dir/$target/\n";
605 print STDERR "Could not symlink $target -> $Dest_dir/$dirlink: $!\n";
611 # Push all #included files in $file onto our stack, except for STDIN
612 # and files we've already processed.
613 sub queue_includes_from
618 return if ($file eq "-");
620 open HEADER, $file or return;
621 while (defined($line = <HEADER>)) {
622 while (/\\$/) { # Handle continuation lines
627 if ($line =~ /^#\s*include\s+<(.*?)>/) {
628 push(@ARGV, $1) unless $Is_converted{$1};
635 # Determine include directories; $Config{usrinc} should be enough for (all
636 # non-GCC?) C compilers, but gcc uses an additional include directory.
639 my $from_gcc = `$Config{cc} -v 2>&1`;
640 $from_gcc =~ s:^Reading specs from (.*?)/specs\b.*:$1/include:s;
642 length($from_gcc) ? ($from_gcc, $Config{usrinc}) : ($Config{usrinc});
646 # Create "_h2ph_pre.ph", if it doesn't exist or was built by a different
648 sub build_preamble_if_necessary
650 # Increment $VERSION every time this function is modified:
652 my $preamble = "$Dest_dir/_h2ph_pre.ph";
654 # Can we skip building the preamble file?
656 # Extract version number from first line of preamble:
657 open PREAMBLE, $preamble or die "Cannot open $preamble: $!";
658 my $line = <PREAMBLE>;
659 $line =~ /(\b\d+\b)/;
660 close PREAMBLE or die "Cannot close $preamble: $!";
662 # Don't build preamble if a compatible preamble exists:
663 return if $1 == $VERSION;
666 my (%define) = _extract_cc_defines();
668 open PREAMBLE, ">$preamble" or die "Cannot open $preamble: $!";
669 print PREAMBLE "# This file was created by h2ph version $VERSION\n";
671 foreach (sort keys %define) {
673 print PREAMBLE "# $_=$define{$_}\n";
676 if ($define{$_} =~ /^(\d+)U?L{0,2}$/i) {
678 "unless (defined &$_) { sub $_() { $1 } }\n\n";
679 } elsif ($define{$_} =~ /^\w+$/) {
681 "unless (defined &$_) { sub $_() { &$define{$_} } }\n\n";
684 "unless (defined &$_) { sub $_() { \"",
685 quotemeta($define{$_}), "\" } }\n\n";
688 close PREAMBLE or die "Cannot close $preamble: $!";
692 # %Config contains information on macros that are pre-defined by the
693 # system's compiler. We need this information to make the .ph files
694 # function with perl as the .h files do with cc.
695 sub _extract_cc_defines
698 my $allsymbols = join " ",
699 @Config{'ccsymbols', 'cppsymbols', 'cppccsymbols'};
701 # Split compiler pre-definitions into `key=value' pairs:
702 foreach (split /\s+/, $allsymbols) {
703 /(.+?)=(.+)/ and $define{$1} = $2;
706 print STDERR "$_: $1 -> $2\n";
716 ##############################################################################
721 h2ph - convert .h C header files to .ph Perl header files
725 B<h2ph [-d destination directory] [-r | -a] [-l] [headerfiles]>
730 converts any C header files specified to the corresponding Perl header file
732 It is most easily run while in /usr/include:
734 cd /usr/include; h2ph * sys/*
738 cd /usr/include; h2ph * sys/* arpa/* netinet/*
742 cd /usr/include; h2ph -r -l .
744 The output files are placed in the hierarchy rooted at Perl's
745 architecture dependent library directory. You can specify a different
746 hierarchy with a B<-d> switch.
748 If run with no arguments, filters standard input to standard output.
754 =item -d destination_dir
756 Put the resulting B<.ph> files beneath B<destination_dir>, instead of
757 beneath the default Perl library location (C<$Config{'installsitsearch'}>).
761 Run recursively; if any of B<headerfiles> are directories, then run I<h2ph>
762 on all files in those directories (and their subdirectories, etc.). B<-r>
763 and B<-a> are mutually exclusive.
767 Run automagically; convert B<headerfiles>, as well as any B<.h> files
768 which they include. This option will search for B<.h> files in all
769 directories which your C compiler ordinarily uses. B<-a> and B<-r> are
774 Symbolic links will be replicated in the destination directory. If B<-l>
775 is not specified, then links are skipped over.
779 Put ``hints'' in the .ph files which will help in locating problems with
780 I<h2ph>. In those cases when you B<require> a B<.ph> file containing syntax
781 errors, instead of the cryptic
783 [ some error condition ] at (eval mmm) line nnn
785 you will see the slightly more helpful
787 [ some error condition ] at filename.ph line nnn
789 However, the B<.ph> files almost double in size when built using B<-h>.
793 Include the code from the B<.h> file as a comment in the B<.ph> file.
794 This is primarily used for debugging I<h2ph>.
798 ``Quiet'' mode; don't print out the names of the files being converted.
804 No environment variables are used.
823 The usual warnings if it can't read or write the files involved.
827 Doesn't construct the %sizeof array for you.
829 It doesn't handle all C constructs, but it does attempt to isolate
830 definitions inside evals so that you can get at the definitions
831 that it can translate.
833 It's only intended as a rough tool.
834 You may need to dicker with the files produced.
836 You have to run this program by hand; it's not run as part of the Perl
839 Doesn't handle complicated expressions built piecemeal, a la:
849 Doesn't necessarily locate all of your C compiler's internally-defined
856 close OUT or die "Can't close $file: $!";
857 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
858 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';