fbab3b4345179acb39b8c1a00552f68651f45fa3
[perl.git] / h2ph.SH
1 case $CONFIG in
2 '')
3     if test ! -f config.sh; then
4         ln ../config.sh . || \
5         ln ../../config.sh . || \
6         ln ../../../config.sh . || \
7         (echo "Can't find config.sh."; exit 1)
8     fi 2>/dev/null
9     . ./config.sh
10     ;;
11 esac
12 : This forces SH files to create target in same directory as SH file.
13 : This is so that make depend always knows where to find SH derivatives.
14 case "$0" in
15 */*) cd `expr X$0 : 'X\(.*\)/'` ;;
16 esac
17 echo "Extracting h2ph (with variable substitutions)"
18 : This section of the file will have variable substitutions done on it.
19 : Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!.
20 : Protect any dollar signs and backticks that you do not want interpreted
21 : by putting a backslash in front.  You may delete these comments.
22 rm -f h2ph
23 $spitshell >h2ph <<!GROK!THIS!
24 #!$bin/perl
25 'di ';
26 'ds 00 \"';
27 'ig 00 ';
28
29 \$perlincl = '$archlibexp';
30 !GROK!THIS!
31
32 : In the following dollars and backticks do not need the extra backslash.
33 $spitshell >>h2ph <<'!NO!SUBS!'
34
35 chdir '/usr/include' || die "Can't cd /usr/include";
36
37 @isatype = split(' ',<<END);
38         char    uchar   u_char
39         short   ushort  u_short
40         int     uint    u_int
41         long    ulong   u_long
42         FILE
43 END
44
45 @isatype{@isatype} = (1) x @isatype;
46 $inif = 0;
47
48 @ARGV = ('-') unless @ARGV;
49
50 foreach $file (@ARGV) {
51     if ($file eq '-') {
52         open(IN, "-");
53         open(OUT, ">-");
54     }
55     else {
56         ($outfile = $file) =~ s/\.h$/.ph/ || next;
57         print "$file -> $outfile\n";
58         if ($file =~ m|^(.*)/|) {
59             $dir = $1;
60             if (!-d "$perlincl/$dir") {
61                 mkdir("$perlincl/$dir",0777);
62             }
63         }
64         open(IN,"$file") || ((warn "Can't open $file: $!\n"),next);
65         open(OUT,">$perlincl/$outfile") || die "Can't create $outfile: $!\n";
66     }
67     while (<IN>) {
68         chop;
69         while (/\\$/) {
70             chop;
71             $_ .= <IN>;
72             chop;
73         }
74         if (s:/\*:\200:g) {
75             s:\*/:\201:g;
76             s/\200[^\201]*\201//g;      # delete single line comments
77             if (s/\200.*//) {           # begin multi-line comment?
78                 $_ .= '/*';
79                 $_ .= <IN>;
80                 redo;
81             }
82         }
83         if (s/^#\s*//) {
84             if (s/^define\s+(\w+)//) {
85                 $name = $1;
86                 $new = '';
87                 s/\s+$//;
88                 if (s/^\(([\w,\s]*)\)//) {
89                     $args = $1;
90                     if ($args ne '') {
91                         foreach $arg (split(/,\s*/,$args)) {
92                             $arg =~ s/^\s*([^\s].*[^\s])\s*$/$1/;
93                             $curargs{$arg} = 1;
94                         }
95                         $args =~ s/\b(\w)/\$$1/g;
96                         $args = "local($args) = \@_;\n$t    ";
97                     }
98                     s/^\s+//;
99                     do expr();
100                     $new =~ s/(["\\])/\\$1/g;
101                     if ($t ne '') {
102                         $new =~ s/(['\\])/\\$1/g;
103                         print OUT $t,
104                           "eval 'sub $name {\n$t    ${args}eval \"$new\";\n$t}';\n";
105                     }
106                     else {
107                         print OUT "sub $name {\n    ${args}eval \"$new\";\n}\n";
108                     }
109                     %curargs = ();
110                 }
111                 else {
112                     s/^\s+//;
113                     do expr();
114                     $new = 1 if $new eq '';
115                     if ($t ne '') {
116                         $new =~ s/(['\\])/\\$1/g;
117                         print OUT $t,"eval 'sub $name {",$new,";}';\n";
118                     }
119                     else {
120                         print OUT $t,"sub $name {",$new,";}\n";
121                     }
122                 }
123             }
124             elsif (/^include\s+<(.*)>/) {
125                 ($incl = $1) =~ s/\.h$/.ph/;
126                 print OUT $t,"require '$incl';\n";
127             }
128             elsif (/^ifdef\s+(\w+)/) {
129                 print OUT $t,"if (defined &$1) {\n";
130                 $tab += 4;
131                 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
132             }
133             elsif (/^ifndef\s+(\w+)/) {
134                 print OUT $t,"if (!defined &$1) {\n";
135                 $tab += 4;
136                 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
137             }
138             elsif (s/^if\s+//) {
139                 $new = '';
140                 $inif = 1;
141                 do expr();
142                 $inif = 0;
143                 print OUT $t,"if ($new) {\n";
144                 $tab += 4;
145                 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
146             }
147             elsif (s/^elif\s+//) {
148                 $new = '';
149                 $inif = 1;
150                 do expr();
151                 $inif = 0;
152                 $tab -= 4;
153                 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
154                 print OUT $t,"}\n${t}elsif ($new) {\n";
155                 $tab += 4;
156                 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
157             }
158             elsif (/^else/) {
159                 $tab -= 4;
160                 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
161                 print OUT $t,"}\n${t}else {\n";
162                 $tab += 4;
163                 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
164             }
165             elsif (/^endif/) {
166                 $tab -= 4;
167                 $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
168                 print OUT $t,"}\n";
169             }
170         }
171     }
172     print OUT "1;\n";
173 }
174
175 sub expr {
176     while ($_ ne '') {
177         s/^(\s+)//              && do {$new .= ' '; next;};
178         s/^(0x[0-9a-fA-F]+)//   && do {$new .= $1; next;};
179         s/^(\d+)//              && do {$new .= $1; next;};
180         s/^("(\\"|[^"])*")//    && do {$new .= $1; next;};
181         s/^'((\\"|[^"])*)'//    && do {
182             if ($curargs{$1}) {
183                 $new .= "ord('\$$1')";
184             }
185             else {
186                 $new .= "ord('$1')";
187             }
188             next;
189         };
190         s/^sizeof\s*\(([^)]+)\)/{$1}/ && do {
191             $new .= '$sizeof';
192             next;
193         };
194         s/^([_a-zA-Z]\w*)//     && do {
195             $id = $1;
196             if ($id eq 'struct') {
197                 s/^\s+(\w+)//;
198                 $id .= ' ' . $1;
199                 $isatype{$id} = 1;
200             }
201             elsif ($id eq 'unsigned') {
202                 s/^\s+(\w+)//;
203                 $id .= ' ' . $1;
204                 $isatype{$id} = 1;
205             }
206             if ($curargs{$id}) {
207                 $new .= '$' . $id;
208             }
209             elsif ($id eq 'defined') {
210                 $new .= 'defined';
211             }
212             elsif (/^\(/) {
213                 s/^\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/i;     # cheat
214                 $new .= " &$id";
215             }
216             elsif ($isatype{$id}) {
217                 if ($new =~ /{\s*$/) {
218                     $new .= "'$id'";
219                 }
220                 elsif ($new =~ /\(\s*$/ && /^[\s*]*\)/) {
221                     $new =~ s/\(\s*$//;
222                     s/^[\s*]*\)//;
223                 }
224                 else {
225                     $new .= $id;
226                 }
227             }
228             else {
229                 if ($inif && $new !~ /defined\($/) {
230                     $new .= '(defined(&' . $id . ') ? &' . $id . ' : 0)';
231                 } else { 
232                     $new .= ' &' . $id;
233                 }
234             }
235             next;
236         };
237         s/^(.)//                        && do {$new .= $1; next;};
238     }
239 }
240 ##############################################################################
241
242         # These next few lines are legal in both Perl and nroff.
243
244 .00 ;                   # finish .ig
245
246 'di                     \" finish diversion--previous line must be blank
247 .nr nl 0-1              \" fake up transition to first page again
248 .nr % 0                 \" start at page 1
249 '; __END__ ############# From here on it's a standard manual page ############
250 .TH H2PH 1 "August 8, 1990"
251 .AT 3
252 .SH NAME
253 h2ph \- convert .h C header files to .ph Perl header files
254 .SH SYNOPSIS
255 .B h2ph [headerfiles]
256 .SH DESCRIPTION
257 .I h2ph
258 converts any C header files specified to the corresponding Perl header file
259 format.
260 It is most easily run while in /usr/include:
261 .nf
262
263         cd /usr/include; h2ph * sys/*
264
265 .fi
266 If run with no arguments, filters standard input to standard output.
267 .SH ENVIRONMENT
268 No environment variables are used.
269 .SH FILES
270 /usr/include/*.h
271 .br
272 /usr/include/sys/*.h
273 .br
274 etc.
275 .SH AUTHOR
276 Larry Wall
277 .SH "SEE ALSO"
278 perl(1)
279 .SH DIAGNOSTICS
280 The usual warnings if it can't read or write the files involved.
281 .SH BUGS
282 Doesn't construct the %sizeof array for you.
283 .PP
284 It doesn't handle all C constructs, but it does attempt to isolate
285 definitions inside evals so that you can get at the definitions
286 that it can translate.
287 .PP
288 It's only intended as a rough tool.
289 You may need to dicker with the files produced.
290 .ex
291 !NO!SUBS!
292 chmod 755 h2ph
293 $eunicefix h2ph
294 rm -f h2ph.man
295 ln h2ph h2ph.man