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