Commit | Line | Data |
4633a7c4 |
1 | #!/usr/local/bin/perl |
2 | |
3 | use Config; |
4 | use File::Basename qw(&basename &dirname); |
5 | |
6 | # List explicitly here the variables you want Configure to |
7 | # generate. Metaconfig only looks for shell variables, so you |
8 | # have to mention them as if they were shell variables, not |
9 | # %Config entries. Thus you write |
10 | # $startperl |
11 | # to ensure Configure will look for $Config{startperl}. |
12 | # Wanted: $archlibexp |
13 | |
14 | # This forces PL files to create target in same directory as PL file. |
15 | # This is so that make depend always knows where to find PL derivatives. |
44a8e56a |
16 | chdir dirname($0); |
17 | $file = basename($0, '.PL'); |
774d564b |
18 | $file .= '.com' if $^O eq 'VMS'; |
4633a7c4 |
19 | |
20 | open OUT,">$file" or die "Can't create $file: $!"; |
21 | |
22 | print "Extracting $file (with variable substitutions)\n"; |
23 | |
24 | # In this section, perl variables will be expanded during extraction. |
25 | # You can use $Config{...} to use Configure variables. |
26 | |
27 | print OUT <<"!GROK!THIS!"; |
5f05dabc |
28 | $Config{startperl} |
29 | eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' |
30 | if \$running_under_some_shell; |
154e51a4 |
31 | !GROK!THIS! |
32 | |
4633a7c4 |
33 | # In the following, perl variables are not expanded during extraction. |
34 | |
35 | print OUT <<'!NO!SUBS!'; |
154e51a4 |
36 | |
2c2acf7e |
37 | use Config; |
b306bf39 |
38 | use File::Path qw(mkpath); |
50f6e060 |
39 | use Getopt::Std; |
40 | |
41 | getopts('d:rlh'); |
42 | |
2c2acf7e |
43 | |
b306bf39 |
44 | my $Exit = 0; |
45 | |
50f6e060 |
46 | my $Dest_dir = $opt_d || $Config{installsitearch}; |
b306bf39 |
47 | die "Destination directory $Dest_dir doesn't exist or isn't a directory\n" |
48 | unless -d $Dest_dir; |
154e51a4 |
49 | |
fe14fcc3 |
50 | @isatype = split(' ',<<END); |
51 | char uchar u_char |
52 | short ushort u_short |
53 | int uint u_int |
54 | long ulong u_long |
fb73857a |
55 | FILE key_t caddr_t |
fe14fcc3 |
56 | END |
57 | |
55204971 |
58 | @isatype{@isatype} = (1) x @isatype; |
748a9306 |
59 | $inif = 0; |
fe14fcc3 |
60 | |
61 | @ARGV = ('-') unless @ARGV; |
154e51a4 |
62 | |
50f6e060 |
63 | while (defined ($file = next_file())) { |
64 | if (-l $file and -d $file) { |
65 | link_if_possible($file) if ($opt_l); |
66 | next; |
67 | } |
68 | |
5f05dabc |
69 | # Recover from header files with unbalanced cpp directives |
70 | $t = ''; |
71 | $tab = 0; |
72 | |
50f6e060 |
73 | # $eval_index goes into ``#line'' directives, to help locate syntax errors: |
74 | $eval_index = 1; |
75 | |
fe14fcc3 |
76 | if ($file eq '-') { |
77 | open(IN, "-"); |
78 | open(OUT, ">-"); |
79 | } |
80 | else { |
81 | ($outfile = $file) =~ s/\.h$/.ph/ || next; |
82 | print "$file -> $outfile\n"; |
83 | if ($file =~ m|^(.*)/|) { |
84 | $dir = $1; |
b306bf39 |
85 | mkpath "$Dest_dir/$dir"; |
154e51a4 |
86 | } |
b306bf39 |
87 | open(IN,"$file") || (($Exit = 1),(warn "Can't open $file: $!\n"),next); |
88 | open(OUT,">$Dest_dir/$outfile") || die "Can't create $outfile: $!\n"; |
154e51a4 |
89 | } |
154e51a4 |
90 | while (<IN>) { |
91 | chop; |
92 | while (/\\$/) { |
93 | chop; |
94 | $_ .= <IN>; |
95 | chop; |
96 | } |
97 | if (s:/\*:\200:g) { |
98 | s:\*/:\201:g; |
99 | s/\200[^\201]*\201//g; # delete single line comments |
100 | if (s/\200.*//) { # begin multi-line comment? |
101 | $_ .= '/*'; |
102 | $_ .= <IN>; |
103 | redo; |
104 | } |
105 | } |
106 | if (s/^#\s*//) { |
107 | if (s/^define\s+(\w+)//) { |
108 | $name = $1; |
109 | $new = ''; |
110 | s/\s+$//; |
111 | if (s/^\(([\w,\s]*)\)//) { |
112 | $args = $1; |
b306bf39 |
113 | my $proto = '() '; |
154e51a4 |
114 | if ($args ne '') { |
b306bf39 |
115 | $proto = ''; |
154e51a4 |
116 | foreach $arg (split(/,\s*/,$args)) { |
55204971 |
117 | $arg =~ s/^\s*([^\s].*[^\s])\s*$/$1/; |
154e51a4 |
118 | $curargs{$arg} = 1; |
119 | } |
120 | $args =~ s/\b(\w)/\$$1/g; |
121 | $args = "local($args) = \@_;\n$t "; |
122 | } |
123 | s/^\s+//; |
5f05dabc |
124 | expr(); |
154e51a4 |
125 | $new =~ s/(["\\])/\\$1/g; |
126 | if ($t ne '') { |
127 | $new =~ s/(['\\])/\\$1/g; |
50f6e060 |
128 | if ($opt_h) { |
129 | print OUT $t, |
130 | "eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name $proto\{\n$t ${args}eval \"$new\";\n$t}' unless defined(\&$name);\n"; |
131 | $eval_index++; |
132 | } else { |
133 | print OUT $t, |
134 | "eval 'sub $name $proto\{\n$t ${args}eval \"$new\";\n$t}' unless defined(\&$name);\n"; |
135 | } |
154e51a4 |
136 | } |
137 | else { |
6ee623d5 |
138 | print OUT "unless (defined(\&$name)) {\nsub $name $proto\{\n ${args}eval \"$new\";\n}\n}\n"; |
154e51a4 |
139 | } |
140 | %curargs = (); |
141 | } |
142 | else { |
143 | s/^\s+//; |
5f05dabc |
144 | expr(); |
154e51a4 |
145 | $new = 1 if $new eq ''; |
146 | if ($t ne '') { |
147 | $new =~ s/(['\\])/\\$1/g; |
50f6e060 |
148 | if ($opt_h) { |
149 | print OUT $t,"eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name () {",$new,";}' unless defined(\&$name);\n"; |
150 | $eval_index++; |
151 | } else { |
152 | print OUT $t,"eval 'sub $name () {",$new,";}' unless defined(\&$name);\n"; |
153 | } |
154e51a4 |
154 | } |
155 | else { |
4a8e146e |
156 | print OUT $t,"unless(defined(\&$name)) {\nsub $name () {",$new,";}\n}\n"; |
154e51a4 |
157 | } |
158 | } |
159 | } |
fb21d8eb |
160 | elsif (/^include\s*<(.*)>/) { |
d9d8d8de |
161 | ($incl = $1) =~ s/\.h$/.ph/; |
162 | print OUT $t,"require '$incl';\n"; |
154e51a4 |
163 | } |
164 | elsif (/^ifdef\s+(\w+)/) { |
165 | print OUT $t,"if (defined &$1) {\n"; |
166 | $tab += 4; |
167 | $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); |
168 | } |
169 | elsif (/^ifndef\s+(\w+)/) { |
170 | print OUT $t,"if (!defined &$1) {\n"; |
171 | $tab += 4; |
172 | $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); |
173 | } |
174 | elsif (s/^if\s+//) { |
175 | $new = ''; |
748a9306 |
176 | $inif = 1; |
5f05dabc |
177 | expr(); |
748a9306 |
178 | $inif = 0; |
154e51a4 |
179 | print OUT $t,"if ($new) {\n"; |
180 | $tab += 4; |
181 | $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); |
182 | } |
183 | elsif (s/^elif\s+//) { |
184 | $new = ''; |
748a9306 |
185 | $inif = 1; |
5f05dabc |
186 | expr(); |
748a9306 |
187 | $inif = 0; |
154e51a4 |
188 | $tab -= 4; |
189 | $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); |
190 | print OUT $t,"}\n${t}elsif ($new) {\n"; |
191 | $tab += 4; |
192 | $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); |
193 | } |
194 | elsif (/^else/) { |
195 | $tab -= 4; |
196 | $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); |
197 | print OUT $t,"}\n${t}else {\n"; |
198 | $tab += 4; |
199 | $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); |
200 | } |
201 | elsif (/^endif/) { |
202 | $tab -= 4; |
203 | $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); |
204 | print OUT $t,"}\n"; |
205 | } |
206 | } |
207 | } |
208 | print OUT "1;\n"; |
209 | } |
210 | |
b306bf39 |
211 | exit $Exit; |
212 | |
154e51a4 |
213 | sub expr { |
214 | while ($_ ne '') { |
50f6e060 |
215 | s/^\&\&// && do { $new .= "&&"; next;}; # handle && operator |
fb73857a |
216 | s/^\&//; # hack for things that take the address of |
154e51a4 |
217 | s/^(\s+)// && do {$new .= ' '; next;}; |
50f6e060 |
218 | s/^(0X[0-9A-F]+)[UL]*//i && do {$new .= lc($1); next;}; |
219 | s/^(-?\d+\.\d+E[-+]\d+)F?//i && do {$new .= $1; next;}; |
220 | s/^(\d+)\s*[LU]*//i && do {$new .= $1; next;}; |
154e51a4 |
221 | s/^("(\\"|[^"])*")// && do {$new .= $1; next;}; |
222 | s/^'((\\"|[^"])*)'// && do { |
223 | if ($curargs{$1}) { |
224 | $new .= "ord('\$$1')"; |
225 | } |
226 | else { |
227 | $new .= "ord('$1')"; |
228 | } |
229 | next; |
230 | }; |
5f05dabc |
231 | # replace "sizeof(foo)" with "{foo}" |
232 | # also, remove * (C dereference operator) to avoid perl syntax |
233 | # problems. Where the %sizeof array comes from is anyone's |
234 | # guess (c2ph?), but this at least avoids fatal syntax errors. |
235 | # Behavior is undefined if sizeof() delimiters are unbalanced. |
236 | # This code was modified to able to handle constructs like this: |
237 | # sizeof(*(p)), which appear in the HP-UX 10.01 header files. |
238 | s/^sizeof\s*\(// && do { |
239 | $new .= '$sizeof'; |
240 | my $lvl = 1; # already saw one open paren |
241 | # tack { on the front, and skip it in the loop |
242 | $_ = "{" . "$_"; |
243 | my $index = 1; |
244 | # find balanced closing paren |
245 | while ($index <= length($_) && $lvl > 0) { |
246 | $lvl++ if substr($_, $index, 1) eq "("; |
247 | $lvl-- if substr($_, $index, 1) eq ")"; |
248 | $index++; |
249 | } |
250 | # tack } on the end, replacing ) |
251 | substr($_, $index - 1, 1) = "}"; |
252 | # remove pesky * operators within the sizeof argument |
253 | substr($_, 0, $index - 1) =~ s/\*//g; |
254 | next; |
255 | }; |
50f6e060 |
256 | # Eliminate typedefs |
257 | /\(([\w\s]+)[\*\s]*\)\s*[\w\(]/ && do { |
258 | foreach (split /\s+/, $1) { # Make sure all the words are types, |
259 | last unless ($isatype{$_} or $_ eq 'struct'); |
260 | } |
261 | s/\([\w\s]+[\*\s]*\)// && next; # then eliminate them. |
262 | }; |
263 | # struct/union member: |
264 | s/^([_A-Z]\w*((\.|->)[_A-Z]\w*)+)//i && do { |
265 | $id = $1; |
266 | $id =~ s/(\.|(->))([^\.-]*)/->\{$3\}/g; |
267 | $new .= ' ($' . $id . ')'; |
268 | }; |
154e51a4 |
269 | s/^([_a-zA-Z]\w*)// && do { |
270 | $id = $1; |
fe14fcc3 |
271 | if ($id eq 'struct') { |
272 | s/^\s+(\w+)//; |
273 | $id .= ' ' . $1; |
274 | $isatype{$id} = 1; |
275 | } |
50f6e060 |
276 | elsif ($id =~ /^((un)?signed)|(long)|(short)$/) { |
277 | while (s/^\s+(\w+)//) { $id .= ' ' . $1; } |
fe14fcc3 |
278 | $isatype{$id} = 1; |
279 | } |
154e51a4 |
280 | if ($curargs{$id}) { |
281 | $new .= '$' . $id; |
282 | } |
283 | elsif ($id eq 'defined') { |
284 | $new .= 'defined'; |
285 | } |
286 | elsif (/^\(/) { |
e5d73d77 |
287 | s/^\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/i; # cheat |
154e51a4 |
288 | $new .= " &$id"; |
289 | } |
290 | elsif ($isatype{$id}) { |
fe14fcc3 |
291 | if ($new =~ /{\s*$/) { |
292 | $new .= "'$id'"; |
293 | } |
294 | elsif ($new =~ /\(\s*$/ && /^[\s*]*\)/) { |
295 | $new =~ s/\(\s*$//; |
296 | s/^[\s*]*\)//; |
297 | } |
298 | else { |
b276c83d |
299 | $new .= q(').$id.q('); |
fe14fcc3 |
300 | } |
154e51a4 |
301 | } |
302 | else { |
c07a80fd |
303 | if ($inif && $new !~ /defined\s*\($/) { |
748a9306 |
304 | $new .= '(defined(&' . $id . ') ? &' . $id . ' : 0)'; |
b306bf39 |
305 | } |
306 | elsif (/^\[/) { |
fb21d8eb |
307 | $new .= ' $' . $id; |
308 | } |
309 | else { |
748a9306 |
310 | $new .= ' &' . $id; |
311 | } |
154e51a4 |
312 | } |
313 | next; |
314 | }; |
fb21d8eb |
315 | s/^(.)// && do { if ($1 ne '#') { $new .= $1; } next;}; |
154e51a4 |
316 | } |
317 | } |
50f6e060 |
318 | |
319 | |
320 | # Handle recursive subdirectories without getting a grotesquely big stack. |
321 | # Could this be implemented using File::Find? |
322 | sub next_file |
323 | { |
324 | my $file; |
325 | |
326 | while (@ARGV) { |
327 | $file = shift @ARGV; |
328 | |
329 | if ($file eq '-' or -f $file or -l $file) { |
330 | return $file; |
331 | } elsif (-d $file) { |
332 | if ($opt_r) { |
333 | expand_glob($file); |
334 | } else { |
335 | print STDERR "Skipping directory `$file'\n"; |
336 | } |
337 | } else { |
338 | print STDERR "Skipping `$file': not a file or directory\n"; |
339 | } |
340 | } |
341 | |
342 | return undef; |
343 | } |
344 | |
345 | |
346 | # Put all the files in $directory into @ARGV for processing. |
347 | sub expand_glob |
348 | { |
349 | my ($directory) = @_; |
350 | |
351 | $directory =~ s:/$::; |
352 | |
353 | opendir DIR, $directory; |
354 | foreach (readdir DIR) { |
355 | next if ($_ eq '.' or $_ eq '..'); |
356 | |
357 | # expand_glob() is going to be called until $ARGV[0] isn't a |
358 | # directory; so push directories, and unshift everything else. |
359 | if (-d "$directory/$_") { push @ARGV, "$directory/$_" } |
360 | else { unshift @ARGV, "$directory/$_" } |
361 | } |
362 | closedir DIR; |
363 | } |
364 | |
365 | |
366 | # Given $file, a symbolic link to a directory in the C include directory, |
367 | # make an equivalent symbolic link in $Dest_dir, if we can figure out how. |
368 | # Otherwise, just duplicate the file or directory. |
369 | sub link_if_possible |
370 | { |
371 | my ($dirlink) = @_; |
372 | my $target = eval 'readlink($dirlink)'; |
373 | |
374 | if ($target =~ m:^\.\./: or $target =~ m:^/:) { |
375 | # The target of a parent or absolute link could leave the $Dest_dir |
376 | # hierarchy, so let's put all of the contents of $dirlink (actually, |
377 | # the contents of $target) into @ARGV; as a side effect down the |
378 | # line, $dirlink will get created as an _actual_ directory. |
379 | expand_glob($dirlink); |
380 | } else { |
381 | if (-l "$Dest_dir/$dirlink") { |
382 | unlink "$Dest_dir/$dirlink" or |
383 | print STDERR "Could not remove link $Dest_dir/$dirlink: $!\n"; |
384 | } |
385 | |
386 | if (eval 'symlink($target, "$Dest_dir/$dirlink")') { |
387 | print "Linking $target -> $Dest_dir/$dirlink\n"; |
388 | |
389 | # Make sure that the link _links_ to something: |
390 | if (! -e "$Dest_dir/$target") { |
391 | mkdir("$Dest_dir/$target", 0755) or |
392 | print STDERR "Could not create $Dest_dir/$target/\n"; |
393 | } |
394 | } else { |
395 | print STDERR "Could not symlink $target -> $Dest_dir/$dirlink: $!\n"; |
396 | } |
397 | } |
398 | } |
399 | |
400 | |
401 | 1; |
402 | |
154e51a4 |
403 | ############################################################################## |
1fef88e7 |
404 | __END__ |
405 | |
406 | =head1 NAME |
407 | |
408 | h2ph - convert .h C header files to .ph Perl header files |
409 | |
410 | =head1 SYNOPSIS |
411 | |
50f6e060 |
412 | B<h2ph [-d destination directory] [-r] [-l] [headerfiles]> |
1fef88e7 |
413 | |
414 | =head1 DESCRIPTION |
154e51a4 |
415 | |
1fef88e7 |
416 | I<h2ph> |
154e51a4 |
417 | converts any C header files specified to the corresponding Perl header file |
418 | format. |
419 | It is most easily run while in /usr/include: |
154e51a4 |
420 | |
421 | cd /usr/include; h2ph * sys/* |
422 | |
50f6e060 |
423 | or |
424 | |
425 | cd /usr/include; h2ph -r -l . |
426 | |
b306bf39 |
427 | The output files are placed in the hierarchy rooted at Perl's |
428 | architecture dependent library directory. You can specify a different |
429 | hierarchy with a B<-d> switch. |
430 | |
fe14fcc3 |
431 | If run with no arguments, filters standard input to standard output. |
1fef88e7 |
432 | |
50f6e060 |
433 | =head1 OPTIONS |
434 | |
435 | =over 4 |
436 | |
437 | =item -d destination_dir |
438 | |
439 | Put the resulting B<.ph> files beneath B<destination_dir>, instead of |
440 | beneath the default Perl library location (C<$Config{'installsitsearch'}>). |
441 | |
442 | =item -r |
443 | |
444 | Run recursively; if any of B<headerfiles> are directories, then run I<h2ph> |
445 | on all files in those directories (and their subdirectories, etc.). |
446 | |
447 | =item -l |
448 | |
449 | Symbolic links will be replicated in the destination directory. If B<-l> |
450 | is not specified, then links are skipped over. |
451 | |
452 | =item -h |
453 | |
454 | Put ``hints'' in the .ph files which will help in locating problems with |
455 | I<h2ph>. In those cases when you B<require> a B<.ph> file containing syntax |
456 | errors, instead of the cryptic |
457 | |
458 | [ some error condition ] at (eval mmm) line nnn |
459 | |
460 | you will see the slightly more helpful |
461 | |
462 | [ some error condition ] at filename.ph line nnn |
463 | |
464 | However, the B<.ph> files almost double in size when built using B<-h>. |
465 | |
466 | =back |
467 | |
1fef88e7 |
468 | =head1 ENVIRONMENT |
469 | |
154e51a4 |
470 | No environment variables are used. |
1fef88e7 |
471 | |
472 | =head1 FILES |
473 | |
474 | /usr/include/*.h |
475 | /usr/include/sys/*.h |
476 | |
154e51a4 |
477 | etc. |
1fef88e7 |
478 | |
479 | =head1 AUTHOR |
480 | |
154e51a4 |
481 | Larry Wall |
1fef88e7 |
482 | |
483 | =head1 SEE ALSO |
484 | |
154e51a4 |
485 | perl(1) |
1fef88e7 |
486 | |
487 | =head1 DIAGNOSTICS |
488 | |
154e51a4 |
489 | The usual warnings if it can't read or write the files involved. |
1fef88e7 |
490 | |
491 | =head1 BUGS |
492 | |
154e51a4 |
493 | Doesn't construct the %sizeof array for you. |
1fef88e7 |
494 | |
154e51a4 |
495 | It doesn't handle all C constructs, but it does attempt to isolate |
496 | definitions inside evals so that you can get at the definitions |
497 | that it can translate. |
1fef88e7 |
498 | |
154e51a4 |
499 | It's only intended as a rough tool. |
500 | You may need to dicker with the files produced. |
1fef88e7 |
501 | |
502 | =cut |
503 | |
154e51a4 |
504 | !NO!SUBS! |
4633a7c4 |
505 | |
506 | close OUT or die "Can't close $file: $!"; |
507 | chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; |
508 | exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; |