//-----------------------------------------------------------------------------
// AScript tcl module
// Tcl/Tk manual: http://www.tcl.tk/man/tcl8.5/
//-----------------------------------------------------------------------------
#include "Module_tcl.h"

AScript_BeginModule(tcl)

AScript_DeclarePrivSymbol(__tclname__);

TCL_DECLARE_MUTEX(g_mutex)

static jmp_buf g_jmpenv;

//-----------------------------------------------------------------------------
// Object_Interp implementation
//-----------------------------------------------------------------------------
Object_Interp::Object_Interp(Tcl_Interp *interp) :
		Object(AScript_PrivClass(Interp)), _interp(interp),
		_cntCreatedCommand(0), _cntCreatedVariable(0)
{
	_thread_id = ::Tcl_GetCurrentThread();
	ObjType_boolean		= ::Tcl_GetObjType("boolean");
	ObjType_bytearray	= ::Tcl_GetObjType("bytearray");
	ObjType_double		= ::Tcl_GetObjType("double");
	ObjType_int			= ::Tcl_GetObjType("int");
	ObjType_list		= ::Tcl_GetObjType("list");
	ObjType_string		= ::Tcl_GetObjType("string");
}

Object_Interp::~Object_Interp()
{
	::Tcl_DeleteInterp(_interp);
}

Object *Object_Interp::Clone() const
{
	return NULL;
}

String Object_Interp::ToString(Signal sig, bool exprFlag)
{
	return String("<tcl.interp>");
}

Tcl_Obj *Object_Interp::ConvToTclObj(Environment &env, Signal sig, const Value &value)
{
	if (value.IsInvalid()) {
		return ::Tcl_NewStringObj("", 0);
	} else if (value.IsBoolean()) {
		return ::Tcl_NewBooleanObj(value.GetBoolean());
	} else if (value.IsBinary()) {
		const Binary &binary = value.GetBinary();
		return ::Tcl_NewByteArrayObj(
			reinterpret_cast<const unsigned char *>(binary.data()), static_cast<int>(binary.size()));
	} else if (value.IsNumber()) {
		Number num = value.GetNumber();
		if (static_cast<Number>(static_cast<long>(num)) == num) {
			return ::Tcl_NewLongObj(static_cast<long>(num));
		} else {
			return ::Tcl_NewDoubleObj(num);
		}
	} else if (value.IsList()) {
		int objc;
		Tcl_Obj **objv = CreateTclObjArray(env, sig, value.GetList(), &objc);
		if (!sig.IsSignalled()) {
			return ::Tcl_NewListObj(objc, objv);
		}
	} else if (value.IsString()) {
		const char *str = value.GetString();
		return ::Tcl_NewStringObj(str, static_cast<int>(::strlen(str)));
	} else if (value.IsFunction()) {
		Handler *pHandler = new Handler(Object_Interp::Reference(this),
					Object_Function::Reference(value.GetFunctionObj()), sig);
		String cmdName = NewCommandName();
		::Tcl_CreateCommand(_interp, cmdName.c_str(), CommandProc,
											pHandler, CommandDeleteProc);
		return ::Tcl_NewStringObj(cmdName.c_str(), static_cast<int>(cmdName.size()));
	} else if (value.IsType(AScript_PrivVTYPE(Variable))) {
		const Object_Variable *pObjVariable =
						dynamic_cast<const Object_Variable *>(value.GetObject());
		const char *varName = pObjVariable->GetVarName();
		return ::Tcl_NewStringObj(varName, static_cast<int>(::strlen(varName)));
	} else if (value.IsObject()) {
		Object *pObj = value.GetObject();
		const Function *pFunc =
					pObj->LookupFunction(AScript_PrivSymbol(__tclname__), true);
		if (pFunc != NULL) {
			Value valueSelf(pObj, false); // reference to self
			Args args(ValueList::Null, valueSelf);
			Value result = pFunc->Eval(*pObj, sig, args);
			if (!sig.IsSignalled()) {
				return ConvToTclObj(env, sig, result);
			}
		}
	}
	String str = value.ToString(sig, false);
	return ::Tcl_NewStringObj(str.c_str(), static_cast<int>(str.size()));
}

