xref: /openbsd-src/gnu/usr.bin/perl/utils/h2ph.PL (revision a28daedfc357b214be5c701aa8ba8adb29a7f1c2) 
1#!/usr/local/bin/perl
2
3use Config;
4use File::Basename qw(basename dirname);
5use Cwd;
6
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
11#  $startperl
12# to ensure Configure will look for $Config{startperl}.
13# Wanted:  $archlibexp
14
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.
17$origdir = cwd;
18chdir dirname($0);
19$file = basename($0, '.PL');
20$file .= '.com' if $^O eq 'VMS';
21
22open OUT,">$file" or die "Can't create $file: $!";
23
24print "Extracting $file (with variable substitutions)\n";
25
26# In this section, perl variables will be expanded during extraction.
27# You can use $Config{...} to use Configure variables.
28
29print OUT <<"!GROK!THIS!";
30$Config{startperl}
31    eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
32	if \$running_under_some_shell;
33!GROK!THIS!
34
35# In the following, perl variables are not expanded during extraction.
36
37print OUT <<'!NO!SUBS!';
38
39use strict;
40
41use Config;
42use File::Path qw(mkpath);
43use Getopt::Std;
44
45# Make sure read permissions for all are set:
46if (defined umask && (umask() & 0444)) {
47    umask (umask() & ~0444);
48}
49
50getopts('Dd:rlhaQe');
51use vars qw($opt_D $opt_d $opt_r $opt_l $opt_h $opt_a $opt_Q $opt_e);
52die "-r and -a options are mutually exclusive\n" if ($opt_r and $opt_a);
53my @inc_dirs = inc_dirs() if $opt_a;
54
55my $Exit = 0;
56
57my $Dest_dir = $opt_d || $Config{installsitearch};
58die "Destination directory $Dest_dir doesn't exist or isn't a directory\n"
59    unless -d $Dest_dir;
60
61my @isatype = qw(
62	char	uchar	u_char
63	short	ushort	u_short
64	int	uint	u_int
65	long	ulong	u_long
66	FILE	key_t	caddr_t
67	float	double	size_t
68);
69
70my %isatype;
71@isatype{@isatype} = (1) x @isatype;
72my $inif = 0;
73my %Is_converted;
74my %bad_file = ();
75
76@ARGV = ('-') unless @ARGV;
77
78build_preamble_if_necessary();
79
80sub reindent($) {
81    my($text) = shift;
82    $text =~ s/\n/\n    /g;
83    $text =~ s/        /\t/g;
84    $text;
85}
86
87my ($t, $tab, %curargs, $new, $eval_index, $dir, $name, $args, $outfile);
88my ($incl, $incl_type, $next);
89while (defined (my $file = next_file())) {
90    if (-l $file and -d $file) {
91        link_if_possible($file) if ($opt_l);
92        next;
93    }
94
95    # Recover from header files with unbalanced cpp directives
96    $t = '';
97    $tab = 0;
98
99    # $eval_index goes into ``#line'' directives, to help locate syntax errors:
100    $eval_index = 1;
101
102    if ($file eq '-') {
103	open(IN, "-");
104	open(OUT, ">-");
105    } else {
106	($outfile = $file) =~ s/\.h$/.ph/ || next;
107	print "$file -> $outfile\n" unless $opt_Q;
108	if ($file =~ m|^(.*)/|) {
109	    $dir = $1;
110	    mkpath "$Dest_dir/$dir";
111	}
112
113	if ($opt_a) { # automagic mode:  locate header file in @inc_dirs
114	    foreach (@inc_dirs) {
115		chdir $_;
116		last if -f $file;
117	    }
118	}
119
120	open(IN,"$file") || (($Exit = 1),(warn "Can't open $file: $!\n"),next);
121	open(OUT,">$Dest_dir/$outfile") || die "Can't create $outfile: $!\n";
122    }
123
124    print OUT
125        "require '_h2ph_pre.ph';\n\n",
126        "no warnings 'redefine';\n\n";
127
128    while (defined (local $_ = next_line($file))) {
129	if (s/^\s*\#\s*//) {
130	    if (s/^define\s+(\w+)//) {
131		$name = $1;
132		$new = '';
133		s/\s+$//;
134		s/\(\w+\s*\(\*\)\s*\(\w*\)\)\s*(-?\d+)/$1/; # (int (*)(foo_t))0
135		if (s/^\(([\w,\s]*)\)//) {
136		    $args = $1;
137		    my $proto = '() ';
138		    if ($args ne '') {
139			$proto = '';
140			foreach my $arg (split(/,\s*/,$args)) {
141			    $arg =~ s/^\s*([^\s].*[^\s])\s*$/$1/;
142			    $curargs{$arg} = 1;
143			}
144			$args =~ s/\b(\w)/\$$1/g;
145			$args = "my($args) = \@_;\n$t    ";
146		    }
147		    s/^\s+//;
148		    expr();
149		    $new =~ s/(["\\])/\\$1/g;       #"]);
150		  EMIT:
151		    $new = reindent($new);
152		    $args = reindent($args);
153		    if ($t ne '') {
154			$new =~ s/(['\\])/\\$1/g;   #']);
155			if ($opt_h) {
156			    print OUT $t,
157                            "eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name $proto\{\n$t    ${args}eval q($new);\n$t}' unless defined(\&$name);\n";
158                            $eval_index++;
159			} else {
160			    print OUT $t,
161                            "eval 'sub $name $proto\{\n$t    ${args}eval q($new);\n$t}' unless defined(\&$name);\n";
162			}
163		    } else {
164                      print OUT "unless(defined(\&$name)) {\n    sub $name $proto\{\n\t${args}eval q($new);\n    }\n}\n";
165		    }
166		    %curargs = ();
167		} else {
168		    s/^\s+//;
169		    expr();
170		    $new = 1 if $new eq '';
171		    $new = reindent($new);
172		    $args = reindent($args);
173		    if ($t ne '') {
174			$new =~ s/(['\\])/\\$1/g;        #']);
175
176			if ($opt_h) {
177			    print OUT $t,"eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name () {",$new,";}' unless defined(\&$name);\n";
178			    $eval_index++;
179			} else {
180			    print OUT $t,"eval 'sub $name () {",$new,";}' unless defined(\&$name);\n";
181			}
182		    } else {
183		    	# Shunt around such directives as `#define FOO FOO':
184		    	next if " \&$name" eq $new;
185
186                      print OUT $t,"unless(defined(\&$name)) {\n    sub $name () {\t",$new,";}\n}\n";
187		    }
188		}
189	    } elsif (/^(include|import|include_next)\s*[<\"](.*)[>\"]/) {
190                $incl_type = $1;
191                $incl = $2;
192                if (($incl_type eq 'include_next') ||
193                    ($opt_e && exists($bad_file{$incl}))) {
194                    $incl =~ s/\.h$/.ph/;
195		print OUT ($t,
196			   "eval {\n");
197                $tab += 4;
198                $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
199                    print OUT ($t, "my(\@REM);\n");
200                    if ($incl_type eq 'include_next') {
201		print OUT ($t,
202			   "my(\%INCD) = map { \$INC{\$_} => 1 } ",
203			           "(grep { \$_ eq \"$incl\" } ",
204                                   "keys(\%INC));\n");
205		print OUT ($t,
206			           "\@REM = map { \"\$_/$incl\" } ",
207			   "(grep { not exists(\$INCD{\"\$_/$incl\"})",
208			           " and -f \"\$_/$incl\" } \@INC);\n");
209                    } else {
210                        print OUT ($t,
211                                   "\@REM = map { \"\$_/$incl\" } ",
212                                   "(grep {-r \"\$_/$incl\" } \@INC);\n");
213                    }
214		print OUT ($t,
215			   "require \"\$REM[0]\" if \@REM;\n");
216                $tab -= 4;
217                $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
218                print OUT ($t,
219			   "};\n");
220		print OUT ($t,
221			   "warn(\$\@) if \$\@;\n");
222                } else {
223                    $incl =~ s/\.h$/.ph/;
224		    print OUT $t,"require '$incl';\n";
225                }
226	    } elsif (/^ifdef\s+(\w+)/) {
227		print OUT $t,"if(defined(&$1)) {\n";
228		$tab += 4;
229		$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
230	    } elsif (/^ifndef\s+(\w+)/) {
231		print OUT $t,"unless(defined(&$1)) {\n";
232		$tab += 4;
233		$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
234	    } elsif (s/^if\s+//) {
235		$new = '';
236		$inif = 1;
237		expr();
238		$inif = 0;
239		print OUT $t,"if($new) {\n";
240		$tab += 4;
241		$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
242	    } elsif (s/^elif\s+//) {
243		$new = '';
244		$inif = 1;
245		expr();
246		$inif = 0;
247		$tab -= 4;
248		$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
249		print OUT $t,"}\n elsif($new) {\n";
250		$tab += 4;
251		$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
252	    } elsif (/^else/) {
253		$tab -= 4;
254		$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
255		print OUT $t,"} else {\n";
256		$tab += 4;
257		$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
258	    } elsif (/^endif/) {
259		$tab -= 4;
260		$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
261		print OUT $t,"}\n";
262	    } elsif(/^undef\s+(\w+)/) {
263		print OUT $t, "undef(&$1) if defined(&$1);\n";
264	    } elsif(/^error\s+(".*")/) {
265		print OUT $t, "die($1);\n";
266	    } elsif(/^error\s+(.*)/) {
267		print OUT $t, "die(\"", quotemeta($1), "\");\n";
268	    } elsif(/^warning\s+(.*)/) {
269		print OUT $t, "warn(\"", quotemeta($1), "\");\n";
270	    } elsif(/^ident\s+(.*)/) {
271		print OUT $t, "# $1\n";
272	    }
273	} elsif (/^\s*(typedef\s*)?enum\s*(\s+[a-zA-Z_]\w*\s*)?/) { # { for vi
274	    until(/\{[^}]*\}.*;/ || /;/) {
275		last unless defined ($next = next_line($file));
276		chomp $next;
277		# drop "#define FOO FOO" in enums
278		$next =~ s/^\s*#\s*define\s+(\w+)\s+\1\s*$//;
279		# #defines in enums (aliases)
280		$next =~ s/^\s*#\s*define\s+(\w+)\s+(\w+)\s*$/$1 = $2,/;
281		$_ .= $next;
282		print OUT "# $next\n" if $opt_D;
283	    }
284	    s/#\s*if.*?#\s*endif//g; # drop #ifdefs
285	    s@/\*.*?\*/@@g;
286	    s/\s+/ /g;
287	    next unless /^\s?(typedef\s?)?enum\s?([a-zA-Z_]\w*)?\s?\{(.*)\}\s?([a-zA-Z_]\w*)?\s?;/;
288	    (my $enum_subs = $3) =~ s/\s//g;
289	    my @enum_subs = split(/,/, $enum_subs);
290	    my $enum_val = -1;
291	    foreach my $enum (@enum_subs) {
292		my ($enum_name, $enum_value) = $enum =~ /^([a-zA-Z_]\w*)(=.+)?$/;
293		$enum_name or next;
294		$enum_value =~ s/^=//;
295		$enum_val = (length($enum_value) ? $enum_value : $enum_val + 1);
296		if ($opt_h) {
297		    print OUT ($t,
298			       "eval(\"\\n#line $eval_index $outfile\\n",
299			       "sub $enum_name () \{ $enum_val; \}\") ",
300			       "unless defined(\&$enum_name);\n");
301		    ++ $eval_index;
302		} else {
303		    print OUT ($t,
304			       "eval(\"sub $enum_name () \{ $enum_val; \}\") ",
305			       "unless defined(\&$enum_name);\n");
306		}
307	    }
308	} elsif (/^(?:__extension__\s+)?(?:extern|static)\s+(?:__)?inline(?:__)?\s+/
309	    and !/;\s*$/ and !/{\s*}\s*$/)
310	{ # { for vi
311	    # This is a hack to parse the inline functions in the glibc headers.
312	    # Warning: massive kludge ahead. We suppose inline functions
313	    # are mainly constructed like macros.
314	    while (1) {
315		last unless defined ($next = next_line($file));
316		chomp $next;
317		undef $_, last if $next =~ /__THROW\s*;/
318			       or $next =~ /^(__extension__|extern|static)\b/;
319		$_ .= " $next";
320		print OUT "# $next\n" if $opt_D;
321		last if $next =~ /^}|^{.*}\s*$/;
322	    }
323	    next if not defined; # because it's only a prototype
324	    s/\b(__extension__|extern|static|(?:__)?inline(?:__)?)\b//g;
325	    # violently drop #ifdefs
326	    s/#\s*if.*?#\s*endif//g
327		and print OUT "# some #ifdef were dropped here -- fill in the blanks\n";
328	    if (s/^(?:\w|\s|\*)*\s(\w+)\s*//) {
329		$name = $1;
330	    } else {
331		warn "name not found"; next; # shouldn't occur...
332	    }
333	    my @args;
334	    if (s/^\(([^()]*)\)\s*(\w+\s*)*//) {
335		for my $arg (split /,/, $1) {
336		    if ($arg =~ /(\w+)\s*$/) {
337			$curargs{$1} = 1;
338			push @args, $1;
339		    }
340		}
341	    }
342	    $args = (
343		@args
344		? "my(" . (join ',', map "\$$_", @args) . ") = \@_;\n$t    "
345		: ""
346	    );
347	    my $proto = @args ? '' : '() ';
348	    $new = '';
349	    s/\breturn\b//g; # "return" doesn't occur in macros usually...
350	    expr();
351	    # try to find and perlify local C variables
352	    our @local_variables = (); # needs to be a our(): (?{...}) bug workaround
353	    {
354		use re "eval";
355		my $typelist = join '|', keys %isatype;
356		$new =~ s['
357		  (?:(?:__)?const(?:__)?\s+)?
358		  (?:(?:un)?signed\s+)?
359		  (?:long\s+)?
360		  (?:$typelist)\s+
361		  (\w+)
362		  (?{ push @local_variables, $1 })
363		  ']
364		 [my \$$1]gx;
365		$new =~ s['
366		  (?:(?:__)?const(?:__)?\s+)?
367		  (?:(?:un)?signed\s+)?
368		  (?:long\s+)?
369		  (?:$typelist)\s+
370		  ' \s+ &(\w+) \s* ;
371		  (?{ push @local_variables, $1 })
372		  ]
373		 [my \$$1;]gx;
374	     }
375	    $new =~ s/&$_\b/\$$_/g for @local_variables;
376	    $new =~ s/(["\\])/\\$1/g;       #"]);
377	    # now that's almost like a macro (we hope)
378	    goto EMIT;
379	}
380    }
381    $Is_converted{$file} = 1;
382    if ($opt_e && exists($bad_file{$file})) {
383        unlink($Dest_dir . '/' . $outfile);
384        $next = '';
385    } else {
386        print OUT "1;\n";
387	queue_includes_from($file) if $opt_a;
388    }
389}
390
391if ($opt_e && (scalar(keys %bad_file) > 0)) {
392    warn "Was unable to convert the following files:\n";
393    warn "\t" . join("\n\t",sort(keys %bad_file)) . "\n";
394}
395
396exit $Exit;
397
398sub expr {
399    $new = '"(assembly code)"' and return if /\b__asm__\b/; # freak out.
400    my $joined_args;
401    if(keys(%curargs)) {
402	$joined_args = join('|', keys(%curargs));
403    }
404    while ($_ ne '') {
405	s/^\&\&// && do { $new .= " &&"; next;}; # handle && operator
406	s/^\&([\(a-z\)]+)/$1/i;	# hack for things that take the address of
407	s/^(\s+)//		&& do {$new .= ' '; next;};
408	s/^0X([0-9A-F]+)[UL]*//i
409	    && do {my $hex = $1;
410		   $hex =~ s/^0+//;
411		   if (length $hex > 8 && !$Config{use64bitint}) {
412		       # Croak if nv_preserves_uv_bits < 64 ?
413		       $new .=         hex(substr($hex, -8)) +
414			       2**32 * hex(substr($hex,  0, -8));
415		       # The above will produce "errorneus" code
416		       # if the hex constant was e.g. inside UINT64_C
417		       # macro, but then again, h2ph is an approximation.
418		   } else {
419		       $new .= lc("0x$hex");
420		   }
421		   next;};
422	s/^(-?\d+\.\d+E[-+]?\d+)[FL]?//i	&& do {$new .= $1; next;};
423	s/^(\d+)\s*[LU]*//i	&& do {$new .= $1; next;};
424	s/^("(\\"|[^"])*")//	&& do {$new .= $1; next;};
425	s/^'((\\"|[^"])*)'//	&& do {
426	    if ($curargs{$1}) {
427		$new .= "ord('\$$1')";
428	    } else {
429		$new .= "ord('$1')";
430	    }
431	    next;
432	};
433        # replace "sizeof(foo)" with "{foo}"
434        # also, remove * (C dereference operator) to avoid perl syntax
435        # problems.  Where the %sizeof array comes from is anyone's
436        # guess (c2ph?), but this at least avoids fatal syntax errors.
437        # Behavior is undefined if sizeof() delimiters are unbalanced.
438        # This code was modified to able to handle constructs like this:
439        #   sizeof(*(p)), which appear in the HP-UX 10.01 header files.
440        s/^sizeof\s*\(// && do {
441            $new .= '$sizeof';
442            my $lvl = 1;  # already saw one open paren
443            # tack { on the front, and skip it in the loop
444            $_ = "{" . "$_";
445            my $index = 1;
446            # find balanced closing paren
447            while ($index <= length($_) && $lvl > 0) {
448                $lvl++ if substr($_, $index, 1) eq "(";
449                $lvl-- if substr($_, $index, 1) eq ")";
450                $index++;
451            }
452            # tack } on the end, replacing )
453            substr($_, $index - 1, 1) = "}";
454            # remove pesky * operators within the sizeof argument
455            substr($_, 0, $index - 1) =~ s/\*//g;
456            next;
457        };
458	# Eliminate typedefs
459	/\(([\w\s]+)[\*\s]*\)\s*[\w\(]/ && do {
460	    my $doit = 1;
461	    foreach (split /\s+/, $1) {  # Make sure all the words are types,
462	        unless($isatype{$_} or $_ eq 'struct' or $_ eq 'union'){
463		    $doit = 0;
464		    last;
465		}
466	    }
467	    if( $doit ){
468		s/\([\w\s]+[\*\s]*\)// && next;      # then eliminate them.
469	    }
470	};
471	# struct/union member, including arrays:
472	s/^([_A-Z]\w*(\[[^\]]+\])?((\.|->)[_A-Z]\w*(\[[^\]]+\])?)+)//i && do {
473	    my $id = $1;
474	    $id =~ s/(\.|(->))([^\.\-]*)/->\{$3\}/g;
475	    $id =~ s/\b([^\$])($joined_args)/$1\$$2/g if length($joined_args);
476	    while($id =~ /\[\s*([^\$\&\d\]]+)\]/) {
477		my($index) = $1;
478		$index =~ s/\s//g;
479		if(exists($curargs{$index})) {
480		    $index = "\$$index";
481		} else {
482		    $index = "&$index";
483		}
484		$id =~ s/\[\s*([^\$\&\d\]]+)\]/[$index]/;
485	    }
486	    $new .= " (\$$id)";
487	};
488	s/^([_a-zA-Z]\w*)//	&& do {
489	    my $id = $1;
490	    if ($id eq 'struct' || $id eq 'union') {
491		s/^\s+(\w+)//;
492		$id .= ' ' . $1;
493		$isatype{$id} = 1;
494	    } elsif ($id =~ /^((un)?signed)|(long)|(short)$/) {
495		while (s/^\s+(\w+)//) { $id .= ' ' . $1; }
496		$isatype{$id} = 1;
497	    }
498	    if ($curargs{$id}) {
499		$new .= "\$$id";
500		$new .= '->' if /^[\[\{]/;
501	    } elsif ($id eq 'defined') {
502		$new .= 'defined';
503	    } elsif (/^\s*\(/) {
504		s/^\s*\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/i;	# cheat
505		$new .= " &$id";
506	    } elsif ($isatype{$id}) {
507		if ($new =~ /{\s*$/) {
508		    $new .= "'$id'";
509		} elsif ($new =~ /\(\s*$/ && /^[\s*]*\)/) {
510		    $new =~ s/\(\s*$//;
511		    s/^[\s*]*\)//;
512		} else {
513		    $new .= q(').$id.q(');
514		}
515	    } else {
516		if ($inif && $new !~ /defined\s*\($/) {
517		    $new .= '(defined(&' . $id . ') ? &' . $id . ' : undef)';
518		} elsif (/^\[/) {
519		    $new .= " \$$id";
520		} else {
521		    $new .= ' &' . $id;
522		}
523	    }
524	    next;
525	};
526	s/^(.)// && do { if ($1 ne '#') { $new .= $1; } next;};
527    }
528}
529
530
531sub next_line
532{
533    my $file = shift;
534    my ($in, $out);
535    my $pre_sub_tri_graphs = 1;
536
537    READ: while (not eof IN) {
538        $in  .= <IN>;
539        chomp $in;
540        next unless length $in;
541
542        while (length $in) {
543            if ($pre_sub_tri_graphs) {
544                # Preprocess all tri-graphs
545                # including things stuck in quoted string constants.
546                $in =~ s/\?\?=/#/g;                         # | ??=|  #|
547                $in =~ s/\?\?\!/|/g;                        # | ??!|  ||
548                $in =~ s/\?\?'/^/g;                         # | ??'|  ^|
549                $in =~ s/\?\?\(/[/g;                        # | ??(|  [|
550                $in =~ s/\?\?\)/]/g;                        # | ??)|  ]|
551                $in =~ s/\?\?\-/~/g;                        # | ??-|  ~|
552                $in =~ s/\?\?\//\\/g;                       # | ??/|  \|
553                $in =~ s/\?\?</{/g;                         # | ??<|  {|
554                $in =~ s/\?\?>/}/g;                         # | ??>|  }|
555            }
556	    if ($in =~ s/^\#ifdef __LANGUAGE_PASCAL__//) {
557		# Tru64 disassembler.h evilness: mixed C and Pascal.
558		while (<IN>) {
559		    last if /^\#endif/;
560		}
561		$in = "";
562		next READ;
563	    }
564	    # Skip inlined functions in headers
565	    if ($in =~ s/^(extern|static) (__inline__|inline) .*[^;]\s*$//) {
566		while (<IN>) {
567		    last if /^}/;
568		}
569		$in = "";
570		next READ;
571	    }
572            if ($in =~ s/\\$//) {                           # \-newline
573                $out    .= ' ';
574                next READ;
575            } elsif ($in =~ s/^([^"'\\\/]+)//) {            # Passthrough
576                $out    .= $1;
577            } elsif ($in =~ s/^(\\.)//) {                   # \...
578                $out    .= $1;
579            } elsif ($in =~ /^'/) {                         # '...
580                if ($in =~ s/^('(\\.|[^'\\])*')//) {
581                    $out    .= $1;
582                } else {
583                    next READ;
584                }
585            } elsif ($in =~ /^"/) {                         # "...
586                if ($in =~ s/^("(\\.|[^"\\])*")//) {
587                    $out    .= $1;
588                } else {
589                    next READ;
590                }
591            } elsif ($in =~ s/^\/\/.*//) {                  # //...
592                # fall through
593            } elsif ($in =~ m/^\/\*/) {                     # /*...
594                # C comment removal adapted from perlfaq6:
595                if ($in =~ s/^\/\*[^*]*\*+([^\/*][^*]*\*+)*\///) {
596                    $out    .= ' ';
597                } else {                                    # Incomplete /* */
598                    next READ;
599                }
600            } elsif ($in =~ s/^(\/)//) {                    # /...
601                $out    .= $1;
602            } elsif ($in =~ s/^([^\'\"\\\/]+)//) {
603                $out    .= $1;
604            } elsif ($^O eq 'linux' &&
605                     $file =~ m!(?:^|/)linux/byteorder/pdp_endian\.h$! &&
606                     $in   =~ s!\'T KNOW!!) {
607                $out    =~ s!I DON$!I_DO_NOT_KNOW!;
608            } else {
609                if ($opt_e) {
610                    warn "Cannot parse $file:\n$in\n";
611                    $bad_file{$file} = 1;
612                    $in = '';
613                    $out = undef;
614                    last READ;
615                } else {
616		die "Cannot parse:\n$in\n";
617                }
618            }
619        }
620
621        last READ if $out =~ /\S/;
622    }
623
624    return $out;
625}
626
627
628# Handle recursive subdirectories without getting a grotesquely big stack.
629# Could this be implemented using File::Find?
630sub next_file
631{
632    my $file;
633
634    while (@ARGV) {
635        $file = shift @ARGV;
636
637        if ($file eq '-' or -f $file or -l $file) {
638            return $file;
639        } elsif (-d $file) {
640            if ($opt_r) {
641                expand_glob($file);
642            } else {
643                print STDERR "Skipping directory `$file'\n";
644            }
645        } elsif ($opt_a) {
646            return $file;
647        } else {
648            print STDERR "Skipping `$file':  not a file or directory\n";
649        }
650    }
651
652    return undef;
653}
654
655
656# Put all the files in $directory into @ARGV for processing.
657sub expand_glob
658{
659    my ($directory)  = @_;
660
661    $directory =~ s:/$::;
662
663    opendir DIR, $directory;
664        foreach (readdir DIR) {
665            next if ($_ eq '.' or $_ eq '..');
666
667            # expand_glob() is going to be called until $ARGV[0] isn't a
668            # directory; so push directories, and unshift everything else.
669            if (-d "$directory/$_") { push    @ARGV, "$directory/$_" }
670            else                    { unshift @ARGV, "$directory/$_" }
671        }
672    closedir DIR;
673}
674
675
676# Given $file, a symbolic link to a directory in the C include directory,
677# make an equivalent symbolic link in $Dest_dir, if we can figure out how.
678# Otherwise, just duplicate the file or directory.
679sub link_if_possible
680{
681    my ($dirlink)  = @_;
682    my $target  = eval 'readlink($dirlink)';
683
684    if ($target =~ m:^\.\./: or $target =~ m:^/:) {
685        # The target of a parent or absolute link could leave the $Dest_dir
686        # hierarchy, so let's put all of the contents of $dirlink (actually,
687        # the contents of $target) into @ARGV; as a side effect down the
688        # line, $dirlink will get created as an _actual_ directory.
689        expand_glob($dirlink);
690    } else {
691        if (-l "$Dest_dir/$dirlink") {
692            unlink "$Dest_dir/$dirlink" or
693                print STDERR "Could not remove link $Dest_dir/$dirlink:  $!\n";
694        }
695
696        if (eval 'symlink($target, "$Dest_dir/$dirlink")') {
697            print "Linking $target -> $Dest_dir/$dirlink\n";
698
699            # Make sure that the link _links_ to something:
700            if (! -e "$Dest_dir/$target") {
701                mkpath("$Dest_dir/$target", 0755) or
702                    print STDERR "Could not create $Dest_dir/$target/\n";
703            }
704        } else {
705            print STDERR "Could not symlink $target -> $Dest_dir/$dirlink:  $!\n";
706        }
707    }
708}
709
710
711# Push all #included files in $file onto our stack, except for STDIN
712# and files we've already processed.
713sub queue_includes_from
714{
715    my ($file)    = @_;
716    my $line;
717
718    return if ($file eq "-");
719
720    open HEADER, $file or return;
721        while (defined($line = <HEADER>)) {
722            while (/\\$/) { # Handle continuation lines
723                chop $line;
724                $line .= <HEADER>;
725            }
726
727            if ($line =~ /^#\s*include\s+<(.*?)>/) {
728                push(@ARGV, $1) unless $Is_converted{$1};
729            }
730        }
731    close HEADER;
732}
733
734
735# Determine include directories; $Config{usrinc} should be enough for (all
736# non-GCC?) C compilers, but gcc uses an additional include directory.
737sub inc_dirs
738{
739    my $from_gcc    = `LC_ALL=C $Config{cc} -v 2>&1`;
740    if( !( $from_gcc =~ s:^Reading specs from (.*?)/specs\b.*:$1/include:s ) )
741    { # gcc-4+ :
742       $from_gcc   = `LC_ALL=C $Config{cc} -print-search-dirs 2>&1`;
743       if ( !($from_gcc =~ s/^install:\s*([^\s]+[^\s\/])([\s\/]*).*$/$1\/include/s) )
744       {
745           $from_gcc = '';
746       };
747    };
748    length($from_gcc) ? ($from_gcc, $Config{usrinc}) : ($Config{usrinc});
749}
750
751
752# Create "_h2ph_pre.ph", if it doesn't exist or was built by a different
753# version of h2ph.
754sub build_preamble_if_necessary
755{
756    # Increment $VERSION every time this function is modified:
757    my $VERSION     = 2;
758    my $preamble    = "$Dest_dir/_h2ph_pre.ph";
759
760    # Can we skip building the preamble file?
761    if (-r $preamble) {
762        # Extract version number from first line of preamble:
763        open  PREAMBLE, $preamble or die "Cannot open $preamble:  $!";
764            my $line = <PREAMBLE>;
765            $line =~ /(\b\d+\b)/;
766        close PREAMBLE            or die "Cannot close $preamble:  $!";
767
768        # Don't build preamble if a compatible preamble exists:
769        return if $1 == $VERSION;
770    }
771
772    my (%define) = _extract_cc_defines();
773
774    open  PREAMBLE, ">$preamble" or die "Cannot open $preamble:  $!";
775	print PREAMBLE "# This file was created by h2ph version $VERSION\n";
776
777	foreach (sort keys %define) {
778	    if ($opt_D) {
779		print PREAMBLE "# $_=$define{$_}\n";
780	    }
781	    if ($define{$_} =~ /^\((.*)\)$/) {
782		# parenthesized value:  d=(v)
783		$define{$_} = $1;
784	    }
785	    if ($define{$_} =~ /^([+-]?(\d+)?\.\d+([eE][+-]?\d+)?)[FL]?$/) {
786		# float:
787		print PREAMBLE
788		    "unless (defined &$_) { sub $_() { $1 } }\n\n";
789	    } elsif ($define{$_} =~ /^([+-]?\d+)U?L{0,2}$/i) {
790		# integer:
791		print PREAMBLE
792		    "unless (defined &$_) { sub $_() { $1 } }\n\n";
793	    } elsif ($define{$_} =~ /^\w+$/) {
794		print PREAMBLE
795		    "unless (defined &$_) { sub $_() { &$define{$_} } }\n\n";
796	    } else {
797		print PREAMBLE
798		    "unless (defined &$_) { sub $_() { \"",
799		    quotemeta($define{$_}), "\" } }\n\n";
800	    }
801	}
802    close PREAMBLE               or die "Cannot close $preamble:  $!";
803}
804
805
806# %Config contains information on macros that are pre-defined by the
807# system's compiler.  We need this information to make the .ph files
808# function with perl as the .h files do with cc.
809sub _extract_cc_defines
810{
811    my %define;
812    my $allsymbols  = join " ",
813	@Config{'ccsymbols', 'cppsymbols', 'cppccsymbols'};
814
815    # Split compiler pre-definitions into `key=value' pairs:
816    while ($allsymbols =~ /([^\s]+)=((\\\s|[^\s])+)/g) {
817	$define{$1} = $2;
818	if ($opt_D) {
819	    print STDERR "$_:  $1 -> $2\n";
820	}
821    }
822
823    return %define;
824}
825
826
8271;
828
829##############################################################################
830__END__
831
832=head1 NAME
833
834h2ph - convert .h C header files to .ph Perl header files
835
836=head1 SYNOPSIS
837
838B<h2ph [-d destination directory] [-r | -a] [-l] [headerfiles]>
839
840=head1 DESCRIPTION
841
842I<h2ph>
843converts any C header files specified to the corresponding Perl header file
844format.
845It is most easily run while in /usr/include:
846
847	cd /usr/include; h2ph * sys/*
848
849or
850
851	cd /usr/include; h2ph * sys/* arpa/* netinet/*
852
853or
854
855	cd /usr/include; h2ph -r -l .
856
857The output files are placed in the hierarchy rooted at Perl's
858architecture dependent library directory.  You can specify a different
859hierarchy with a B<-d> switch.
860
861If run with no arguments, filters standard input to standard output.
862
863=head1 OPTIONS
864
865=over 4
866
867=item -d destination_dir
868
869Put the resulting B<.ph> files beneath B<destination_dir>, instead of
870beneath the default Perl library location (C<$Config{'installsitearch'}>).
871
872=item -r
873
874Run recursively; if any of B<headerfiles> are directories, then run I<h2ph>
875on all files in those directories (and their subdirectories, etc.).  B<-r>
876and B<-a> are mutually exclusive.
877
878=item -a
879
880Run automagically; convert B<headerfiles>, as well as any B<.h> files
881which they include.  This option will search for B<.h> files in all
882directories which your C compiler ordinarily uses.  B<-a> and B<-r> are
883mutually exclusive.
884
885=item -l
886
887Symbolic links will be replicated in the destination directory.  If B<-l>
888is not specified, then links are skipped over.
889
890=item -h
891
892Put ``hints'' in the .ph files which will help in locating problems with
893I<h2ph>.  In those cases when you B<require> a B<.ph> file containing syntax
894errors, instead of the cryptic
895
896	[ some error condition ] at (eval mmm) line nnn
897
898you will see the slightly more helpful
899
900	[ some error condition ] at filename.ph line nnn
901
902However, the B<.ph> files almost double in size when built using B<-h>.
903
904=item -D
905
906Include the code from the B<.h> file as a comment in the B<.ph> file.
907This is primarily used for debugging I<h2ph>.
908
909=item -Q
910
911``Quiet'' mode; don't print out the names of the files being converted.
912
913=back
914
915=head1 ENVIRONMENT
916
917No environment variables are used.
918
919=head1 FILES
920
921 /usr/include/*.h
922 /usr/include/sys/*.h
923
924etc.
925
926=head1 AUTHOR
927
928Larry Wall
929
930=head1 SEE ALSO
931
932perl(1)
933
934=head1 DIAGNOSTICS
935
936The usual warnings if it can't read or write the files involved.
937
938=head1 BUGS
939
940Doesn't construct the %sizeof array for you.
941
942It doesn't handle all C constructs, but it does attempt to isolate
943definitions inside evals so that you can get at the definitions
944that it can translate.
945
946It's only intended as a rough tool.
947You may need to dicker with the files produced.
948
949You have to run this program by hand; it's not run as part of the Perl
950installation.
951
952Doesn't handle complicated expressions built piecemeal, a la:
953
954    enum {
955	FIRST_VALUE,
956	SECOND_VALUE,
957    #ifdef ABC
958	THIRD_VALUE
959    #endif
960    };
961
962Doesn't necessarily locate all of your C compiler's internally-defined
963symbols.
964
965=cut
966
967!NO!SUBS!
968
969close OUT or die "Can't close $file: $!";
970chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
971exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
972chdir $origdir;
973