[perl5.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)) =~ s/\.PL$//;
$file =~ s/\.pl$//
	if ($^O eq 'VMS' or $^O eq 'os2');  # "case-forgiving"

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