--- 8Kingdoms-1.1.0/common/TCL/tcl_script.cpp 2007-07-22 03:32:50.000000000 +0200
+++ 8Kingdoms-1.1.0.new/common/TCL/tcl_script.cpp 2008-01-08 14:33:59.000000000 +0100
@@ -12,34 +12,96 @@
#include "common/TCL/tcl_struct.h"
#include "world/useful.h"
#include "world/typedefs.h"
+#include "world/rules.h"
using namespace std;
+/* We can get called from multiple threads, protected against reentrance
+ through locks. But locks are not enough. Tcl is thread aware and does not
+ allow an interpreter to be called from another thread then it is created.
+ With Tcl-8.4 things work even when violating this Tcl thread model rule, but
+ thats pure luck on our side.
+
+ However with Tcl-8.5 calling an interpreter from another thread then it is
+ created really no longer works. Under pthread using OS we solve this by
+ using a per thread variable for the interpreter and creating an interpreter
+ for each thread. Under non pthread OS we keep relying on our luck, so
+ Tcl-8.5 may not be used there! */
+
+#ifdef __unix__
+/* interpreter destructor for the per thread interpreter */
+static void interpreter_destructor(void *_interpreter)
+{
+ Tcl_DeleteInterp((Tcl_Interp *)_interpreter);
+}
+#endif
+
TTCL_Interpreter::TTCL_Interpreter()
{
- _interpreter = Tcl_CreateInterp();
+#ifdef __unix__
+ pthread_key_create(&_interpreter_key, interpreter_destructor);
+ _rules = NULL;
+#else
+ _interpreter = Tcl_CreateInterp();
+#endif
}
TTCL_Interpreter::~TTCL_Interpreter()
{
+#ifdef __unix__
+ pthread_key_delete(_interpreter_key);
+#else
Tcl_DeleteInterp(_interpreter);
//KMemFree(_interpreter);
+#endif
+}
+
+Tcl_Interp *TTCL_Interpreter::getInterpreter()
+{
+#ifdef __unix__
+ Tcl_Interp *_interpreter =
+ (Tcl_Interp *)pthread_getspecific(_interpreter_key);
+
+ if (!_interpreter)
+ {
+ _interpreter = Tcl_CreateInterp();
+ pthread_setspecific(_interpreter_key, _interpreter);
+
+ if (_rules)
+ {
+ _rules->writeToTCL(*this);
+ Tcl_CreateCommand(_interpreter, "KSendMessage", _TCLSendMessageProc,
+ NULL, NULL);
+ TTCL_Script script(this);
+ script.loadStruct(_init_script);
+ script.run();
+ }
+ }
+#endif
+ return _interpreter;
}
-void TTCL_Interpreter::init(TCL_SCRIPT * init_script)
+void TTCL_Interpreter::init(World::TRules * rules,
+ Tcl_CmdProc * TCLSendMessageProc, TCL_SCRIPT * init_script)
{
+#ifdef __unix__
+ _rules = rules;
+ _TCLSendMessageProc = TCLSendMessageProc;
+ _init_script = init_script;
+#else
+ rules->writeToTCL(*this);
+ Tcl_CreateCommand(getInterpreter(), "KSendMessage", TCLSendMessageProc,
+ NULL, NULL);
TTCL_Script script(this);
script.loadStruct(init_script);
script.run();
+#endif
}
bool TTCL_Interpreter::setVar(const char * name, const TCL_VAR_TYPE type, void * value)
{
- if (_interpreter == NULL)
- THROW(E_8K_TCL_Error, "TCL interpreter has not been initialized properly");
-
// odstraneni predchoziho vyskytu promenne
- Tcl_UnsetVar(_interpreter, name, 0);
+ Tcl_UnsetVar(getInterpreter(), name, 0);
// nastaveni nove hodnoty
bool result;
@@ -48,7 +110,7 @@
switch (type) {
case TVT_STRING:
// STRING
- result = (Tcl_SetVar(_interpreter, name, (const char *)value, 0) != NULL);
+ result = (Tcl_SetVar(getInterpreter(), name, (const char *)value, 0) != NULL);
break;
case TVT_INT:
// INT
@@ -56,7 +118,7 @@
snprintf(s, 255, "%d", *(int *)value);
// ulozim cislo do TCL
- result = (Tcl_SetVar(_interpreter, name, s, 0) != NULL);
+ result = (Tcl_SetVar(getInterpreter(), name, s, 0) != NULL);
break;
case TVT_FLOAT:
// FLOAT
@@ -64,7 +126,7 @@
snprintf(s, 255, "%f", *(float *)value);
// ulozim cislo do TCL
- result = (Tcl_SetVar(_interpreter, name, s, 0) != NULL);
+ result = (Tcl_SetVar(getInterpreter(), name, s, 0) != NULL);
break;
case TVT_FLOAT_LIST:
{
@@ -153,11 +215,8 @@
bool TTCL_Interpreter::getVar(const char * name, const TCL_VAR_TYPE type, void * value)
{
- if (_interpreter == NULL)
- THROW(E_8K_TCL_Error, "TCL interpreter has not been initialized properly");
-
// nacteni objektu z TCL
- Tcl_Obj * tcl_obj = Tcl_GetVar2Ex(_interpreter, name, NULL, TCL_LEAVE_ERR_MSG);
+ Tcl_Obj * tcl_obj = Tcl_GetVar2Ex(getInterpreter(), name, NULL, TCL_LEAVE_ERR_MSG);
// promennou se nepodarilo nacist (a pritom to nebylo asociativni pole)
if ((tcl_obj == NULL) && (type != TVT_INT_ARRAY) && (type != TVT_FLOAT_ARRAY) && (type != TVT_STRING_ARRAY)) {
@@ -173,14 +232,14 @@
return true;
break;
case TVT_INT:
- if (Tcl_GetIntFromObj(_interpreter, tcl_obj, (int *)value) == TCL_OK)
+ if (Tcl_GetIntFromObj(getInterpreter(), tcl_obj, (int *)value) == TCL_OK)
return true;
else
return false;
break;
case TVT_FLOAT:
double _value;
- if (Tcl_GetDoubleFromObj(_interpreter, tcl_obj, &_value) == TCL_OK) {
+ if (Tcl_GetDoubleFromObj(getInterpreter(), tcl_obj, &_value) == TCL_OK) {
// pretypovani na float
*(float *)value = (float)_value;
return true;
@@ -415,7 +474,7 @@
char s[MAX_STRLEN];
snprintf(s, MAX_STRLEN, "%d", value);
- return (Tcl_SetVar(_interpreter, name, s, 0) != NULL);
+ return (Tcl_SetVar(getInterpreter(), name, s, 0) != NULL);
}
bool TTCL_Interpreter::setConstDouble(const char * name, const double value)
@@ -423,29 +482,21 @@
char s[MAX_STRLEN];
snprintf(s, MAX_STRLEN, "%.2f", value);
- return (Tcl_SetVar(_interpreter, name, s, 0) != NULL);
+ return (Tcl_SetVar(getInterpreter(), name, s, 0) != NULL);
}
int TTCL_Interpreter::eval(const char * code)
{
- if (_interpreter == NULL)
- THROW(E_8K_TCL_Error, "TCL interpreter has not been initialized properly");
-
- int result = Tcl_Eval(_interpreter, code);
+ int result = Tcl_Eval(getInterpreter(), code);
if (result == TCL_ERROR) {
- THROW(E_8K_TCL_Error, Tcl_GetStringResult(_interpreter));
+ THROW(E_8K_TCL_Error, Tcl_GetStringResult(getInterpreter()));
}
return result;
}
const char * TTCL_Interpreter::getError()
{
- return Tcl_GetStringResult(_interpreter);
-}
-
-Tcl_Command TTCL_Interpreter::createCommand(const char * tclName, Tcl_CmdProc * cName, ClientData clientData, Tcl_CmdDeleteProc * deleteProc)
-{
- return Tcl_CreateCommand(_interpreter, tclName, cName, clientData, deleteProc);
+ return Tcl_GetStringResult(getInterpreter());
}
void TTCL_Interpreter::setResult(TCL_VAR_TYPE type, void * value)
@@ -455,21 +506,21 @@
switch (type) {
case TVT_STRING:
// STRING
- Tcl_SetResult(_interpreter, (char *)value, NULL);
+ Tcl_SetResult(getInterpreter(), (char *)value, NULL);
break;
case TVT_INT:
// INT
// prevedu cislo na string
snprintf(s, MAX_STRLEN, "%d", *(int *)value);
- Tcl_SetResult(_interpreter, s, NULL);
+ Tcl_SetResult(getInterpreter(), s, NULL);
break;
case TVT_FLOAT:
// FLOAT
// prevedu cislo na string
snprintf(s, MAX_STRLEN, "%f", *(float *)value);
- Tcl_SetResult(_interpreter, s, NULL);
+ Tcl_SetResult(getInterpreter(), s, NULL);
break;
default:
THROW(E_8K_TCL_UnknownType, "");
--- 8Kingdoms-1.1.0/common/TCL/tcl_script.h 2007-07-22 03:32:50.000000000 +0200
+++ 8Kingdoms-1.1.0.new/common/TCL/tcl_script.h 2008-01-08 14:30:55.000000000 +0100
@@ -9,6 +9,9 @@
#include <map>
#include <tcl.h>
+#ifdef __unix__
+#include <pthread.h>
+#endif
#include "common/TCL/tcl_var.h"
/// pocet desetinnych mist, pouzitych pri konverzi cisel do TCL
@@ -172,6 +175,11 @@
char * code;
};
+namespace World
+{
+ class TRules;
+};
+
/** Interpret skriptu jazyka TCL
Objektovy "obal" puvodnich TCL struktur.
@@ -184,16 +192,26 @@
class TTCL_Interpreter
{
private:
+#ifdef __unix__
+ pthread_key_t _interpreter_key;
+ TCL_SCRIPT * _init_script;
+ Tcl_CmdProc * _TCLSendMessageProc;
+ World::TRules * _rules;
+#else
Tcl_Interp * _interpreter;
+#endif
+ Tcl_Interp *getInterpreter();
+
public:
TTCL_Interpreter();
~TTCL_Interpreter();
-
+
/** Inicializace prostredi TCL interpreteru.
Nastaveni globalnich promennych, inkluze knihoven a definice spolecnych
funkci.
*/
- void init(TCL_SCRIPT * init_script);
+ void init(World::TRules * rules, Tcl_CmdProc * TCLSendMessageProc,
+ TCL_SCRIPT * init_script);
/** Ulozeni promenne do prostredi TCL interpretu
@param name jmeno promenne
@@ -256,15 +274,6 @@
*/
const char * getError();
- /** Nastaveni uzivatelske funkce.
- Umozni asociovat volani funkce z TCL s funkci v C
- @param tclName jmeno funkce v TCL, jejiz volani chceme obsluhovat sami
- @param cName funkce z C, ktera bude realizovat telo funkce z TCL
- @param clientData arbitrary one-word value to pass to proc and deleteProc.
- @param deleteProc procedure to call before cmdName is deleted from the interpreter; allows for command-specific cleanup. If NULL, then no procedure is called before the command is deleted.
- */
- Tcl_Command createCommand(const char * tclName, Tcl_CmdProc * cName, ClientData clientData = NULL, Tcl_CmdDeleteProc * deleteProc = NULL);
-
/// Nastaveni navratove hodnoty funkce
void setResult(TCL_VAR_TYPE type, void * value);
};
--- 8Kingdoms-1.1.0/world/world_client.cpp 2008-01-08 14:39:20.000000000 +0100
+++ 8Kingdoms-1.1.0.new/world/world_client.cpp 2008-01-08 14:37:05.000000000 +0100
@@ -107,13 +107,7 @@
world->init();
// inicializace negine
- engine->init(world);
-
- // registrace zprav z TCL
- engine->interpreter.createCommand("KSendMessage", (Tcl_CmdProc *)World::WorldClient_SendMessage);
-
- // inkluze knihoven pro TCL (spusteni inicializacniho skriptu)
- engine->interpreter.init(world->rules->scripts[TS_INIT]);
+ engine->init(world, (Tcl_CmdProc *)World::WorldClient_SendMessage);
}
// svet je pripraven
--- 8Kingdoms-1.1.0/world/world_engine.cpp 2008-01-08 14:39:21.000000000 +0100
+++ 8Kingdoms-1.1.0.new/world/world_engine.cpp 2008-01-08 14:38:37.000000000 +0100
@@ -30,11 +29,10 @@
}
-void TWorldEngine::init(TWorld * world)
+void TWorldEngine::init(TWorld * world, Tcl_CmdProc *TCLSendMessageProc)
{
- // zapis pravidel do prostredi TCL interpreteru
- if (world->rules)
- world->rules->writeToTCL(interpreter);
+ interpreter.init(world->rules, TCLSendMessageProc,
+ world->rules->scripts[TS_INIT]);
}
int TWorldEngine::lock()
--- 8Kingdoms-1.1.0/world/world_engine.h 2007-07-22 03:33:12.000000000 +0200
+++ 8Kingdoms-1.1.0.new/world/world_engine.h 2008-01-08 13:44:32.000000000 +0100
@@ -45,7 +45,7 @@
~TWorldEngine();
/** Inicializace */
- void init(TWorld * world);
+ void init(TWorld * world, Tcl_CmdProc *TCLSendMessageProc);
/// Zamceni mutexu
int lock();
--- 8Kingdoms-1.1.0/world/world_server.cpp 2008-01-08 14:39:20.000000000 +0100
+++ 8Kingdoms-1.1.0.new/world/world_server.cpp 2008-01-08 14:36:44.000000000 +0100
@@ -87,13 +87,7 @@
world.init();
// inicializace world_engine
- engine.init(&world);
-
- // registrace zprav z TCL
- engine.interpreter.createCommand("KSendMessage", (Tcl_CmdProc *)WorldServer_SendMessage);
-
- // inkluze knihoven pro TCL (spusteni inicializacniho skriptu)
- engine.interpreter.init(world.rules->scripts[TS_INIT]);
+ engine.init(&world, (Tcl_CmdProc *)WorldServer_SendMessage);
}
void TWorldServer::shutdown()
--- 8Kingdoms-1.1.0/8Kingdoms.cpp~ 2008-01-08 20:31:01.000000000 +0100
+++ 8Kingdoms-1.1.0/8Kingdoms.cpp 2008-01-08 20:31:01.000000000 +0100
@@ -25,6 +25,7 @@
//rozhrani
#include <sstream>
+#include <tcl.h>
#include "common/Interface.h"
#include "common/Msg.h"
@@ -470,6 +471,8 @@ void print_help(){
*/
int main(int argc, char** argv){
+ Tcl_FindExecutable(argv[0]);
+
try{
//parametry z prikazoveho radku
TCommandLine::parseCommandLine(argc, argv);