Value Object_Interp::ConvFromTclObj(Environment &env, Signal sig, Tcl_Obj *objPtr)
{
	Tcl_ObjType *typePtr = objPtr->typePtr;
	if (typePtr == NULL) {
		return Value(env, objPtr->bytes, objPtr->length);
	} else if (typePtr == ObjType_boolean) {
		int value;
		::Tcl_GetBooleanFromObj(_interp, objPtr, &value);
		return Value(value? true : false);
	} else if (typePtr == ObjType_bytearray) {
		int length;
		unsigned char *binary = ::Tcl_GetByteArrayFromObj(objPtr, &length);
		Value result;
		result.InitAsBinary(env, Binary(reinterpret_cast<char *>(binary), length));
		return result;
	} else if (typePtr == ObjType_double) {
		double value;
		::Tcl_GetDoubleFromObj(_interp, objPtr, &value);
		return Value(value);
	} else if (typePtr == ObjType_int) {
		int value;
		::Tcl_GetIntFromObj(_interp, objPtr, &value);
		return Value(value);
	} else if (typePtr == ObjType_list) {
		int length;
		::Tcl_ListObjLength(_interp, objPtr, &length);
		Value result;
		ValueList &valList = result.InitAsList(env);
		valList.reserve(length);
		for (int i = 0; i < length; i++) {
			Tcl_Obj *objElemPtr;
			::Tcl_ListObjIndex(_interp, objPtr, i, &objElemPtr);
			valList.push_back(ConvFromTclObj(env, sig, objElemPtr));
			if (sig.IsSignalled()) return Value::Null;
		}
		return result;
	} else if (typePtr == ObjType_string) {
		int length;
		char *value = ::Tcl_GetStringFromObj(objPtr, &length);
		return Value(env, value);
	}
	return Value(env, objPtr->bytes, objPtr->length);
}

Tcl_Obj **Object_Interp::CreateTclObjArray(Environment &env, Signal sig,
										const ValueList &valList, int *pObjc)
{
	*pObjc = static_cast<int>(valList.size());
	Tcl_Obj **objv = new Tcl_Obj *[*pObjc];
	int i = 0;
	foreach_const (ValueList, pValue, valList) {
		objv[i++] = ConvToTclObj(env, sig, *pValue);
		if (sig.IsSignalled()) {
			DeleteTclObjArray(i - 1, objv);
			return NULL;
		}
	}
	return objv;
}

void Object_Interp::DeleteTclObjArray(int objc, Tcl_Obj **objv)
{
	for (int i = 0; i < objc; i++) {
		Tcl_DecrRefCount(objv[i]);
	}
	delete[] objv;
}

Value Object_Interp::TclEval(Environment &env, Signal sig, const ValueList &valList)
{
	int objc;
	Tcl_Obj **objv = CreateTclObjArray(env, sig, valList, &objc);
	if (sig.IsSignalled()) return Value::Null;
	int rtn = ::Tcl_EvalObjv(_interp, objc, objv, TCL_EVAL_DIRECT | TCL_EVAL_GLOBAL);
	if (rtn != TCL_OK) {
		sig.SetError(ERR_RuntimeError, "%s\n", ::Tcl_GetStringResult(_interp));
		delete[] objv;
		return Value::Null;
	}
	delete[] objv;
	Tcl_Obj *obj = ::Tcl_GetObjResult(_interp);
	if (obj == NULL) return Value::Null;
	Value result = ConvFromTclObj(env, sig, obj);
	return result;
}

String Object_Interp::NewCommandName()
{
	char cmdName[32];
	::sprintf(cmdName, "::ascript::cmd%d", _cntCreatedCommand);
	_cntCreatedCommand++;
	return String(cmdName);
}

