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