[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;

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