4 use File::Basename qw(&basename &dirname);
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
11 # to ensure Configure will look for $Config{startperl}.
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.
17 $file = basename($0, '.PL');
18 $file .= '.com' if $^O eq 'VMS';
20 open OUT,">$file" or die "Can't create $file: $!";
22 print "Extracting $file (with variable substitutions)\n";
24 # In this section, perl variables will be expanded during extraction.
25 # You can use $Config{...} to use Configure variables.
27 print OUT <<"!GROK!THIS!";
29 eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
30 if \$running_under_some_shell;
33 # In the following, perl variables are not expanded during extraction.
35 print OUT <<'!NO!SUBS!';
38 use File::Path qw(mkpath);
46 my $Dest_dir = $opt_d || $Config{installsitearch};
47 die "Destination directory $Dest_dir doesn't exist or isn't a directory\n"
50 @isatype = split(' ',<<END);
58 @isatype{@isatype} = (1) x @isatype;
61 @ARGV = ('-') unless @ARGV;
63 while (defined ($file = next_file())) {
64 if (-l $file and -d $file) {
65 link_if_possible($file) if ($opt_l);
69 # Recover from header files with unbalanced cpp directives
73 # $eval_index goes into ``#line'' directives, to help locate syntax errors:
81 ($outfile = $file) =~ s/\.h$/.ph/ || next;
82 print "$file -> $outfile\n";
83 if ($file =~ m|^(.*)/|) {
85 mkpath "$Dest_dir/$dir";
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";
99 s/\200[^\201]*\201//g; # delete single line comments
100 if (s/\200.*//) { # begin multi-line comment?
107 if (s/^define\s+(\w+)//) {
111 if (s/^\(([\w,\s]*)\)//) {
116 foreach $arg (split(/,\s*/,$args)) {
117 $arg =~ s/^\s*([^\s].*[^\s])\s*$/$1/;
120 $args =~ s/\b(\w)/\$$1/g;
121 $args = "local($args) = \@_;\n$t ";
125 $new =~ s/(["\\])/\\$1/g;
127 $new =~ s/(['\\])/\\$1/g;
130 "eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name $proto\{\n$t ${args}eval \"$new\";\n$t}' unless defined(\&$name);\n";
134 "eval 'sub $name $proto\{\n$t ${args}eval \"$new\";\n$t}' unless defined(\&$name);\n";
138 print OUT "unless defined(\&$name) {\nsub $name $proto\{\n ${args}eval \"$new\";\n}\n}\n";
145 $new = 1 if $new eq '';
147 $new =~ s/(['\\])/\\$1/g;
149 print OUT $t,"eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name () {",$new,";}' unless defined(\&$name);\n";
152 print OUT $t,"eval 'sub $name () {",$new,";}' unless defined(\&$name);\n";
156 print OUT $t,"unless(defined(\&$name)) {\nsub $name () {",$new,";}\n}\n";
160 elsif (/^include\s*<(.*)>/) {
161 ($incl = $1) =~ s/\.h$/.ph/;
162 print OUT $t,"require '$incl';\n";
164 elsif (/^ifdef\s+(\w+)/) {
165 print OUT $t,"if (defined &$1) {\n";
167 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
169 elsif (/^ifndef\s+(\w+)/) {
170 print OUT $t,"if (!defined &$1) {\n";
172 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
179 print OUT $t,"if ($new) {\n";
181 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
183 elsif (s/^elif\s+//) {
189 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
190 print OUT $t,"}\n${t}elsif ($new) {\n";
192 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
196 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
197 print OUT $t,"}\n${t}else {\n";
199 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
203 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
215 s/^\&\&// && do { $new .= "&&"; next;}; # handle && operator
216 s/^\&//; # hack for things that take the address of
217 s/^(\s+)// && do {$new .= ' '; next;};
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;};
221 s/^("(\\"|[^"])*")// && do {$new .= $1; next;};
222 s/^'((\\"|[^"])*)'// && do {
224 $new .= "ord('\$$1')";
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 {
240 my $lvl = 1; # already saw one open paren
241 # tack { on the front, and skip it in the loop
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 ")";
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;
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');
261 s/\([\w\s]+[\*\s]*\)// && next; # then eliminate them.
263 # struct/union member:
264 s/^([_A-Z]\w*((\.|->)[_A-Z]\w*)+)//i && do {
266 $id =~ s/(\.|(->))([^\.-]*)/->\{$3\}/g;
267 $new .= ' ($' . $id . ')';
269 s/^([_a-zA-Z]\w*)// && do {
271 if ($id eq 'struct') {
276 elsif ($id =~ /^((un)?signed)|(long)|(short)$/) {
277 while (s/^\s+(\w+)//) { $id .= ' ' . $1; }
283 elsif ($id eq 'defined') {
287 s/^\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/i; # cheat
290 elsif ($isatype{$id}) {
291 if ($new =~ /{\s*$/) {
294 elsif ($new =~ /\(\s*$/ && /^[\s*]*\)/) {
299 $new .= q(').$id.q(');
303 if ($inif && $new !~ /defined\s*\($/) {
304 $new .= '(defined(&' . $id . ') ? &' . $id . ' : 0)';
315 s/^(.)// && do { if ($1 ne '#') { $new .= $1; } next;};
320 # Handle recursive subdirectories without getting a grotesquely big stack.
321 # Could this be implemented using File::Find?
329 if ($file eq '-' or -f $file or -l $file) {
335 print STDERR "Skipping directory `$file'\n";
338 print STDERR "Skipping `$file': not a file or directory\n";
346 # Put all the files in $directory into @ARGV for processing.
349 my ($directory) = @_;
351 $directory =~ s:/$::;
353 opendir DIR, $directory;
354 foreach (readdir DIR) {
355 next if ($_ eq '.' or $_ eq '..');
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/$_" }
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.
372 my $target = eval 'readlink($dirlink)';
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);
381 if (-l "$Dest_dir/$dirlink") {
382 unlink "$Dest_dir/$dirlink" or
383 print STDERR "Could not remove link $Dest_dir/$dirlink: $!\n";
386 if (eval 'symlink($target, "$Dest_dir/$dirlink")') {
387 print "Linking $target -> $Dest_dir/$dirlink\n";
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";
395 print STDERR "Could not symlink $target -> $Dest_dir/$dirlink: $!\n";
403 ##############################################################################
408 h2ph - convert .h C header files to .ph Perl header files
412 B<h2ph [-d destination directory] [-r] [-l] [headerfiles]>
417 converts any C header files specified to the corresponding Perl header file
419 It is most easily run while in /usr/include:
421 cd /usr/include; h2ph * sys/*
425 cd /usr/include; h2ph -r -l .
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.
431 If run with no arguments, filters standard input to standard output.
437 =item -d destination_dir
439 Put the resulting B<.ph> files beneath B<destination_dir>, instead of
440 beneath the default Perl library location (C<$Config{'installsitsearch'}>).
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.).
449 Symbolic links will be replicated in the destination directory. If B<-l>
450 is not specified, then links are skipped over.
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
458 [ some error condition ] at (eval mmm) line nnn
460 you will see the slightly more helpful
462 [ some error condition ] at filename.ph line nnn
464 However, the B<.ph> files almost double in size when built using B<-h>.
470 No environment variables are used.
489 The usual warnings if it can't read or write the files involved.
493 Doesn't construct the %sizeof array for you.
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.
499 It's only intended as a rough tool.
500 You may need to dicker with the files produced.
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 ':';