package Iotta::Copp::GetIDs;
use strict;
require Iotta::Elem;
our @ISA = ("Iotta::Elem");

my $ws = "[ \t\n]";

sub addid {
	my $self = shift;
	my $l = shift;
	my $id = shift;
	unless (grep /^$id$/, @$l) {
		push @$l, "$id"
	}
}


sub run {
	my $self = shift;
	my $meta = shift;
	my $data = shift;

	$self->next->run ($meta, $data) if ($self->next);
}

1;


my %ptsmap = (
	"char *" => "s",
	"int" => "i",
	"long int" => "l"
);

my $initfunc_add;

sub meth {
	my $in = shift;
	$_ = $in; my %msg; my %fwd; my %tab; my %pmtab;
	my %flav;
	my @objs;
	while (s/CO_METH$ws*\((.*?),(.*?)(?:,(.*?)|)\)//sm) {
		my $o = $1;
		my $m = $2;
		my $argl = $3;
		$o =~ s/^$ws+|$ws+$//g;
		$m =~ s/^$ws+|$ws+$//g;
		my $def = "#define CO_METH_INI_${o}_$m ";
		#print STDERR "${o}_$m ($argl)\n";
		my @arg = split /,/, $argl;
		my $pwrap = "static PyObject *${o}_${m}_PyWrap (PyObject * self,"
			."PyObject *args)\n";
		my $pargdecl;
		my $pargstr;
		my $parglst;
		my $carglst;
		for (@arg) {
			s/^$ws+|$ws+$//g;
			my $t = $_;
			my $n = $_;
			$t =~ s/[a-zA-Z_@]+$//;
			$t =~ s/^$ws+|$ws+$//g;
			#print STDERR "arg: $_ = va_arg (ap, $t);\n";
			$n =~ s/.*?([a-zA-Z_@]+)$/$1/;
			$n =~ s/^$ws+|$ws+$//g;
			$def .= "$_ = va_arg (ap, $t); ";
			$pargstr .= $ptsmap{$t};
			$pargdecl .= "\t$_;\n";
			$parglst .= "&$n, ";
			$carglst .= "$n, ";
		}
		$parglst =~ s/, $//;
		$carglst =~ s/, $//;
		$pwrap .= "{\n\tint __ok;\n$pargdecl\n\t__ok = PyArg_ParseTuple "
			."(args, \"$pargstr\"";
		$pwrap .= ", $parglst" if ($parglst);
		$pwrap .= ");";
		$pwrap .= "\n\tCO_M (((co_o_python) self) -> co_object, $m";
		$pwrap .= ", $carglst" if ($carglst);
		$pwrap .= ");\n";
		$pwrap .= "\treturn Py_BuildValue (\"i\", 0); \n}"; # FIXME
		#$def =~ s/; $//;
		$def .= "$o td CO_POSSIBLY_UNUSED = this -> data";
		print OUT "$def\n";
		print OUT "$pwrap\n";
		#$msg{$o} = "\tCO_MH_BEGIN;\n" unless ($msg{$o});
		#$msg{$o} .= "\tCO_MH_CASE (message, $m) {\n\t\treturn "
		#	."${o}_$m (this, self, message, ap);\n\t}\n";
		$fwd{$o} .= "co_v ${o}_$m (co_o_minimal this, co self, co_id_t message, va_list"
			." ap);\n";
		$tab{$o} .= "\tco_meth_add (o -> meth_ar, COM ($m),"
			." (co_message_handler) ${o}_$m);\n";
		$pmtab{$o} .= "{ \"$m\", ${o}_${m}_PyWrap, METH_VARARGS, \"$o: $m\"},";
		push @objs, $o unless grep /^$o$/, @objs;
	}
	my $o;
	while (s/(CO_OBJECT|CO_ATTR)$ws*\((.*?)\)//) {
		my $match = $1;
		if ($match eq "CO_OBJECT") {
			my $fl;
			$o = $2;
			$o =~ s/(.*?),(.*)/$1/;
			$fl = $2;
			$fl =~ s/^[ \t]*|[ \t]*$//g;
			$flav{$o} = $fl;
			#push @objs, $o;
			push @objs, $o unless grep /^$o$/, @objs;
		} else {
			my ($t, $m) = split /,/, $2;
			#my $m = $2;
			$o =~ s/^$ws+|$ws+$//g;
			$t =~ s/^$ws+|$ws+$//g;
			$m =~ s/^$ws+|$ws+$//g;
			#$msg{$o} = "\tCO_MH_BEGIN;\n" unless ($msg{$o});
			#$msg{$o} .= "\tCO_MH_CASE (message, $m) {\n\t\tCO_RETURN (${t}_p, "
			#	."&(this -> $m));\n\t}\n";
			#$fwd{$o} .= "co_v ${o}_$m (co this, co self, co_id_t message, va_list"
			#	." ap);\n";
			$tab{$o} .= "\tco_meth_add (o -> meth_ar, COM ($m),"
				." (co_message_handler) ${o}_$m);\n";
			$fwd{$o} .= "
static co_v ${o}_$m (co this,
	co self CO_POSSIBLY_UNUSED,
	co_id_t message CO_POSSIBLY_UNUSED,
	va_list ap CO_POSSIBLY_UNUSED)
{
	$o td = ((co_o_minimal) this) -> data;
	CO_RETURN (${t}_p, &(td -> $m));
}";
		}
	}
	for (@objs) {
		$o = $_;
		for (keys %def_meth) {
			my $meth = $def_meth{$_};
			$meth =~ s/#OBJ#/$o/;
			$meth =~ s/#FLAV#/$flav{$o}/;
			#$fwd{$o} .= "co_v $def_meth{$_} (co this, co self, "
			#	."co_id_t message, va_list ap);\n";
			$tab{$o} .= "\tco_meth_add (o -> meth_ar,"
				." COM ($_), $meth);\n";
		}
	}
	for (@objs) {
		print OUT "\n// FWD FOR $_\n";
		print OUT $fwd{$_}."\n";
print OUT <<EOF
static co_v ${_}_clone_shallow (co _src)
{
	$_ src = _src;
	$_ dest = new (${_}_s);
	memcpy (dest, src, sizeof (${_}_s));
	cox_pop (dest);
	CO_PUSH (dest);
	CO_RETURN (co, dest);
}
EOF
;
		#print OUT "/* static co_v ${_}_msg (co __this, co self, co_id_t"
		#	." message, va_list ap) {\n";
		#print OUT "$_ this = __this;\n";
		#print OUT $msg{$_};
		#if ($in =~ /CO_MSG_DEFAULT$ws*\($ws*$_$ws*,(.*?)\)/) {
		#	print OUT "\tCO_MH_DEFAULT(message) {\n\t\treturn CO_D_V "
		#		."($1, self, message, ap);\n\t}\n";
		#}
		#print OUT "\tCO_RETURN (int, 0xBAD0);\n";
		#print OUT "} */\n";
		print OUT "\nstatic void ${_}_meth_ar_init (co object) {\n";
		print OUT "\tco_o_small o = object;\n";
		print OUT "\to -> meth_ar = co_meth_array_new ();\n";
		#print OUT "\tco_meth_add (o -> meth_ar, COM (has_method),"
		#	." co_has_method);\n";
		print OUT $tab{$_};
		print OUT "}";
		my $flavor = $flav{$_};
print OUT <<EOF
static PyObject *${_}_PyNew (PyObject *self, PyObject *args);

// create new (unblessed) object - blessings shalt be received later
co ${_}_new (void)
{
	co o = co_o_${flavor}_new ();
	${_}_meth_ar_init (o);
	CO_M (o, init);
	return o;
}

static PyMethodDef ${_}_PyMethods[] = {
	{"new", ${_}_PyNew, METH_VARARGS, "create new $_"},
	{NULL, NULL, 0, NULL}
};

static PyMethodDef ${_}_PyObjMethods[] = {
	$pmtab{$_}
	{NULL, NULL, 0, NULL}
};

static PyObject *${_}_PyGetattr (PyObject *self, char *name)
{
	CO_DEBUG (1, "get attr: \%s", name);
	return Py_FindMethod (${_}_PyObjMethods, self, name);
}

static PyTypeObject ${_}_PyTypeObject = {
	PyObject_HEAD_INIT(NULL)
	0,
	\"$_\",
	sizeof (co_o_python_s),
	0,
	co_o_python_del,
	0,
	${_}_PyGetattr,
	0 /* setattr */
};
static PyObject * ${_}_PyNew (PyObject *self, PyObject *args) {
	co_o_python nwobj;
	nwobj = PyObject_New (co_o_python_s, &${_}_PyTypeObject);
	nwobj -> co_object = ${_}_new ();
	CO_DEBUG (1, "create obj: \%p", nwobj -> co_object);
	return nwobj;
}
EOF
;
		$initfunc_add .= "\n\t${_}_PyTypeObject . ob_type = &PyType_Type;";
		$initfunc_add .= "\n\tPy_InitModule (\"$_\", ${_}_PyMethods);";
	}
	#return \%msg;
}

