#!/usr/sbin/perl -w
#
# bldhdr -- Perl 5 script to build IRIX 6.5.x header files
#
# Usage: bldhdr struct_name
#
# where:
#
#	struct_name	is the name of the structure for which a
#			header file is required.
#
# The header file will be output on STDOUT; errors on STDERR.

# Defined constants

%BinTy = (				# built-in types
    "char", "char",
    "double", "double",
    "float", "float",
    "int", "int",
    "long", "long",
    "short", "short",
    "void", "void",

);
$DBX = "/usr/bin/dbx";		# dbx path
#DEBUG $DBX = "/bin/gdb";	# DEBUG
$DBXIN = "./dbx_command_input";
$DBXPIPE_OPEN = 0;			# pipe from dbx is open
$KERNEL = "/unix";
$PN = "bldhdr";				# program name

# Initialization

$ENV{PATH} = "/bin:/sbin:/usr/bin";	# make path environment "safe"

# Establish structure name.

if ($#ARGV != 0) {
   print STDERR "$PN ****ERROR****: usage: $PN structure_name\n";
   exit(1);
}
$Struct = $ARGV[0];

# Initialize %ResTy -- the hash of resolved types.

%ResTy = ();

# Ask dbx to resolve the requested structure name.

&whatis($Struct);
$req = "";
$ss = 0;
while (<DBXPIPE>) {
    if (!$ss) {
	if (/^struct\s+$Struct\s+{\s*\n/) {

	# Normal struture -- "struct <name> {"

	    $req = $_;
	    $ss = 1;
	    $td = 0;
	}
	if (/^typedef\s+struct\s+(\w+)\s+{\s*\n/) {

	# Typedef structure -- "typedef struct name {"

	    $req = $_;
	    $ss = 1;
	    $td = 1;
	}
	next;
    }
    $req .= $_;
    if (!$td && /^};\s*\n/) { last; }
    if ($td && /^}\s+$Struct\s*;\n/) { last; }
}
close(DBXPIPE); $DBXPIPE_OPEN = 0;
if ($req eq "") {
    print STDERR "$PN: $DBX doesn't grok struct $Struct\n";
    exit(1);
}

# Reduce the requested structure to a form that can be output, but
# defer the output until all unresolved types and structures can be
# resolved.

$req_red = &reduce_struct($req);
print "DEBUG: reduced request structure; $Struct\n$req_red";

# Reduce all structures and types on the stack.

while ($#UnResStr >= 0 || $#UnResTy >= 0) {
    while (defined(($str = pop(@UnResStr)))) {
	$red_str = &reduce_struct($str);
	print "DEBUG: reduced unresolved structure:\n$red_str";
	push(@RedStr, $red_str);
    }
    while (defined($ty = shift(@UnResTy))) {
	$red_ty = &reduce_type($ty);
	if ($red_ty ne "") {
	    print "DEBUG: resolved type: $red_ty\n";
	    push(@RedTy, $red_ty);
	} else { print "DEBUG: $ty reduced to a typedef struct\n"; }
    }
}
exit 0;		# DEBUG

## reduce_struct() -- reduce a structure definition to resolved type and
#		      structure definitons, stacking unresolved ones for
#		      later resolution.

