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    key_t   caddr_t
  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}' unless defined(\&$name);\n";
 120                     }
 121                     else {
 122                       print OUT "unless defined(\&$name) {\nsub $name $proto\{\n    ${args}eval \"$new\";\n}\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,";}' unless defined(\&$name);\n";
 133                     }
 134                     else {
 135                       print OUT $t,"unless(defined(\&$name)) {\nsub $name () {",$new,";}\n}\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/^\&//;                # hack for things that take the address of
 195         s/^(\s+)//              && do {$new .= ' '; next;};
 196         s/^(0x[0-9a-fA-F]+)//   && do {$new .= $1; next;};
 197         s/^(\d+)\s*[LlUu]*//    && do {$new .= $1; next;};
 198         s/^("(\\"|[^"])*")//    && do {$new .= $1; next;};
 199         s/^'((\\"|[^"])*)'//    && do {
 200             if ($curargs{$1}) {
 201                 $new .= "ord('\$$1')";
 202             }
 203             else {
 204                 $new .= "ord('$1')";
 205             }
 206             next;
 207         };
 208         # replace "sizeof(foo)" with "{foo}"
 209         # also, remove * (C dereference operator) to avoid perl syntax
 210         # problems.  Where the %sizeof array comes from is anyone's
 211         # guess (c2ph?), but this at least avoids fatal syntax errors.
 212         # Behavior is undefined if sizeof() delimiters are unbalanced.
 213         # This code was modified to able to handle constructs like this:
 214         #   sizeof(*(p)), which appear in the HP-UX 10.01 header files.
 215         s/^sizeof\s*\(// && do {
 216             $new .= '$sizeof';
 217             my $lvl = 1;  # already saw one open paren
 218             # tack { on the front, and skip it in the loop
 219             $_ = "{" . "$_";
 220             my $index = 1;
 221             # find balanced closing paren
 222             while ($index <= length($_) && $lvl > 0) {
 223                 $lvl++ if substr($_, $index, 1) eq "(";
 224                 $lvl-- if substr($_, $index, 1) eq ")";
 225                 $index++;
 226             }
 227             # tack } on the end, replacing )
 228             substr($_, $index - 1, 1) = "}";
 229             # remove pesky * operators within the sizeof argument
 230             substr($_, 0, $index - 1) =~ s/\*//g;
 231             next;
 232         };
 233         s/^([_a-zA-Z]\w*)//     && do {
 234             $id = $1;
 235             if ($id eq 'struct') {
 236                 s/^\s+(\w+)//;
 237                 $id .= ' ' . $1;
 238                 $isatype{$id} = 1;
 239             }
 240             elsif ($id eq 'unsigned' || $id eq 'long') {
 241                 s/^\s+(\w+)//;
 242                 $id .= ' ' . $1;
 243                 $isatype{$id} = 1;
 244             }
 245             if ($curargs{$id}) {
 246                 $new .= '$' . $id;
 247             }
 248             elsif ($id eq 'defined') {
 249                 $new .= 'defined';
 250             }
 251             elsif (/^\(/) {
 252                 s/^\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/i;     # cheat
 253                 $new .= " &$id";
 254             }
 255             elsif ($isatype{$id}) {
 256                 if ($new =~ /{\s*$/) {
 257                     $new .= "'$id'";
 258                 }
 259                 elsif ($new =~ /\(\s*$/ && /^[\s*]*\)/) {
 260                     $new =~ s/\(\s*$//;
 261                     s/^[\s*]*\)//;
 262                 }
 263                 else {
 264                     $new .= q(').$id.q(');
 265                 }
 266             }
 267             else {
 268                 if ($inif && $new !~ /defined\s*\($/) {
 269                     $new .= '(defined(&' . $id . ') ? &' . $id . ' : 0)';
 270                 }
 271                 elsif (/^\[/) {
 272                     $new .= ' $' . $id;
 273                 }
 274                 else {
 275                     $new .= ' &' . $id;
 276                 }
 277             }
 278             next;
 279         };
 280         s/^(.)// && do { if ($1 ne '#') { $new .= $1; } next;};
 281     }
 282 }
 283 ##############################################################################
 284 __END__
 285
 286 =head1 NAME
 287
 288 h2ph - convert .h C header files to .ph Perl header files
 289
 290 =head1 SYNOPSIS
 291
 292 B<h2ph [headerfiles]>
 293
 294 =head1 DESCRIPTION
 295
 296 I<h2ph>
 297 converts any C header files specified to the corresponding Perl header file
 298 format.
 299 It is most easily run while in /usr/include:
 300
 301         cd /usr/include; h2ph * sys/*
 302
 303 The output files are placed in the hierarchy rooted at Perl's
 304 architecture dependent library directory.  You can specify a different
 305 hierarchy with a B<-d> switch.
 306
 307 If run with no arguments, filters standard input to standard output.
 308
 309 =head1 ENVIRONMENT
 310
 311 No environment variables are used.
 312
 313 =head1 FILES
 314
 315  /usr/include/*.h
 316  /usr/include/sys/*.h
 317
 318 etc.
 319
 320 =head1 AUTHOR
 321
 322 Larry Wall
 323
 324 =head1 SEE ALSO
 325
 326 perl(1)
 327
 328 =head1 DIAGNOSTICS
 329
 330 The usual warnings if it can't read or write the files involved.
 331
 332 =head1 BUGS
 333
 334 Doesn't construct the %sizeof array for you.
 335
 336 It doesn't handle all C constructs, but it does attempt to isolate
 337 definitions inside evals so that you can get at the definitions
 338 that it can translate.
 339
 340 It's only intended as a rough tool.
 341 You may need to dicker with the files produced.
 342
 343 =cut
 344
 345 !NO!SUBS!
 346
 347 close OUT or die "Can't close $file: $!";
 348 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
 349 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';