String Object_Interp::NewVariableName()
{
	char varName[32];
	::sprintf(varName, "ascript_variable%d", _cntCreatedVariable);
	_cntCreatedVariable++;
	return String(varName);
}

void Object_Interp::ExitMainLoop()
{
	//Tk_Window tkwin = ::Tk_MainWindow(_interp);
	//if (tkwin != NULL) ::Tk_DestroyWindow(tkwin);
	::longjmp(g_jmpenv, 1);
}

int Object_Interp::CommandProc(ClientData clientData,
							Tcl_Interp *interp, int argc, const char *argv[])
{
	Handler *pHandler = reinterpret_cast<Handler *>(clientData);
	Object_Interp *pObjInterp = pHandler->GetInterpObj();
	Environment &env = *pObjInterp;
	Signal &sig = pHandler->GetSignal();
	if (argc > 0) {
		// skip the first argument
		argc--, argv++;
	}
	Value result = pHandler->Eval(argc, argv);
	if (sig.IsSignalled()) {
		pObjInterp->ExitMainLoop();
		return TCL_OK;
	}
	Tcl_Obj *obj = pObjInterp->ConvToTclObj(env, sig, result);
	if (sig.IsSignalled()) {
		pObjInterp->ExitMainLoop();
		return TCL_OK;
	}
	::Tcl_SetObjResult(interp, obj);
	return TCL_OK;
}

void Object_Interp::CommandDeleteProc(ClientData clientData)
{
	Handler *pHandler = reinterpret_cast<Handler *>(clientData);
	delete pHandler;
}

int Object_Interp::TclThreadProc(Tcl_Event *ev, int flags)
{
	EventPack *pEventPack = reinterpret_cast<EventPack *>(ev);
	pEventPack->rtn = ::Tcl_EvalObjv(pEventPack->interp,
		pEventPack->objc, pEventPack->objv, TCL_EVAL_DIRECT | TCL_EVAL_GLOBAL);
	pEventPack->objRtn = ::Tcl_GetObjResult(pEventPack->interp);
	Tcl_IncrRefCount(pEventPack->objRtn);
	Object_Interp::DeleteTclObjArray(pEventPack->objc, pEventPack->objv);
	pEventPack->objv = NULL;
	// wake up calling thread
	Tcl_MutexLock(&g_mutex);
	Tcl_ConditionNotify(pEventPack->pCond);
	Tcl_MutexUnlock(&g_mutex);
	return 1;
}

Value Object_Interp::InvokeTclThread(Environment &env, Signal sig,
												const ValueList &valListArg)
{
	Tcl_Condition cond = NULL;
	EventPack *pEventPack =
			reinterpret_cast<EventPack *>(::ckalloc(sizeof(EventPack)));
	pEventPack->ev.proc = TclThreadProc;
	pEventPack->interp = _interp;
	pEventPack->objv = CreateTclObjArray(env, sig, valListArg, &pEventPack->objc);
	if (sig.IsSignalled()) return Value::Null;
	pEventPack->rtn = TCL_OK;
	pEventPack->objRtn = NULL;
	pEventPack->pCond = &cond;
	do {
		Tcl_MutexLock(g_mutex);
		::Tcl_ThreadQueueEvent(_thread_id,
					reinterpret_cast<Tcl_Event *>(pEventPack), TCL_QUEUE_TAIL);
		::Tcl_ThreadAlert(_thread_id);
		Tcl_ConditionWait(&cond, g_mutex, NULL);
		Tcl_MutexUnlock(g_mutex);
	} while (0);
	Tcl_ConditionFinalize(&cond);
	if (pEventPack->rtn != TCL_OK) {
		int length;
		const char *str = ::Tcl_GetStringFromObj(pEventPack->objRtn, &length);
		Tcl_DecrRefCount(pEventPack->objRtn);
		sig.SetError(ERR_RuntimeError, "%s\n", str);
		return Value::Null;
	}
	Value result = ConvFromTclObj(env, sig, pEventPack->objRtn);
	Tcl_DecrRefCount(pEventPack->objRtn);
	return result;
}

