
#include <tcl.h>
#include <tclOO.h>
#include "tcloo_util.h"


	// return Tcl_Class or NULL

Tcl_Class tcloox_getClass(Tcl_Interp *interp, const char *className) {
	Tcl_Object classObject;
	Tcl_Obj *nameObj = Tcl_NewStringObj(className,-1);
	Tcl_IncrRefCount(nameObj);
	if ((classObject = Tcl_GetObjectFromObj(interp, nameObj)) == NULL) {
		Tcl_DecrRefCount(nameObj);
		return NULL;
	}
	Tcl_DecrRefCount(nameObj);
	return Tcl_GetObjectAsClass(classObject);	
}


void tcloox_registerConstructor(Tcl_Interp *interp, Tcl_Class clazz, const Tcl_MethodType *methodTypePtr) {
	Tcl_ClassSetConstructor(interp, clazz,
		Tcl_NewMethod(interp, clazz, NULL, 0,
					  methodTypePtr,
					  NULL));
// ??  why the isPublic flag is 0 ??
}


void tcloox_registerDestructor(Tcl_Interp *interp, Tcl_Class clazz, const Tcl_MethodType *methodTypePtr) {
	Tcl_ClassSetDestructor(interp, clazz,
		Tcl_NewMethod(interp, clazz, NULL, 0,
					  methodTypePtr,
					  NULL));
// ??  why the isPublic flag is 0 ??
}


Tcl_Method tcloox_registerMethod( Tcl_Interp *interp, Tcl_Class clazz, const Tcl_MethodType *methodType ) {
	Tcl_Method method;
	Tcl_Obj *nameObj;
	
	nameObj = Tcl_NewStringObj(methodType->name,-1);
	Tcl_IncrRefCount(nameObj);
	method = Tcl_NewMethod(interp,clazz,nameObj,1,methodType,NULL);
	Tcl_DecrRefCount(nameObj);
	return method;
}


int tcloox_registerMethods( Tcl_Interp *interp, Tcl_Class clazz, const Tcl_MethodType *methods [] ) {
	for (int i = 0; methods[i] != NULL; ++i) {
		tcloox_registerMethod( interp, clazz, methods[i]);
	}
	return TCL_OK;
}

 /*
 **  this is very simlar in purpose to Tcl_WrongNumArgs()
 **  but it works only (and better) for tcloo methods.
 **  Like Tcl_WrongNumArgs, this function generates a standard error message
 **  and stores it int the result value of interp.
 **  The result includes the involved object, the method, plus message,
 **  E.g.
 **    wrong # args: should be "_objectname_ _method_ _message_
 */ 
void tcloox_methodUsage(Tcl_Interp* interp, Tcl_ObjectContext objectContext, const char* message) {
	Tcl_Obj* objectName = Tcl_GetObjectName(interp,Tcl_ObjectContextObject(objectContext));
	Tcl_Obj* methodName = Tcl_MethodName(Tcl_ObjectContextMethod(objectContext));

	Tcl_SetObjResult(interp, Tcl_ObjPrintf("wrong # args: should be \"%s %s %s\"",
		Tcl_GetString(objectName), Tcl_GetString(methodName), (message?message:"")
		));
}

// -----------------------------------------------

int NoCloneMethod(
	Tcl_Interp* interp,		/* Tcl interpreter for error reporting */
	ClientData metadata,	/* Metadata to be cloned */
	ClientData* newMetaData	/* Where to put the cloned metadata */
) {
	//  TODO ... retrive the class name 
	char * classname = "..THESE...";
	Tcl_SetObjResult(interp, Tcl_ObjPrintf("%s objects are not clonable",classname));
	return TCL_ERROR;
}
