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 if (s/^\(([\w,\s]*)\)//) {
123 foreach my $arg (split(/,\s*/,$args)) {
124 $arg =~ s/^\s*([^\s].*[^\s])\s*$/$1/;
127 $args =~ s/\b(\w)/\$$1/g;
128 $args = "local($args) = \@_;\n$t ";
132 $new =~ s/(["\\])/\\$1/g; #"]);
133 $new = reindent($new);
134 $args = reindent($args);
136 $new =~ s/(['\\])/\\$1/g; #']);
139 "eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name $proto\{\n$t ${args}eval q($new);\n$t}' unless defined(\&$name);\n";
143 "eval 'sub $name $proto\{\n$t ${args}eval q($new);\n$t}' unless defined(\&$name);\n";
146 print OUT "unless(defined(\&$name)) {\n sub $name $proto\{\n\t${args}eval q($new);\n }\n}\n";
152 $new = 1 if $new eq '';
153 $new = reindent($new);
154 $args = reindent($args);
156 $new =~ s/(['\\])/\\$1/g; #']);
159 print OUT $t,"eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name () {",$new,";}' unless defined(\&$name);\n";
162 print OUT $t,"eval 'sub $name () {",$new,";}' unless defined(\&$name);\n";
165 # Shunt around such directives as `#define FOO FOO':
166 next if " \&$name" eq $new;
168 print OUT $t,"unless(defined(\&$name)) {\n sub $name () {\t",$new,";}\n}\n";
171 } elsif (/^(include|import)\s*[<"](.*)[>"]/) {
172 ($incl = $2) =~ s/\.h$/.ph/;
173 print OUT $t,"require '$incl';\n";
174 } elsif(/^include_next\s*[<"](.*)[>"]/) {
175 ($incl = $1) =~ s/\.h$/.ph/;
179 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
181 "my(\%INCD) = map { \$INC{\$_} => 1 } ",
182 "(grep { \$_ eq \"$incl\" } keys(\%INC));\n");
184 "my(\@REM) = map { \"\$_/$incl\" } ",
185 "(grep { not exists(\$INCD{\"\$_/$incl\"})",
186 "and -f \"\$_/$incl\" } \@INC);\n");
188 "require \"\$REM[0]\" if \@REM;\n");
190 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
194 "warn(\$\@) if \$\@;\n");
195 } elsif (/^ifdef\s+(\w+)/) {
196 print OUT $t,"if(defined(&$1)) {\n";
198 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
199 } elsif (/^ifndef\s+(\w+)/) {
200 print OUT $t,"unless(defined(&$1)) {\n";
202 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
203 } elsif (s/^if\s+//) {
208 print OUT $t,"if($new) {\n";
210 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
211 } elsif (s/^elif\s+//) {
217 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
218 print OUT $t,"}\n elsif($new) {\n";
220 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
223 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
224 print OUT $t,"} else {\n";
226 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
229 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
231 } elsif(/^undef\s+(\w+)/) {
232 print OUT $t, "undef(&$1) if defined(&$1);\n";
233 } elsif(/^error\s+(".*")/) {
234 print OUT $t, "die($1);\n";
235 } elsif(/^error\s+(.*)/) {
236 print OUT $t, "die(\"", quotemeta($1), "\");\n";
237 } elsif(/^warning\s+(.*)/) {
238 print OUT $t, "warn(\"", quotemeta($1), "\");\n";
239 } elsif(/^ident\s+(.*)/) {
240 print OUT $t, "# $1\n";
242 } elsif(/^\s*(typedef\s*)?enum\s*(\s+[a-zA-Z_]\w*\s*)?/) {
243 until(/\{[^}]*\}.*;/ || /;/) {
244 last unless defined ($next = next_line($file));
246 # drop "#define FOO FOO" in enums
247 $next =~ s/^\s*#\s*define\s+(\w+)\s+\1\s*$//;
249 print OUT "# $next\n" if $opt_D;
251 s/#\s*if.*?#\s*endif//g; # drop #ifdefs
254 next unless /^\s?(typedef\s?)?enum\s?([a-zA-Z_]\w*)?\s?\{(.*)\}\s?([a-zA-Z_]\w*)?\s?;/;
255 (my $enum_subs = $3) =~ s/\s//g;
256 my @enum_subs = split(/,/, $enum_subs);
258 foreach my $enum (@enum_subs) {
259 my ($enum_name, $enum_value) = $enum =~ /^([a-zA-Z_]\w*)(=.+)?$/;
260 $enum_value =~ s/^=//;
261 $enum_val = (length($enum_value) ? $enum_value : $enum_val + 1);
264 "eval(\"\\n#line $eval_index $outfile\\n",
265 "sub $enum_name () \{ $enum_val; \}\") ",
266 "unless defined(\&$enum_name);\n");
270 "eval(\"sub $enum_name () \{ $enum_val; \}\") ",
271 "unless defined(\&$enum_name);\n");
278 $Is_converted{$file} = 1;
279 queue_includes_from($file) if ($opt_a);
296 $joined_args = join('|', keys(%curargs));
299 s/^\&\&// && do { $new .= " &&"; next;}; # handle && operator
300 s/^\&([\(a-z\)]+)/$1/i; # hack for things that take the address of
301 s/^(\s+)// && do {$new .= ' '; next;};
302 s/^(0X[0-9A-F]+)[UL]*//i && do {$new .= lc($1); next;};
303 s/^(-?\d+\.\d+E[-+]?\d+)[FL]?//i && do {$new .= $1; next;};
304 s/^(\d+)\s*[LU]*//i && do {$new .= $1; next;};
305 s/^("(\\"|[^"])*")// && do {$new .= $1; next;};
306 s/^'((\\"|[^"])*)'// && do {
308 $new .= "ord('\$$1')";
314 # replace "sizeof(foo)" with "{foo}"
315 # also, remove * (C dereference operator) to avoid perl syntax
316 # problems. Where the %sizeof array comes from is anyone's
317 # guess (c2ph?), but this at least avoids fatal syntax errors.
318 # Behavior is undefined if sizeof() delimiters are unbalanced.
319 # This code was modified to able to handle constructs like this:
320 # sizeof(*(p)), which appear in the HP-UX 10.01 header files.
321 s/^sizeof\s*\(// && do {
323 my $lvl = 1; # already saw one open paren
324 # tack { on the front, and skip it in the loop
327 # find balanced closing paren
328 while ($index <= length($_) && $lvl > 0) {
329 $lvl++ if substr($_, $index, 1) eq "(";
330 $lvl-- if substr($_, $index, 1) eq ")";
333 # tack } on the end, replacing )
334 substr($_, $index - 1, 1) = "}";
335 # remove pesky * operators within the sizeof argument
336 substr($_, 0, $index - 1) =~ s/\*//g;
340 /\(([\w\s]+)[\*\s]*\)\s*[\w\(]/ && do {
341 foreach (split /\s+/, $1) { # Make sure all the words are types,
342 last unless ($isatype{$_} or $_ eq 'struct' or $_ eq 'union');
344 s/\([\w\s]+[\*\s]*\)// && next; # then eliminate them.
346 # struct/union member, including arrays:
347 s/^([_A-Z]\w*(\[[^\]]+\])?((\.|->)[_A-Z]\w*(\[[^\]]+\])?)+)//i && do {
349 $id =~ s/(\.|(->))([^\.\-]*)/->\{$3\}/g;
350 $id =~ s/\b([^\$])($joined_args)/$1\$$2/g if length($joined_args);
351 while($id =~ /\[\s*([^\$\&\d\]]+)\]/) {
354 if(exists($curargs{$index})) {
359 $id =~ s/\[\s*([^\$\&\d\]]+)\]/[$index]/;
363 s/^([_a-zA-Z]\w*)// && do {
365 if ($id eq 'struct' || $id eq 'union') {
369 } elsif ($id =~ /^((un)?signed)|(long)|(short)$/) {
370 while (s/^\s+(\w+)//) { $id .= ' ' . $1; }
375 $new .= '->' if /^[\[\{]/;
376 } elsif ($id eq 'defined') {
379 s/^\s*\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/i; # cheat
381 } elsif ($isatype{$id}) {
382 if ($new =~ /{\s*$/) {
384 } elsif ($new =~ /\(\s*$/ && /^[\s*]*\)/) {
388 $new .= q(').$id.q(');
391 if ($inif && $new !~ /defined\s*\($/) {
392 $new .= '(defined(&' . $id . ') ? &' . $id . ' : 0)';
401 s/^(.)// && do { if ($1 ne '#') { $new .= $1; } next;};
410 my $pre_sub_tri_graphs = 1;
412 READ: while (not eof IN) {
415 next unless length $in;
418 if ($pre_sub_tri_graphs) {
419 # Preprocess all tri-graphs
420 # including things stuck in quoted string constants.
421 $in =~ s/\?\?=/#/g; # | ??=| #|
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; # | ??>| }|
431 if ($in =~ /^\#ifdef __LANGUAGE_PASCAL__/) {
432 # Tru64 disassembler.h evilness: mixed C and Pascal.
438 if ($in =~ /^extern inline / &&
439 $^O eq 'linux' && $file =~ m!(?:^|/)asm/[^/]+\.h$!) {
445 if ($in =~ s/\\$//) { # \-newline
448 } elsif ($in =~ s/^([^"'\\\/]+)//) { # Passthrough
450 } elsif ($in =~ s/^(\\.)//) { # \...
452 } elsif ($in =~ s/^('(\\.|[^'\\])*')//) { # '...
454 } elsif ($in =~ s/^("(\\.|[^"\\])*")//) { # "...
456 } elsif ($in =~ s/^\/\/.*//) { # //...
458 } elsif ($in =~ m/^\/\*/) { # /*...
459 # C comment removal adapted from perlfaq6:
460 if ($in =~ s/^\/\*[^*]*\*+([^\/*][^*]*\*+)*\///) {
462 } else { # Incomplete /* */
465 } elsif ($in =~ s/^(\/)//) { # /...
467 } elsif ($in =~ s/^([^\'\"\\\/]+)//) {
469 } elsif ($^O eq 'linux' &&
470 $file =~ m!(?:^|/)linux/byteorder/pdp_endian\.h$! &&
471 $in =~ s!\'T KNOW!!) {
472 $out =~ s!I DON$!I_DO_NOT_KNOW!;
474 die "Cannot parse:\n$in\n";
478 last READ if $out =~ /\S/;
485 # Handle recursive subdirectories without getting a grotesquely big stack.
486 # Could this be implemented using File::Find?
494 if ($file eq '-' or -f $file or -l $file) {
500 print STDERR "Skipping directory `$file'\n";
505 print STDERR "Skipping `$file': not a file or directory\n";
513 # Put all the files in $directory into @ARGV for processing.
516 my ($directory) = @_;
518 $directory =~ s:/$::;
520 opendir DIR, $directory;
521 foreach (readdir DIR) {
522 next if ($_ eq '.' or $_ eq '..');
524 # expand_glob() is going to be called until $ARGV[0] isn't a
525 # directory; so push directories, and unshift everything else.
526 if (-d "$directory/$_") { push @ARGV, "$directory/$_" }
527 else { unshift @ARGV, "$directory/$_" }
533 # Given $file, a symbolic link to a directory in the C include directory,
534 # make an equivalent symbolic link in $Dest_dir, if we can figure out how.
535 # Otherwise, just duplicate the file or directory.
539 my $target = eval 'readlink($dirlink)';
541 if ($target =~ m:^\.\./: or $target =~ m:^/:) {
542 # The target of a parent or absolute link could leave the $Dest_dir
543 # hierarchy, so let's put all of the contents of $dirlink (actually,
544 # the contents of $target) into @ARGV; as a side effect down the
545 # line, $dirlink will get created as an _actual_ directory.
546 expand_glob($dirlink);
548 if (-l "$Dest_dir/$dirlink") {
549 unlink "$Dest_dir/$dirlink" or
550 print STDERR "Could not remove link $Dest_dir/$dirlink: $!\n";
553 if (eval 'symlink($target, "$Dest_dir/$dirlink")') {
554 print "Linking $target -> $Dest_dir/$dirlink\n";
556 # Make sure that the link _links_ to something:
557 if (! -e "$Dest_dir/$target") {
558 mkpath("$Dest_dir/$target", 0755) or
559 print STDERR "Could not create $Dest_dir/$target/\n";
562 print STDERR "Could not symlink $target -> $Dest_dir/$dirlink: $!\n";
568 # Push all #included files in $file onto our stack, except for STDIN
569 # and files we've already processed.
570 sub queue_includes_from
575 return if ($file eq "-");
577 open HEADER, $file or return;
578 while (defined($line = <HEADER>)) {
579 while (/\\$/) { # Handle continuation lines
584 if ($line =~ /^#\s*include\s+<(.*?)>/) {
585 push(@ARGV, $1) unless $Is_converted{$1};
592 # Determine include directories; $Config{usrinc} should be enough for (all
593 # non-GCC?) C compilers, but gcc uses an additional include directory.
596 my $from_gcc = `$Config{cc} -v 2>&1`;
597 $from_gcc =~ s:^Reading specs from (.*?)/specs\b.*:$1/include:s;
599 length($from_gcc) ? ($from_gcc, $Config{usrinc}) : ($Config{usrinc});
603 # Create "_h2ph_pre.ph", if it doesn't exist or was built by a different
605 sub build_preamble_if_necessary
607 # Increment $VERSION every time this function is modified:
609 my $preamble = "$Dest_dir/_h2ph_pre.ph";
611 # Can we skip building the preamble file?
613 # Extract version number from first line of preamble:
614 open PREAMBLE, $preamble or die "Cannot open $preamble: $!";
615 my $line = <PREAMBLE>;
616 $line =~ /(\b\d+\b)/;
617 close PREAMBLE or die "Cannot close $preamble: $!";
619 # Don't build preamble if a compatible preamble exists:
620 return if $1 == $VERSION;
623 my (%define) = _extract_cc_defines();
625 open PREAMBLE, ">$preamble" or die "Cannot open $preamble: $!";
626 print PREAMBLE "# This file was created by h2ph version $VERSION\n";
628 foreach (sort keys %define) {
630 print PREAMBLE "# $_=$define{$_}\n";
633 if ($define{$_} =~ /^(\d+)U?L{0,2}$/i) {
635 "unless (defined &$_) { sub $_() { $1 } }\n\n";
636 } elsif ($define{$_} =~ /^\w+$/) {
638 "unless (defined &$_) { sub $_() { &$define{$_} } }\n\n";
641 "unless (defined &$_) { sub $_() { \"",
642 quotemeta($define{$_}), "\" } }\n\n";
645 close PREAMBLE or die "Cannot close $preamble: $!";
649 # %Config contains information on macros that are pre-defined by the
650 # system's compiler. We need this information to make the .ph files
651 # function with perl as the .h files do with cc.
652 sub _extract_cc_defines
655 my $allsymbols = join " ",
656 @Config{'ccsymbols', 'cppsymbols', 'cppccsymbols'};
658 # Split compiler pre-definitions into `key=value' pairs:
659 foreach (split /\s+/, $allsymbols) {
660 /(.+?)=(.+)/ and $define{$1} = $2;
663 print STDERR "$_: $1 -> $2\n";
673 ##############################################################################
678 h2ph - convert .h C header files to .ph Perl header files
682 B<h2ph [-d destination directory] [-r | -a] [-l] [headerfiles]>
687 converts any C header files specified to the corresponding Perl header file
689 It is most easily run while in /usr/include:
691 cd /usr/include; h2ph * sys/*
695 cd /usr/include; h2ph * sys/* arpa/* netinet/*
699 cd /usr/include; h2ph -r -l .
701 The output files are placed in the hierarchy rooted at Perl's
702 architecture dependent library directory. You can specify a different
703 hierarchy with a B<-d> switch.
705 If run with no arguments, filters standard input to standard output.
711 =item -d destination_dir
713 Put the resulting B<.ph> files beneath B<destination_dir>, instead of
714 beneath the default Perl library location (C<$Config{'installsitsearch'}>).
718 Run recursively; if any of B<headerfiles> are directories, then run I<h2ph>
719 on all files in those directories (and their subdirectories, etc.). B<-r>
720 and B<-a> are mutually exclusive.
724 Run automagically; convert B<headerfiles>, as well as any B<.h> files
725 which they include. This option will search for B<.h> files in all
726 directories which your C compiler ordinarily uses. B<-a> and B<-r> are
731 Symbolic links will be replicated in the destination directory. If B<-l>
732 is not specified, then links are skipped over.
736 Put ``hints'' in the .ph files which will help in locating problems with
737 I<h2ph>. In those cases when you B<require> a B<.ph> file containing syntax
738 errors, instead of the cryptic
740 [ some error condition ] at (eval mmm) line nnn
742 you will see the slightly more helpful
744 [ some error condition ] at filename.ph line nnn
746 However, the B<.ph> files almost double in size when built using B<-h>.
750 Include the code from the B<.h> file as a comment in the B<.ph> file.
751 This is primarily used for debugging I<h2ph>.
755 ``Quiet'' mode; don't print out the names of the files being converted.
761 No environment variables are used.
780 The usual warnings if it can't read or write the files involved.
784 Doesn't construct the %sizeof array for you.
786 It doesn't handle all C constructs, but it does attempt to isolate
787 definitions inside evals so that you can get at the definitions
788 that it can translate.
790 It's only intended as a rough tool.
791 You may need to dicker with the files produced.
793 You have to run this program by hand; it's not run as part of the Perl
796 Doesn't handle complicated expressions built piecemeal, a la:
806 Doesn't necessarily locate all of your C compiler's internally-defined
813 close OUT or die "Can't close $file: $!";
814 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
815 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';