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