[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');

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;
$perlincl = @Config{installsitearch};

chdir '/usr/include' || die "Can't cd /usr/include";

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

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

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

foreach $file (@ARGV) {
    # Recover from header files with unbalanced cpp directives
    $t = '';
    $tab = 0;

    if ($file eq '-') {
	open(IN, "-");
	open(OUT, ">-");
    }
    else {
	($outfile = $file) =~ s/\.h$/.ph/ || next;
	print "$file -> $outfile\n";
	if ($file =~ m|^(.*)/|) {
	    $dir = $1;
	    if (!-d "$perlincl/$dir") {
		mkdir("$perlincl/$dir",0777);
	    }
	}
	open(IN,"$file") || ((warn "Can't open $file: $!\n"),next);
	open(OUT,">$perlincl/$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;
		    if ($args ne '') {
			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;
			print OUT $t,
			  "eval 'sub $name {\n$t    ${args}eval \"$new\";\n$t}';\n";
		    }
		    else {
			print OUT "sub $name {\n    ${args}eval \"$new\";\n}\n";
		    }
		    %curargs = ();
		}
		else {
		    s/^\s+//;
		    expr();
		    $new = 1 if $new eq '';
		    if ($t ne '') {
			$new =~ s/(['\\])/\\$1/g;
			print OUT $t,"eval 'sub $name {",$new,";}';\n";
		    }
		    else {
			print OUT $t,"sub $name {",$new,";}\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";
}

sub expr {
    while ($_ ne '') {
	s/^(\s+)//		&& do {$new .= ' '; next;};
	s/^(0x[0-9a-fA-F]+)//	&& do {$new .= $1; next;};
	s/^(\d+)[LlUu]*//	&& 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;
        };
	s/^([_a-zA-Z]\w*)//	&& do {
	    $id = $1;
	    if ($id eq 'struct') {
		s/^\s+(\w+)//;
		$id .= ' ' . $1;
		$isatype{$id} = 1;
	    }
	    elsif ($id eq 'unsigned') {
		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;};
    }
}
##############################################################################
__END__

=head1 NAME

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

=head1 SYNOPSIS

B<h2ph [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/*

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

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