//-----------------------------------------------------------------------------
// AScript interfaces for Object_Interp
//-----------------------------------------------------------------------------
// interp#eval(objs+)
AScript_DeclareMethod(Interp, eval)
{
	SetMode(RSLTMODE_Normal, FLAG_None);
	DeclareArg(env, "objs", VTYPE_Any, OCCUR_OnceOrMore);
}

AScript_ImplementMethod(Interp, eval)
{
	Object_Interp *pSelf = Object_Interp::GetSelfObj(args);
	return pSelf->TclEval(env, sig, args.GetList(0));
}

#if 0
AScript_ImplementMethod(Interp, eval)
{
	Object_Interp *pSelf = Object_Interp::GetSelfObj(args);
	return pSelf->InvokeTclThread(env, sig, args.GetList(0));
}
#endif

// interp#evalscript(script:string)
AScript_DeclareMethod(Interp, evalscript)
{
	SetMode(RSLTMODE_Normal, FLAG_None);
	DeclareArg(env, "script", VTYPE_String);
}

AScript_ImplementMethod(Interp, evalscript)
{
	Object_Interp *pSelf = Object_Interp::GetSelfObj(args);
	Tcl_Interp *interp = pSelf->GetInterp();
	int rtn = ::Tcl_Eval(interp, args.GetString(0));
	if (rtn != TCL_OK) {
		sig.SetError(ERR_RuntimeError, "%s\n", ::Tcl_GetStringResult(interp));
		return Value::Null;
	}
	return pSelf->ConvFromTclObj(env, sig, ::Tcl_GetObjResult(interp));
}

// interp#variable(value?, varName?:string)
AScript_DeclareMethod(Interp, variable)
{
	SetMode(RSLTMODE_Normal, FLAG_None);
	DeclareArg(env, "value", VTYPE_Any, OCCUR_ZeroOrOnce);
	DeclareArg(env, "varName", VTYPE_String, OCCUR_ZeroOrOnce);
}

AScript_ImplementMethod(Interp, variable)
{
	Object_Interp *pSelf = Object_Interp::GetSelfObj(args);
	Object_Interp *pObjInterp = Object_Interp::Reference(pSelf);
	String varName;
	if (args.IsString(1)) {
		varName = args.GetString(1);
	} else {
		varName = pObjInterp->NewVariableName();
	}
	Object_Variable *pObjVariable = new Object_Variable(pObjInterp, varName.c_str());
	if (args.IsValid(0)) {
		if (!pObjVariable->Set(env, sig, args.GetValue(0))) return Value::Null;
	}
	return Value(pObjVariable);
}

// interp#command(func:function)
AScript_DeclareMethod(Interp, command)
{
	SetMode(RSLTMODE_Normal, FLAG_None);
	DeclareArg(env, "func", VTYPE_Function);
}

AScript_ImplementMethod(Interp, command)
{
	Object_Interp *pSelf = Object_Interp::GetSelfObj(args);
	Tcl_Interp *interp = pSelf->GetInterp();
	Handler *pHandler = new Handler(Object_Interp::Reference(pSelf),
					Object_Function::Reference(args.GetFunctionObj(0)), sig);
	String cmdName = pSelf->NewCommandName();
	::Tcl_CreateCommand(interp, cmdName.c_str(), Object_Interp::CommandProc,
									pHandler, Object_Interp::CommandDeleteProc);
	return Value(env, cmdName.c_str());
}

// interp#timer()
AScript_DeclareMethod(Interp, timer)
{
	SetMode(RSLTMODE_Normal, FLAG_None);
}

