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);
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;
69 @ARGV = ('-') unless @ARGV;
71 build_preamble_if_necessary();
73 my ($t, $tab, %curargs, $new, $eval_index, $dir, $name, $args, $outfile);
75 while (defined (my $file = next_file())) {
76 if (-l $file and -d $file) {
77 link_if_possible($file) if ($opt_l);
81 # Recover from header files with unbalanced cpp directives
85 # $eval_index goes into ``#line'' directives, to help locate syntax errors:
92 ($outfile = $file) =~ s/\.h$/.ph/ || next;
93 print "$file -> $outfile\n" unless $opt_Q;
94 if ($file =~ m|^(.*)/|) {
96 mkpath "$Dest_dir/$dir";
99 if ($opt_a) { # automagic mode: locate header file in @inc_dirs
100 foreach (@inc_dirs) {
106 open(IN,"$file") || (($Exit = 1),(warn "Can't open $file: $!\n"),next);
107 open(OUT,">$Dest_dir/$outfile") || die "Can't create $outfile: $!\n";
110 print OUT "require '_h2ph_pre.ph';\n\n";
112 while (defined (local $_ = next_line($file))) {
114 if (s/^define\s+(\w+)//) {
118 s/\(\w+\s*\(\*\)\s*\(\w*\)\)\s*(-?\d+)/$1/; # (int (*)(foo_t))0
119 if (s/^\(([\w,\s]*)\)//) {
124 foreach my $arg (split(/,\s*/,$args)) {
125 $arg =~ s/^\s*([^\s].*[^\s])\s*$/$1/;
128 $args =~ s/\b(\w)/\$$1/g;
129 $args = "local($args) = \@_;\n$t ";
133 $new =~ s/(["\\])/\\$1/g; #"]);
134 $new = reindent($new);
135 $args = reindent($args);
137 $new =~ s/(['\\])/\\$1/g; #']);
140 "eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name $proto\{\n$t ${args}eval q($new);\n$t}' unless defined(\&$name);\n";
144 "eval 'sub $name $proto\{\n$t ${args}eval q($new);\n$t}' unless defined(\&$name);\n";
147 print OUT "unless(defined(\&$name)) {\n sub $name $proto\{\n\t${args}eval q($new);\n }\n}\n";
153 $new = 1 if $new eq '';
154 $new = reindent($new);
155 $args = reindent($args);
157 $new =~ s/(['\\])/\\$1/g; #']);
160 print OUT $t,"eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name () {",$new,";}' unless defined(\&$name);\n";
163 print OUT $t,"eval 'sub $name () {",$new,";}' unless defined(\&$name);\n";
166 # Shunt around such directives as `#define FOO FOO':
167 next if " \&$name" eq $new;
169 print OUT $t,"unless(defined(\&$name)) {\n sub $name () {\t",$new,";}\n}\n";
172 } elsif (/^(include|import)\s*[<"](.*)[>"]/) {
173 ($incl = $2) =~ s/\.h$/.ph/;
174 print OUT $t,"require '$incl';\n";
175 } elsif(/^include_next\s*[<"](.*)[>"]/) {
176 ($incl = $1) =~ s/\.h$/.ph/;
180 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
182 "my(\%INCD) = map { \$INC{\$_} => 1 } ",
183 "(grep { \$_ eq \"$incl\" } keys(\%INC));\n");
185 "my(\@REM) = map { \"\$_/$incl\" } ",
186 "(grep { not exists(\$INCD{\"\$_/$incl\"})",
187 "and -f \"\$_/$incl\" } \@INC);\n");
189 "require \"\$REM[0]\" if \@REM;\n");
191 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
195 "warn(\$\@) if \$\@;\n");
196 } elsif (/^ifdef\s+(\w+)/) {
197 print OUT $t,"if(defined(&$1)) {\n";
199 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
200 } elsif (/^ifndef\s+(\w+)/) {
201 print OUT $t,"unless(defined(&$1)) {\n";
203 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
204 } elsif (s/^if\s+//) {
209 print OUT $t,"if($new) {\n";
211 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
212 } elsif (s/^elif\s+//) {
218 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
219 print OUT $t,"}\n elsif($new) {\n";
221 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
224 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
225 print OUT $t,"} else {\n";
227 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
230 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
232 } elsif(/^undef\s+(\w+)/) {
233 print OUT $t, "undef(&$1) if defined(&$1);\n";
234 } elsif(/^error\s+(".*")/) {
235 print OUT $t, "die($1);\n";
236 } elsif(/^error\s+(.*)/) {
237 print OUT $t, "die(\"", quotemeta($1), "\");\n";
238 } elsif(/^warning\s+(.*)/) {
239 print OUT $t, "warn(\"", quotemeta($1), "\");\n";
240 } elsif(/^ident\s+(.*)/) {
241 print OUT $t, "# $1\n";
243 } elsif(/^\s*(typedef\s*)?enum\s*(\s+[a-zA-Z_]\w*\s*)?/) {
244 until(/\{[^}]*\}.*;/ || /;/) {
245 last unless defined ($next = next_line($file));
247 # drop "#define FOO FOO" in enums
248 $next =~ s/^\s*#\s*define\s+(\w+)\s+\1\s*$//;
250 print OUT "# $next\n" if $opt_D;
252 s/#\s*if.*?#\s*endif//g; # drop #ifdefs
255 next unless /^\s?(typedef\s?)?enum\s?([a-zA-Z_]\w*)?\s?\{(.*)\}\s?([a-zA-Z_]\w*)?\s?;/;
256 (my $enum_subs = $3) =~ s/\s//g;
257 my @enum_subs = split(/,/, $enum_subs);
259 foreach my $enum (@enum_subs) {
260 my ($enum_name, $enum_value) = $enum =~ /^([a-zA-Z_]\w*)(=.+)?$/;
261 $enum_value =~ s/^=//;
262 $enum_val = (length($enum_value) ? $enum_value : $enum_val + 1);
265 "eval(\"\\n#line $eval_index $outfile\\n",
266 "sub $enum_name () \{ $enum_val; \}\") ",
267 "unless defined(\&$enum_name);\n");
271 "eval(\"sub $enum_name () \{ $enum_val; \}\") ",
272 "unless defined(\&$enum_name);\n");
279 $Is_converted{$file} = 1;
280 queue_includes_from($file) if ($opt_a);
297 $joined_args = join('|', keys(%curargs));
300 s/^\&\&// && do { $new .= " &&"; next;}; # handle && operator
301 s/^\&([\(a-z\)]+)/$1/i; # hack for things that take the address of
302 s/^(\s+)// && do {$new .= ' '; next;};
303 s/^(0X[0-9A-F]+)[UL]*//i && do {$new .= lc($1); next;};
304 s/^(-?\d+\.\d+E[-+]?\d+)[FL]?//i && do {$new .= $1; next;};
305 s/^(\d+)\s*[LU]*//i && do {$new .= $1; next;};
306 s/^("(\\"|[^"])*")// && do {$new .= $1; next;};
307 s/^'((\\"|[^"])*)'// && do {
309 $new .= "ord('\$$1')";
315 # replace "sizeof(foo)" with "{foo}"
316 # also, remove * (C dereference operator) to avoid perl syntax
317 # problems. Where the %sizeof array comes from is anyone's
318 # guess (c2ph?), but this at least avoids fatal syntax errors.
319 # Behavior is undefined if sizeof() delimiters are unbalanced.
320 # This code was modified to able to handle constructs like this:
321 # sizeof(*(p)), which appear in the HP-UX 10.01 header files.
322 s/^sizeof\s*\(// && do {
324 my $lvl = 1; # already saw one open paren
325 # tack { on the front, and skip it in the loop
328 # find balanced closing paren
329 while ($index <= length($_) && $lvl > 0) {
330 $lvl++ if substr($_, $index, 1) eq "(";
331 $lvl-- if substr($_, $index, 1) eq ")";
334 # tack } on the end, replacing )
335 substr($_, $index - 1, 1) = "}";
336 # remove pesky * operators within the sizeof argument
337 substr($_, 0, $index - 1) =~ s/\*//g;
341 /\(([\w\s]+)[\*\s]*\)\s*[\w\(]/ && do {
342 foreach (split /\s+/, $1) { # Make sure all the words are types,
343 last unless ($isatype{$_} or $_ eq 'struct' or $_ eq 'union');
345 s/\([\w\s]+[\*\s]*\)// && next; # then eliminate them.
347 # struct/union member, including arrays:
348 s/^([_A-Z]\w*(\[[^\]]+\])?((\.|->)[_A-Z]\w*(\[[^\]]+\])?)+)//i && do {
350 $id =~ s/(\.|(->))([^\.\-]*)/->\{$3\}/g;
351 $id =~ s/\b([^\$])($joined_args)/$1\$$2/g if length($joined_args);
352 while($id =~ /\[\s*([^\$\&\d\]]+)\]/) {
355 if(exists($curargs{$index})) {
360 $id =~ s/\[\s*([^\$\&\d\]]+)\]/[$index]/;
364 s/^([_a-zA-Z]\w*)// && do {
366 if ($id eq 'struct' || $id eq 'union') {
370 } elsif ($id =~ /^((un)?signed)|(long)|(short)$/) {
371 while (s/^\s+(\w+)//) { $id .= ' ' . $1; }
376 $new .= '->' if /^[\[\{]/;
377 } elsif ($id eq 'defined') {
380 s/^\s*\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/i; # cheat
382 } elsif ($isatype{$id}) {
383 if ($new =~ /{\s*$/) {
385 } elsif ($new =~ /\(\s*$/ && /^[\s*]*\)/) {
389 $new .= q(').$id.q(');
392 if ($inif && $new !~ /defined\s*\($/) {
393 $new .= '(defined(&' . $id . ') ? &' . $id . ' : 0)';
402 s/^(.)// && do { if ($1 ne '#') { $new .= $1; } next;};
411 my $pre_sub_tri_graphs = 1;
413 READ: while (not eof IN) {
416 next unless length $in;
419 if ($pre_sub_tri_graphs) {
420 # Preprocess all tri-graphs
421 # including things stuck in quoted string constants.
422 $in =~ s/\?\?=/#/g; # | ??=| #|
423 $in =~ s/\?\?\!/|/g; # | ??!| ||
424 $in =~ s/\?\?'/^/g; # | ??'| ^|
425 $in =~ s/\?\?\(/[/g; # | ??(| [|
426 $in =~ s/\?\?\)/]/g; # | ??)| ]|
427 $in =~ s/\?\?\-/~/g; # | ??-| ~|
428 $in =~ s/\?\?\//\\/g; # | ??/| \|
429 $in =~ s/\?\?</{/g; # | ??<| {|
430 $in =~ s/\?\?>/}/g; # | ??>| }|
432 if ($in =~ /^\#ifdef __LANGUAGE_PASCAL__/) {
433 # Tru64 disassembler.h evilness: mixed C and Pascal.
439 if ($in =~ /^extern inline / &&
440 $^O eq 'linux' && $file =~ m!(?:^|/)asm/[^/]+\.h$!) {
446 if ($in =~ s/\\$//) { # \-newline
449 } elsif ($in =~ s/^([^"'\\\/]+)//) { # Passthrough
451 } elsif ($in =~ s/^(\\.)//) { # \...
453 } elsif ($in =~ s/^('(\\.|[^'\\])*')//) { # '...
455 } elsif ($in =~ s/^("(\\.|[^"\\])*")//) { # "...
457 } elsif ($in =~ s/^\/\/.*//) { # //...
459 } elsif ($in =~ m/^\/\*/) { # /*...
460 # C comment removal adapted from perlfaq6:
461 if ($in =~ s/^\/\*[^*]*\*+([^\/*][^*]*\*+)*\///) {
463 } else { # Incomplete /* */
466 } elsif ($in =~ s/^(\/)//) { # /...
468 } elsif ($in =~ s/^([^\'\"\\\/]+)//) {
470 } elsif ($^O eq 'linux' &&
471 $file =~ m!(?:^|/)linux/byteorder/pdp_endian\.h$! &&
472 $in =~ s!\'T KNOW!!) {
473 $out =~ s!I DON$!I_DO_NOT_KNOW!;
475 die "Cannot parse:\n$in\n";
479 last READ if $out =~ /\S/;
486 # Handle recursive subdirectories without getting a grotesquely big stack.
487 # Could this be implemented using File::Find?
495 if ($file eq '-' or -f $file or -l $file) {
501 print STDERR "Skipping directory `$file'\n";
506 print STDERR "Skipping `$file': not a file or directory\n";
514 # Put all the files in $directory into @ARGV for processing.
517 my ($directory) = @_;
519 $directory =~ s:/$::;
521 opendir DIR, $directory;
522 foreach (readdir DIR) {
523 next if ($_ eq '.' or $_ eq '..');
525 # expand_glob() is going to be called until $ARGV[0] isn't a
526 # directory; so push directories, and unshift everything else.
527 if (-d "$directory/$_") { push @ARGV, "$directory/$_" }
528 else { unshift @ARGV, "$directory/$_" }
534 # Given $file, a symbolic link to a directory in the C include directory,
535 # make an equivalent symbolic link in $Dest_dir, if we can figure out how.
536 # Otherwise, just duplicate the file or directory.
540 my $target = eval 'readlink($dirlink)';
542 if ($target =~ m:^\.\./: or $target =~ m:^/:) {
543 # The target of a parent or absolute link could leave the $Dest_dir
544 # hierarchy, so let's put all of the contents of $dirlink (actually,
545 # the contents of $target) into @ARGV; as a side effect down the
546 # line, $dirlink will get created as an _actual_ directory.
547 expand_glob($dirlink);
549 if (-l "$Dest_dir/$dirlink") {
550 unlink "$Dest_dir/$dirlink" or
551 print STDERR "Could not remove link $Dest_dir/$dirlink: $!\n";
554 if (eval 'symlink($target, "$Dest_dir/$dirlink")') {
555 print "Linking $target -> $Dest_dir/$dirlink\n";
557 # Make sure that the link _links_ to something:
558 if (! -e "$Dest_dir/$target") {
559 mkpath("$Dest_dir/$target", 0755) or
560 print STDERR "Could not create $Dest_dir/$target/\n";
563 print STDERR "Could not symlink $target -> $Dest_dir/$dirlink: $!\n";
569 # Push all #included files in $file onto our stack, except for STDIN
570 # and files we've already processed.
571 sub queue_includes_from
576 return if ($file eq "-");
578 open HEADER, $file or return;
579 while (defined($line = <HEADER>)) {
580 while (/\\$/) { # Handle continuation lines
585 if ($line =~ /^#\s*include\s+<(.*?)>/) {
586 push(@ARGV, $1) unless $Is_converted{$1};
593 # Determine include directories; $Config{usrinc} should be enough for (all
594 # non-GCC?) C compilers, but gcc uses an additional include directory.
597 my $from_gcc = `$Config{cc} -v 2>&1`;
598 $from_gcc =~ s:^Reading specs from (.*?)/specs\b.*:$1/include:s;
600 length($from_gcc) ? ($from_gcc, $Config{usrinc}) : ($Config{usrinc});
604 # Create "_h2ph_pre.ph", if it doesn't exist or was built by a different
606 sub build_preamble_if_necessary
608 # Increment $VERSION every time this function is modified:
610 my $preamble = "$Dest_dir/_h2ph_pre.ph";
612 # Can we skip building the preamble file?
614 # Extract version number from first line of preamble:
615 open PREAMBLE, $preamble or die "Cannot open $preamble: $!";
616 my $line = <PREAMBLE>;
617 $line =~ /(\b\d+\b)/;
618 close PREAMBLE or die "Cannot close $preamble: $!";
620 # Don't build preamble if a compatible preamble exists:
621 return if $1 == $VERSION;
624 my (%define) = _extract_cc_defines();
626 open PREAMBLE, ">$preamble" or die "Cannot open $preamble: $!";
627 print PREAMBLE "# This file was created by h2ph version $VERSION\n";
629 foreach (sort keys %define) {
631 print PREAMBLE "# $_=$define{$_}\n";
634 if ($define{$_} =~ /^(\d+)U?L{0,2}$/i) {
636 "unless (defined &$_) { sub $_() { $1 } }\n\n";
637 } elsif ($define{$_} =~ /^\w+$/) {
639 "unless (defined &$_) { sub $_() { &$define{$_} } }\n\n";
642 "unless (defined &$_) { sub $_() { \"",
643 quotemeta($define{$_}), "\" } }\n\n";
646 close PREAMBLE or die "Cannot close $preamble: $!";
650 # %Config contains information on macros that are pre-defined by the
651 # system's compiler. We need this information to make the .ph files
652 # function with perl as the .h files do with cc.
653 sub _extract_cc_defines
656 my $allsymbols = join " ",
657 @Config{'ccsymbols', 'cppsymbols', 'cppccsymbols'};
659 # Split compiler pre-definitions into `key=value' pairs:
660 foreach (split /\s+/, $allsymbols) {
661 /(.+?)=(.+)/ and $define{$1} = $2;
664 print STDERR "$_: $1 -> $2\n";
674 ##############################################################################
679 h2ph - convert .h C header files to .ph Perl header files
683 B<h2ph [-d destination directory] [-r | -a] [-l] [headerfiles]>
688 converts any C header files specified to the corresponding Perl header file
690 It is most easily run while in /usr/include:
692 cd /usr/include; h2ph * sys/*
696 cd /usr/include; h2ph * sys/* arpa/* netinet/*
700 cd /usr/include; h2ph -r -l .
702 The output files are placed in the hierarchy rooted at Perl's
703 architecture dependent library directory. You can specify a different
704 hierarchy with a B<-d> switch.
706 If run with no arguments, filters standard input to standard output.
712 =item -d destination_dir
714 Put the resulting B<.ph> files beneath B<destination_dir>, instead of
715 beneath the default Perl library location (C<$Config{'installsitsearch'}>).
719 Run recursively; if any of B<headerfiles> are directories, then run I<h2ph>
720 on all files in those directories (and their subdirectories, etc.). B<-r>
721 and B<-a> are mutually exclusive.
725 Run automagically; convert B<headerfiles>, as well as any B<.h> files
726 which they include. This option will search for B<.h> files in all
727 directories which your C compiler ordinarily uses. B<-a> and B<-r> are
732 Symbolic links will be replicated in the destination directory. If B<-l>
733 is not specified, then links are skipped over.
737 Put ``hints'' in the .ph files which will help in locating problems with
738 I<h2ph>. In those cases when you B<require> a B<.ph> file containing syntax
739 errors, instead of the cryptic
741 [ some error condition ] at (eval mmm) line nnn
743 you will see the slightly more helpful
745 [ some error condition ] at filename.ph line nnn
747 However, the B<.ph> files almost double in size when built using B<-h>.
751 Include the code from the B<.h> file as a comment in the B<.ph> file.
752 This is primarily used for debugging I<h2ph>.
756 ``Quiet'' mode; don't print out the names of the files being converted.
762 No environment variables are used.
781 The usual warnings if it can't read or write the files involved.
785 Doesn't construct the %sizeof array for you.
787 It doesn't handle all C constructs, but it does attempt to isolate
788 definitions inside evals so that you can get at the definitions
789 that it can translate.
791 It's only intended as a rough tool.
792 You may need to dicker with the files produced.
794 You have to run this program by hand; it's not run as part of the Perl
797 Doesn't handle complicated expressions built piecemeal, a la:
807 Doesn't necessarily locate all of your C compiler's internally-defined
814 close OUT or die "Can't close $file: $!";
815 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
816 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';