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