[p5sagit/p5-mst-13.2.git] / utils / h2ph.PL

#!/usr/local/bin/perl

use Config;
use File::Basename qw(&basename &dirname);

# List explicitly here the variables you want Configure to
# generate.  Metaconfig only looks for shell variables, so you
# have to mention them as if they were shell variables, not
# %Config entries.  Thus you write
#  $startperl
# to ensure Configure will look for $Config{startperl}.
# Wanted:  $archlibexp

# This forces PL files to create target in same directory as PL file.
# This is so that make depend always knows where to find PL derivatives.
chdir dirname($0);
$file = basename($0, '.PL');
$file .= '.com' if $^O eq 'VMS';

open OUT,">$file" or die "Can't create $file: $!";

print "Extracting $file (with variable substitutions)\n";

# In this section, perl variables will be expanded during extraction.
# You can use $Config{...} to use Configure variables.

print OUT <<"!GROK!THIS!";
$Config{startperl}
    eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
	if \$running_under_some_shell;
!GROK!THIS!

# In the following, perl variables are not expanded during extraction.

print OUT <<'!NO!SUBS!';

use Config;
use File::Path qw(mkpath);
use Getopt::Std;

getopts('d:rlh');


my $Exit = 0;

my $Dest_dir = $opt_d || $Config{installsitearch};
die "Destination directory $Dest_dir doesn't exist or isn't a directory\n"
    unless -d $Dest_dir;

@isatype = split(' ',<<END);
	char	uchar	u_char
	short	ushort	u_short
	int	uint	u_int
	long	ulong	u_long
	FILE	key_t	caddr_t
END

@isatype{@isatype} = (1) x @isatype;
$inif = 0;

@ARGV = ('-') unless @ARGV;

