static AP_Result tcl_coerce_number(AP_World *w, AP_Obj interp_name, AP_Obj item, AP_Obj atom)
{
Tcl_Interp *interp;
AP_Obj result;
interp = GetInterp(w, interp_name);
if (!interp) return AP_EXCEPTION;
if (AP_ObjType(w, item) == AP_INTEGER
|| AP_ObjType(w, item) == AP_FLOAT) result = item;
else {
Tcl_Obj *tcl_obj = PrologToTclObj(w, item, interp);
int r;
r = Tcl_ConvertToType(interp, tcl_obj, tcl_integer_type);
if (r != TCL_OK)
r = Tcl_ConvertToType(interp, tcl_obj, tcl_double_type);
if (r != TCL_OK)
return AP_SetException(w,
AP_NewInitStructure(w, AP_NewSymbolFromStr(w, "error"), 2,
AP_NewInitStructure(w, AP_NewSymbolFromStr(w, "tcl_error"), 1,
TclToPrologObj(interp, Tcl_GetObjResult(interp), w, NULL)),
AP_UNBOUND_OBJ));
result = TclToPrologObj(interp, tcl_obj, w, NULL);
Tcl_DecrRefCount(tcl_obj);
}
return AP_Unify(w, result, atom);
}
int
Tcl_GetBoolean(
Tcl_Interp *interp, /* Interpreter used for error reporting. */
const char *src, /* String containing one of the boolean values
* 1, 0, true, false, yes, no, on, off. */
int *boolPtr) /* Place to store converted result, which will
* be 0 or 1. */
{
Tcl_Obj obj;
int code;
obj.refCount = 1;
obj.bytes = (char *) src;
obj.length = strlen(src);
obj.typePtr = NULL;
code = Tcl_ConvertToType(interp, &obj, &tclBooleanType);
if (obj.refCount > 1) {
Tcl_Panic("invalid sharing of Tcl_Obj on C stack");
}
if (code == TCL_OK) {
*boolPtr = obj.internalRep.longValue;
}
return code;
}
static int
installConsts(Tcl_Interp *interp,struct ConstEntry *table) {
struct ConstEntry *entry;
if (table==NULL) return TCL_ERROR;
for(entry=table+0;entry->objPtr!=NULL;entry++) {
Tcl_Obj *obj;
if (*entry->objPtr!=NULL) {
//WARN("const %s already defined\n",entry->name);
continue;
}
if (entry->value==NULL)
obj=Tcl_NewObj();
else
obj=Tcl_NewStringObj(entry->value,-1);
Tcl_IncrRefCount(obj);
if (entry->typePtr!=NULL && *entry->typePtr!=NULL) {
if (Tcl_ConvertToType(interp,obj,*entry->typePtr)!=TCL_OK) {
ERR("in convert const %s to %s",entry->name,(*entry->typePtr)->name);
Tcl_DecrRefCount(obj);
return TCL_ERROR;
}
}
Tcl_IncrRefCount(obj);
*entry->objPtr=obj;
}
return TCL_OK;
}
int
Tcljson_JsonObjFromTclObj(Tcl_Interp *interp, Tcl_Obj *objPtr, struct json_object **joPtrPtr)
{
TclJsonObject *tjPtr;
if (objPtr->typePtr == NULL) {
if (interp != NULL) {
Tcl_SetResult(interp, "invalid json object", TCL_STATIC);
}
return TCL_ERROR;
}
if (Tcljson_TclObjIsJsonObj(objPtr) != 1) {
if (Tcl_ConvertToType(interp, objPtr, &tclJsonObjectType) != TCL_OK) {
if (interp != NULL) {
Tcl_SetResult(interp, "invalid json object", TCL_STATIC);
}
return TCL_ERROR;
}
}
tjPtr = (TclJsonObject *) objPtr->internalRep.otherValuePtr;
*joPtrPtr = tjPtr->joPtr;
return TCL_OK;
}
Tcl_Obj *
CmdNameType::newObj (Tcl_Interp *interp, InternalRep *pRep)
{
Tcl_Obj *pObj = Tcl_NewStringObj(
const_cast<char *>(pRep->name().c_str()), -1);
Tcl_ConvertToType(interp, pObj, ms_pCmdNameType);
return pObj;
}
int
TkGetWindowFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tk_Window tkwin, /* A token to get the main window from. */
Tcl_Obj *objPtr, /* The object from which to get window. */
Tk_Window *windowPtr) /* Place to store resulting window. */
{
TkMainInfo *mainPtr = ((TkWindow *) tkwin)->mainPtr;
register WindowRep *winPtr;
int result;
result = Tcl_ConvertToType(interp, objPtr, &windowObjType);
if (result != TCL_OK) {
return result;
}
winPtr = (WindowRep *) objPtr->internalRep.twoPtrValue.ptr1;
if (winPtr->tkwin == NULL
|| winPtr->mainPtr == NULL
|| winPtr->mainPtr != mainPtr
|| winPtr->epoch != mainPtr->deletionEpoch)
{
/*
* Cache is invalid.
*/
winPtr->tkwin = Tk_NameToWindow(interp,
Tcl_GetString(objPtr), tkwin);
if (winPtr->tkwin == NULL) {
/* ASSERT: Tk_NameToWindow has left error message in interp */
return TCL_ERROR;
}
winPtr->mainPtr = mainPtr;
winPtr->epoch = mainPtr ? mainPtr->deletionEpoch : 0;
}
*windowPtr = winPtr->tkwin;
return TCL_OK;
}
static AP_Result tcl_coerce_list(AP_World *w, AP_Obj interp_name, AP_Obj item, AP_Obj list)
{
Tcl_Interp *interp;
AP_Obj result;
interp = GetInterp(w, interp_name);
if (!interp) return AP_EXCEPTION;
if (AP_ObjType(w, item) == AP_LIST || AP_IsNullList(w, item)) result = item;
else {
Tcl_Obj *tcl_obj = PrologToTclObj(w, item, interp);
int r = Tcl_ConvertToType(interp, tcl_obj, tcl_list_type);
if (r != TCL_OK)
return AP_SetException(w,
AP_NewInitStructure(w, AP_NewSymbolFromStr(w, "error"), 2,
AP_NewInitStructure(w, AP_NewSymbolFromStr(w, "tcl_error"), 1,
TclToPrologObj(interp, Tcl_GetObjResult(interp), w, NULL)),
AP_UNBOUND_OBJ));
result = TclToPrologObj(interp, tcl_obj, w, NULL);
Tcl_DecrRefCount(tcl_obj);
}
return AP_Unify(w, result, list);
}
static int
TestobjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int varIndex, destIndex, i;
const char *index, *subCmd, *string;
const Tcl_ObjType *targetType;
if (objc < 2) {
wrongNumArgs:
Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
return TCL_ERROR;
}
subCmd = Tcl_GetString(objv[1]);
if (strcmp(subCmd, "assign") == 0) {
if (objc != 4) {
goto wrongNumArgs;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
string = Tcl_GetString(objv[3]);
if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) {
return TCL_ERROR;
}
SetVarToObj(destIndex, varPtr[varIndex]);
Tcl_SetObjResult(interp, varPtr[destIndex]);
} else if (strcmp(subCmd, "convert") == 0) {
const char *typeName;
if (objc != 4) {
goto wrongNumArgs;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
typeName = Tcl_GetString(objv[3]);
if ((targetType = Tcl_GetObjType(typeName)) == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"no type ", typeName, " found", NULL);
return TCL_ERROR;
}
if (Tcl_ConvertToType(interp, varPtr[varIndex], targetType)
!= TCL_OK) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "duplicate") == 0) {
if (objc != 4) {
goto wrongNumArgs;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
string = Tcl_GetString(objv[3]);
if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) {
return TCL_ERROR;
}
SetVarToObj(destIndex, Tcl_DuplicateObj(varPtr[varIndex]));
Tcl_SetObjResult(interp, varPtr[destIndex]);
} else if (strcmp(subCmd, "freeallvars") == 0) {
if (objc != 2) {
goto wrongNumArgs;
}
for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) {
if (varPtr[i] != NULL) {
Tcl_DecrRefCount(varPtr[i]);
varPtr[i] = NULL;
}
}
} else if (strcmp(subCmd, "invalidateStringRep") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
Tcl_InvalidateStringRep(varPtr[varIndex]);
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "newobj") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
SetVarToObj(varIndex, Tcl_NewObj());
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "objtype") == 0) {
const char *typeName;
/*
* Return an object containing the name of the argument's type of
* internal rep. If none exists, return "none".
*/
if (objc != 3) {
goto wrongNumArgs;
}
if (objv[2]->typePtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1));
} else {
typeName = objv[2]->typePtr->name;
Tcl_SetObjResult(interp, Tcl_NewStringObj(typeName, -1));
}
} else if (strcmp(subCmd, "refcount") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(varPtr[varIndex]->refCount));
} else if (strcmp(subCmd, "type") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
if (varPtr[varIndex]->typePtr == NULL) { /* a string! */
Tcl_AppendToObj(Tcl_GetObjResult(interp), "string", -1);
} else {
Tcl_AppendToObj(Tcl_GetObjResult(interp),
varPtr[varIndex]->typePtr->name, -1);
}
} else if (strcmp(subCmd, "types") == 0) {
if (objc != 2) {
goto wrongNumArgs;
}
if (Tcl_AppendAllObjTypes(interp,
Tcl_GetObjResult(interp)) != TCL_OK) {
return TCL_ERROR;
}
} else {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad option \"", Tcl_GetString(objv[1]),
"\": must be assign, convert, duplicate, freeallvars, "
"newobj, objcount, objtype, refcount, type, or types", NULL);
return TCL_ERROR;
}
return TCL_OK;
}
static int
TeststringobjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_UniChar *unicode;
int varIndex, option, i, length;
#define MAX_STRINGS 11
const char *index, *string, *strings[MAX_STRINGS+1];
TestString *strPtr;
static const char *const options[] = {
"append", "appendstrings", "get", "get2", "length", "length2",
"set", "set2", "setlength", "maxchars", "getunicode",
"appendself", "appendself2", NULL
};
if (objc < 3) {
wrongNumArgs:
Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
return TCL_ERROR;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &option)
!= TCL_OK) {
return TCL_ERROR;
}
switch (option) {
case 0: /* append */
if (objc != 5) {
goto wrongNumArgs;
}
if (Tcl_GetIntFromObj(interp, objv[4], &length) != TCL_OK) {
return TCL_ERROR;
}
if (varPtr[varIndex] == NULL) {
SetVarToObj(varIndex, Tcl_NewObj());
}
/*
* If the object bound to variable "varIndex" is shared, we must
* "copy on write" and append to a copy of the object.
*/
if (Tcl_IsShared(varPtr[varIndex])) {
SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
}
string = Tcl_GetString(objv[3]);
Tcl_AppendToObj(varPtr[varIndex], string, length);
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case 1: /* appendstrings */
if (objc > (MAX_STRINGS+3)) {
goto wrongNumArgs;
}
if (varPtr[varIndex] == NULL) {
SetVarToObj(varIndex, Tcl_NewObj());
}
/*
* If the object bound to variable "varIndex" is shared, we must
* "copy on write" and append to a copy of the object.
*/
if (Tcl_IsShared(varPtr[varIndex])) {
SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
}
for (i = 3; i < objc; i++) {
strings[i-3] = Tcl_GetString(objv[i]);
}
for ( ; i < 12 + 3; i++) {
strings[i - 3] = NULL;
}
Tcl_AppendStringsToObj(varPtr[varIndex], strings[0], strings[1],
strings[2], strings[3], strings[4], strings[5],
strings[6], strings[7], strings[8], strings[9],
strings[10], strings[11]);
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case 2: /* get */
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case 3: /* get2 */
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
string = Tcl_GetString(varPtr[varIndex]);
Tcl_AppendToObj(Tcl_GetObjResult(interp), string, -1);
break;
case 4: /* length */
if (objc != 3) {
goto wrongNumArgs;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), (varPtr[varIndex] != NULL)
? varPtr[varIndex]->length : -1);
break;
case 5: /* length2 */
if (objc != 3) {
goto wrongNumArgs;
}
if (varPtr[varIndex] != NULL) {
Tcl_ConvertToType(NULL, varPtr[varIndex],
Tcl_GetObjType("string"));
strPtr = (TestString *)
(varPtr[varIndex])->internalRep.otherValuePtr;
length = (int) strPtr->allocated;
} else {
length = -1;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), length);
break;
case 6: /* set */
if (objc != 4) {
goto wrongNumArgs;
}
/*
* If the object currently bound to the variable with index
* varIndex has ref count 1 (i.e. the object is unshared) we can
* modify that object directly. Otherwise, if RC>1 (i.e. the
* object is shared), we must create a new object to modify/set
* and decrement the old formerly-shared object's ref count. This
* is "copy on write".
*/
string = Tcl_GetStringFromObj(objv[3], &length);
if ((varPtr[varIndex] != NULL)
&& !Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetStringObj(varPtr[varIndex], string, length);
} else {
SetVarToObj(varIndex, Tcl_NewStringObj(string, length));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case 7: /* set2 */
if (objc != 4) {
goto wrongNumArgs;
}
SetVarToObj(varIndex, objv[3]);
break;
case 8: /* setlength */
if (objc != 4) {
goto wrongNumArgs;
}
if (Tcl_GetIntFromObj(interp, objv[3], &length) != TCL_OK) {
return TCL_ERROR;
}
if (varPtr[varIndex] != NULL) {
Tcl_SetObjLength(varPtr[varIndex], length);
}
break;
case 9: /* maxchars */
if (objc != 3) {
goto wrongNumArgs;
}
if (varPtr[varIndex] != NULL) {
Tcl_ConvertToType(NULL, varPtr[varIndex],
Tcl_GetObjType("string"));
strPtr = (TestString *)
(varPtr[varIndex])->internalRep.otherValuePtr;
length = strPtr->maxChars;
} else {
length = -1;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), length);
break;
case 10: /* getunicode */
if (objc != 3) {
goto wrongNumArgs;
}
Tcl_GetUnicodeFromObj(varPtr[varIndex], NULL);
break;
case 11: /* appendself */
if (objc != 4) {
goto wrongNumArgs;
}
if (varPtr[varIndex] == NULL) {
SetVarToObj(varIndex, Tcl_NewObj());
}
/*
* If the object bound to variable "varIndex" is shared, we must
* "copy on write" and append to a copy of the object.
*/
if (Tcl_IsShared(varPtr[varIndex])) {
SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
}
string = Tcl_GetStringFromObj(varPtr[varIndex], &length);
if (Tcl_GetIntFromObj(interp, objv[3], &i) != TCL_OK) {
return TCL_ERROR;
}
if ((i < 0) || (i > length)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"index value out of range", -1));
return TCL_ERROR;
}
Tcl_AppendToObj(varPtr[varIndex], string + i, length - i);
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case 12: /* appendself2 */
if (objc != 4) {
goto wrongNumArgs;
}
if (varPtr[varIndex] == NULL) {
SetVarToObj(varIndex, Tcl_NewObj());
}
/*
* If the object bound to variable "varIndex" is shared, we must
* "copy on write" and append to a copy of the object.
*/
if (Tcl_IsShared(varPtr[varIndex])) {
SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
}
unicode = Tcl_GetUnicodeFromObj(varPtr[varIndex], &length);
if (Tcl_GetIntFromObj(interp, objv[3], &i) != TCL_OK) {
return TCL_ERROR;
}
if ((i < 0) || (i > length)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"index value out of range", -1));
return TCL_ERROR;
}
Tcl_AppendUnicodeToObj(varPtr[varIndex], unicode + i, length - i);
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
}
return TCL_OK;
}
/*************************************************************************
* FUNCTION : RPMTransaction_Set::Install_or_remove *
* ARGUMENTS : RPM headers to add *
* RETURNS : TCL_OK or TCL_ERROR *
* EXCEPTIONS : none *
* PURPOSE : Add an RPM to an install set *
*************************************************************************/
int RPMTransaction_Set::Install_or_remove(Tcl_Obj *name,Install_mode mode)
{
// Is this a list? if so, recurse through it
Tcl_ObjType *listtype = Tcl_GetObjType("list");
if (name->typePtr == listtype)
{
// OK, go recursive on this
int count = 0;
if (Tcl_ListObjLength(_interp,name,&count) != TCL_OK)
return TCL_ERROR;
for (int i = 0; i < count; ++i)
{
Tcl_Obj *element = 0;
if (Tcl_ListObjIndex(_interp,name,i,&element) != TCL_OK)
{
return TCL_ERROR;
}
if (Install_or_remove(element,mode) != TCL_OK)
return TCL_ERROR;
}
return TCL_OK;
}
// OK, so not a list. Try to make it into an RPM header
if (Tcl_ConvertToType(_interp,name,&RPMHeader_Obj::mytype) != TCL_OK)
return TCL_ERROR;
RPMHeader_Obj *header = ( RPMHeader_Obj *)(name->internalRep.otherValuePtr);
\
// Unfortunately, the transaction set API does not give us a way to know when
// it has freed a fnpyKey key object. In order to clean these up, we will create
// a TCL list object of all headers we use for this purpose, and clean it as needed.
Tcl_Obj *hdr_copy = header->Get_obj();
Tcl_IncrRefCount(hdr_copy);
int error = 0;
switch (mode)
{
case INSTALL:
error = rpmtsAddInstallElement(transaction,*header,header,0,0);
break;
case UPGRADE:
error = rpmtsAddInstallElement(transaction,*header,header,1,0);
break;
case REMOVE:
error = rpmtsAddEraseElement(transaction,*header,header->DB_entry());
break;
}
switch (error)
{
case 0:
// Record that we have created an entry on the list
header_list = Grow_list(header_list,hdr_copy);
return TCL_OK;
case 1:
header->Dec_refcount();
return Error("Error adding %s: %s\n",Tcl_GetStringFromObj(name,0),rpmErrorString());
case 2:
header->Dec_refcount();
return Error("Error adding %s: needs capabilities %s\n",Tcl_GetStringFromObj(name,0),rpmErrorString());
default:
header->Dec_refcount();
return Error("Unknown RPMlib error %d adding %s: needs capabilities %s\n",error,Tcl_GetStringFromObj(name,0),rpmErrorString());
}
return TCL_OK;
}
static int
Tcl_ALS_Prolog_Call(ClientData prolog_world, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv)
{
AP_World *w = prolog_world;
const char *name;
AP_Obj module, functor, call, vars, wrap_call;
AP_Result result;
if (objc < 4 || (objc%2) != 0) {
Tcl_WrongNumArgs(interp, 1, objv, (char *)"call module functor ?-type arg ...?");
return TCL_ERROR;
}
module = AP_NewSymbolFromStr(w, Tcl_GetStringFromObj(objv[2], NULL));
functor = AP_NewSymbolFromStr(w, Tcl_GetStringFromObj(objv[3], NULL));
if (objc == 4) {
call = functor;
vars = AP_NullList(w);
} else {
int i, a, argc, option;
AP_Obj arg = AP_UNBOUND_OBJ;
enum {NUMBER, ATOM, LIST, VAR};
const char *callOptions[] = {"-number", "-atom", "-list", "-var", NULL};
argc = (objc-4)/2;
call = AP_NewStructure(w, functor, argc);
for (a = 0, i = 4, vars = AP_NullList(w); a < argc; a++, i+=2) {
if (Tcl_GetIndexFromObj(NULL, objv[i], callOptions, (char *)"", TCL_EXACT, &option) == TCL_OK) {
switch (option) {
case NUMBER:
if (Tcl_ConvertToType(interp, objv[i+1], tcl_integer_type) == TCL_OK
|| Tcl_ConvertToType(interp, objv[i+1], tcl_double_type) == TCL_OK)
arg = TclToPrologObj0(interp, objv[i+1], w, &vars);
else return TCL_ERROR;
break;
case ATOM:
arg = AP_NewUIAFromStr(w, Tcl_GetStringFromObj(objv[i+1], NULL));
break;
case LIST:
if (Tcl_ConvertToType(interp, objv[i+1], tcl_list_type) != TCL_OK)
return TCL_ERROR;
arg = TclToPrologObj0(interp, objv[i+1], w, &vars);
break;
case VAR:
name = Tcl_GetStringFromObj(objv[i+1], NULL);
if (!strcmp(name, "_")) arg = AP_UNBOUND_OBJ;
else arg = AddVarList(w, &vars, name);
break;
}
} else {
Tcl_WrongNumArgs(interp, 2, objv,
(char *)"module functor ?-type arg ...?"
);
return TCL_ERROR;
}
AP_Unify(w, arg, AP_GetArgument(w, call, a+1));
}
}
/* Wrap up call and variable list, so it will be updated in
the event of a gc. */
wrap_call = AP_NewInitStructure(w,
AP_NewSymbolFromStr(w, "eval_results"), 3,
module, call, vars);
result = AP_Call(w, tcltk_module, &wrap_call);
if (result == AP_SUCCESS) {
AP_Obj v, pair, value;
/* Get the new value of vars */
vars = AP_GetArgument(w, wrap_call, 3);
for (v = vars; !AP_IsNullList(w, v); v = AP_ListTail(w, v)) {
pair = AP_ListHead(w, v);
name = AP_GetAtomStr(w, AP_GetArgument(w, pair, 1));
if (*name) {
value = AP_GetArgument(w, pair, 2);
Tcl_ObjSetVar2(interp, Tcl_NewStringObj((char *)name, -1), NULL, PrologToTclObj(w, value, interp), 0);
}
}
}
return PrologToTclResult(interp, w, result);
}
