#!perl

$xsizeof{"int"} = 4;
$xsizeof{"char"} = 1;
$xsizeof{"BYTE"} = 1;
$xsizeof{"BOOL"} = 1;
$xsizeof{"long"} = 4;
$xsizeof{"CARD8"} = 1;
$xsizeof{"CARD16"} = 2;
$xsizeof{"CARD32"} = 4;
$xsizeof{"INT8"} = 1;
$xsizeof{"INT16"} = 2;
$xsizeof{"INT32"} = 4;

# oops, X11R4 is missing one...
# X11R6 has it though.
# $xsizeof{"xGetModifierMappingReply"} = 256;

$xpackof{"int"} = "L";
$xpackof{"char"} = "C";
$xpackof{"BYTE"} = "C";
$xpackof{"BOOL"} = "C";
$xpackof{"long"} = "L";
$xpackof{"CARD8"} = "C";
$xpackof{"CARD16"} = "S";
$xpackof{"CARD32"} = "L";
$xpackof{"INT8"} = "C";
$xpackof{"INT16"} = "S";
$xpackof{"INT32"} = "L";

# these are stored in %xpad in case we decide we want to be general later on
# but for now we copy it all into %xpackof anyhow.
for $i ("", 1..3) {
    $xpad{"BYTE pad$i"} = "x";
}
$xpad{"BYTE bpad"} = "x";
$xpad{"CARD8 pad"} = "x";
$xpad{"CARD8 pad1"} = "x";
$xpad{"CARD16 pad"} = "x2";
$xpad{"CARD16 pad1"} = "x2";
$xpad{"CARD16 pad2"} = "x2";
# these are mostly Xevent subfields...
for $i ("", "00", 1..7) {
    $xpad{"CARD32 pad$i"} = "x4";
}

for $i (keys %xpad) { $xpackof{$i} = $xpad{$i}; }

$incomment = 0;
sub fropcomment { # $incomment
    my($incomment) = @_;
    s/\/\*.*\*\///g;
    if(/\*\//) {
	$incomment = 0;
	s/^.*\*\///;
    }
    next if $incomment;
    if(/\/\*/) {
	$incomment = 1;
	s/\/\*.*//;
    }
}