sub append {
	$_ = shift;
	my $rx = shift;
	my $l = shift;
	my $T = shift;
	while (s/$rx//) {
		my $id = $1;
		$id =~ s/^$ws+|$ws+$//g;
		&addid ($l, "$T$id");
	}
}

sub dump2 {
	my $templ = shift;
	my $lst = shift;
	for (@$lst) {
		/(.)(.*)/;
		my $T = $1;
		my $id = $2;
		my $l = $$templ{$T};
		$l =~ s/#ID#/$id/g;
		#print STDERR "$l";
		print OUT $l;
	}
}

sub erruse {
	print STDERR "usage error!\n";
	exit (1);
}

my $decls = {
	"M" => "static co_id_t __co_id_message_#ID#;\n",
	"P" => "static co_id_t __co_id_property_#ID#;\n",
	"E" => "static co_id_t __co_id_event_#ID#;\n",
	"X" => "static co_id_t __co_id_exception_#ID#;\n",
	"T" => "static co_id_t __co_id_type_#ID#;\n"
};
my $defs = {
	"M" => "\tCOM (#ID#) = co_id_init (super -> id_msg, \"#ID#\");\n",
	"P" => "\tCOP (#ID#) = co_id_init (super -> id_prop, \"#ID#\");\n",
	"E" => "\tCOE (#ID#) = co_id_init (super -> id_event, \"#ID#\");\n",
	"X" => "\tCOX_ID (#ID#) = co_id_init (super -> id_exception, \"#ID#\");\n",
	"T" => "\tCOT (#ID#) = co_id_init (super -> id_type, \"#ID#\");\n",
};

