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