1 files changed, 656 insertions, 0 deletions
diff --git a/Plugins/ScriptingTcl/scriptingtcl.cpp b/Plugins/ScriptingTcl/scriptingtcl.cpp
new file mode 100644
index 0000000..5709808
--- /dev/null
+++ b/Plugins/ScriptingTcl/scriptingtcl.cpp
@@ -0,0 +1,656 @@
+#include "scriptingtcl.h"
+#include "common/global.h"
+#include "common/unused.h"
+#include "db/db.h"
+#include "parser/lexer.h"
+#include "parser/token.h"
+#include "common/utils_sql.h"
+#include <QDebug>
+#include <QMutexLocker>
+
+ScriptingTcl::ScriptingTcl()
+{
+    mainInterpMutex = new QMutex();
+}
+
+ScriptingTcl::~ScriptingTcl()
+{
+    safe_delete(mainInterpMutex);
+}
+
+bool ScriptingTcl::init()
+{
+    Q_INIT_RESOURCE(scriptingtcl);
+    QMutexLocker locker(mainInterpMutex);
+    mainContext = new ContextTcl();
+    return true;
+}
+
+void ScriptingTcl::deinit()
+{
+    QMutexLocker locker(mainInterpMutex);
+    safe_delete(mainContext);
+    Tcl_Finalize();
+    Q_CLEANUP_RESOURCE(scriptingtcl);
+}
+
+QString ScriptingTcl::getLanguage() const
+{
+    return "Tcl";
+}
+
+ScriptingPlugin::Context* ScriptingTcl::createContext()
+{
+    ContextTcl* ctx = new ContextTcl();
+    contexts << ctx;
+    return ctx;
+}
+
+void ScriptingTcl::releaseContext(ScriptingPlugin::Context* context)
+{
+    ContextTcl* ctx = getContext(context);
+    if (!ctx)
+        return;
+
+    contexts.removeOne(ctx);
+    delete ctx;
+}
+
+void ScriptingTcl::resetContext(ScriptingPlugin::Context* context)
+{
+    ContextTcl* ctx = getContext(context);
+    if (!ctx)
+        return;
+
+    ctx->reset();
+}
+
+void ScriptingTcl::setVariable(ScriptingPlugin::Context* context, const QString& name, const QVariant& value)
+{
+    ContextTcl* ctx = getContext(context);
+    if (!ctx)
+        return;
+
+    setVariable(ctx->interp, name, value);
+}
+
+QVariant ScriptingTcl::getVariable(ScriptingPlugin::Context* context, const QString& name)
+{
+    ContextTcl* ctx = getContext(context);
+    if (!ctx)
+        return QVariant();
+
+    return getVariable(ctx->interp, name);
+}
+
+bool ScriptingTcl::hasError(ScriptingPlugin::Context* context) const
+{
+    ContextTcl* ctx = getContext(context);
+    if (!ctx)
+        return false;
+
+    return !ctx->error.isEmpty();
+}
+
+QString ScriptingTcl::getErrorMessage(ScriptingPlugin::Context* context) const
+{
+    ContextTcl* ctx = getContext(context);
+    if (!ctx)
+        return QString();
+
+    return ctx->error;
+}
+
+QString ScriptingTcl::getIconPath() const
+{
+    return ":/scriptingtcl/scriptingtcl.png";
+}
+
+QVariant ScriptingTcl::evaluate(ScriptingPlugin::Context* context, const QString& code, const QList<QVariant>& args, Db* db, bool locking)
+{
+    ContextTcl* ctx = getContext(context);
+    if (!ctx)
+        return QVariant();
+
+    setArgs(ctx, args);
+    return compileAndEval(ctx, code, db, locking);
+}
+
+QVariant ScriptingTcl::evaluate(const QString& code, const QList<QVariant>& args, Db* db, bool locking, QString* errorMessage)
+{
+    QMutexLocker locker(mainInterpMutex);
+    setArgs(mainContext, args);
+    QVariant results = compileAndEval(mainContext, code, db, locking);
+
+    if (errorMessage && !mainContext->error.isEmpty())
+        *errorMessage = mainContext->error;
+
+    return results;
+}
+
+ScriptingTcl::ContextTcl* ScriptingTcl::getContext(ScriptingPlugin::Context* context) const
+{
+    ContextTcl* ctx = dynamic_cast<ContextTcl*>(context);
+    if (!ctx)
+        qDebug() << "Invalid context passed to ScriptingTcl:" << context;
+
+    return ctx;
+}
+
+QVariant ScriptingTcl::compileAndEval(ScriptingTcl::ContextTcl* ctx, const QString& code, Db* db, bool locking)
+{
+    ScriptObject* scriptObj = nullptr;
+    if (!ctx->scriptCache.contains(code))
+    {
+        scriptObj = new ScriptObject(code);
+        ctx->scriptCache.insert(code, scriptObj);
+    }
+    else
+    {
+        scriptObj = ctx->scriptCache[code];
+    }
+    Tcl_ResetResult(ctx->interp);
+    ctx->error.clear();
+
+    ctx->db = db;
+    ctx->useDbLocking = locking;
+
+    int result = Tcl_EvalObjEx(ctx->interp, scriptObj->getTclObj(), TCL_EVAL_GLOBAL);
+
+    ctx->db = nullptr;
+    ctx->useDbLocking = false;
+
+    if (result != TCL_OK)
+    {
+        ctx->error = QString::fromUtf8(Tcl_GetStringResult(ctx->interp));
+        return QVariant();
+    }
+    return extractResult(ctx);
+}
+
+QVariant ScriptingTcl::extractResult(ScriptingTcl::ContextTcl* ctx)
+{
+    Tcl_Obj* obj = Tcl_GetObjResult(ctx->interp);
+    return tclObjToVariant(obj);
+}
+
+void ScriptingTcl::setArgs(ScriptingTcl::ContextTcl* ctx, const QList<QVariant>& args)
+{
+    setVariable(ctx, "argc", args.size());
+    setVariable(ctx, "argv", args);
+}
+
+Tcl_Obj* ScriptingTcl::argsToList(const QList<QVariant>& args)
+{
+    Tcl_Obj** objArray = new Tcl_Obj*[args.size()];
+
+    int i = 0;
+    for (const QVariant& arg : args)
+        objArray[i++] = variantToTclObj(arg);
+
+    Tcl_Obj* obj = Tcl_NewListObj(args.size(), objArray);
+    delete[] objArray;
+
+    return obj;
+}
+
+QVariant ScriptingTcl::tclObjToVariant(Tcl_Obj* obj)
+{
+    static const QStringList typeLiterals = {"boolean", "booleanString", "double", "int", "wideInt", "bignum", "bytearray", "string", "list", "dict"};
+
+    TclDataType type = TclDataType::UNKNOWN;
+    if (obj->typePtr)
+    {
+        int typeIdx = typeLiterals.indexOf(obj->typePtr->name);
+        if (typeIdx > -1)
+            type = static_cast<TclDataType>(typeIdx);
+    }
+
+    QVariant result;
+    bool ok = true;
+    switch (type)
+    {
+        case TclDataType::Boolean:
+        case TclDataType::BooleanString:
+        {
+            int b;
+            if (Tcl_GetBooleanFromObj(nullptr, obj, &b) == TCL_OK)
+                result = (bool)b;
+            else
+                ok = false;
+
+            break;
+        }
+        case TclDataType::Double:
+        {
+            double d;
+            if (Tcl_GetDoubleFromObj(nullptr, obj, &d) == TCL_OK)
+                result = d;
+            else
+                ok = false;
+
+            break;
+        }
+        case TclDataType::Int:
+        {
+            int i;
+            if (Tcl_GetIntFromObj(nullptr, obj, &i) == TCL_OK)
+                result = i;
+            else
+                ok = false;
+
+            break;
+        }
+        case TclDataType::WideInt:
+        {
+            Tcl_WideInt wideInt;
+            if (Tcl_GetWideIntFromObj(nullptr, obj, &wideInt) == TCL_OK)
+                result = (qint64)wideInt;
+            else
+                ok = false;
+
+            break;
+        }
+        case TclDataType::Bytearray:
+        {
+            int lgt;
+            unsigned char* bytes = Tcl_GetByteArrayFromObj(obj, &lgt);
+            result = QByteArray::fromRawData(reinterpret_cast<char*>(bytes), lgt);
+            break;
+        }
+        case TclDataType::List:
+        {
+            QList<QVariant> list;
+            int objc;
+            Tcl_Obj** objv = nullptr;
+            Tcl_ListObjGetElements(nullptr, obj, &objc, &objv);
+            for (int i = 0; i < objc; i++)
+                list << tclObjToVariant(objv[i]);
+
+            result = list;
+            break;
+        }
+        case TclDataType::Dict:
+        {
+            Tcl_DictSearch search;
+            Tcl_Obj* key = nullptr;
+            Tcl_Obj* value = nullptr;
+            QString keyStr;
+            QVariant valueVariant;
+            int done;
+            QHash<QString,QVariant> hash;
+            if (Tcl_DictObjFirst(nullptr, obj, &search, &key, &value, &done) == TCL_OK)
+            {
+                for (; !done ; Tcl_DictObjNext(&search, &key, &value, &done))
+                {
+                    keyStr = QString::fromUtf8(Tcl_GetStringFromObj(key, nullptr));
+                    valueVariant = tclObjToVariant(value);
+                    hash[keyStr] = valueVariant;
+                }
+                Tcl_DictObjDone(&search);
+            }
+            result = hash;
+        }
+        case TclDataType::Bignum:
+        case TclDataType::String:
+        case TclDataType::UNKNOWN:
+        default:
+            result = tclObjToString(obj);
+            break;
+    }
+
+    if (!ok)
+        result = tclObjToString(obj);
+
+    return result;
+}
+
+QString ScriptingTcl::tclObjToString(Tcl_Obj* obj)
+{
+    return QString::fromUtf8(Tcl_GetStringFromObj(obj, nullptr));
+}
+
+Tcl_Obj* ScriptingTcl::variantToTclObj(const QVariant& value)
+{
+    Tcl_Obj* obj = nullptr;
+    switch (value.type())
+    {
+        case QVariant::Bool:
+            obj = Tcl_NewBooleanObj(value.toBool());
+            break;
+        case QVariant::Int:
+        case QVariant::UInt:
+            obj = Tcl_NewIntObj(value.toInt());
+            break;
+        case QVariant::LongLong:
+        case QVariant::ULongLong:
+            obj = Tcl_NewWideIntObj((Tcl_WideInt)value.toLongLong());
+            break;
+        case QVariant::Double:
+            obj = Tcl_NewDoubleObj(value.toDouble());
+            break;
+        case QVariant::ByteArray:
+        {
+            QByteArray bytes = value.toByteArray();
+            unsigned char* ubytes = reinterpret_cast<unsigned char*>(bytes.data());
+            obj = Tcl_NewByteArrayObj(ubytes, bytes.size());
+            break;
+        }
+        case QVariant::List:
+        {
+            QList<QVariant> list = value.toList();
+            int listSize = list.size();
+            Tcl_Obj** objList = new Tcl_Obj*[listSize];
+            for (int i = 0; i < listSize; ++i)
+                objList[i] = variantToTclObj(list[i]);
+
+            obj = Tcl_NewListObj(listSize, objList);
+            delete[] objList;
+            break;
+        }
+        case QVariant::StringList:
+        {
+            QStringList list = value.toStringList();
+            int listSize = list.size();
+            Tcl_Obj** objList = new Tcl_Obj*[listSize];
+            for (int i = 0; i < listSize; ++i)
+                objList[i] = stringToTclObj(list[i]);
+
+            obj = Tcl_NewListObj(listSize, objList);
+            delete[] objList;
+            break;
+        }
+        case QVariant::Hash:
+        {
+            QHash<QString, QVariant> hash = value.toHash();
+            obj = Tcl_NewDictObj();
+            QHashIterator<QString, QVariant> it(hash);
+            while (it.hasNext())
+            {
+                it.next();
+                Tcl_DictObjPut(nullptr, obj, variantToTclObj(it.key()), variantToTclObj(it.value()));
+            }
+            break;
+        }
+        case QVariant::Map:
+        {
+            QMap<QString, QVariant> map = value.toMap();
+            obj = Tcl_NewDictObj();
+            QMapIterator<QString, QVariant> it(map);
+            while (it.hasNext())
+            {
+                it.next();
+                Tcl_DictObjPut(nullptr, obj, variantToTclObj(it.key()), variantToTclObj(it.value()));
+            }
+            break;
+        }
+        case QVariant::String:
+        default:
+            obj = stringToTclObj(value.toString());
+            break;
+    }
+
+    if (!obj)
+        obj = stringToTclObj(value.toString());
+
+    return obj;
+}
+
+Tcl_Obj* ScriptingTcl::stringToTclObj(const QString& value)
+{
+    return Tcl_NewStringObj(value.toUtf8().constData(), -1);
+}
+
+int ScriptingTcl::dbCommand(ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* const objv[])
+{
+    ContextTcl* ctx = reinterpret_cast<ContextTcl*>(clientData);
+
+    Tcl_Obj* result = nullptr;
+    if (!ctx->db)
+    {
+        result = Tcl_NewStringObj(tr("No database available in current context, while called Tcl's 'db' command.").toUtf8().constData(), -1);
+        Tcl_SetObjResult(interp, result);
+        return TCL_ERROR;
+    }
+
+    if (strcmp(Tcl_GetStringFromObj(objv[1], nullptr), "eval") == 0)
+    {
+        if (objc == 3)
+            return dbEval(ctx, interp, objv);
+        else if (objc == 5) {
+            return dbEvalRowByRow(ctx, interp, objv);
+        }
+    }
+    else if (strcmp(Tcl_GetStringFromObj(objv[1], nullptr), "rows") == 0 && objc == 3)
+    {
+        return dbEvalDeepResults(ctx, interp, objv);
+    }
+    else if (strcmp(Tcl_GetStringFromObj(objv[1], nullptr), "onecolumn") == 0 && objc == 3)
+    {
+        return dbEvalOneColumn(ctx, interp, objv);
+    }
+
+    result = Tcl_NewStringObj(tr("Invalid 'db' command sytax. Should be: db eval sql").toUtf8().constData(), -1);
+    Tcl_SetObjResult(interp, result);
+    return TCL_ERROR;
+}
+
+int ScriptingTcl::dbEval(ContextTcl* ctx, Tcl_Interp* interp, Tcl_Obj* const objv[])
+{
+    SqlQueryPtr execResults = dbCommonEval(ctx, interp, objv);
+    if (execResults->isError())
+        return TCL_ERROR;
+
+    Tcl_Obj* result = nullptr;
+    QList<QVariant> cells;
+    SqlResultsRowPtr row;
+    while (execResults->hasNext())
+    {
+        row = execResults->next();
+        cells += row->valueList();
+    }
+    result = variantToTclObj(cells);
+
+    Tcl_SetObjResult(interp, result);
+    return TCL_OK;
+}
+
+int ScriptingTcl::dbEvalRowByRow(ContextTcl* ctx, Tcl_Interp* interp, Tcl_Obj* const objv[])
+{
+    SqlQueryPtr execResults = dbCommonEval(ctx, interp, objv);
+    if (execResults->isError())
+        return TCL_ERROR;
+
+    Tcl_Obj* code = objv[4];
+    QString arrayName = tclObjToString(objv[3]);
+    const char* arrayCharName = arrayName.toUtf8().constData();
+    SqlResultsRowPtr row;
+    int resCode = TCL_OK;
+    QHash<QString, QVariant> valueMap;
+    while (execResults->hasNext())
+    {
+        row = execResults->next();
+
+        Tcl_UnsetVar2(interp, arrayCharName, nullptr, 0);
+        valueMap = row->valueMap();
+        valueMap["*"] = QStringList(valueMap.keys());
+        if (setArrayVariable(interp, arrayName, valueMap) != TCL_OK)
+            return TCL_ERROR;
+
+        resCode = Tcl_EvalObjEx(interp, code, 0);
+
+        if (resCode == TCL_ERROR)
+            return TCL_ERROR;
+        else if (resCode == TCL_BREAK)
+            break;
+        else if (resCode == TCL_RETURN)
+            return TCL_RETURN;
+    }
+
+    return TCL_OK;
+}
+
+int ScriptingTcl::dbEvalDeepResults(ContextTcl* ctx, Tcl_Interp* interp, Tcl_Obj* const objv[])
+{
+    SqlQueryPtr execResults = dbCommonEval(ctx, interp, objv);
+    if (execResults->isError())
+        return TCL_ERROR;
+
+    Tcl_Obj* result = nullptr;
+    QList<QVariant> rows;
+    SqlResultsRowPtr row;
+    while (execResults->hasNext())
+    {
+        row = execResults->next();
+        rows << QVariant(row->valueList());
+    }
+    result = variantToTclObj(rows);
+
+    Tcl_SetObjResult(interp, result);
+    return TCL_OK;
+}
+
+int ScriptingTcl::dbEvalOneColumn(ScriptingTcl::ContextTcl* ctx, Tcl_Interp* interp, Tcl_Obj* const objv[])
+{
+    SqlQueryPtr execResults = dbCommonEval(ctx, interp, objv);
+    if (execResults->isError())
+        return TCL_ERROR;
+
+    Tcl_Obj* result = nullptr;
+    QVariant resultValue;
+    if (execResults->hasNext())
+        resultValue = execResults->getSingleCell();
+
+    result = variantToTclObj(resultValue);
+
+    Tcl_SetObjResult(interp, result);
+    return TCL_OK;
+}
+
+SqlQueryPtr ScriptingTcl::dbCommonEval(ContextTcl* ctx, Tcl_Interp* interp, Tcl_Obj* const objv[])
+{
+    Db::Flags flags;
+    if (!ctx->useDbLocking)
+        flags |= Db::Flag::NO_LOCK;
+
+    Tcl_Obj* result = nullptr;
+    QString sql = QString::fromUtf8(Tcl_GetStringFromObj(objv[2], nullptr));
+
+    TokenList bindTokens = Lexer::tokenize(sql, ctx->db->getDialect()).filter(Token::BIND_PARAM);
+    QString bindVarName;
+    QHash<QString, QVariant> queryArgs;
+    for (const TokenPtr& token : bindTokens)
+    {
+        bindVarName = getBindTokenName(token);
+        if (bindVarName == "?")
+            continue;
+
+        queryArgs[token->value] = getVariable(interp, bindVarName);
+    }
+
+    SqlQueryPtr execResults = ctx->db->exec(sql, queryArgs, flags);
+    if (execResults->isError())
+    {
+        result = Tcl_NewStringObj(tr("Error from Tcl's' 'db' command: %1").arg(execResults->getErrorText()).toUtf8().constData(), -1);
+        Tcl_SetObjResult(interp, result);
+    }
+    return execResults;
+}
+
+int ScriptingTcl::setArrayVariable(Tcl_Interp* interp, const QString& arrayName, const QHash<QString, QVariant>& hash)
+{
+    Tcl_Obj* varName = Tcl_NewStringObj(arrayName.toUtf8().constData(), -1);
+    Tcl_IncrRefCount(varName);
+
+    Tcl_Obj* key = nullptr;
+    Tcl_Obj* value = nullptr;
+    Tcl_Obj* res = nullptr;
+
+    QHashIterator<QString, QVariant> it(hash);
+    while (it.hasNext())
+    {
+        it.next();
+        key = variantToTclObj(it.key());
+        value = variantToTclObj(it.value());
+
+        Tcl_IncrRefCount(key);
+        Tcl_IncrRefCount(value);
+
+        res = Tcl_ObjSetVar2(interp, varName, key, value, 0);
+
+        Tcl_DecrRefCount(key);
+        Tcl_DecrRefCount(value);
+
+        if (!res)
+            return TCL_ERROR;
+    }
+    return TCL_OK;
+}
+
+void ScriptingTcl::setVariable(Tcl_Interp* interp, const QString& name, const QVariant& value)
+{
+    Tcl_Obj* varName = Tcl_NewStringObj(name.toUtf8().constData(), -1);
+    Tcl_IncrRefCount(varName);
+    Tcl_Obj* tclObjValue = variantToTclObj(value);
+    Tcl_IncrRefCount(tclObjValue);
+    Tcl_ObjSetVar2(interp, varName, nullptr, tclObjValue, 0);
+    Tcl_DecrRefCount(tclObjValue);
+    Tcl_DecrRefCount(varName);
+}
+
+QVariant ScriptingTcl::getVariable(Tcl_Interp* interp, const QString& name)
+{
+    Tcl_Obj* varName = Tcl_NewStringObj(name.toUtf8().constData(), -1);
+    Tcl_IncrRefCount(varName);
+    Tcl_Obj* obj = Tcl_ObjGetVar2(interp, varName, nullptr, 0);
+    if (!obj)
+        return QVariant();
+
+    Tcl_IncrRefCount(obj);
+    QVariant val = tclObjToVariant(obj);
+    Tcl_DecrRefCount(varName);
+    Tcl_DecrRefCount(obj);
+    return val;
+}
+
+ScriptingTcl::ScriptObject::ScriptObject(const QString& code)
+{
+    QByteArray utf8Bytes = code.toUtf8();
+    obj = Tcl_NewStringObj(utf8Bytes.constData(), utf8Bytes.size());
+    Tcl_IncrRefCount(obj);
+}
+
+ScriptingTcl::ScriptObject::~ScriptObject()
+{
+    Tcl_DecrRefCount(obj);
+}
+
+Tcl_Obj* ScriptingTcl::ScriptObject::getTclObj()
+{
+    return obj;
+}
+
+ScriptingTcl::ContextTcl::ContextTcl()
+{
+    scriptCache.setMaxCost(cacheSize);
+    interp = Tcl_CreateInterp();
+    init();
+}
+
+ScriptingTcl::ContextTcl::~ContextTcl()
+{
+    Tcl_DeleteInterp(interp);
+}
+
+void ScriptingTcl::ContextTcl::reset()
+{
+    Tcl_DeleteInterp(interp);
+    interp = Tcl_CreateInterp();
+    error = QString();
+    init();
+}
+
+void ScriptingTcl::ContextTcl::init()
+{
+    Tcl_CreateObjCommand(interp, "db", ScriptingTcl::dbCommand, reinterpret_cast<ClientData>(this), nullptr);
+}