[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, '.PL');
$file .= '.com' if $^O eq 'VMS';

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;
use File::Path qw(mkpath);

my $Exit = 0;

my $Dest_dir = (@ARGV && $ARGV[0] =~ s/^-d//)
		    ? shift || shift
		    : $Config{installsitearch};
die "Destination directory $Dest_dir doesn't exist or isn't a directory\n"
    unless -d $Dest_dir;

@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;
	    mkpath "$Dest_dir/$dir";
	}
	open(IN,"$file") || (($Exit = 1),(warn "Can't open $file: $!\n"),next);
	open(OUT,">$Dest_dir/$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;
    	    	    my $proto = '() ';
		    if ($args ne '') {
    	    	    	$proto = '';
			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 $proto\{\n$t    ${args}eval \"$new\";\n$t}';\n";
		    }
		    else {
			print OUT "sub $name $proto\{\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";
}

exit $Exit;

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' || $id eq 'long') {
		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/*

The output files are placed in the hierarchy rooted at Perl's
architecture dependent library directory.  You can specify a different
hierarchy with a B<-d> switch.

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