#!/usr/bin/perl


%aliases = qw[
	StyleSheet	CSSStyleSheet
	CSS2Properties	CSSStyleDeclaration
];

@pack2interf = (qw[
CSS::DOM                   CSSStyleSheet
CSS::DOM::StyleSheetList   StyleSheetList         
CSS::DOM::MediaList        MediaList
CSS::DOM::RuleList         CSSRuleList
CSS::DOM::Rule             CSSRule
CSS::DOM::Rule::Style      CSSStyleRule
CSS::DOM::Rule::Media      CSSMediaRule
CSS::DOM::Rule::FontFace   CSSFontFaceRule
CSS::DOM::Rule::Page       CSSPageRule
CSS::DOM::Rule::Import     CSSImportRule
CSS::DOM::Rule::Charset    CSSCharsetRule
CSS::DOM::Style        CSSStyleDeclaration
CSS::DOM::Value            CSSValue
CSS::DOM::Value::Primitive CSSPrimitiveValue
CSS::DOM::Value::List      CSSValueList
CSS::DOM::RGBColor         RGBColor
CSS::DOM::Rect             Rect
CSS::DOM::Counter          Counter
]);

%interf2pack = reverse(@pack2interf);

%skip_interf = map +($_=>1), qw(
  LinkStyle
  DocumentStyle
  ViewCSS
  DocumentCSS
  DOMImplementationCSS
  ElementCSSInlineStyle

  CSSUnknownRule
),

# ~~~ Are these lists complete?
%is_hash = qw/  /;
%is_ary = qw/ StyleSheetList 1 CSSRuleList 1 MediaList 1
              CSSStyleDeclaration 1 /;

use File::Basename;
use File::Slurp;
BEGIN { chdir dirname $0;} 
use lib '../lib';

eval "require $_" for values %interf2pack;

%types = qw(
	void VOID
	boolean BOOL
	DOMString STR
	short NUM
	long NUM
);

print "  %CSS::DOM::Interface = (\n";
print "  \t'" . shift(@pack2interf) . "' => '" . shift(@pack2interf) .
	"',\n" while @pack2interf;

for (<*.idl>) {

*_ = \scalar read_file $_;

# This is not a full-blown IDL parser. It is simply one I threw together
# that happens to work with the DOM IDL files.

s/\/\/.*//g;

while(/interface\s+(\w+)\s*(?::\s*(?:[\w:]+:)?([\w]+)\s*)?\{(.*?)\}/sg) {
	my($name,$super,$members) = map $$_, 1..3;
	next if $skip_interf{$name};
	
	if($aliases{$name}) {
		$name = $aliases{$name};
		$super and $super{$name} = $super;
	} else {
	 push @interfaces, $name;
	 push @{$interfaces{$name}}, "\t\t_isa => '" .
		($super{$name}||$super) . "',\n"
		if $super and $aliases{$super} ne $name;
	 $interfaces{$name}[0] .= "\t\t_hash => " . (0+$is_hash{$name})
		 . ",\n" .
		"\t\t_array => " . (0+$is_ary{$name})
		. ",\n";
	} # else

	next if $members =~ /^\s*$/;
	for (split /;\s*/, $members) {
		if(/((?s).*?)\(/) {
			split ' ', $1;
			# $_[-2] has the type; $_[-1] has the name
			# These offset are negative, because some types
			# types are two words long, such as unsigned long
			push @{$interfaces{$name}},
				"  " .
				('#' x! $interf2pack{$name}->can($_[-1])) .
				"\t\t$_[-1] => METHOD | " . 
				($types{$_[-2]} || 'OBJ') . ",\n";
			next;
		}
		split;
		if ($_[0] eq 'const') {
			# $_[3] is the name of the constant 
			push @{$constants{$name}}, $_[3];
			next
		}
		my $ro = $_[0] eq 'readonly';
		# $_[-1] has the name
		# $_[-2] has the type
		push @{$interfaces{$name}},
			"  " .
			('#' x! $interf2pack{$name}->can($_[-1])) .
			"\t\t$_[-1] => " . 
			($types{$_[-2]} || 'OBJ') .
			' | READONLY' x $ro . ",\n";
	}
}

} #for <*.idl>

#unshift @interfaces, DOMException;
#$constants{DOMException} = [qw/
#INDEX_SIZE_ERR
#DOMSTRING_SIZE_ERR
#HIERARCHY_REQUEST_ERR
#WRONG_DOCUMENT_ERR 
#INVALID_CHARACTER_ERR
#NO_DATA_ALLOWED_ERR 
#NO_MODIFICATION_ALLOWED_ERR
#NOT_FOUND_ERR
#NOT_SUPPORTED_ERR
#INUSE_ATTRIBUTE_ERR
#INVALID_STATE_ERR
#SYNTAX_ERR
#INVALID_MODIFICATION_ERR
#NAMESPACE_ERR
#INVALID_ACCESS_ERR
#UNSPECIFIED_EVENT_TYPE_ERR
#
#/];
## ~~~ How exactly are non-DOMException exception constants accessible in
##     ECMAScript?


for (@interfaces) {
	print "  \t $_ => {\n",shift @{$interfaces{$_}};
	if($constants{$_}) {
		print "  \t\t_constants => [qw[\n";
		for $c (@{$constants{$_}}) {
			print "  " . 
				('#' x! defined &{"$interf2pack{$_}::$c"})
				. "\t\t\t$interf2pack{$_}::$c\n"
			;
	
		}
		print "  \t\t]],\n";
	}
	print @{$interfaces{$_}}, "  \t },\n";
}
print "  );\n";