AScript_ImplementMethod(Interp, timer)
{
	Object_Interp *pSelf = Object_Interp::GetSelfObj(args);
	Object_Interp *pObjInterp = Object_Interp::Reference(pSelf);
	Object_Timer *pObjTimer = new Object_Timer(pObjInterp);
	return Value(pObjTimer);
}


// implementation of class Interp
AScript_ImplementPrivClass(Interp)
{
	AScript_AssignMethod(Interp, eval);
	AScript_AssignMethod(Interp, evalscript);
	AScript_AssignMethod(Interp, variable);
	AScript_AssignMethod(Interp, command);
	AScript_AssignMethod(Interp, timer);
}

//-----------------------------------------------------------------------------
// Handler implementation
//-----------------------------------------------------------------------------
Handler::~Handler()
{
	Object::Delete(_pObjInterp);
	Object::Delete(_pObjFunc);
}

Value Handler::Eval(ValueList &valListArg)
{
	Function *pFunc = _pObjFunc->GetFunction();
	Environment &env = pFunc->GetEnvScope();
	Value result = _pObjFunc->Eval(env, _sig, valListArg);
	if (_sig.IsSignalled()) {
		_pObjInterp->ExitMainLoop();
		return Value::Null;
	}
	return result;
}

Value Handler::Eval(int argc, const char *argv[])
{
	Function *pFunc = _pObjFunc->GetFunction();
	Environment &env = pFunc->GetEnvScope();
	ValueList valListArg;
	//argc = ChooseMin(argc, static_cast<int>(pFunc->GetDeclList().size()));
	if (argc > 0) {
		valListArg.reserve(argc);
		for (int i = 0; i < argc; i++) {
			valListArg.push_back(Value(env, argv[i]));
		}
	}
	Value result = _pObjFunc->Eval(env, _sig, valListArg);
	if (_sig.IsSignalled()) {
		_pObjInterp->ExitMainLoop();
		return Value::Null;
	}
	return result;
}

//-----------------------------------------------------------------------------
// Object_Variable implementation
//-----------------------------------------------------------------------------
Object_Variable::Object_Variable(Object_Interp *pObjInterp, const char *varName) :
		Object(AScript_PrivClass(Variable)), _pObjInterp(pObjInterp), _varName(varName)
{
}

Object_Variable::~Object_Variable()
{
	Object::Delete(_pObjInterp);
}

Object *Object_Variable::Clone() const
{
	return new Object_Variable(Object_Interp::Reference(_pObjInterp), GetVarName());
}

String Object_Variable::ToString(Signal sig, bool exprFlag)
{
	String str;
	str += "<tcl.variable:";
	str += _varName;
	str += ">";
	return str;
}

Value Object_Variable::DoPropGet(Signal sig, const Symbol *pSymbol, bool &evaluatedFlag)
{
	Environment &env = *this;
	if (pSymbol->IsIdentical(AScript_Symbol(boolean))) {
		Value value = Get(env, sig);
		if (sig.IsSignalled()) return Value::Null;
		if (!value.IsBoolean()) {
			bool flag = value.GetBoolean();
			value = Value(flag);
		}
		evaluatedFlag = true;
		return value;
	} else if (pSymbol->IsIdentical(AScript_Symbol(string))) {
		Value value = Get(env, sig);
		if (sig.IsSignalled()) return Value::Null;
		if (!value.IsString()) {
			String str = value.ToString(sig, false);
			if (sig.IsSignalled()) return Value::Null;
			value = Value(env, str.c_str());
		}
		evaluatedFlag = true;
		return value;
	} else if (pSymbol->IsIdentical(AScript_Symbol(number))) {
		Value value = Get(env, sig);
		if (sig.IsSignalled()) return Value::Null;
		if (!value.IsNumber()) {
			bool successFlag;
			Number num = value.ToNumber(true, successFlag);
			value = Value(num);
		}
		evaluatedFlag = true;
		return value;
	}
	return Value::Null;
}

