[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)) =~ 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 perl -S \$0 "\$@"'
	if 0;

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

\$perlincl = "$Config{archlibexp}";  # or  {sitearchexp}

!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	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	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!";
	29	$Config{'startperl'}
	30	eval 'exec perl -S \$0 "\$@"'
	31	if 0;
	32
a0d0e21e	33	'di ';
	34	'ds 00 \"';
	35	'ig 00 ';
154e51a4	36
760ac839	37	\$perlincl = "$Config{archlibexp}"; # or {sitearchexp}
4633a7c4	38
154e51a4	39	!GROK!THIS!
154e51a4	40
4633a7c4	41	# In the following, perl variables are not expanded during extraction.
	42
	43	print OUT <<'!NO!SUBS!';
154e51a4	44
	45	chdir '/usr/include' \|\| die "Can't cd /usr/include";
	46
fe14fcc3	47	@isatype = split(' ',<<END);
	48	char uchar u_char
	49	short ushort u_short
	50	int uint u_int
	51	long ulong u_long
	52	FILE
	53	END
	54
55204971	55	@isatype{@isatype} = (1) x @isatype;
748a9306	56	$inif = 0;
fe14fcc3	57
fe14fcc3	58	@ARGV = ('-') unless @ARGV;
154e51a4	59
154e51a4	60	foreach $file (@ARGV) {
fe14fcc3	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	74	open(IN,"$file") \|\| ((warn "Can't open $file: $!\n"),next);
fe14fcc3	75	open(OUT,">$perlincl/$outfile") \|\| die "Can't create $outfile: $!\n";
154e51a4	76	}
154e51a4	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	103	$curargs{$arg} = 1;
	104	}
	105	$args =~ s/\b(\w)/\$$1/g;
	106	$args = "local($args) = \@_;\n$t ";
	107	}
	108	s/^\s+//;
	109	do expr();
	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+//;
	123	do expr();
	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	135	($incl = $1) =~ s/\.h$/.ph/;
d9d8d8de	136	print OUT $t,"require '$incl';\n";
154e51a4	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;
154e51a4	151	do expr();
748a9306	152	$inif = 0;
154e51a4	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;
154e51a4	160	do expr();
748a9306	161	$inif = 0;
154e51a4	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	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	};
b276c83d	200	s/^sizeof\s*\(([^)]+)\)/{$1}/ && do {
154e51a4	201	$new .= '$sizeof';
	202	next;
	203	};
	204	s/^([_a-zA-Z]\w*)// && do {
	205	$id = $1;
fe14fcc3	206	if ($id eq 'struct') {
	207	s/^\s+(\w+)//;
	208	$id .= ' ' . $1;
	209	$isatype{$id} = 1;
	210	}
	211	elsif ($id eq 'unsigned') {
	212	s/^\s+(\w+)//;
	213	$id .= ' ' . $1;
	214	$isatype{$id} = 1;
	215	}
154e51a4	216	if ($curargs{$id}) {
	217	$new .= '$' . $id;
	218	}
	219	elsif ($id eq 'defined') {
	220	$new .= 'defined';
	221	}
	222	elsif (/^\(/) {
e5d73d77	223	s/^\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/i; # cheat
154e51a4	224	$new .= " &$id";
	225	}
	226	elsif ($isatype{$id}) {
fe14fcc3	227	if ($new =~ /{\s*$/) {
	228	$new .= "'$id'";
	229	}
	230	elsif ($new =~ /\(\s$/ && /^[\s]*\)/) {
	231	$new =~ s/\(\s*$//;
	232	s/^[\s]\)//;
	233	}
	234	else {
b276c83d	235	$new .= q(').$id.q(');
fe14fcc3	236	}
154e51a4	237	}
154e51a4	238	else {
c07a80fd	239	if ($inif && $new !~ /defined\s*\($/) {
748a9306	240	$new .= '(defined(&' . $id . ') ? &' . $id . ' : 0)';
fb21d8eb	241	}
	242	elsif (/^\[/) {
	243	$new .= ' $' . $id;
	244	}
	245	else {
748a9306	246	$new .= ' &' . $id;
748a9306	247	}
154e51a4	248	}
	249	next;
	250	};
fb21d8eb	251	s/^(.)// && do { if ($1 ne '#') { $new .= $1; } next;};
154e51a4	252	}
	253	}
	254	##############################################################################
	255
	256	# These next few lines are legal in both Perl and nroff.
	257
a0d0e21e	258	.00 ; # finish .ig
a0d0e21e	259
154e51a4	260	'di \" finish diversion--previous line must be blank
	261	.nr nl 0-1 \" fake up transition to first page again
	262	.nr % 0 \" start at page 1
	263	'; __END__ ############# From here on it's a standard manual page ############
	264	.TH H2PH 1 "August 8, 1990"
	265	.AT 3
	266	.SH NAME
	267	h2ph \- convert .h C header files to .ph Perl header files
	268	.SH SYNOPSIS
	269	.B h2ph [headerfiles]
	270	.SH DESCRIPTION
	271	.I h2ph
	272	converts any C header files specified to the corresponding Perl header file
	273	format.
	274	It is most easily run while in /usr/include:
	275	.nf
	276
	277	cd /usr/include; h2ph * sys/*
	278
	279	.fi
fe14fcc3	280	If run with no arguments, filters standard input to standard output.
154e51a4	281	.SH ENVIRONMENT
	282	No environment variables are used.
	283	.SH FILES
	284	/usr/include/*.h
	285	.br
	286	/usr/include/sys/*.h
	287	.br
	288	etc.
	289	.SH AUTHOR
	290	Larry Wall
	291	.SH "SEE ALSO"
	292	perl(1)
	293	.SH DIAGNOSTICS
	294	The usual warnings if it can't read or write the files involved.
	295	.SH BUGS
	296	Doesn't construct the %sizeof array for you.
	297	.PP
	298	It doesn't handle all C constructs, but it does attempt to isolate
	299	definitions inside evals so that you can get at the definitions
	300	that it can translate.
	301	.PP
	302	It's only intended as a rough tool.
	303	You may need to dicker with the files produced.
	304	.ex
	305	!NO!SUBS!
4633a7c4	306
	307	close OUT or die "Can't close $file: $!";
	308	chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
	309	exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';