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