Value Object_Variable::DoPropSet(Signal sig, const Symbol *pSymbol,
									const Value &value, bool &evaluatedFlag)
{
	Environment &env = *this;
	if (pSymbol->IsIdentical(AScript_Symbol(boolean))) {
		Set(env, sig, value);
		if (sig.IsSignalled()) return Value::Null;
		evaluatedFlag = true;
		return value;
	} else if (pSymbol->IsIdentical(AScript_Symbol(string))) {
		Set(env, sig, value);
		if (sig.IsSignalled()) return Value::Null;
		evaluatedFlag = true;
		return value;
	} else if (pSymbol->IsIdentical(AScript_Symbol(number))) {
		Set(env, sig, value);
		if (sig.IsSignalled()) return Value::Null;
		evaluatedFlag = true;
		return value;
	}
	return Value::Null;
}

bool Object_Variable::Set(Environment &env, Signal sig, const Value &value)
{
	ValueList valList(Value(env, "set"), Value(env, GetVarName()), value);
	_pObjInterp->TclEval(env, sig, valList);
	return !sig.IsSignalled();
}

Value Object_Variable::Get(Environment &env, Signal sig)
{
	ValueList valList(Value(env, "set"), Value(env, GetVarName()));
	return _pObjInterp->TclEval(env, sig, valList);
}

//-----------------------------------------------------------------------------
// AScript interfaces for Object_Variable
//-----------------------------------------------------------------------------
// implementation of class Variable
AScript_ImplementPrivClass(Variable)
{
}

//-----------------------------------------------------------------------------
// Object_Timer implementation
//-----------------------------------------------------------------------------
Object_Timer::Object_Timer(Object_Interp *pObjInterp) :
		Object(AScript_PrivClass(Timer)), _pObjInterp(pObjInterp),
		_contFlag(false), _cnt(0), _idx(0), _msecCont(0)
{
}

Object_Timer::~Object_Timer()
{
	Object::Delete(_pObjInterp);
	::Tcl_DeleteTimerHandler(_token);
}

Object *Object_Timer::Clone() const
{
	return NULL;
}

String Object_Timer::ToString(Signal sig, bool exprFlag)
{
	String str;
	str += "<tcl.timer:";
	str += ">";
	return str;
}

void Object_Timer::Start(Signal sig, const Function *pFunc,
									int msec, int msecCont, int cnt)
{
	Environment &env = *this;
	_contFlag = true;
	_cnt = cnt, _idx = 0;
	_msecCont = msecCont;
	if (_cnt == 0) return;
	Object::Reference(this);
	_token = ::Tcl_CreateTimerHandler(msec, TimerProcStub, this);
	Object_Function *pObjFunc = new Object_Function(env,
									Function::Reference(pFunc), Value::Null);
	_pHandler.reset(new Handler(Object_Interp::Reference(_pObjInterp), pObjFunc, sig));
}

void Object_Timer::Cancel()
{
	::Tcl_DeleteTimerHandler(_token);
	_contFlag = false;
}

bool Object_Timer::TimerProc()
{
	ValueList valListArg;
	valListArg.reserve(1);
	valListArg.push_back(Value(this, false));
	_pHandler->Eval(valListArg);
	_idx++;
	if (_contFlag && _idx != _cnt) {
		_token = ::Tcl_CreateTimerHandler(_msecCont, TimerProcStub, this);
		return true;
	}
	_contFlag = false;
	return false;
}

void Object_Timer::TimerProcStub(ClientData clientData)
{
	Object_Timer *pObjTimer =
						reinterpret_cast<Object_Timer *>(clientData);
	if (!pObjTimer->TimerProc()) {
		Object::Delete(pObjTimer);
	}
}

//-----------------------------------------------------------------------------
// AScript interfaces for Object_Timer
//-----------------------------------------------------------------------------
// timer#start(msec:number, msecCont?:number, count?:number):reduce {block}
AScript_DeclareMethod(Timer, start)
{
	SetMode(RSLTMODE_Reduce, FLAG_None);
	DeclareArg(env, "msec", VTYPE_Number);
	DeclareArg(env, "msecCont", VTYPE_Number, OCCUR_ZeroOrOnce);
	DeclareArg(env, "count", VTYPE_Number, OCCUR_ZeroOrOnce);
	DeclareBlock(OCCUR_Once);
}