sub reduce_struct {
    local $bodyin = $_[0];

    local $bodyout = "";
    local $line = "";
    local $level;
    local $memnm;
    local $new;
    local $sname;
    local $tline;
    local $typedef = 0;
    local $tydfnm = "";
    local @W;

    if (($bodyin =~ s/^(\s*struct\s+\w+\s+{\s*\n)(.*)/$2/)) { 

    # It's a structure definition -- "struct name {"

	$bodyout = $1;
	$typedef = 0;
    } elsif (($bodyin =~ s/^(\s*typedef\s+struct)\s+(\w+)\s+({\s*\n)(.*)/$4/)) { 
    # It's a typedef structure -- "typedef struct name {"

	$bodyout = "$1 lsof_$2 $3";
	$typedef = 1;
    } else {
	print STDERR "$PN: structure to reduce isn't:\n$bodyin\n";
	exit(1);
    }

# Process the body of the structure or typedef structure a line at a time.

    while ($bodyin ne "") {
	if (!($bodyin =~ s/(^[^\n]*)\n(.*)/$2/)) { last; }
	$line = $1;
	if ($line eq "") { last; }
	if (($line =~ /\s*}\s*;\s*$/) && $bodyin eq "") {

	# "^};" ends a structure definition.

	    $bodyout .= "$line\n";
	    last;
	}
	if ($typedef && ($line =~ /\s*}\s+(\w+)\s*;\s*$/) && $bodyin eq "") {

	# "^} name;" ends a typedef structure definition.

	    $tydfnm = $1;
	    $bodyout .= "} lsof_$tydfnm;\n";
	    $ResTy{$tydfnm} = "lsof_$tydfnm";
	    last;
	}

    # Split the line into words.

	@W = split(' ', $line, 999);
	if ($#W < 0) {
	}
	$w0 = $W[0];
	$w1 = ($#W < 1) ? "" : $W[1];
	$w0 =~ s/([^\*]*)\**/$1/;
	$w1 =~ s/([^\*]*)\**/$1/;
	if (defined($BinTy{$w0})
	||  ($w0 eq "unsigned" && defined($BinTy{$w1}))) {

	# If the element uses [unsigned] basic type, pass it without
	# modification.

	    $bodyout .= "$line\n";
	    next;
	}
	if (defined($ResTy{$w0})) { $bt = 0; }
	elsif ($w0 eq "unsigned" && defined($ResTy{$w1})) { $bt = 1; }
	else { $bt = -1; }
	if ($bt >= 0) {

	# If the element uses [unsigned] resolved type, pass it without
	# further modification,

	    if ($ResTy{$W[$bt]} ne $W[$bt]) {
		$line =~ s/ $W[$bt] / $ResTy{$W[$bt]} /;
	    }
	    $bodyout .= "$line\n";
	    next;
	}
	if ($W[0] eq "struct") {
	    if ($W[1] =~ /\w+\*/) {
		$line =~ s/$W[0]/KA_T/;
		$line =~ s/\s+$W[1]\*//;
		$bodyout .= "$line\n";
		next;
	    }
	    if ($#W == 2 && $W[2] eq "{") {
		$sname = "lsof_$W[1]";
		$line =~ s/$W[1]/$sname/;
		$new = defined($PrivStr{$sname}) ? 0 : 1;
		if ($new) { $TBody = "$line\n"; }
		$level = 1;
		$memnm = "";
		while ($bodyin ne "") {
		    if (!($bodyin =~ s/^([^\n]*)\n(.*)/$2/)) { last; }
		    $tline = $1;
		    if ($tline =~ /.*{\s*$/) {
			if ($new) { $TBody .= "$tline\n"; }
			$level++;
			next;
		    }
		    if ($tline =~ /\s*}/) {
			$level--;
			if ($level == 0) {
			    if ($tline =~ /.*}\s+(\S+);.*/) {
				$memnm = $1;
				$tline =~ s/(\s*}).*/$1;/;
				if ($new) { $TBody .= "$tline\n"; }
			    } else {
				$memnm = "UNKNOWN";
				if ($new) { $TBody .= "$tline\n"; }
			    }
			    last;
			}
		    }
		    if ($new) { $TBody .= "$tline\n"; }
		}
		$line =~ s/{/$memnm;/;	# }
		$bodyout .= "$line\n";
		if ($new) {
		    $PrivStr{$sname} = 1;
		    push(@UnResStr, $TBody);
		}
	    next;
	    }
	}
	if ($W[0] eq "typedef") {
	}
	if ($W[0] eq "union") { $bodyout .= "$line\n"; next; }
	for ($i = 0; $i <= $#UnResTy; $i++) {
	    if ("lsof_$w0" eq $UnResTy[$i]) { last; }
	}
	if ($i > $#UnResTy) { push (@UnResTy, "lsof_$w0"); }
	$line =~ s/$w0/lsof_$w0/;
	$bodyout .= "$line\n";
    }
    return($bodyout);
}


## reduce_ty -- reduce a type definition to a definition to a basic type
#

sub reduce_type {
    local $tynm = $_[0];

    local $body;
    local $core;
    local $f;
    local $line;
    local $nm;
    local $tydf = "";
    local $ux;
    local @W;
    local $wx;

    if (!($tynm =~ /^lsof_(\w+)/)) {
	print "****ERROR**** bad unresolved type name: $tynm\n";
	exit(1);
    }
    $nm = $1;
    &whatis($nm);
    $f = 1;
    while(<DBXPIPE>) {
	if (!/^typedef/) { next; }
	if (/^typedef\s+struct/) {
	    $body = $_;
	    while (<DBXPIPE>) {
		$body .= $_;
		if (/^}\s+\w+\s*;\n/) { last; }
	    }
	    $red_str = &reduce_struct($body);
	    print "DEBUG: reduced unresolved typedef structure:\n$red_str";
	    push(@RedStr, $red_str);
	    return("");
	}
	if (!/^typedef([^;]*);\n/) {
	    print "****ERROR**** bad whatis typedef response: $_";
	    exit(1);
	}
	$core = $1;
	@W = split(' ', $core, 999);
	if ($#W < 1) { next; }
	if ($#W > 1) {
	    if ($W[0] ne "unsigned") { next; }
	    $tydf = "typedef unsigned";
	    $wx = 1;
	} else { $tydf = "typedef"; $wx = 0; }
	if (defined($BinTy{$W[$wx]})) {
	    $nm = "lsof_$W[$wx+1]";
	    $tydf = "$tydf $W[$wx] $nm;";
	    $ResTy{$W[$wx]} = $nm;
	} else {
	    $tydf = "$tydf lsof_$W[$wx] lsof_$W[$wx + 1];";
	    $nm = "lsof_$W[$wx]";
	    if (!defined($ResTy{$W[$wx]})) {
		for ($ux = 0; $ux <= $#UnResTy; $ux++) {
		    if ($nm eq $UnResTy[$ux]) { last; }
		}
		if ($ux > $#UnResTy) { push(@UnResTy, "$nm"); }
	    }
	}
	last;
    }
    close(DBXPIPE); $DBXPIPE_OPEN = 0;
    if ($tydf eq "") {
	print "****ERROR**** can't resolve type: $tynm\n";
	exit(1);
    }
    return($tydf);
}


## whatis() -- ask dbx a "whatis" question
#
#	       The dbx response can be obtained by reading DBXPIPE.

sub whatis {
    local $par = $_[0];

    if ($DBXPIPE_OPEN) { close(DBXPIPE); $DBXPIPE_OPEN = 0; }
    unlink($DBXIN);
    if (!open(DI, ">$DBXIN")) {
	print STDERR "$PN: can't create dbx input file ${DBXIN}: $!\n";
	exit(1);
    }
    print DI "set \$page=0\n";
    print DI "whatis $par\n";
    print DI "quit\n";
    close(DI);
    if (!open(DBXPIPE, "$DBX -c $DBXIN -k $KERNEL |")) {
	print STDERR "$PN: can't execute ${DBX}: $~\n";
	exit(1);
    }
    $DBXPIPE_OPEN = 1;
}
