[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 ($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+)//		&& 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 .= $id;
		}
	    }
	    else {
		if ($inif && $new !~ /defined\($/) {
		    $new .= '(defined(&' . $id . ') ? &' . $id . ' : 0)';
		} else { 
		    $new .= ' &' . $id;
		}
	    }
	    next;
	};
	s/^(.)//			&& do {$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$//
	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	34	'di ';
	35	'ds 00 \"';
	36	'ig 00 ';
154e51a4	37
25f94b33	38	\$perlincl = "$Config{archlibexp}";
4633a7c4	39
154e51a4	40	!GROK!THIS!
154e51a4	41
4633a7c4	42	# In the following, perl variables are not expanded during extraction.
	43
	44	print OUT <<'!NO!SUBS!';
154e51a4	45
	46	chdir '/usr/include' \|\| die "Can't cd /usr/include";
	47
fe14fcc3	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	58
fe14fcc3	59	@ARGV = ('-') unless @ARGV;
154e51a4	60
154e51a4	61	foreach $file (@ARGV) {
fe14fcc3	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	75	open(IN,"$file") \|\| ((warn "Can't open $file: $!\n"),next);
fe14fcc3	76	open(OUT,">$perlincl/$outfile") \|\| die "Can't create $outfile: $!\n";
154e51a4	77	}
154e51a4	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	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	}
55204971	135	elsif (/^include\s+<(.*)>/) {
d9d8d8de	136	($incl = $1) =~ s/\.h$/.ph/;
d9d8d8de	137	print OUT $t,"require '$incl';\n";
154e51a4	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	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	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;};
	190	s/^(\d+)// && do {$new .= $1; next;};
	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	};
154e51a4	201	s/^sizeof\s*\(([^)]+)\)/{$1}/ && do {
	202	$new .= '$sizeof';
	203	next;
	204	};
	205	s/^([_a-zA-Z]\w*)// && do {
	206	$id = $1;
fe14fcc3	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	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	225	$new .= " &$id";
	226	}
	227	elsif ($isatype{$id}) {
fe14fcc3	228	if ($new =~ /{\s*$/) {
	229	$new .= "'$id'";
	230	}
	231	elsif ($new =~ /\(\s$/ && /^[\s]*\)/) {
	232	$new =~ s/\(\s*$//;
	233	s/^[\s]\)//;
	234	}
	235	else {
	236	$new .= $id;
	237	}
154e51a4	238	}
154e51a4	239	else {
748a9306	240	if ($inif && $new !~ /defined\($/) {
	241	$new .= '(defined(&' . $id . ') ? &' . $id . ' : 0)';
	242	} else {
	243	$new .= ' &' . $id;
	244	}
154e51a4	245	}
	246	next;
	247	};
	248	s/^(.)// && do {$new .= $1; next;};
	249	}
	250	}
	251	##############################################################################
	252
	253	# These next few lines are legal in both Perl and nroff.
	254
a0d0e21e	255	.00 ; # finish .ig
a0d0e21e	256
154e51a4	257	'di \" finish diversion--previous line must be blank
	258	.nr nl 0-1 \" fake up transition to first page again
	259	.nr % 0 \" start at page 1
	260	'; __END__ ############# From here on it's a standard manual page ############
	261	.TH H2PH 1 "August 8, 1990"
	262	.AT 3
	263	.SH NAME
	264	h2ph \- convert .h C header files to .ph Perl header files
	265	.SH SYNOPSIS
	266	.B h2ph [headerfiles]
	267	.SH DESCRIPTION
	268	.I h2ph
	269	converts any C header files specified to the corresponding Perl header file
	270	format.
	271	It is most easily run while in /usr/include:
	272	.nf
	273
	274	cd /usr/include; h2ph * sys/*
	275
	276	.fi
fe14fcc3	277	If run with no arguments, filters standard input to standard output.
154e51a4	278	.SH ENVIRONMENT
	279	No environment variables are used.
	280	.SH FILES
	281	/usr/include/*.h
	282	.br
	283	/usr/include/sys/*.h
	284	.br
	285	etc.
	286	.SH AUTHOR
	287	Larry Wall
	288	.SH "SEE ALSO"
	289	perl(1)
	290	.SH DIAGNOSTICS
	291	The usual warnings if it can't read or write the files involved.
	292	.SH BUGS
	293	Doesn't construct the %sizeof array for you.
	294	.PP
	295	It doesn't handle all C constructs, but it does attempt to isolate
	296	definitions inside evals so that you can get at the definitions
	297	that it can translate.
	298	.PP
	299	It's only intended as a rough tool.
	300	You may need to dicker with the files produced.
	301	.ex
	302	!NO!SUBS!
4633a7c4	303
	304	close OUT or die "Can't close $file: $!";
	305	chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
	306	exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';