# walk XPROTO file and fill in any defines, xsizeof, xtypeof, requests
# we come across, sometimes calling process_struct to help
sub munchproto {
    while(<XPROTO>) {
	$incomment = &fropcomment($incomment);

	if(/\#if defined\(\_\_cplusplus\) \|\| defined\(c\_plusplus\)/) {
	    while(<XPROTO>) {
		last if (/\#else/);
	    }
	}
	next if(/\#else/);
	next if(/\#endif/);
	next if(/\#undef/);
	next if(/\#ifdef NEED_EVENTS/);
	next if(/\#ifdef NEED_REPLIES/);
	next if(/\#ifndef XPROTO_H/);
	next if(/\#include/);	# maybe do these some other time.

	$eventing=1 if(/^\#define KeyPress/);
	$eventing=0 if(/^\#define LASTEvent/);

	if(/^\#define (\w+)$/) {
	    $defines{$1} = 1;
	    print "# defined flag $1\n";
	    next;
	}
    
	if(/^\#define sz_(\w+) (\d+)$/) {
	    $xsizeof{$1} = $2;
	    print "# processed size $1\n";
	    next;
	}

	if(/^\#define (\w+) CARD(\d+)$/) {
	    $xtypeof{$1} = "CARD".$2;
	    $xsizeof{$1} = $2/8;
	    print "# processed type $1\n";
	    next;
	}

	if(/^\#define (\w+)\s+(\d+)L?\s*$/) {
	    $defines{$1} = $2;
	    print "# defined flag $1 = $2\n";
	    my ($s,$t) = ($1,$2);
	    if(/^\#define X\_/) {
		$requests[$t] = $s;
		print "# request $t maps to $s\n";
	    }
	    if ($eventing) {
		$events[$t] = $s;
		print "# event code $t maps to $s\n";
	    }
	    $eventing=0 if(/^\#define LASTEvent/);
	    next;
	}

	if(/^\#define (\w+)\s+(0x[0-9a-fA-F]+)\s*$/) {
	    $defines{$1} = oct($2);
	    print "# defined flag $1 = $2\n";
	    next;
	}
    
	if(/^\#define (\w+)\s+\(1L?<<(\d+)\)\s*$/) {
	    $defines{$1} = 2**$2;
	    print "# defined flag $1 = $defines{$1} (2**$2)\n";
	    next;
	}
    
	if(/^typedef CARD(\d+) (\w+);/) {
	    $xtypeof{$2} = "CARD".$1;
	    $xsizeof{$2} = $1/8;
	    print "# processed type $2\n";
	    next;
	}

	if(/^typedef struct \{/) {
	    &process_struct();
	    next;
	}

	if(/^typedef struct _(\w+) \{/) {
	    &process_struct();
	    next;
	}

	if(/^typedef (\w+) (\w+);/) {
	    $xtypeof{$2} = $xtypeof{$1};
	    $xsizeof{$2} = $xsizeof{$1};
	    print "# processed type $2 (alias of $1)\n";
	    $xalias{$2} = $1;
	    next;
	}

#	print;
    }
}

# process_struct: walk XPROTO when we've got a typedef struct to work on
# handle some unions, filling in xsizeof and xtypeof only.  skip comments
# and WORD64 code.
sub process_struct {
    my($typ,$siz) = ([],0);
    while(<XPROTO>) {
	$incomment = &fropcomment($incomment);
	if(/\#if defined\(\_\_cplusplus\) \|\| defined\(c\_plusplus\)/) {
	    while(<XPROTO>) {
		last if (/\#else/);
	    }
	}
	if(/\#ifdef WORD64/) {
	    while(<XPROTO>) {
		last if (/\#else/);
	    }
	}
	next if(/\#else/);
	next if(/\#endif/);
	s/ +B16//g;
	s/ B32//g;
	last if(/\} (\w+)\;/);

	if(/union \{/) {
	    my($utt);
	    print "# handling Union\n";
	    while(<XPROTO>) {
		local($in_union) = !defined($xtypeof{"mappingNotify"});
		$utt = $_;
		if(/struct \{/) {
		    &process_struct();
		}
		last if($utt =~ /\} u\;/);
	    }
	}

	while(/(\w+)\s+(\w*)\,/) {
	    while(/(\w+)\s+(\w+)\,/) {
		push(@$typ,"$1 $2");
		$siz += $xsizeof{$1};
		s/$2\,//;
	    }
	    last if (/(\w+)\s+(\w+)\;/);
	    $_ .= <XPROTO>;
	    s/\/\*.*\*\///g;
	    s/ +B16//g;
	    s/ B32//g;
	}
	if(/(\w+)\s+(\w+)\[(\d+)\]\;/) {
	    push(@$typ,"$1 $2 $3");
	    $siz += $xsizeof{$1}*$3;
	}
	if(/(\w+)\s+(\w+)\;/) {
	    push(@$typ,"$1 $2");
	    $siz += $xsizeof{$1};
	}

    }
    m/\} (\w+);/;
    my $t = $1;
    print "# processed type $t\n";
    
    if($t eq "xEvent") {
	# xEvent is a "special" case...
	# xsizeof is already set...
	# and we don't really need xtypeof...
	$typ = ["BYTE raw_bits 32"];
	$siz = 32;
    }
    if($siz != $xsizeof{$t}) {
	print "### mismatch:  @$typ, $siz, $t, $xsizeof{$t}\n";
    }
    if ($in_union == 1) {
	if ($t eq "u") {
	    if (!defined($xtypeof{"mappingNotify"})) {
		print "SETTING union_u to @$typ/$siz\n";
		$union_u_typeof = $typ;
		$union_u_sizeof = $siz;
	    } else {
		$in_union = 0;
	    }
	} else {
	    print "ADDING @$union_u_typeof to $t\n";
	    print "WAS @$typ...\n";
	    if ($$typ[0] eq "CARD32 pad00") {
		splice(@$typ,0,1,@$union_u_typeof);
	    }
	    print "IS NOW @$typ...\n";
	    print "SIZ is $siz\n";
	}
    }
    $xtypeof{$t} = join(":",@$typ);
    $xsizeof{$t} = $siz;
}

# munchkeys: walk all xtypeof and generate xpackof
sub munchkeys {
    for $typ (keys %xtypeof) {
	print "Walking: $typ -- ";
	&walk_type($typ);
	$ss = length(pack($xpackof{$typ},0));
	print "$xpackof{$typ}, $xsizeof{$typ} $ss\n";
	if($ss != $xsizeof{$typ}) {
	    print "MISMATCH: $xtypeof{$typ}\n";
	}
    }
}

# walk_type: given a type that's in xtypeof, generate xpackof
#  *and* modify xtypeof by dropping pad fields
sub walk_type {
    my($typ) = @_;
    return if $xpackof{$typ} ne ""; # already done
    return if !defined($xtypeof{$typ});	# not doable
    my($xele,$save_1,$save_3);
    my $xnew = [];
    for $xele (split(/\:/,$xtypeof{$typ})) {
	if($xele =~ /^(\w+) (\w+)$/) {
	    $save_1 = $1;
	    # allow preloads for "special" names like "BYTE pad"
	    if($xpackof{$xele} ne "") {
		# assume a "whole line" subst means padding,
		# and we drop the field. Might change this later.
		$save_1 = $xele;
	    } else {
		push(@$xnew,$xele);
	    }
	    if($xpackof{$save_1} eq "") {
		&walk_type($save_1);
	    }
	    $xpackof{$typ} .= $xpackof{$save_1};
	} elsif($xele =~ /^(\w+) (\w+) (\d+)$/) {
	    $save_1 = $1; $save_3 = $3;
	    # allow preloads for "special" names like "BYTE pad 3"
	    if($xpackof{"$1 $2"} ne "") {
		# assume a "whole line" subst means padding,
		# and we drop the field. Might change this later.
		$save_1 = "$1 $2";
	    } else {
		push(@$xnew,$xele);
	    }
	    if($xpackof{$save_1} eq "") {
		&walk_type($save_1);
	    }
	    $xpackof{$typ} .= $xpackof{$save_1}.$save_3;
	} elsif($xele =~ /^(\w+)$/) {
	    # it can't really recurse here, can it?
	    # maybe if something is typedef xCharInfo.
	    push(@$xnew,$xele);
	    $xpackof{$typ} .= $xpackof{$1};
	} else {
	    die "bad element of $typ: $xele ($xtypeof{$typ})";
	}
    }
    $xtypeof{$typ} = join(":",@$xnew);
}

for $fn ("/usr/include/X11/Xproto.h", "/usr/include/X11/Xprotostr.h",
	 "extra-Xproto.h", "/usr/include/X11/X.h", 
	 "/usr/include/X11/cursorfont.h") {
    open(XPROTO,"< $fn") || die "Couldn't open $fn: $@";
    &munchproto;
    close XPROTO;
}
# X.h to actually to pick up *Mask, GC* and the like...

&munchkeys;

open(PERLOUT,">Xproto2.perl") || die "couldn't open Xproto2.perl: $@";
open(LISPOUT,">Xproto2.el") || die "couldn't open Xproto2.el: $@";

print PERLOUT "package X;\n";
print PERLOUT "\%xpackof = (\n";
print LISPOUT "(setq xpackof '(\n";
for $xtype (sort keys %xpackof) {
    print PERLOUT qq{"$xtype", "$xpackof{$xtype}",\n};
    print LISPOUT qq{("$xtype" "$xpackof{$xtype}")\n};
}
print PERLOUT "); # xpackof\n";
print LISPOUT ")) ; xpackof\n";
print PERLOUT "\%xtypeof = (\n";
print LISPOUT "(setq xtypeof '(\n";
for $xtype (sort keys %xtypeof) {
    print PERLOUT qq{"$xtype", "$xtypeof{$xtype}", \n};
    print LISPOUT qq{("$xtype" (};
    for (split(/\:/,$xtypeof{$xtype})) {
	m/(\w+) ?(\w+)?/;
	print LISPOUT qq{("$2" $1) };
	$result{$2} = shift @fields;
    }
    print LISPOUT qq{))\n};
#    print LISPOUT qq{("$xtype" "$xtypeof{$xtype}")\n};
}
print PERLOUT "); # xtypeof\n";
print LISPOUT ")) ; xtypeof\n";
print PERLOUT "\%xsizeof = (\n";
print LISPOUT "(setq xsizeof '(\n";
for $xtype (sort keys %xtypeof) {
    print PERLOUT qq{"$xtype", $xsizeof{$xtype},\n};
    print LISPOUT qq{("$xtype" $xsizeof{$xtype})\n};
}
print PERLOUT "); # xsizeof\n";
print LISPOUT ")) ; xsizeof\n";
print PERLOUT "\%defines = (\n";
print LISPOUT "(setq xdefines '(\n";
for $def (sort keys %defines) {
    print PERLOUT qq{"$def", $defines{$def},\n};
    print LISPOUT qq{("$def" $defines{$def})\n};
}
print PERLOUT "); # defines\n";
print LISPOUT ")) ; xdefines\n";

print PERLOUT "sub pad4 { ((\$_[0]+3)>>2)<<2; }\n";
print PERLOUT qq{sub xpad { my \$l=pad4(\$_[0])-\$_[0]; "\\0" x \$l; }\n};
%xsubs=();
for $def (sort keys %defines) {
    next if $def !~ /^X_/;
    ($j = $def) =~ s/^X_//;
    print PERLOUT qq{\$$j = $defines{$def};\n};
    # don't need X:: scoping in these copies...
    my $req = "x${j}Req";
    if (defined $xpackof{$req}) {
	if ($xalias{$req} eq "xResourceReq") {
	    print PERLOUT qq{sub $req { pack(\$xpackof{"$req"},\$$j,2,\@_);}\n};
	    $xsubs{$req} = $req;
	    print PERLOUT "sub new$req { $req(\@_); }\n";
	    $xsubs{"new$req"} = "new$req";
	} elsif ($xalias{$req} eq "xReq") {
	    print "GOTONE: xReq $j/$req isn't fake\n";
	    print PERLOUT qq{sub $req { pack(\$xpackof{"$req"},\$$j,0,1);}\n};
	} else {
	    my @fields = split(/\:/,$xtypeof{$req});
	    if ($fields[1] eq "CARD16 length") { 
		print PERLOUT 
		    qq{sub $req { pack(\$xpackof{"$req"},\$$j,\@_);}\n};
	    } elsif ($fields[2] eq "CARD16 length") { 
		print PERLOUT 
		    qq{sub $req { pack(\$xpackof{"$req"},\$$j,\$_[1],\$_[0],\@_[2..\$#_]);}\n};
            } else {
		print "$req failed: ".join(":",@fields)."\n";
		die;
	    } 
 my $fl = scalar(@fields)-2; # -length, -reqType, so points to extra
print PERLOUT "sub new$req { my \$l=\$_[$fl]; my \$x=$req(0,\@_).\$l; $req(pad4(length(\$x))/4,\@_).\$l.xpad(length(\$x)); }\n";
	    $xsubs{$req} = $req;
	    $xsubs{"new$req"} = "new$req";
	}
    } elsif ($xalias{$j} eq "xReq") {
	print PERLOUT qq{sub $req { pack(\$xpackof{"$j"},\$$j,0,1);}\n};
	$xsubs{$req} = $req;
	print PERLOUT "sub new$req { $req(\@_); }\n";
	$xsubs{"new$req"} = "new$req";
    }
}
print PERLOUT "\%xsubs = (\n";
for $subs (sort keys %xsubs) {
    print PERLOUT qq{"$subs" => \\&$subs,\n};
}
print PERLOUT ");\n";
for $def (sort keys %defines) {
    print PERLOUT qq{\$requests[$defines{$def}] = "$def";\n} if $def =~ /^X_/;
}
{
    print PERLOUT "\@xevents = (\"";
    print PERLOUT join(qq{\",\"}, @events);
    print PERLOUT "\"); # xevents\n";
}
print PERLOUT "package XC;\n";
for $def (sort keys %defines) {
    next if $def !~ /^XC_(.*)$/;
    print PERLOUT "\$$1 = $defines{$def};\n";
}

print PERLOUT "1;\n";
close PERLOUT;
close LISPOUT;