AScript_ImplementMethod(Timer, start)
{
	Object_Timer *pSelf = Object_Timer::GetSelfObj(args);
	const Function *pFuncBlock =
					args.GetBlockFunc(env, sig, GetSymbolForBlock());
	int msec = args.GetInt(0);
	int msecCont = args.IsNumber(1)? args.GetInt(1) : msec;
	int cnt = args.IsNumber(2)? args.GetInt(2) : -1;
	pSelf->Start(sig, pFuncBlock, msec, msecCont, cnt);
	return args.GetSelf();
}

// timer#cancel()
AScript_DeclareMethod(Timer, cancel)
{
	SetMode(RSLTMODE_Normal, FLAG_None);
}

AScript_ImplementMethod(Timer, cancel)
{
	Object_Timer *pSelf = Object_Timer::GetSelfObj(args);
	pSelf->Cancel();
	Object::Delete(pSelf);
	return Value::Null;
}

// implementation of class Timer
AScript_ImplementPrivClass(Timer)
{
	AScript_AssignMethod(Timer, start);
	AScript_AssignMethod(Timer, cancel);
}

//-----------------------------------------------------------------------------
// AScript interfaces for Object_Image
//-----------------------------------------------------------------------------
// image#readtcl(interp:interp, imageName:string):reduce
AScript_DeclareMethod(Image, readtcl)
{
	SetMode(RSLTMODE_Reduce, FLAG_None);
	DeclareArg(env, "interp", AScript_PrivVTYPE(Interp));
	DeclareArg(env, "imageName", VTYPE_String);
	SetHelp("Reads an image data from TCL image object.");
}

AScript_ImplementMethod(Image, readtcl)
{
	Object_Image *pSelf = Object_Image::GetSelfObj(args);
	if (!pSelf->CheckEmpty(sig)) return Value::Null;
	Object_Interp *pObjInterp = reinterpret_cast<Object_Interp *>(args.GetObject(0));
	Tcl_Interp *interp = pObjInterp->GetInterp();
	const char *imageName = args.GetString(1);
	Tk_PhotoHandle handle = ::Tk_FindPhoto(interp, imageName);
	if (handle == NULL) {
		sig.SetError(ERR_ValueError, "invalid image name %s", imageName);
		return Value::Null;
	}
	int width, height;
	::Tk_PhotoGetSize(handle, &width, &height);
	if (!pSelf->AllocBuffer(sig, width, height, 0xff)) return Value::Null;
	Tk_PhotoImageBlock photoImageBlock;
	photoImageBlock.pixelPtr = reinterpret_cast<unsigned char *>(pSelf->GetBuffer());
	photoImageBlock.width = width;
	photoImageBlock.height = height;
	photoImageBlock.pitch = static_cast<int>(pSelf->GetBytesPerLine());
	photoImageBlock.pixelSize = static_cast<int>(pSelf->GetBytesPerPixel());
	photoImageBlock.offset[0] = Object_Image::OffsetRed;
	photoImageBlock.offset[1] = Object_Image::OffsetGreen;
	photoImageBlock.offset[2] = Object_Image::OffsetBlue;
	photoImageBlock.offset[3] = Object_Image::OffsetAlpha;
	::Tk_PhotoGetImage(handle, &photoImageBlock);
	return args.GetSelf();
}

// image#writetcl(interp:interp, imageName:string):reduce
AScript_DeclareMethod(Image, writetcl)
{
	SetMode(RSLTMODE_Reduce, FLAG_None);
	DeclareArg(env, "interp", AScript_PrivVTYPE(Interp));
	DeclareArg(env, "imageName", VTYPE_String);
	SetHelp("Writes an image data to TCL image object.");
}

