LC_COLLATE.
[perl.git] / utils / h2ph.PL
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.
16 chdir(dirname($0));
17 ($file = basename($0)) =~ s/\.PL$//;
18 $file =~ s/\.pl$//
19         if ($^O eq 'VMS' or $^O eq 'os2');  # "case-forgiving"
20
21 open OUT,">$file" or die "Can't create $file: $!";
22
23 print "Extracting $file (with variable substitutions)\n";
24
25 # In this section, perl variables will be expanded during extraction.
26 # You can use $Config{...} to use Configure variables.
27
28 print OUT <<"!GROK!THIS!";
29 $Config{'startperl'}
30     eval 'exec perl -S \$0 "\$@"'
31         if 0;
32
33 !GROK!THIS!
34
35 # In the following, perl variables are not expanded during extraction.
36
37 print OUT <<'!NO!SUBS!';
38
39 use Config;
40 $perlincl = @Config{installsitearch};
41
42 chdir '/usr/include' || die "Can't cd /usr/include";
43
44 @isatype = split(' ',<<END);
45         char    uchar   u_char
46         short   ushort  u_short
47         int     uint    u_int
48         long    ulong   u_long
49         FILE
50 END
51
52 @isatype{@isatype} = (1) x @isatype;
53 $inif = 0;
54
55 @ARGV = ('-') unless @ARGV;
56
57 foreach $file (@ARGV) {
58     if ($file eq '-') {
59         open(IN, "-");
60         open(OUT, ">-");
61     }
62     else {
63         ($outfile = $file) =~ s/\.h$/.ph/ || next;
64         print "$file -> $outfile\n";
65         if ($file =~ m|^(.*)/|) {
66             $dir = $1;
67             if (!-d "$perlincl/$dir") {
68                 mkdir("$perlincl/$dir",0777);
69             }
70         }
71         open(IN,"$file") || ((warn "Can't open $file: $!\n"),next);
72         open(OUT,">$perlincl/$outfile") || die "Can't create $outfile: $!\n";
73     }
74     while (<IN>) {
75         chop;
76         while (/\\$/) {
77             chop;
78             $_ .= <IN>;
79             chop;
80         }
81         if (s:/\*:\200:g) {
82             s:\*/:\201:g;
83             s/\200[^\201]*\201//g;      # delete single line comments
84             if (s/\200.*//) {           # begin multi-line comment?
85                 $_ .= '/*';
86                 $_ .= <IN>;
87                 redo;
88             }
89         }
90         if (s/^#\s*//) {
91             if (s/^define\s+(\w+)//) {
92                 $name = $1;
93                 $new = '';
94                 s/\s+$//;
95                 if (s/^\(([\w,\s]*)\)//) {
96                     $args = $1;
97                     if ($args ne '') {
98                         foreach $arg (split(/,\s*/,$args)) {
99                             $arg =~ s/^\s*([^\s].*[^\s])\s*$/$1/;
100                             $curargs{$arg} = 1;
101                         }
102                         $args =~ s/\b(\w)/\$$1/g;
103                         $args = "local($args) = \@_;\n$t    ";
104                     }
105                     s/^\s+//;
106                     do expr();
107                     $new =~ s/(["\\])/\\$1/g;
108                     if ($t ne '') {
109                         $new =~ s/(['\\])/\\$1/g;
110                         print OUT $t,
111                           "eval 'sub $name {\n$t    ${args}eval \"$new\";\n$t}';\n";
112                     }
113                     else {
114                         print OUT "sub $name {\n    ${args}eval \"$new\";\n}\n";
115                     }
116                     %curargs = ();
117                 }
118                 else {
119                     s/^\s+//;
120                     do expr();
121                     $new = 1 if $new eq '';
122                     if ($t ne '') {
123                         $new =~ s/(['\\])/\\$1/g;
124                         print OUT $t,"eval 'sub $name {",$new,";}';\n";
125                     }
126                     else {
127                         print OUT $t,"sub $name {",$new,";}\n";
128                     }
129                 }
130             }
131             elsif (/^include\s*<(.*)>/) {
132                 ($incl = $1) =~ s/\.h$/.ph/;
133                 print OUT $t,"require '$incl';\n";
134             }
135             elsif (/^ifdef\s+(\w+)/) {
136                 print OUT $t,"if (defined &$1) {\n";
137                 $tab += 4;
138                 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
139             }
140             elsif (/^ifndef\s+(\w+)/) {
141                 print OUT $t,"if (!defined &$1) {\n";
142                 $tab += 4;
143                 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
144             }
145             elsif (s/^if\s+//) {
146                 $new = '';
147                 $inif = 1;
148                 do expr();
149                 $inif = 0;
150                 print OUT $t,"if ($new) {\n";
151                 $tab += 4;
152                 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
153             }
154             elsif (s/^elif\s+//) {
155                 $new = '';
156                 $inif = 1;
157                 do expr();
158                 $inif = 0;
159                 $tab -= 4;
160                 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
161                 print OUT $t,"}\n${t}elsif ($new) {\n";
162                 $tab += 4;
163                 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
164             }
165             elsif (/^else/) {
166                 $tab -= 4;
167                 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
168                 print OUT $t,"}\n${t}else {\n";
169                 $tab += 4;
170                 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
171             }
172             elsif (/^endif/) {
173                 $tab -= 4;
174                 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
175                 print OUT $t,"}\n";
176             }
177         }
178     }
179     print OUT "1;\n";
180 }
181
182 sub expr {
183     while ($_ ne '') {
184         s/^(\s+)//              && do {$new .= ' '; next;};
185         s/^(0x[0-9a-fA-F]+)//   && do {$new .= $1; next;};
186         s/^(\d+)[LlUu]*//       && do {$new .= $1; next;};
187         s/^("(\\"|[^"])*")//    && do {$new .= $1; next;};
188         s/^'((\\"|[^"])*)'//    && do {
189             if ($curargs{$1}) {
190                 $new .= "ord('\$$1')";
191             }
192             else {
193                 $new .= "ord('$1')";
194             }
195             next;
196         };
197         s/^sizeof\s*\(([^)]+)\)/{$1}/ && do {
198             $new .= '$sizeof';
199             next;
200         };
201         s/^([_a-zA-Z]\w*)//     && do {
202             $id = $1;
203             if ($id eq 'struct') {
204                 s/^\s+(\w+)//;
205                 $id .= ' ' . $1;
206                 $isatype{$id} = 1;
207             }
208             elsif ($id eq 'unsigned') {
209                 s/^\s+(\w+)//;
210                 $id .= ' ' . $1;
211                 $isatype{$id} = 1;
212             }
213             if ($curargs{$id}) {
214                 $new .= '$' . $id;
215             }
216             elsif ($id eq 'defined') {
217                 $new .= 'defined';
218             }
219             elsif (/^\(/) {
220                 s/^\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/i;     # cheat
221                 $new .= " &$id";
222             }
223             elsif ($isatype{$id}) {
224                 if ($new =~ /{\s*$/) {
225                     $new .= "'$id'";
226                 }
227                 elsif ($new =~ /\(\s*$/ && /^[\s*]*\)/) {
228                     $new =~ s/\(\s*$//;
229                     s/^[\s*]*\)//;
230                 }
231                 else {
232                     $new .= q(').$id.q(');
233                 }
234             }
235             else {
236                 if ($inif && $new !~ /defined\s*\($/) {
237                     $new .= '(defined(&' . $id . ') ? &' . $id . ' : 0)';
238                 } 
239                 elsif (/^\[/) { 
240                     $new .= ' $' . $id;
241                 }
242                 else {
243                     $new .= ' &' . $id;
244                 }
245             }
246             next;
247         };
248         s/^(.)// && do { if ($1 ne '#') { $new .= $1; } next;};
249     }
250 }
251 ##############################################################################
252 __END__
253
254 =head1 NAME
255
256 h2ph - convert .h C header files to .ph Perl header files
257
258 =head1 SYNOPSIS
259
260 B<h2ph [headerfiles]>
261
262 =head1 DESCRIPTION
263
264 I<h2ph>
265 converts any C header files specified to the corresponding Perl header file
266 format.
267 It is most easily run while in /usr/include:
268
269         cd /usr/include; h2ph * sys/*
270
271 If run with no arguments, filters standard input to standard output.
272
273 =head1 ENVIRONMENT
274
275 No environment variables are used.
276
277 =head1 FILES
278
279  /usr/include/*.h
280  /usr/include/sys/*.h
281
282 etc.
283
284 =head1 AUTHOR
285
286 Larry Wall
287
288 =head1 SEE ALSO
289
290 perl(1)
291
292 =head1 DIAGNOSTICS
293
294 The usual warnings if it can't read or write the files involved.
295
296 =head1 BUGS
297
298 Doesn't construct the %sizeof array for you.
299
300 It doesn't handle all C constructs, but it does attempt to isolate
301 definitions inside evals so that you can get at the definitions
302 that it can translate.
303
304 It's only intended as a rough tool.
305 You may need to dicker with the files produced.
306
307 =cut
308
309 !NO!SUBS!
310
311 close OUT or die "Can't close $file: $!";
312 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
313 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';