while (defined ($file = next_file())) {
    if (-l $file and -d $file) {
        link_if_possible($file) if ($opt_l);
        next;
    }

    # Recover from header files with unbalanced cpp directives
    $t = '';
    $tab = 0;

    # $eval_index goes into ``#line'' directives, to help locate syntax errors:
    $eval_index = 1;

    if ($file eq '-') {
	open(IN, "-");
	open(OUT, ">-");
    }
    else {
	($outfile = $file) =~ s/\.h$/.ph/ || next;
	print "$file -> $outfile\n";
	if ($file =~ m|^(.*)/|) {
	    $dir = $1;
	    mkpath "$Dest_dir/$dir";
	}
	open(IN,"$file") || (($Exit = 1),(warn "Can't open $file: $!\n"),next);
	open(OUT,">$Dest_dir/$outfile") || die "Can't create $outfile: $!\n";
    }
    while (<IN>) {
	chop;
	while (/\\$/) {
	    chop;
	    $_ .= <IN>;
	    chop;
	}
	if (s:/\*:\200:g) {
	    s:\*/:\201:g;
	    s/\200[^\201]*\201//g;	# delete single line comments
	    if (s/\200.*//) {		# begin multi-line comment?
		$_ .= '/*';
		$_ .= <IN>;
		redo;
	    }
	}
	if (s/^#\s*//) {
	    if (s/^define\s+(\w+)//) {
		$name = $1;
		$new = '';
		s/\s+$//;
		if (s/^\(([\w,\s]*)\)//) {
		    $args = $1;
    	    	    my $proto = '() ';
		    if ($args ne '') {
    	    	    	$proto = '';
			foreach $arg (split(/,\s*/,$args)) {
			    $arg =~ s/^\s*([^\s].*[^\s])\s*$/$1/;
			    $curargs{$arg} = 1;
			}
			$args =~ s/\b(\w)/\$$1/g;
			$args = "local($args) = \@_;\n$t    ";
		    }
		    s/^\s+//;
		    expr();
		    $new =~ s/(["\\])/\\$1/g;
		    if ($t ne '') {
			$new =~ s/(['\\])/\\$1/g;
			if ($opt_h) {
			    print OUT $t,
                            "eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name $proto\{\n$t    ${args}eval \"$new\";\n$t}' unless defined(\&$name);\n";
                            $eval_index++;
			} else {
			    print OUT $t,
                            "eval 'sub $name $proto\{\n$t    ${args}eval \"$new\";\n$t}' unless defined(\&$name);\n";
			}
		    }
		    else {
                      print OUT "unless (defined(\&$name)) {\nsub $name $proto\{\n    ${args}eval \"$new\";\n}\n}\n";
		    }
		    %curargs = ();
		}
		else {
		    s/^\s+//;
		    expr();
		    $new = 1 if $new eq '';
		    if ($t ne '') {
			$new =~ s/(['\\])/\\$1/g;
			if ($opt_h) {
			    print OUT $t,"eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name () {",$new,";}' unless defined(\&$name);\n";
			    $eval_index++;
			} else {
			    print OUT $t,"eval 'sub $name () {",$new,";}' unless defined(\&$name);\n";
			}
		    }
		    else {
                      print OUT $t,"unless(defined(\&$name)) {\nsub $name () {",$new,";}\n}\n";
		    }
		}
	    }
	    elsif (/^include\s*<(.*)>/) {
		($incl = $1) =~ s/\.h$/.ph/;
		print OUT $t,"require '$incl';\n";
	    }
	    elsif (/^ifdef\s+(\w+)/) {
		print OUT $t,"if (defined &$1) {\n";
		$tab += 4;
		$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
	    }
	    elsif (/^ifndef\s+(\w+)/) {
		print OUT $t,"if (!defined &$1) {\n";
		$tab += 4;
		$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
	    }
	    elsif (s/^if\s+//) {
		$new = '';
		$inif = 1;
		expr();
		$inif = 0;
		print OUT $t,"if ($new) {\n";
		$tab += 4;
		$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
	    }
	    elsif (s/^elif\s+//) {
		$new = '';
		$inif = 1;
		expr();
		$inif = 0;
		$tab -= 4;
		$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
		print OUT $t,"}\n${t}elsif ($new) {\n";
		$tab += 4;
		$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
	    }
	    elsif (/^else/) {
		$tab -= 4;
		$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
		print OUT $t,"}\n${t}else {\n";
		$tab += 4;
		$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
	    }
	    elsif (/^endif/) {
		$tab -= 4;
		$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
		print OUT $t,"}\n";
	    }
	}
    }
    print OUT "1;\n";
}

exit $Exit;

sub expr {
    while ($_ ne '') {
	s/^\&\&// && do { $new .= "&&"; next;}; # handle && operator
	s/^\&//;		# hack for things that take the address of
	s/^(\s+)//		&& do {$new .= ' '; next;};
	s/^(0X[0-9A-F]+)[UL]*//i	&& do {$new .= lc($1); next;};
	s/^(-?\d+\.\d+E[-+]\d+)F?//i	&& do {$new .= $1; next;};
	s/^(\d+)\s*[LU]*//i	&& do {$new .= $1; next;};
	s/^("(\\"|[^"])*")//	&& do {$new .= $1; next;};
	s/^'((\\"|[^"])*)'//	&& do {
	    if ($curargs{$1}) {
		$new .= "ord('\$$1')";
	    }
	    else {
		$new .= "ord('$1')";
	    }
	    next;
	};
        # replace "sizeof(foo)" with "{foo}"
        # also, remove * (C dereference operator) to avoid perl syntax
        # problems.  Where the %sizeof array comes from is anyone's
        # guess (c2ph?), but this at least avoids fatal syntax errors.
        # Behavior is undefined if sizeof() delimiters are unbalanced.
        # This code was modified to able to handle constructs like this:
        #   sizeof(*(p)), which appear in the HP-UX 10.01 header files.
        s/^sizeof\s*\(// && do {
            $new .= '$sizeof';
            my $lvl = 1;  # already saw one open paren
            # tack { on the front, and skip it in the loop
            $_ = "{" . "$_";
            my $index = 1;
            # find balanced closing paren
            while ($index <= length($_) && $lvl > 0) {
                $lvl++ if substr($_, $index, 1) eq "(";
                $lvl-- if substr($_, $index, 1) eq ")";
                $index++;
            }
            # tack } on the end, replacing )
            substr($_, $index - 1, 1) = "}";
            # remove pesky * operators within the sizeof argument
            substr($_, 0, $index - 1) =~ s/\*//g;
            next;
        };
	# Eliminate typedefs
	/\(([\w\s]+)[\*\s]*\)\s*[\w\(]/ && do {
	    foreach (split /\s+/, $1) {  # Make sure all the words are types,
		last unless ($isatype{$_} or $_ eq 'struct');
	    }
	    s/\([\w\s]+[\*\s]*\)// && next;      # then eliminate them.
	};
	# struct/union member:
	s/^([_A-Z]\w*((\.|->)[_A-Z]\w*)+)//i && do {
	    $id = $1;
	    $id =~ s/(\.|(->))([^\.-]*)/->\{$3\}/g;
	    $new .= ' ($' . $id . ')';
	};
	s/^([_a-zA-Z]\w*)//	&& do {
	    $id = $1;
	    if ($id eq 'struct') {
		s/^\s+(\w+)//;
		$id .= ' ' . $1;
		$isatype{$id} = 1;
	    }
	    elsif ($id =~ /^((un)?signed)|(long)|(short)$/) {
		while (s/^\s+(\w+)//) { $id .= ' ' . $1; }
		$isatype{$id} = 1;
	    }
	    if ($curargs{$id}) {
		$new .= '$' . $id;
	    }
	    elsif ($id eq 'defined') {
		$new .= 'defined';
	    }
	    elsif (/^\(/) {
		s/^\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/i;	# cheat
		$new .= " &$id";
	    }
	    elsif ($isatype{$id}) {
		if ($new =~ /{\s*$/) {
		    $new .= "'$id'";
		}
		elsif ($new =~ /\(\s*$/ && /^[\s*]*\)/) {
		    $new =~ s/\(\s*$//;
		    s/^[\s*]*\)//;
		}
		else {
		    $new .= q(').$id.q(');
		}
	    }
	    else {
		if ($inif && $new !~ /defined\s*\($/) {
		    $new .= '(defined(&' . $id . ') ? &' . $id . ' : 0)';
		}
		elsif (/^\[/) {
		    $new .= ' $' . $id;
		}
		else {
		    $new .= ' &' . $id;
		}
	    }
	    next;
	};
	s/^(.)// && do { if ($1 ne '#') { $new .= $1; } next;};
    }
}


# Handle recursive subdirectories without getting a grotesquely big stack.
# Could this be implemented using File::Find?
sub next_file
{
    my $file;

    while (@ARGV) {
        $file = shift @ARGV;

        if ($file eq '-' or -f $file or -l $file) {
            return $file;
        } elsif (-d $file) {
            if ($opt_r) {
                expand_glob($file);
            } else {
                print STDERR "Skipping directory `$file'\n";
            }
        } else {
            print STDERR "Skipping `$file':  not a file or directory\n";
        }
    }

    return undef;
}


# Put all the files in $directory into @ARGV for processing.
sub expand_glob
{
    my ($directory)  = @_;

    $directory =~ s:/$::;

    opendir DIR, $directory;
        foreach (readdir DIR) {
            next if ($_ eq '.' or $_ eq '..');

            # expand_glob() is going to be called until $ARGV[0] isn't a
            # directory; so push directories, and unshift everything else.
            if (-d "$directory/$_") { push    @ARGV, "$directory/$_" }
            else                    { unshift @ARGV, "$directory/$_" }
        }
    closedir DIR;
}


# Given $file, a symbolic link to a directory in the C include directory,
# make an equivalent symbolic link in $Dest_dir, if we can figure out how.
# Otherwise, just duplicate the file or directory.
sub link_if_possible
{
    my ($dirlink)  = @_;
    my $target  = eval 'readlink($dirlink)';

    if ($target =~ m:^\.\./: or $target =~ m:^/:) {
        # The target of a parent or absolute link could leave the $Dest_dir
        # hierarchy, so let's put all of the contents of $dirlink (actually,
        # the contents of $target) into @ARGV; as a side effect down the
        # line, $dirlink will get created as an _actual_ directory.
        expand_glob($dirlink);
    } else {
        if (-l "$Dest_dir/$dirlink") {
            unlink "$Dest_dir/$dirlink" or
                print STDERR "Could not remove link $Dest_dir/$dirlink:  $!\n";
        }

        if (eval 'symlink($target, "$Dest_dir/$dirlink")') {
            print "Linking $target -> $Dest_dir/$dirlink\n";

            # Make sure that the link _links_ to something:
            if (! -e "$Dest_dir/$target") {
                mkdir("$Dest_dir/$target", 0755) or
                    print STDERR "Could not create $Dest_dir/$target/\n";
            }
        } else {
            print STDERR "Could not symlink $target -> $Dest_dir/$dirlink:  $!\n";
        }
    }
}


1;

##############################################################################
__END__

=head1 NAME

h2ph - convert .h C header files to .ph Perl header files

=head1 SYNOPSIS

B<h2ph [-d destination directory] [-r] [-l] [headerfiles]>

=head1 DESCRIPTION

I<h2ph>
converts any C header files specified to the corresponding Perl header file
format.
It is most easily run while in /usr/include:

	cd /usr/include; h2ph * sys/*

or

	cd /usr/include; h2ph -r -l .

The output files are placed in the hierarchy rooted at Perl's
architecture dependent library directory.  You can specify a different
hierarchy with a B<-d> switch.

If run with no arguments, filters standard input to standard output.

=head1 OPTIONS

=over 4

=item -d destination_dir

Put the resulting B<.ph> files beneath B<destination_dir>, instead of
beneath the default Perl library location (C<$Config{'installsitsearch'}>).

=item -r

Run recursively; if any of B<headerfiles> are directories, then run I<h2ph>
on all files in those directories (and their subdirectories, etc.).

=item -l

Symbolic links will be replicated in the destination directory.  If B<-l>
is not specified, then links are skipped over.

=item -h

Put ``hints'' in the .ph files which will help in locating problems with
I<h2ph>.  In those cases when you B<require> a B<.ph> file containing syntax
errors, instead of the cryptic

	[ some error condition ] at (eval mmm) line nnn

you will see the slightly more helpful

	[ some error condition ] at filename.ph line nnn

However, the B<.ph> files almost double in size when built using B<-h>.

=back

=head1 ENVIRONMENT

No environment variables are used.

=head1 FILES

 /usr/include/*.h
 /usr/include/sys/*.h

etc.

=head1 AUTHOR

Larry Wall

=head1 SEE ALSO

perl(1)

=head1 DIAGNOSTICS

The usual warnings if it can't read or write the files involved.

=head1 BUGS

Doesn't construct the %sizeof array for you.

It doesn't handle all C constructs, but it does attempt to isolate
definitions inside evals so that you can get at the definitions
that it can translate.

It's only intended as a rough tool.
You may need to dicker with the files produced.

=cut

!NO!SUBS!

close OUT or die "Can't close $file: $!";
chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
Commit	Line	Data
4633a7c4	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.
44a8e56a	16	chdir dirname($0);
44a8e56a	17	$file = basename($0, '.PL');
774d564b	18	$file .= '.com' if $^O eq 'VMS';
4633a7c4	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!";
5f05dabc	28	$Config{startperl}
	29	eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
	30	if \$running_under_some_shell;
154e51a4	31	!GROK!THIS!
154e51a4	32
4633a7c4	33	# In the following, perl variables are not expanded during extraction.
	34
	35	print OUT <<'!NO!SUBS!';
154e51a4	36
2c2acf7e	37	use Config;
b306bf39	38	use File::Path qw(mkpath);
50f6e060	39	use Getopt::Std;
	40
	41	getopts('d:rlh');
	42
2c2acf7e	43
b306bf39	44	my $Exit = 0;
b306bf39	45
50f6e060	46	my $Dest_dir = $opt_d \|\| $Config{installsitearch};
b306bf39	47	die "Destination directory $Dest_dir doesn't exist or isn't a directory\n"
b306bf39	48	unless -d $Dest_dir;
154e51a4	49
fe14fcc3	50	@isatype = split(' ',<<END);
	51	char uchar u_char
	52	short ushort u_short
	53	int uint u_int
	54	long ulong u_long
fb73857a	55	FILE key_t caddr_t
fe14fcc3	56	END
fe14fcc3	57
55204971	58	@isatype{@isatype} = (1) x @isatype;
748a9306	59	$inif = 0;
fe14fcc3	60
fe14fcc3	61	@ARGV = ('-') unless @ARGV;
154e51a4	62
50f6e060	63	while (defined ($file = next_file())) {
	64	if (-l $file and -d $file) {
	65	link_if_possible($file) if ($opt_l);
	66	next;
	67	}
	68
5f05dabc	69	# Recover from header files with unbalanced cpp directives
	70	$t = '';
	71	$tab = 0;
	72
50f6e060	73	# $eval_index goes into ``#line'' directives, to help locate syntax errors:
	74	$eval_index = 1;
	75
fe14fcc3	76	if ($file eq '-') {
	77	open(IN, "-");
	78	open(OUT, ">-");
	79	}
	80	else {
	81	($outfile = $file) =~ s/\.h$/.ph/ \|\| next;
	82	print "$file -> $outfile\n";
	83	if ($file =~ m\|^(.*)/\|) {
	84	$dir = $1;
b306bf39	85	mkpath "$Dest_dir/$dir";
154e51a4	86	}
b306bf39	87	open(IN,"$file") \|\| (($Exit = 1),(warn "Can't open $file: $!\n"),next);
b306bf39	88	open(OUT,">$Dest_dir/$outfile") \|\| die "Can't create $outfile: $!\n";
154e51a4	89	}
154e51a4	90	while (<IN>) {
	91	chop;
	92	while (/\\$/) {
	93	chop;
	94	$_ .= <IN>;
	95	chop;
	96	}
	97	if (s:/\*:\200:g) {
	98	s:\*/:\201:g;
	99	s/\200[^\201]*\201//g; # delete single line comments
	100	if (s/\200.*//) { # begin multi-line comment?
	101	$_ .= '/*';
	102	$_ .= <IN>;
	103	redo;
	104	}
	105	}
	106	if (s/^#\s*//) {
	107	if (s/^define\s+(\w+)//) {
	108	$name = $1;
	109	$new = '';
	110	s/\s+$//;
	111	if (s/^\(([\w,\s]*)\)//) {
	112	$args = $1;
b306bf39	113	my $proto = '() ';
154e51a4	114	if ($args ne '') {
b306bf39	115	$proto = '';
154e51a4	116	foreach $arg (split(/,\s*/,$args)) {
55204971	117	$arg =~ s/^\s([^\s].[^\s])\s*$/$1/;
154e51a4	118	$curargs{$arg} = 1;
	119	}
	120	$args =~ s/\b(\w)/\$$1/g;
	121	$args = "local($args) = \@_;\n$t ";
	122	}
	123	s/^\s+//;
5f05dabc	124	expr();
154e51a4	125	$new =~ s/(["\\])/\\$1/g;
	126	if ($t ne '') {
	127	$new =~ s/(['\\])/\\$1/g;
50f6e060	128	if ($opt_h) {
	129	print OUT $t,
	130	"eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name $proto\{\n$t ${args}eval \"$new\";\n$t}' unless defined(\&$name);\n";
	131	$eval_index++;
	132	} else {
	133	print OUT $t,
	134	"eval 'sub $name $proto\{\n$t ${args}eval \"$new\";\n$t}' unless defined(\&$name);\n";
	135	}
154e51a4	136	}
154e51a4	137	else {
6ee623d5	138	print OUT "unless (defined(\&$name)) {\nsub $name $proto\{\n ${args}eval \"$new\";\n}\n}\n";
154e51a4	139	}
	140	%curargs = ();
	141	}
	142	else {
	143	s/^\s+//;
5f05dabc	144	expr();
154e51a4	145	$new = 1 if $new eq '';
	146	if ($t ne '') {
	147	$new =~ s/(['\\])/\\$1/g;
50f6e060	148	if ($opt_h) {
	149	print OUT $t,"eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name () {",$new,";}' unless defined(\&$name);\n";
	150	$eval_index++;
	151	} else {
	152	print OUT $t,"eval 'sub $name () {",$new,";}' unless defined(\&$name);\n";
	153	}
154e51a4	154	}
154e51a4	155	else {
4a8e146e	156	print OUT $t,"unless(defined(\&$name)) {\nsub $name () {",$new,";}\n}\n";
154e51a4	157	}
	158	}
	159	}
fb21d8eb	160	elsif (/^include\s<(.)>/) {
d9d8d8de	161	($incl = $1) =~ s/\.h$/.ph/;
d9d8d8de	162	print OUT $t,"require '$incl';\n";
154e51a4	163	}
	164	elsif (/^ifdef\s+(\w+)/) {
	165	print OUT $t,"if (defined &$1) {\n";
	166	$tab += 4;
	167	$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
	168	}
	169	elsif (/^ifndef\s+(\w+)/) {
	170	print OUT $t,"if (!defined &$1) {\n";
	171	$tab += 4;
	172	$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
	173	}
	174	elsif (s/^if\s+//) {
	175	$new = '';
748a9306	176	$inif = 1;
5f05dabc	177	expr();
748a9306	178	$inif = 0;
154e51a4	179	print OUT $t,"if ($new) {\n";
	180	$tab += 4;
	181	$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
	182	}
	183	elsif (s/^elif\s+//) {
	184	$new = '';
748a9306	185	$inif = 1;
5f05dabc	186	expr();
748a9306	187	$inif = 0;
154e51a4	188	$tab -= 4;
	189	$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
	190	print OUT $t,"}\n${t}elsif ($new) {\n";
	191	$tab += 4;
	192	$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
	193	}
	194	elsif (/^else/) {
	195	$tab -= 4;
	196	$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
	197	print OUT $t,"}\n${t}else {\n";
	198	$tab += 4;
	199	$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
	200	}
	201	elsif (/^endif/) {
	202	$tab -= 4;
	203	$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
	204	print OUT $t,"}\n";
	205	}
	206	}
	207	}
	208	print OUT "1;\n";
	209	}
	210
b306bf39	211	exit $Exit;
b306bf39	212
154e51a4	213	sub expr {
154e51a4	214	while ($_ ne '') {
50f6e060	215	s/^\&\&// && do { $new .= "&&"; next;}; # handle && operator
fb73857a	216	s/^\&//; # hack for things that take the address of
154e51a4	217	s/^(\s+)// && do {$new .= ' '; next;};
50f6e060	218	s/^(0X[0-9A-F]+)[UL]*//i && do {$new .= lc($1); next;};
	219	s/^(-?\d+\.\d+E[-+]\d+)F?//i && do {$new .= $1; next;};
	220	s/^(\d+)\s[LU]//i && do {$new .= $1; next;};
154e51a4	221	s/^("(\\"\|[^"])*")// && do {$new .= $1; next;};
	222	s/^'((\\"\|[^"])*)'// && do {
	223	if ($curargs{$1}) {
	224	$new .= "ord('\$$1')";
	225	}
	226	else {
	227	$new .= "ord('$1')";
	228	}
	229	next;
	230	};
5f05dabc	231	# replace "sizeof(foo)" with "{foo}"
	232	# also, remove * (C dereference operator) to avoid perl syntax
	233	# problems. Where the %sizeof array comes from is anyone's
	234	# guess (c2ph?), but this at least avoids fatal syntax errors.
	235	# Behavior is undefined if sizeof() delimiters are unbalanced.
	236	# This code was modified to able to handle constructs like this:
	237	# sizeof(*(p)), which appear in the HP-UX 10.01 header files.
	238	s/^sizeof\s*\(// && do {
	239	$new .= '$sizeof';
	240	my $lvl = 1; # already saw one open paren
	241	# tack { on the front, and skip it in the loop
	242	$_ = "{" . "$_";
	243	my $index = 1;
	244	# find balanced closing paren
	245	while ($index <= length($_) && $lvl > 0) {
	246	$lvl++ if substr($_, $index, 1) eq "(";
	247	$lvl-- if substr($_, $index, 1) eq ")";
	248	$index++;
	249	}
	250	# tack } on the end, replacing )
	251	substr($_, $index - 1, 1) = "}";
	252	# remove pesky * operators within the sizeof argument
	253	substr($_, 0, $index - 1) =~ s/\*//g;
	254	next;
	255	};
50f6e060	256	# Eliminate typedefs
	257	/\(([\w\s]+)[\\s]\)\s*[\w\(]/ && do {
	258	foreach (split /\s+/, $1) { # Make sure all the words are types,
	259	last unless ($isatype{$_} or $_ eq 'struct');
	260	}
	261	s/\([\w\s]+[\\s]\)// && next; # then eliminate them.
	262	};
	263	# struct/union member:
	264	s/^([_A-Z]\w((\.\|->)[_A-Z]\w)+)//i && do {
	265	$id = $1;
	266	$id =~ s/(\.\|(->))([^\.-]*)/->\{$3\}/g;
	267	$new .= ' ($' . $id . ')';
	268	};
154e51a4	269	s/^([_a-zA-Z]\w*)// && do {
154e51a4	270	$id = $1;
fe14fcc3	271	if ($id eq 'struct') {
	272	s/^\s+(\w+)//;
	273	$id .= ' ' . $1;
	274	$isatype{$id} = 1;
	275	}
50f6e060	276	elsif ($id =~ /^((un)?signed)\|(long)\|(short)$/) {
50f6e060	277	while (s/^\s+(\w+)//) { $id .= ' ' . $1; }
fe14fcc3	278	$isatype{$id} = 1;
fe14fcc3	279	}
154e51a4	280	if ($curargs{$id}) {
	281	$new .= '$' . $id;
	282	}
	283	elsif ($id eq 'defined') {
	284	$new .= 'defined';
	285	}
	286	elsif (/^\(/) {
e5d73d77	287	s/^\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/i; # cheat
154e51a4	288	$new .= " &$id";
	289	}
	290	elsif ($isatype{$id}) {
fe14fcc3	291	if ($new =~ /{\s*$/) {
	292	$new .= "'$id'";
	293	}
	294	elsif ($new =~ /\(\s$/ && /^[\s]*\)/) {
	295	$new =~ s/\(\s*$//;
	296	s/^[\s]\)//;
	297	}
	298	else {
b276c83d	299	$new .= q(').$id.q(');
fe14fcc3	300	}
154e51a4	301	}
154e51a4	302	else {
c07a80fd	303	if ($inif && $new !~ /defined\s*\($/) {
748a9306	304	$new .= '(defined(&' . $id . ') ? &' . $id . ' : 0)';
b306bf39	305	}
b306bf39	306	elsif (/^\[/) {
fb21d8eb	307	$new .= ' $' . $id;
	308	}
	309	else {
748a9306	310	$new .= ' &' . $id;
748a9306	311	}
154e51a4	312	}
	313	next;
	314	};
fb21d8eb	315	s/^(.)// && do { if ($1 ne '#') { $new .= $1; } next;};
154e51a4	316	}
154e51a4	317	}
50f6e060	318
	319
	320	# Handle recursive subdirectories without getting a grotesquely big stack.
	321	# Could this be implemented using File::Find?
	322	sub next_file
	323	{
	324	my $file;
	325
	326	while (@ARGV) {
	327	$file = shift @ARGV;
	328
	329	if ($file eq '-' or -f $file or -l $file) {
	330	return $file;
	331	} elsif (-d $file) {
	332	if ($opt_r) {
	333	expand_glob($file);
	334	} else {
	335	print STDERR "Skipping directory `$file'\n";
	336	}
	337	} else {
	338	print STDERR "Skipping `$file': not a file or directory\n";
	339	}
	340	}
	341
	342	return undef;
	343	}
	344
	345
	346	# Put all the files in $directory into @ARGV for processing.
	347	sub expand_glob
	348	{
	349	my ($directory) = @_;
	350
	351	$directory =~ s:/$::;
	352
	353	opendir DIR, $directory;
	354	foreach (readdir DIR) {
	355	next if ($_ eq '.' or $_ eq '..');
	356
	357	# expand_glob() is going to be called until $ARGV[0] isn't a
	358	# directory; so push directories, and unshift everything else.
	359	if (-d "$directory/$_") { push @ARGV, "$directory/$_" }
	360	else { unshift @ARGV, "$directory/$_" }
	361	}
	362	closedir DIR;
	363	}
	364
	365
	366	# Given $file, a symbolic link to a directory in the C include directory,
	367	# make an equivalent symbolic link in $Dest_dir, if we can figure out how.
	368	# Otherwise, just duplicate the file or directory.
	369	sub link_if_possible
	370	{
	371	my ($dirlink) = @_;
	372	my $target = eval 'readlink($dirlink)';
	373
	374	if ($target =~ m:^\.\./: or $target =~ m:^/:) {
	375	# The target of a parent or absolute link could leave the $Dest_dir
	376	# hierarchy, so let's put all of the contents of $dirlink (actually,
	377	# the contents of $target) into @ARGV; as a side effect down the
	378	# line, $dirlink will get created as an _actual_ directory.
	379	expand_glob($dirlink);
	380	} else {
	381	if (-l "$Dest_dir/$dirlink") {
382	unlink "$Dest_dir/$dirlink" or
383	print STDERR "Could not remove link $Dest_dir/$dirlink: $!\n";
384	}
385
386	if (eval 'symlink($target, "$Dest_dir/$dirlink")') {
387	print "Linking $target -> $Dest_dir/$dirlink\n";
388
389	# Make sure that the link _links_ to something:
390	if (! -e "$Dest_dir/$target") {
391	mkdir("$Dest_dir/$target", 0755) or
392	print STDERR "Could not create $Dest_dir/$target/\n";
393	}
394	} else {
395	print STDERR "Could not symlink $target -> $Dest_dir/$dirlink: $!\n";
396	}
397	}
398	}
399
400
401	1;
402
154e51a4	403	##############################################################################
1fef88e7	404	__END__
	405
	406	=head1 NAME
	407
	408	h2ph - convert .h C header files to .ph Perl header files
	409
	410	=head1 SYNOPSIS
	411
50f6e060	412	B<h2ph [-d destination directory] [-r] [-l] [headerfiles]>
1fef88e7	413
1fef88e7	414	=head1 DESCRIPTION
154e51a4	415
1fef88e7	416	I<h2ph>
154e51a4	417	converts any C header files specified to the corresponding Perl header file
	418	format.
	419	It is most easily run while in /usr/include:
154e51a4	420
	421	cd /usr/include; h2ph * sys/*
	422
50f6e060	423	or
	424
	425	cd /usr/include; h2ph -r -l .
	426
b306bf39	427	The output files are placed in the hierarchy rooted at Perl's
	428	architecture dependent library directory. You can specify a different
	429	hierarchy with a B<-d> switch.
	430
fe14fcc3	431	If run with no arguments, filters standard input to standard output.
1fef88e7	432
50f6e060	433	=head1 OPTIONS
	434
	435	=over 4
	436
	437	=item -d destination_dir
	438
	439	Put the resulting B<.ph> files beneath B<destination_dir>, instead of
	440	beneath the default Perl library location (C<$Config{'installsitsearch'}>).
	441
	442	=item -r
	443
	444	Run recursively; if any of B<headerfiles> are directories, then run I<h2ph>
	445	on all files in those directories (and their subdirectories, etc.).
	446
	447	=item -l
	448
	449	Symbolic links will be replicated in the destination directory. If B<-l>
	450	is not specified, then links are skipped over.
	451
	452	=item -h
	453
	454	Put ``hints'' in the .ph files which will help in locating problems with
	455	I<h2ph>. In those cases when you B<require> a B<.ph> file containing syntax
	456	errors, instead of the cryptic
	457
	458	[ some error condition ] at (eval mmm) line nnn
	459
	460	you will see the slightly more helpful
	461
	462	[ some error condition ] at filename.ph line nnn
	463
	464	However, the B<.ph> files almost double in size when built using B<-h>.
	465
	466	=back
	467
1fef88e7	468	=head1 ENVIRONMENT
1fef88e7	469
154e51a4	470	No environment variables are used.
1fef88e7	471
	472	=head1 FILES
	473
	474	/usr/include/*.h
	475	/usr/include/sys/*.h
	476
154e51a4	477	etc.
1fef88e7	478
	479	=head1 AUTHOR
	480
154e51a4	481	Larry Wall
1fef88e7	482
	483	=head1 SEE ALSO
	484
154e51a4	485	perl(1)
1fef88e7	486
	487	=head1 DIAGNOSTICS
	488
154e51a4	489	The usual warnings if it can't read or write the files involved.
1fef88e7	490
	491	=head1 BUGS
	492
154e51a4	493	Doesn't construct the %sizeof array for you.
1fef88e7	494
154e51a4	495	It doesn't handle all C constructs, but it does attempt to isolate
	496	definitions inside evals so that you can get at the definitions
	497	that it can translate.
1fef88e7	498
154e51a4	499	It's only intended as a rough tool.
154e51a4	500	You may need to dicker with the files produced.
1fef88e7	501
	502	=cut
	503
154e51a4	504	!NO!SUBS!
4633a7c4	505
	506	close OUT or die "Can't close $file: $!";
	507	chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
	508	exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';