AScript_ImplementMethod(Image, writetcl)
{
	Object_Image *pSelf = Object_Image::GetSelfObj(args);
	if (!pSelf->CheckValid(sig)) return Value::Null;
	Object_Interp *pObjInterp = reinterpret_cast<Object_Interp *>(args.GetObject(0));
	Tcl_Interp *interp = pObjInterp->GetInterp();
	const char *imageName = args.GetString(1);
	Tk_PhotoHandle handle = ::Tk_FindPhoto(interp, imageName);
	if (handle == NULL) {
		sig.SetError(ERR_ValueError, "invalid image name %s", imageName);
		return Value::Null;
	}
	int width = static_cast<int>(pSelf->GetWidth());
	int height = static_cast<int>(pSelf->GetHeight());
	Tk_PhotoImageBlock photoImageBlock;
	photoImageBlock.pixelPtr = reinterpret_cast<unsigned char *>(pSelf->GetBuffer());
	photoImageBlock.width = width;
	photoImageBlock.height = height;
	photoImageBlock.pitch = static_cast<int>(pSelf->GetBytesPerLine());
	photoImageBlock.pixelSize = static_cast<int>(pSelf->GetBytesPerPixel());
	photoImageBlock.offset[0] = Object_Image::OffsetRed;
	photoImageBlock.offset[1] = Object_Image::OffsetGreen;
	photoImageBlock.offset[2] = Object_Image::OffsetBlue;
	photoImageBlock.offset[3] = Object_Image::OffsetAlpha;
	::Tk_PhotoPutBlock(interp, handle, &photoImageBlock,
							0, 0, width, height, TK_PHOTO_COMPOSITE_SET);
	return args.GetSelf();
}

//-----------------------------------------------------------------------------
// AScript module functions: tcl
//-----------------------------------------------------------------------------
// tcl.interp()
AScript_DeclareFunction(interp)
{
	SetMode(RSLTMODE_Normal, FLAG_None);
}

AScript_ImplementFunction(interp)
{
	Tcl_Interp *interp = ::Tcl_CreateInterp();
	if (::Tcl_Init(interp) != TCL_OK) {
		sig.SetError(ERR_RuntimeError, "%s\n", ::Tcl_GetStringResult(interp));
		::Tcl_DeleteInterp(interp);
		return Value::Null;
	}
	if (::Tk_Init(interp) != TCL_OK) {
		sig.SetError(ERR_RuntimeError, "%s\n", ::Tcl_GetStringResult(interp));
		::Tcl_DeleteInterp(interp);
		return Value::Null;
	}
	return Value(new Object_Interp(interp));
}

// tcl.Tk_MainLoop()
AScript_DeclareFunction(Tk_MainLoop)
{
	SetMode(RSLTMODE_Normal, FLAG_None);
}

AScript_ImplementFunction(Tk_MainLoop)
{
	if (::setjmp(g_jmpenv)) return Value::Null;
	::Tk_MainLoop();
	return Value::Null;
}

// Module entry
AScript_ModuleEntry()
{
	// symbol realization
	AScript_RealizePrivSymbol(__tclname__);
	// class realization
	AScript_RealizePrivClass(Interp, "interp", env.LookupClass(VTYPE_Object));
	AScript_RealizePrivClass(Variable, "variable", env.LookupClass(VTYPE_Object));
	AScript_RealizePrivClass(Timer, "timer", env.LookupClass(VTYPE_Object));
	// function assignment
	AScript_AssignFunction(interp);
	AScript_AssignFunction(Tk_MainLoop);
	// method assignment to image class
	AScript_AssignMethodTo(VTYPE_Image, Image, readtcl);
	AScript_AssignMethodTo(VTYPE_Image, Image, writetcl);
}

AScript_ModuleTerminate()
{
}

AScript_EndModule(tcl, tcl)

AScript_RegisterModule(tcl)