use Digest::SHA1;

my $cmd = "erruse";
my @args;
my $out = "-";
my $suff = ".cometa";
my $check = 1;
my $ahash = 1;
my $header = "";
my $hash;

while (scalar @ARGV) {
	$_ = shift @ARGV;
	#print STDERR "'$_'\n";
	if ($_ eq "-m") {
		#&erruse if ($mode);
		$cmd = "meta";
		push @args, (shift @ARGV);
	} elsif ($_ eq "-i") {
		my @files;
		while (($_ = shift @ARGV) !~ /^-/) {
			push @args, $_;
		}
		unshift @ARGV, $_;
		$cmd = "init"
	} elsif ($_ eq "-o") {
		$out = shift @ARGV;
		#print STDERR "out: $out\n";
	} elsif ($_ eq "-s") {
		$suff = shift @ARGV;
	} elsif ($_ eq "-h") {
		$header = shift @ARGV;
	} elsif ($_ eq "-H") {
		$ahash = 0;
	} elsif ($_ eq "-f") {
		$check = 0;
	} else {
		&erruse;
	}
}

&$cmd (@args);


sub getf {
	my $file = shift;
	my $in;
	my $noh;
	if ($header) {
		open (IN, $header);
		$in .= $_ while (<IN>);
		close (IN);
	}
	open (IN, $file);
	while (<IN>) {
		$in .= $_;
		$noh .= $_;
	}
	close (IN);
	$in =~ s!(\#if 0\n).*?(\#endif /\* 0 \*/\n)!!gsm;
	$in =~ s/\/\*.*?\*\///gsm;
	$in =~ s/\/\/.*?$//gsm;
	$noh =~ s!(\#if 0\n).*?(\#endif /\* 0 \*/\n)!!gsm;
	$noh =~ s/\/\*.*?\*\///gsm;
	$noh =~ s/\/\/.*?$//gsm;
	$hash = &Digest::SHA1::sha1_hex ($noh);
	return $in;
}

sub meta {
	my $file = shift;
	my $in = &getf ($file);
	#print STDERR "out: \">$out\"\n";
	open (OUT, ">$out");

	my @list;
	&append ($in, qr/\bCO_CNT$ws*\(.*?,(.*?),/, \@list, "E");
	&append ($in, qr/\bCO_CNT$ws*\(.*?,.*?,.*?,(.*?)\)/, \@list, "M");
	&append ($in, qr/\bCO_M$ws*\(.*?,(.*?)[,)]/, \@list, "M");
	#&append ($in, qr/CO_ATTR$ws*\(.*?,(.*?)[,)]/, \@list, "M");
	&append ($in, qr/\bCO_ATTR$ws*\(.*?,(.*?)[,)]/, \@list, "M");
	&append ($in, qr/\bCO_METH$ws*\(.*?,(.*?)[,)]/, \@list, "M");
	&append ($in, qr/\bCO_METH$ws*\((.*?),/, \@list, "T");
	&append ($in, qr/\bCO_OBJECT$ws*\((.*?),/, \@list, "T");
	&append ($in, qr/\bCO_EV$ws*\(.*?,(.*?)[,)]/, \@list, "E");
	&append ($in, qr/\bCO_P$ws*\(.*?,(.*?)[,)]/, \@list, "P");
	&append ($in, qr/\bCO_A$ws*\(.*?,.*?,(.*?)[,)]/, \@list, "M");
	&append ($in, qr/\bCO_PH_RET$ws*\(.*?,(.*?)[,)]/, \@list, "P");
	&append ($in, qr/\bCO_PH_RET_C$ws*\(.*?,(.*?)[,)]/, \@list, "P");
	&append ($in, qr/\bCO_MH_CASE$ws*\(.*?,(.*?)[,)]/, \@list, "M");
	&append ($in, qr/\bCOM$ws*\((.*?)\)/, \@list, "M");
	&append ($in, qr/\bCOE$ws*\((.*?)\)/, \@list, "E");
	&append ($in, qr/\bCOP$ws*\((.*?)\)/, \@list, "P");
	&append ($in, qr/\bCOX_THROW$ws*\((.*?)\)/, \@list, "X");
	&append ($in, qr/\bCOX_ID$ws*\((.*?)\)/, \@list, "X");
	&append ($in, qr/\bCO_BLESS(?:_M|_MP|_0|)$ws*\(.*?,(.*?)[,)]/, \@list, "T");
	if ($in =~ /#include[ \t]*[<"].*?co_conv.h[">]/) {
		&append ($in, qr/\bP$ws*\(.*?,(.*?)[,)]/, \@list, "P");
		&append ($in, qr/\bM$ws*\(.*?,(.*?)[,)]/, \@list, "M");
		&append ($in, qr/\bE$ws*\(.*?,(.*?)[,)]/, \@list, "E");
	}
	#if ($in =~ /CO_OBJECT/) { # FIXME
		#&addid (\@list, "Mhas_method");
		#	&addid (\@list, "Mclone");
	#}
	foreach (keys %def_meth) {
		&addid (\@list, "M$_");
	}

	print OUT "#include <co_python.h>\n";
	print OUT "#include <co_o_default.h>\n";
	print OUT "#include <co_super.h>\n";
	print OUT "#include <co_type.h>\n";
	&dump2 ($decls, \@list);
	&meth ($in);

	$file =~ s#.*?/##g;
	$file =~ s/\.|-/_/g;

	if ($ahash) {
		$hash = "_$hash";
	} else {
		$hash = "";
	}

	print OUT "void __co_file_init_${file}$hash (co_o_small _super);\n";
	print OUT "void __co_file_init_${file}$hash (co_o_small _super) {\n";
	print OUT "co_super super = _super -> data;\n";
	print OUT "\tCO_DEBUG (3, \"called\");\n";
	&dump2 ($defs, \@list);
	print OUT $initfunc_add;
	print OUT "}\n";
	close OUT;
}

sub init {
	my %ifcs;
	open (OUT, ">$out");
	for (@_) {
		my $f = $_;
		my $in = &getf ($_);
		if ($check) {
			my $b = $f;
			$b =~ s/^.*\///;
			$b =~ s/\..*//;
			#print STDERR "checking: ($f) $b$suff\n";
			next unless ($in =~ /^#include$ws*[<"]$b$suff[">]/sm);
		}
		$f =~ s#.*?/##g;
		$f =~ s/\.|-/_/g;
		$ifcs{$f} = &Digest::SHA1::sha1_hex ($in);
	}
	print OUT "#include <co_super.h>\n";
	for (keys %ifcs) {
		print OUT "void __co_file_init_${_}_$ifcs{$_} (co);\n";
	}
	print OUT "void __co_mod_autoinit (co_super super);\n";
	print OUT "void __co_mod_autoinit (co_super super) {\n";
	for (keys %ifcs) {
		print OUT "__co_file_init_${_}_$ifcs{$_} (super);\n";
	}
	print OUT "}\n";
	close OUT;
}

__END__