[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 ($Config{'osname'} eq 'VMS' or
	    $Config{'osname'} 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 perl -S \$0 "\$@"'
	if 0;

'di ';
'ds 00 \"';
'ig 00 ';

\$perlincl = "$Config{archlibexp}";

!GROK!THIS!

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

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

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) {
    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+//;
		    do 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+//;
		    do 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;
		do 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;
		do 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;
	};
	s/^sizeof\s*\(([^)]+)\)/{$1}/ && do {
	    $new .= '$sizeof';
	    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;};
    }
}
##############################################################################

	# These next few lines are legal in both Perl and nroff.

.00 ;			# finish .ig

'di			\" finish diversion--previous line must be blank
.nr nl 0-1		\" fake up transition to first page again
.nr % 0			\" start at page 1
'; __END__ ############# From here on it's a standard manual page ############
.TH H2PH 1 "August 8, 1990"
.AT 3
.SH NAME
h2ph \- convert .h C header files to .ph Perl header files
.SH SYNOPSIS
.B h2ph [headerfiles]
.SH 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:
.nf

	cd /usr/include; h2ph * sys/*

.fi
If run with no arguments, filters standard input to standard output.
.SH ENVIRONMENT
No environment variables are used.
.SH FILES
/usr/include/*.h
.br
/usr/include/sys/*.h
.br
etc.
.SH AUTHOR
Larry Wall
.SH "SEE ALSO"
perl(1)
.SH DIAGNOSTICS
The usual warnings if it can't read or write the files involved.
.SH BUGS
Doesn't construct the %sizeof array for you.
.PP
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.
.PP
It's only intended as a rough tool.
You may need to dicker with the files produced.
.ex
!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$//
	19	if ($Config{'osname'} eq 'VMS' or
	20	$Config{'osname'} eq 'OS2'); # "case-forgiving"
	21
	22	open OUT,">$file" or die "Can't create $file: $!";
	23
	24	print "Extracting $file (with variable substitutions)\n";
	25
	26	# In this section, perl variables will be expanded during extraction.
	27	# You can use $Config{...} to use Configure variables.
	28
	29	print OUT <<"!GROK!THIS!";
	30	$Config{'startperl'}
	31	eval 'exec perl -S \$0 "\$@"'
	32	if 0;
	33
a0d0e21e LW	34	'di ';
	35	'ds 00 \"';
	36	'ig 00 ';
154e51a4	37
25f94b33	38	\$perlincl = "$Config{archlibexp}";
4633a7c4	39
154e51a4 LW	40	!GROK!THIS!
154e51a4 LW	41
4633a7c4 LW	42	# In the following, perl variables are not expanded during extraction.
	43
	44	print OUT <<'!NO!SUBS!';
154e51a4 LW	45
	46	chdir '/usr/include' \|\| die "Can't cd /usr/include";
	47
fe14fcc3 LW	48	@isatype = split(' ',<<END);
	49	char uchar u_char
	50	short ushort u_short
	51	int uint u_int
	52	long ulong u_long
	53	FILE
	54	END
	55
55204971	56	@isatype{@isatype} = (1) x @isatype;
748a9306	57	$inif = 0;
fe14fcc3 LW	58
fe14fcc3 LW	59	@ARGV = ('-') unless @ARGV;
154e51a4 LW	60
154e51a4 LW	61	foreach $file (@ARGV) {
fe14fcc3 LW	62	if ($file eq '-') {
	63	open(IN, "-");
	64	open(OUT, ">-");
	65	}
	66	else {
	67	($outfile = $file) =~ s/\.h$/.ph/ \|\| next;
	68	print "$file -> $outfile\n";
	69	if ($file =~ m\|^(.*)/\|) {
	70	$dir = $1;
	71	if (!-d "$perlincl/$dir") {
	72	mkdir("$perlincl/$dir",0777);
	73	}
154e51a4	74	}
fe14fcc3 LW	75	open(IN,"$file") \|\| ((warn "Can't open $file: $!\n"),next);
fe14fcc3 LW	76	open(OUT,">$perlincl/$outfile") \|\| die "Can't create $outfile: $!\n";
154e51a4	77	}
154e51a4 LW	78	while (<IN>) {
	79	chop;
	80	while (/\\$/) {
	81	chop;
	82	$_ .= <IN>;
	83	chop;
	84	}
	85	if (s:/\*:\200:g) {
	86	s:\*/:\201:g;
	87	s/\200[^\201]*\201//g; # delete single line comments
	88	if (s/\200.*//) { # begin multi-line comment?
	89	$_ .= '/*';
	90	$_ .= <IN>;
	91	redo;
	92	}
	93	}
	94	if (s/^#\s*//) {
	95	if (s/^define\s+(\w+)//) {
	96	$name = $1;
	97	$new = '';
	98	s/\s+$//;
	99	if (s/^\(([\w,\s]*)\)//) {
	100	$args = $1;
	101	if ($args ne '') {
	102	foreach $arg (split(/,\s*/,$args)) {
55204971	103	$arg =~ s/^\s([^\s].[^\s])\s*$/$1/;
154e51a4 LW	104	$curargs{$arg} = 1;
	105	}
	106	$args =~ s/\b(\w)/\$$1/g;
	107	$args = "local($args) = \@_;\n$t ";
	108	}
	109	s/^\s+//;
	110	do expr();
	111	$new =~ s/(["\\])/\\$1/g;
	112	if ($t ne '') {
	113	$new =~ s/(['\\])/\\$1/g;
	114	print OUT $t,
	115	"eval 'sub $name {\n$t ${args}eval \"$new\";\n$t}';\n";
	116	}
	117	else {
	118	print OUT "sub $name {\n ${args}eval \"$new\";\n}\n";
	119	}
	120	%curargs = ();
	121	}
	122	else {
	123	s/^\s+//;
	124	do expr();
	125	$new = 1 if $new eq '';
	126	if ($t ne '') {
	127	$new =~ s/(['\\])/\\$1/g;
	128	print OUT $t,"eval 'sub $name {",$new,";}';\n";
	129	}
	130	else {
	131	print OUT $t,"sub $name {",$new,";}\n";
	132	}
	133	}
	134	}
fb21d8eb	135	elsif (/^include\s<(.)>/) {
d9d8d8de LW	136	($incl = $1) =~ s/\.h$/.ph/;
d9d8d8de LW	137	print OUT $t,"require '$incl';\n";
154e51a4 LW	138	}
	139	elsif (/^ifdef\s+(\w+)/) {
	140	print OUT $t,"if (defined &$1) {\n";
	141	$tab += 4;
	142	$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
	143	}
	144	elsif (/^ifndef\s+(\w+)/) {
	145	print OUT $t,"if (!defined &$1) {\n";
	146	$tab += 4;
	147	$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
	148	}
	149	elsif (s/^if\s+//) {
	150	$new = '';
748a9306	151	$inif = 1;
154e51a4	152	do expr();
748a9306	153	$inif = 0;
154e51a4 LW	154	print OUT $t,"if ($new) {\n";
	155	$tab += 4;
	156	$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
	157	}
	158	elsif (s/^elif\s+//) {
	159	$new = '';
748a9306	160	$inif = 1;
154e51a4	161	do expr();
748a9306	162	$inif = 0;
154e51a4 LW	163	$tab -= 4;
	164	$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
	165	print OUT $t,"}\n${t}elsif ($new) {\n";
	166	$tab += 4;
	167	$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
	168	}
	169	elsif (/^else/) {
	170	$tab -= 4;
	171	$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
	172	print OUT $t,"}\n${t}else {\n";
	173	$tab += 4;
	174	$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
	175	}
	176	elsif (/^endif/) {
	177	$tab -= 4;
	178	$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
	179	print OUT $t,"}\n";
	180	}
	181	}
	182	}
	183	print OUT "1;\n";
	184	}
	185
	186	sub expr {
	187	while ($_ ne '') {
	188	s/^(\s+)// && do {$new .= ' '; next;};
	189	s/^(0x[0-9a-fA-F]+)// && do {$new .= $1; next;};
b276c83d	190	s/^(\d+)[LlUu]*// && do {$new .= $1; next;};
154e51a4 LW	191	s/^("(\\"\|[^"])*")// && do {$new .= $1; next;};
	192	s/^'((\\"\|[^"])*)'// && do {
	193	if ($curargs{$1}) {
	194	$new .= "ord('\$$1')";
	195	}
	196	else {
	197	$new .= "ord('$1')";
	198	}
	199	next;
	200	};
b276c83d	201	s/^sizeof\s*\(([^)]+)\)/{$1}/ && do {
154e51a4 LW	202	$new .= '$sizeof';
	203	next;
	204	};
	205	s/^([_a-zA-Z]\w*)// && do {
	206	$id = $1;
fe14fcc3 LW	207	if ($id eq 'struct') {
	208	s/^\s+(\w+)//;
	209	$id .= ' ' . $1;
	210	$isatype{$id} = 1;
	211	}
	212	elsif ($id eq 'unsigned') {
	213	s/^\s+(\w+)//;
	214	$id .= ' ' . $1;
	215	$isatype{$id} = 1;
	216	}
154e51a4 LW	217	if ($curargs{$id}) {
	218	$new .= '$' . $id;
	219	}
	220	elsif ($id eq 'defined') {
	221	$new .= 'defined';
	222	}
	223	elsif (/^\(/) {
e5d73d77	224	s/^\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/i; # cheat
154e51a4 LW	225	$new .= " &$id";
	226	}
	227	elsif ($isatype{$id}) {
fe14fcc3 LW	228	if ($new =~ /{\s*$/) {
	229	$new .= "'$id'";
	230	}
	231	elsif ($new =~ /\(\s$/ && /^[\s]*\)/) {
	232	$new =~ s/\(\s*$//;
	233	s/^[\s]\)//;
	234	}
	235	else {
b276c83d	236	$new .= q(').$id.q(');
fe14fcc3	237	}
154e51a4 LW	238	}
154e51a4 LW	239	else {
c07a80fd	240	if ($inif && $new !~ /defined\s*\($/) {
748a9306	241	$new .= '(defined(&' . $id . ') ? &' . $id . ' : 0)';
fb21d8eb	242	}
	243	elsif (/^\[/) {
	244	$new .= ' $' . $id;
	245	}
	246	else {
748a9306 LW	247	$new .= ' &' . $id;
748a9306 LW	248	}
154e51a4 LW	249	}
	250	next;
	251	};
fb21d8eb	252	s/^(.)// && do { if ($1 ne '#') { $new .= $1; } next;};
154e51a4 LW	253	}
	254	}
	255	##############################################################################
	256
	257	# These next few lines are legal in both Perl and nroff.
	258
a0d0e21e LW	259	.00 ; # finish .ig
a0d0e21e LW	260
154e51a4 LW	261	'di \" finish diversion--previous line must be blank
	262	.nr nl 0-1 \" fake up transition to first page again
	263	.nr % 0 \" start at page 1
	264	'; __END__ ############# From here on it's a standard manual page ############
	265	.TH H2PH 1 "August 8, 1990"
	266	.AT 3
	267	.SH NAME
	268	h2ph \- convert .h C header files to .ph Perl header files
	269	.SH SYNOPSIS
	270	.B h2ph [headerfiles]
	271	.SH DESCRIPTION
	272	.I h2ph
	273	converts any C header files specified to the corresponding Perl header file
	274	format.
	275	It is most easily run while in /usr/include:
	276	.nf
	277
	278	cd /usr/include; h2ph * sys/*
	279
	280	.fi
fe14fcc3	281	If run with no arguments, filters standard input to standard output.
154e51a4 LW	282	.SH ENVIRONMENT
	283	No environment variables are used.
	284	.SH FILES
	285	/usr/include/*.h
	286	.br
	287	/usr/include/sys/*.h
	288	.br
	289	etc.
	290	.SH AUTHOR
	291	Larry Wall
	292	.SH "SEE ALSO"
	293	perl(1)
	294	.SH DIAGNOSTICS
	295	The usual warnings if it can't read or write the files involved.
	296	.SH BUGS
	297	Doesn't construct the %sizeof array for you.
	298	.PP
	299	It doesn't handle all C constructs, but it does attempt to isolate
	300	definitions inside evals so that you can get at the definitions
	301	that it can translate.
	302	.PP
	303	It's only intended as a rough tool.
	304	You may need to dicker with the files produced.
	305	.ex
	306	!NO!SUBS!
4633a7c4 LW	307
	308	close OUT or die "Can't close $file: $!";
	309	chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
	310	exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';