#!/u1/project/ARSperl/perl/bin/perl
eval
'exec /u1/project/ARSperl/perl/bin/perl -S $0 ${1+"$@"}'
if
$running_under_some_shell
;
getopts(
'Dd:rlhaQ'
);
use
vars
qw($opt_D $opt_d $opt_r $opt_l $opt_h $opt_a $opt_Q)
;
die
"-r and -a options are mutually exclusive\n"
if
(
$opt_r
and
$opt_a
);
my
@inc_dirs
= inc_dirs()
if
$opt_a
;
my
$Exit
= 0;
my
$Dest_dir
=
$opt_d
||
$Config
{installsitearch};
die
"Destination directory $Dest_dir doesn't exist or isn't a directory\n"
unless
-d
$Dest_dir
;
my
@isatype
=
split
(
' '
,
<<END);
char uchar u_char
short ushort u_short
int uint u_int
long ulong u_long
FILE key_t caddr_t
END
my
%isatype
;
@isatype
{
@isatype
} = (1) x
@isatype
;
my
$inif
= 0;
my
%Is_converted
;
@ARGV
= (
'-'
)
unless
@ARGV
;
build_preamble_if_necessary();
my
(
$t
,
$tab
,
%curargs
,
$new
,
$eval_index
,
$dir
,
$name
,
$args
,
$outfile
);
my
(
$incl
,
$next
);
while
(
defined
(
my
$file
= next_file())) {
if
(-l
$file
and -d
$file
) {
link_if_possible(
$file
)
if
(
$opt_l
);
next
;
}
$t
=
''
;
$tab
= 0;
$eval_index
= 1;
if
(
$file
eq
'-'
) {
open
(IN,
"-"
);
open
(OUT,
">-"
);
}
else
{
(
$outfile
=
$file
) =~ s/\.h$/.ph/ ||
next
;
print
"$file -> $outfile\n"
unless
$opt_Q
;
if
(
$file
=~ m|^(.*)/|) {
$dir
= $1;
mkpath
"$Dest_dir/$dir"
;
}
if
(
$opt_a
) {
foreach
(
@inc_dirs
) {
chdir
$_
;
last
if
-f
$file
;
}
}
open
(IN,
"$file"
) || ((
$Exit
= 1),(
warn
"Can't open $file: $!\n"
),
next
);
open
(OUT,
">$Dest_dir/$outfile"
) ||
die
"Can't create $outfile: $!\n"
;
}
print
OUT
"require '_h2ph_pre.ph';\n\n"
;
while
(
defined
(
local
$_
= next_line(
$file
))) {
if
(s/^\s*\
if
(s/^define\s+(\w+)//) {
$name
= $1;
$new
=
''
;
s/\s+$//;
s/\(\w+\s*\(\*\)\s*\(\w*\)\)\s*(-?\d+)/$1/;
if
(s/^\(([\w,\s]*)\)//) {
$args
= $1;
my
$proto
=
'() '
;
if
(
$args
ne
''
) {
$proto
=
''
;
foreach
my
$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; #"
]);
$new
= reindent(
$new
);
$args
= reindent(
$args
);
if
(
$t
ne
''
) {
$new
=~ s/([
'\\])/\\$1/g; #'
]);
if
(
$opt_h
) {
print
OUT
$t
,
"eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name $proto\{\n$t ${args}eval q($new);\n$t}' unless defined(\&$name);\n"
;
$eval_index
++;
}
else
{
print
OUT
$t
,
"eval 'sub $name $proto\{\n$t ${args}eval q($new);\n$t}' unless defined(\&$name);\n"
;
}
}
else
{
print
OUT
"unless(defined(\&$name)) {\n sub $name $proto\{\n\t${args}eval q($new);\n }\n}\n"
;
}
%curargs
= ();
}
else
{
s/^\s+//;
expr();
$new
= 1
if
$new
eq
''
;
$new
= reindent(
$new
);
$args
= reindent(
$args
);
if
(
$t
ne
''
) {
$new
=~ s/([
'\\])/\\$1/g; #'
]);
if
(
$opt_h
) {
print
OUT
$t
,
"eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name () {"
,
$new
,
";}' unless defined(\&$name);\n"
;
$eval_index
++;
}
else
{
print
OUT
$t
,
"eval 'sub $name () {"
,
$new
,
";}' unless defined(\&$name);\n"
;
}
}
else
{
next
if
" \&$name"
eq
$new
;
print
OUT
$t
,
"unless(defined(\&$name)) {\n sub $name () {\t"
,
$new
,
";}\n}\n"
;
}
}
}
elsif
(/^(include|
import
)\s*[<
"](.*)[>"
]/) {
(
$incl
= $2) =~ s/\.h$/.ph/;
print
OUT
$t
,
"require '$incl';\n"
;
}
elsif
(/^include_next\s*[<
"](.*)[>"
]/) {
(
$incl
= $1) =~ s/\.h$/.ph/;
print
OUT (
$t
,
"eval {\n"
);
$tab
+= 4;
$t
=
"\t"
x (
$tab
/ 8) .
' '
x (
$tab
% 8);
print
OUT (
$t
,
"my(\%INCD) = map { \$INC{\$_} => 1 } "
,
"(grep { \$_ eq \"$incl\" } keys(\%INC));\n"
);
print
OUT (
$t
,
"my(\@REM) = map { \"\$_/$incl\" } "
,
"(grep { not exists(\$INCD{\"\$_/$incl\"})"
,
"and -f \"\$_/$incl\" } \@INC);\n"
);
print
OUT (
$t
,
"require \"\$REM[0]\" if \@REM;\n"
);
$tab
-= 4;
$t
=
"\t"
x (
$tab
/ 8) .
' '
x (
$tab
% 8);
print
OUT (
$t
,
"};\n"
);
print
OUT (
$t
,
"warn(\$\@) if \$\@;\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
,
"unless(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 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
,
"} 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"
;
}
elsif
(/^
undef
\s+(\w+)/) {
print
OUT
$t
,
"undef(&$1) if defined(&$1);\n"
;
}
elsif
(/^error\s+(
".*"
)/) {
print
OUT
$t
,
"die($1);\n"
;
}
elsif
(/^error\s+(.*)/) {
print
OUT
$t
,
"die(\""
,
quotemeta
($1),
"\");\n"
;
}
elsif
(/^warning\s+(.*)/) {
print
OUT
$t
,
"warn(\""
,
quotemeta
($1),
"\");\n"
;
}
elsif
(/^ident\s+(.*)/) {
print
OUT
$t
,
"# $1\n"
;
}
}
elsif
(/^\s*(typedef\s*)?enum\s*(\s+[a-zA-Z_]\w*\s*)?/) {
until
(/\{[^}]*\}.*;/ || /;/) {
last
unless
defined
(
$next
= next_line(
$file
));
chomp
$next
;
$next
=~ s/^\s*
$_
.=
$next
;
print
OUT
"# $next\n"
if
$opt_D
;
}
s/
s@/\*.*?\*/@
@g
;
s/\s+/ /g;
next
unless
/^\s?(typedef\s?)?enum\s?([a-zA-Z_]\w*)?\s?\{(.*)\}\s?([a-zA-Z_]\w*)?\s?;/;
(
my
$enum_subs
= $3) =~ s/\s//g;
my
@enum_subs
=
split
(/,/,
$enum_subs
);
my
$enum_val
= -1;
foreach
my
$enum
(
@enum_subs
) {
my
(
$enum_name
,
$enum_value
) =
$enum
=~ /^([a-zA-Z_]\w*)(=.+)?$/;
$enum_value
=~ s/^=//;
$enum_val
= (
length
(
$enum_value
) ?
$enum_value
:
$enum_val
+ 1);
if
(
$opt_h
) {
print
OUT (
$t
,
"eval(\"\\n#line $eval_index $outfile\\n"
,
"sub $enum_name () \{ $enum_val; \}\") "
,
"unless defined(\&$enum_name);\n"
);
++
$eval_index
;
}
else
{
print
OUT (
$t
,
"eval(\"sub $enum_name () \{ $enum_val; \}\") "
,
"unless defined(\&$enum_name);\n"
);
}
}
}
}
print
OUT
"1;\n"
;
$Is_converted
{
$file
} = 1;
queue_includes_from(
$file
)
if
(
$opt_a
);
}
exit
$Exit
;
sub
reindent($) {
my
(
$text
) =
shift
;
$text
=~ s/\n/\n /g;
$text
=~ s/ /\t/g;
$text
;
}
sub
expr {
my
$joined_args
;
if
(
keys
(
%curargs
)) {
$joined_args
=
join
(
'|'
,
keys
(
%curargs
));
}
while
(
$_
ne
''
) {
s/^\&\&// &&
do
{
$new
.=
" &&"
;
next
;};
s/^\&([\(a-z\)]+)/$1/i;
s/^(\s+)// &&
do
{
$new
.=
' '
;
next
;};
s/^0X([0-9A-F]+)[UL]*//i
&&
do
{
my
$hex
= $1;
$hex
=~ s/^0+//;
if
(
length
$hex
> 8 && !
$Config
{use64bitint}) {
$new
.=
hex
(
substr
(
$hex
, -8)) +
2**32 *
hex
(
substr
(
$hex
, 0, -8));
}
else
{
$new
.=
lc
(
"0x$hex"
);
}
next
;};
s/^(-?\d+\.\d+E[-+]?\d+)[FL]?//i &&
do
{
$new
.= $1;
next
;};
s/^(\d+)\s*[LU]*//i &&
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*\(// &&
do
{
$new
.=
'$sizeof'
;
my
$lvl
= 1;
$_
=
"{"
.
"$_"
;
my
$index
= 1;
while
(
$index
<=
length
(
$_
) &&
$lvl
> 0) {
$lvl
++
if
substr
(
$_
,
$index
, 1) eq
"("
;
$lvl
--
if
substr
(
$_
,
$index
, 1) eq
")"
;
$index
++;
}
substr
(
$_
,
$index
- 1, 1) =
"}"
;
substr
(
$_
, 0,
$index
- 1) =~ s/\*//g;
next
;
};
/\(([\w\s]+)[\*\s]*\)\s*[\w\(]/ &&
do
{
foreach
(
split
/\s+/, $1) {
last
unless
(
$isatype
{
$_
} or
$_
eq
'struct'
or
$_
eq
'union'
);
}
s/\([\w\s]+[\*\s]*\)// &&
next
;
};
s/^([_A-Z]\w*(\[[^\]]+\])?((\.|->)[_A-Z]\w*(\[[^\]]+\])?)+)//i &&
do
{
my
$id
= $1;
$id
=~ s/(\.|(->))([^\.\-]*)/->\{$3\}/g;
$id
=~ s/\b([^\$])(
$joined_args
)/$1\$$2/g
if
length
(
$joined_args
);
while
(
$id
=~ /\[\s*([^\$\&\d\]]+)\]/) {
my
(
$index
) = $1;
$index
=~ s/\s//g;
if
(
exists
(
$curargs
{
$index
})) {
$index
=
"\$$index"
;
}
else
{
$index
=
"&$index"
;
}
$id
=~ s/\[\s*([^\$\&\d\]]+)\]/[
$index
]/;
}
$new
.=
" (\$$id)"
;
};
s/^([_a-zA-Z]\w*)// &&
do
{
my
$id
= $1;
if
(
$id
eq
'struct'
||
$id
eq
'union'
) {
s/^\s+(\w+)//;
$id
.=
' '
. $1;
$isatype
{
$id
} = 1;
}
elsif
(
$id
=~ /^((un)?signed)|(long)|(short)$/) {
while
(s/^\s+(\w+)//) {
$id
.=
' '
. $1; }
$isatype
{
$id
} = 1;
}
if
(
$curargs
{
$id
}) {
$new
.=
"\$$id"
;
$new
.=
'->'
if
/^[\[\{]/;
}
elsif
(
$id
eq
'defined'
) {
$new
.=
'defined'
;
}
elsif
(/^\s*\(/) {
s/^\s*\((\w),/(
"$1"
,/
if
$id
=~ /^_IO[WR]*$/i;
$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
;};
}
}
sub
next_line
{
my
$file
=
shift
;
my
(
$in
,
$out
);
my
$pre_sub_tri_graphs
= 1;
READ:
while
(not
eof
IN) {
$in
.= <IN>;
chomp
$in
;
next
unless
length
$in
;
while
(
length
$in
) {
if
(
$pre_sub_tri_graphs
) {
$in
=~ s/\?\?=/
$in
=~ s/\?\?\!/|/g;
$in
=~ s/\?\?
'/^/g; # | ??'
| ^|
$in
=~ s/\?\?\(/[/g;
$in
=~ s/\?\?\)/]/g;
$in
=~ s/\?\?\-/~/g;
$in
=~ s/\?\?\//\\/g;
$in
=~ s/\?\?</{/g;
$in
=~ s/\?\?>/}/g;
}
if
(
$in
=~ /^\
while
(<IN>) {
last
if
/^\
}
next
READ;
}
if
(
$in
=~ /^extern inline / &&
$^O eq
'linux'
&&
$file
=~ m!(?:^|/)asm/[^/]+\.h$!) {
while
(<IN>) {
last
if
/^}/;
}
next
READ;
}
if
(
$in
=~ s/\\$//) {
$out
.=
' '
;
next
READ;
}
elsif
(
$in
=~ s/^([^"'\\\/]+)//) {
$out
.= $1;
}
elsif
(
$in
=~ s/^(\\.)//) {
$out
.= $1;
}
elsif
(
$in
=~ s/^(
'(\\.|[^'
\\])*
')//) { # '
...
$out
.= $1;
}
elsif
(
$in
=~ s/^(
"(\\.|[^"
\\])*
")//) { # "
...
$out
.= $1;
}
elsif
(
$in
=~ s/^\/\/.*//) {
}
elsif
(
$in
=~ m/^\/\*/) {
if
(
$in
=~ s/^\/\*[^*]*\*+([^\/*][^*]*\*+)*\///) {
$out
.=
' '
;
}
else
{
next
READ;
}
}
elsif
(
$in
=~ s/^(\/)//) {
$out
.= $1;
}
elsif
(
$in
=~ s/^([^\'\"\\\/]+)//) {
$out
.= $1;
}
elsif
($^O eq
'linux'
&&
$file
=~ m!(?:^|/)linux/byteorder/pdp_endian\.h$! &&
$in
=~ s!\'T KNOW!!) {
$out
=~ s!I DON$!I_DO_NOT_KNOW!;
}
else
{
die
"Cannot parse:\n$in\n"
;
}
}
last
READ
if
$out
=~ /\S/;
}
return
$out
;
}
sub
next_file
{
my
$file
;
while
(
@ARGV
) {
$file
=
shift
@ARGV
;
if
(
$file
eq
'-'
or -f
$file
or -l
$file
) {
return
$file
;
}
elsif
(-d
$file
) {
if
(
$opt_r
) {
expand_glob(
$file
);
}
else
{
print
STDERR
"Skipping directory `$file'\n"
;
}
}
elsif
(
$opt_a
) {
return
$file
;
}
else
{
print
STDERR
"Skipping `$file': not a file or directory\n"
;
}
}
return
undef
;
}
sub
expand_glob
{
my
(
$directory
) =
@_
;
$directory
=~ s:/$::;
opendir
DIR,
$directory
;
foreach
(
readdir
DIR) {
next
if
(
$_
eq
'.'
or
$_
eq
'..'
);
if
(-d
"$directory/$_"
) {
push
@ARGV
,
"$directory/$_"
}
else
{
unshift
@ARGV
,
"$directory/$_"
}
}
closedir
DIR;
}
sub
link_if_possible
{
my
(
$dirlink
) =
@_
;
my
$target
=
eval
'readlink($dirlink)'
;
if
(
$target
=~ m:^\.\./: or
$target
=~ m:^/:) {
expand_glob(
$dirlink
);
}
else
{
if
(-l
"$Dest_dir/$dirlink"
) {
unlink
"$Dest_dir/$dirlink"
or
print
STDERR
"Could not remove link $Dest_dir/$dirlink: $!\n"
;
}
if
(
eval
'symlink($target, "$Dest_dir/$dirlink")'
) {
print
"Linking $target -> $Dest_dir/$dirlink\n"
;
if
(! -e
"$Dest_dir/$target"
) {
mkpath(
"$Dest_dir/$target"
, 0755) or
print
STDERR
"Could not create $Dest_dir/$target/\n"
;
}
}
else
{
print
STDERR
"Could not symlink $target -> $Dest_dir/$dirlink: $!\n"
;
}
}
}
sub
queue_includes_from
{
my
(
$file
) =
@_
;
my
$line
;
return
if
(
$file
eq
"-"
);
open
HEADER,
$file
or
return
;
while
(
defined
(
$line
= <HEADER>)) {
while
(/\\$/) {
chop
$line
;
$line
.= <HEADER>;
}
if
(
$line
=~ /^
push
(
@ARGV
, $1)
unless
$Is_converted
{$1};
}
}
close
HEADER;
}
sub
inc_dirs
{
my
$from_gcc
= `
$Config
{cc} -v 2>&1`;
$from_gcc
=~ s:^Reading specs from (.*?)/specs\b.*:$1/include:s;
length
(
$from_gcc
) ? (
$from_gcc
,
$Config
{usrinc}) : (
$Config
{usrinc});
}
sub
build_preamble_if_necessary
{
my
$VERSION
= 2;
my
$preamble
=
"$Dest_dir/_h2ph_pre.ph"
;
if
(-r
$preamble
) {
open
PREAMBLE,
$preamble
or
die
"Cannot open $preamble: $!"
;
my
$line
= <PREAMBLE>;
$line
=~ /(\b\d+\b)/;
close
PREAMBLE or
die
"Cannot close $preamble: $!"
;
return
if
$1 ==
$VERSION
;
}
my
(
%define
) = _extract_cc_defines();
open
PREAMBLE,
">$preamble"
or
die
"Cannot open $preamble: $!"
;
print
PREAMBLE
"# This file was created by h2ph version $VERSION\n"
;
foreach
(
sort
keys
%define
) {
if
(
$opt_D
) {
print
PREAMBLE
"# $_=$define{$_}\n"
;
}
if
(
$define
{
$_
} =~ /^(\d+)U?L{0,2}$/i) {
print
PREAMBLE
"unless (defined &$_) { sub $_() { $1 } }\n\n"
;
}
elsif
(
$define
{
$_
} =~ /^\w+$/) {
print
PREAMBLE
"unless (defined &$_) { sub $_() { &$define{$_} } }\n\n"
;
}
else
{
print
PREAMBLE
"unless (defined &$_) { sub $_() { \""
,
quotemeta
(
$define
{
$_
}),
"\" } }\n\n"
;
}
}
close
PREAMBLE or
die
"Cannot close $preamble: $!"
;
}
sub
_extract_cc_defines
{
my
%define
;
my
$allsymbols
=
join
" "
,
@Config
{
'ccsymbols'
,
'cppsymbols'
,
'cppccsymbols'
};
foreach
(
split
/\s+/,
$allsymbols
) {
/(.+?)=(.+)/ and
$define
{$1} = $2;
if
(
$opt_D
) {
print
STDERR
"$_: $1 -> $2\n"
;
}
}
return
%define
;
}
1;