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