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