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