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 ':';