static int _list_ports(ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj* const *objv) { if (argc != 2) return fw_error_str(interp, "jack-client list-ports"); _t *dp = (_t *)clientData; Tcl_Obj *dict = Tcl_NewDictObj(); const char **portv[] = { jack_get_ports (dp->fw.client, NULL, JACK_DEFAULT_AUDIO_TYPE, 0), jack_get_ports (dp->fw.client, NULL, JACK_DEFAULT_MIDI_TYPE, 0) }; for (int p = 0; p < 2; p += 1) if (portv[p] != NULL) { for (int i = 0; portv[p][i] != NULL; i += 1) { jack_port_t *port = jack_port_by_name(dp->fw.client, portv[p][i]); if (port != NULL) { Tcl_Obj *pdict = Tcl_NewDictObj(); int flags = jack_port_flags(port); Tcl_DictObjPut(interp, pdict, Tcl_NewStringObj("direction", -1), flags & JackPortIsInput ? Tcl_NewStringObj("input", -1) : Tcl_NewStringObj("output", -1) ); Tcl_DictObjPut(interp, pdict, Tcl_NewStringObj("physical", -1), Tcl_NewIntObj(flags & JackPortIsPhysical ? 1 : 0)); Tcl_DictObjPut(interp, pdict, Tcl_NewStringObj("type", -1), p == 0 ? Tcl_NewStringObj("audio", -1) : Tcl_NewStringObj("midi", -1)); const char **connv = jack_port_get_all_connections(dp->fw.client, port); Tcl_Obj *list = Tcl_NewListObj(0, NULL); if (connv != NULL) { for (int j = 0; connv[j] != NULL; j += 1) Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj(connv[j], -1)); jack_free(connv); } Tcl_DictObjPut(interp, pdict, Tcl_NewStringObj("connections", -1), list); Tcl_DictObjPut(interp, dict, Tcl_NewStringObj(portv[p][i], -1), pdict); } } jack_free(portv[p]); } Tcl_SetObjResult(interp, dict); return TCL_OK; }
static int TestgetwindowinfoObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { long hwnd; Tcl_Obj *dictObj = NULL, *classObj = NULL, *textObj = NULL; Tcl_Obj *childrenObj = NULL; TCHAR buf[512]; int cch, cchBuf = 256; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "hwnd"); return TCL_ERROR; } if (Tcl_GetLongFromObj(interp, objv[1], &hwnd) != TCL_OK) return TCL_ERROR; cch = GetClassName(INT2PTR(hwnd), buf, cchBuf); if (cch == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("failed to get class name: ", -1)); AppendSystemError(interp, GetLastError()); return TCL_ERROR; } else { Tcl_DString ds; Tcl_WinTCharToUtf(buf, -1, &ds); classObj = Tcl_NewStringObj(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)); Tcl_DStringFree(&ds); } dictObj = Tcl_NewDictObj(); Tcl_DictObjPut(interp, dictObj, Tcl_NewStringObj("class", 5), classObj); Tcl_DictObjPut(interp, dictObj, Tcl_NewStringObj("id", 2), Tcl_NewLongObj(GetWindowLongA(INT2PTR(hwnd), GWL_ID))); cch = GetWindowText(INT2PTR(hwnd), (LPTSTR)buf, cchBuf); textObj = Tcl_NewUnicodeObj((LPCWSTR)buf, cch); Tcl_DictObjPut(interp, dictObj, Tcl_NewStringObj("text", 4), textObj); Tcl_DictObjPut(interp, dictObj, Tcl_NewStringObj("parent", 6), Tcl_NewLongObj(PTR2INT(GetParent((INT2PTR(hwnd)))))); childrenObj = Tcl_NewListObj(0, NULL); EnumChildWindows(INT2PTR(hwnd), EnumChildrenProc, (LPARAM)childrenObj); Tcl_DictObjPut(interp, dictObj, Tcl_NewStringObj("children", -1), childrenObj); Tcl_SetObjResult(interp, dictObj); return TCL_OK; }
Tcl_Command TclInitChanCmd( Tcl_Interp *interp) { /* * Most commands are plugged directly together, but some are done via * alias-like rewriting; [chan configure] is this way for security reasons * (want overwriting of [fconfigure] to control that nicely), and [chan * names] because the functionality isn't available as a separate command * function at the moment. */ static const EnsembleImplMap initMap[] = { {"blocked", Tcl_FblockedObjCmd}, {"close", Tcl_CloseObjCmd}, {"copy", Tcl_FcopyObjCmd}, {"create", TclChanCreateObjCmd}, /* TIP #219 */ {"eof", Tcl_EofObjCmd}, {"event", Tcl_FileEventObjCmd}, {"flush", Tcl_FlushObjCmd}, {"gets", Tcl_GetsObjCmd}, {"pending", ChanPendingObjCmd}, /* TIP #287 */ {"postevent", TclChanPostEventObjCmd}, /* TIP #219 */ {"puts", Tcl_PutsObjCmd}, {"read", Tcl_ReadObjCmd}, {"seek", Tcl_SeekObjCmd}, {"tell", Tcl_TellObjCmd}, {"truncate", ChanTruncateObjCmd}, /* TIP #208 */ {NULL} }; static const char *extras[] = { "configure", "::fconfigure", "names", "::file channels", NULL }; Tcl_Command ensemble; Tcl_Obj *mapObj; int i; ensemble = TclMakeEnsemble(interp, "chan", initMap); Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj); for (i=0 ; extras[i] ; i+=2) { /* * Can assume that reference counts are all incremented. */ Tcl_DictObjPut(NULL, mapObj, Tcl_NewStringObj(extras[i], -1), Tcl_NewStringObj(extras[i+1], -1)); } Tcl_SetEnsembleMappingDict(interp, ensemble, mapObj); return ensemble; }
void weechat_tcl_hashtable_map_cb (void *data, struct t_hashtable *hashtable, const char *key, const char *value) { void **data_array; Tcl_Interp *interp; Tcl_Obj *dict; /* make C compiler happy */ (void) hashtable; data_array = (void **)data; interp = data_array[0]; dict = data_array[1]; Tcl_DictObjPut (interp, dict, Tcl_NewStringObj (key, -1), Tcl_NewStringObj (value, -1)); }
static int Ta4r_PackageInit (Tcl_Interp *interp) { Tcl_Namespace *ns; Ta4r_Cmd *c; Tcl_Obj *o; Tcl_Obj *m; Tcl_Obj *f; if ((ns = Tcl_FindNamespace(interp, Ta4r, NULL, TCL_LEAVE_ERR_MSG)) == NULL) { return TCL_ERROR; } m = Tcl_NewDictObj(); for (c = &Ta4r_Cmds[0]; c->name != NULL; c++) { /* Put commands into sub-namespace so as not to conflict with ensemble name */ /* This will also create the sub-namespace. Slightly cheap? */ o = Tcl_ObjPrintf("%s::commands::%s", Ta4r, c->name); Tcl_IncrRefCount(o); f = Tcl_ObjPrintf("::tcl::mathfunc::%s", c->name); Tcl_IncrRefCount(f); if (Tcl_CreateObjCommand(interp, Tcl_GetString(o), c->proc, NULL, NULL) == NULL) { Tcl_DecrRefCount(o); Tcl_DecrRefCount(f); return TCL_ERROR; } if (Tcl_CreateAlias(interp, Tcl_GetString(f), interp, Tcl_GetString(o), 0, NULL) != TCL_OK) { Tcl_DecrRefCount(o); Tcl_DecrRefCount(f); return TCL_ERROR; } Tcl_DictObjPut(interp, m, Tcl_NewStringObj(c->name+4, -1), o); Tcl_DecrRefCount(o); Tcl_DecrRefCount(f); } if (Tcl_SetEnsembleMappingDict(interp, Tcl_CreateEnsemble(interp, (Ta4r+2), ns, TCL_ENSEMBLE_PREFIX), m) != TCL_OK) { return TCL_ERROR; }; if (Tcl_Export(interp, ns, (Ta4r+2), 0) != TCL_OK) { return TCL_ERROR; } return TCL_OK; }
void Tcl_RegisterConfig( Tcl_Interp *interp, /* Interpreter the configuration command is * registered in. */ const char *pkgName, /* Name of the package registering the * embedded configuration. ASCII, thus in * UTF-8 too. */ const Tcl_Config *configuration, /* Embedded configuration. */ const char *valEncoding) /* Name of the encoding used to store the * configuration values, ASCII, thus UTF-8. */ { Tcl_Obj *pDB, *pkgDict; Tcl_DString cmdName; const Tcl_Config *cfg; QCCD *cdPtr = ckalloc(sizeof(QCCD)); cdPtr->interp = interp; if (valEncoding) { cdPtr->encoding = ckalloc(strlen(valEncoding)+1); strcpy(cdPtr->encoding, valEncoding); } else { cdPtr->encoding = NULL; } cdPtr->pkg = Tcl_NewStringObj(pkgName, -1); /* * Phase I: Adding the provided information to the internal database of * package meta data. * * Phase II: Create a command for querying this database, specific to the * package registering its configuration. This is the approved interface * in TIP 59. In the future a more general interface should be done, as * follow-up to TIP 59. Simply because our database is now general across * packages, and not a structure tied to one package. * * Note, the created command will have a reference through its clientdata. */ Tcl_IncrRefCount(cdPtr->pkg); /* * For venc == NULL aka bogus encoding we skip the step setting up the * dictionaries visible at Tcl level. I.e. they are not filled */ pDB = GetConfigDict(interp); /* * Retrieve package specific configuration... */ if (Tcl_DictObjGet(interp, pDB, cdPtr->pkg, &pkgDict) != TCL_OK || (pkgDict == NULL)) { pkgDict = Tcl_NewDictObj(); } else if (Tcl_IsShared(pkgDict)) { pkgDict = Tcl_DuplicateObj(pkgDict); } /* * Extend the package configuration... * We cannot assume that the encodings are initialized, therefore * store the value as-is in a byte array. See Bug [9b2e636361]. */ for (cfg=configuration ; cfg->key!=NULL && cfg->key[0]!='\0' ; cfg++) { Tcl_DictObjPut(interp, pkgDict, Tcl_NewStringObj(cfg->key, -1), Tcl_NewByteArrayObj((unsigned char *)cfg->value, strlen(cfg->value))); } /* * Write the changes back into the overall database. */ Tcl_DictObjPut(interp, pDB, cdPtr->pkg, pkgDict); /* * Now create the interface command for retrieval of the package * information. */ Tcl_DStringInit(&cmdName); TclDStringAppendLiteral(&cmdName, "::"); Tcl_DStringAppend(&cmdName, pkgName, -1); /* * The incomplete command name is the name of the namespace to place it * in. */ if (Tcl_FindNamespace(interp, Tcl_DStringValue(&cmdName), NULL, TCL_GLOBAL_ONLY) == NULL) { if (Tcl_CreateNamespace(interp, Tcl_DStringValue(&cmdName), NULL, NULL) == NULL) { Tcl_Panic("%s.\n%s: %s", Tcl_GetStringResult(interp), "Tcl_RegisterConfig", "Unable to create namespace for package configuration."); } } TclDStringAppendLiteral(&cmdName, "::pkgconfig"); if (Tcl_CreateObjCommand(interp, Tcl_DStringValue(&cmdName), QueryConfigObjCmd, cdPtr, QueryConfigDelete) == NULL) { Tcl_Panic("%s: %s", "Tcl_RegisterConfig", "Unable to create query command for package configuration"); } Tcl_DStringFree(&cmdName); }
/* * ------------------------------------------------------------------------ * ItclFinishCmd() * * called when an interp is deleted to free up memory or called explicitly * to check memory leaks * * ------------------------------------------------------------------------ */ static int ItclFinishCmd( ClientData clientData, /* unused */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_HashEntry *hPtr; Tcl_HashSearch place; Tcl_Namespace *nsPtr; Tcl_Obj **newObjv; Tcl_Obj *objPtr; Tcl_Obj *ensObjPtr; Tcl_Command cmdPtr; Tcl_Obj *mapDict; ItclObjectInfo *infoPtr; ItclCmdsInfo *iciPtr; int checkMemoryLeaks; int i; int result; ItclShowArgs(1, "ItclFinishCmd", objc, objv); result = TCL_OK; infoPtr = Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); if (infoPtr == NULL) { infoPtr = (ItclObjectInfo *)clientData; } checkMemoryLeaks = 0; if (objc > 1) { if (strcmp(Tcl_GetString(objv[1]), "checkmemoryleaks") == 0) { /* if we have that option, the namespace of the Tcl ensembles * is not teared down, so we have to simulate it here to * have the correct reference counts for infoPtr->infoVars2Ptr * infoPtr->infoVars3Ptr and infoPtr->infoVars4Ptr */ checkMemoryLeaks = 1; } } newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * 2); newObjv[0] = Tcl_NewStringObj("my", -1);; for (i = 0; ;i++) { iciPtr = &itclCmds[i]; if (iciPtr->name == NULL) { break; } if ((iciPtr->flags & ITCL_IS_ENSEMBLE) == 0) { result = Itcl_RenameCommand(interp, iciPtr->name, ""); } else { objPtr = Tcl_NewStringObj(iciPtr->name, -1); newObjv[1] = objPtr; Itcl_EnsembleDeleteCmd(infoPtr, infoPtr->interp, 2, newObjv); Tcl_DecrRefCount(objPtr); } iciPtr++; } Tcl_DecrRefCount(newObjv[0]); ckfree((char *)newObjv); /* remove the unknow handler, to free the reference to the * Tcl_Obj with the name of it */ ensObjPtr = Tcl_NewStringObj("::itcl::builtin::Info::delegated", -1); cmdPtr = Tcl_FindEnsemble(interp, ensObjPtr, TCL_LEAVE_ERR_MSG); if (cmdPtr != NULL) { Tcl_SetEnsembleUnknownHandler(NULL, cmdPtr, NULL); } Tcl_DecrRefCount(ensObjPtr); while (1) { hPtr = Tcl_FirstHashEntry(&infoPtr->instances, &place); if (hPtr == NULL) { break; } Tcl_DeleteHashEntry(hPtr); } Tcl_DeleteHashTable(&infoPtr->instances); while (1) { hPtr = Tcl_FirstHashEntry(&infoPtr->classTypes, &place); if (hPtr == NULL) { break; } Tcl_DeleteHashEntry(hPtr); } Tcl_DeleteHashTable(&infoPtr->classTypes); nsPtr = Tcl_FindNamespace(interp, "::itcl::parser", NULL, 0); if (nsPtr != NULL) { Tcl_DeleteNamespace(nsPtr); } mapDict = NULL; ensObjPtr = Tcl_NewStringObj("::itcl::builtin::Info", -1); if (Tcl_FindNamespace(interp, Tcl_GetString(ensObjPtr), NULL, 0) != NULL) { Tcl_SetEnsembleUnknownHandler(NULL, Tcl_FindEnsemble(interp, ensObjPtr, TCL_LEAVE_ERR_MSG), NULL); } Tcl_DecrRefCount(ensObjPtr); /* remove the itclinfo and vars entry from the info dict */ /* and replace it by the original one */ cmdPtr = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY); if (cmdPtr != NULL && Tcl_IsEnsemble(cmdPtr)) { Tcl_GetEnsembleMappingDict(NULL, cmdPtr, &mapDict); if (mapDict != NULL) { objPtr = Tcl_NewStringObj("vars", -1); Tcl_DictObjRemove(interp, mapDict, objPtr); Tcl_DictObjPut(interp, mapDict, objPtr, infoPtr->infoVars4Ptr); Tcl_DecrRefCount(objPtr); objPtr = Tcl_NewStringObj("itclinfo", -1); Tcl_DictObjRemove(interp, mapDict, objPtr); Tcl_DecrRefCount(objPtr); Tcl_SetEnsembleMappingDict(interp, cmdPtr, mapDict); } } /* FIXME have to figure out why the refCount of * ::itcl::builtin::Info * and ::itcl::builtin::Info::vars and vars is 2 here !! */ /* seems to be as the tclOO commands are not yet deleted ?? */ Tcl_DecrRefCount(infoPtr->infoVars2Ptr); Tcl_DecrRefCount(infoPtr->infoVars3Ptr); Tcl_DecrRefCount(infoPtr->infoVars4Ptr); if (checkMemoryLeaks) { Tcl_DecrRefCount(infoPtr->infoVars2Ptr); Tcl_DecrRefCount(infoPtr->infoVars3Ptr); Tcl_DecrRefCount(infoPtr->infoVars4Ptr); /* see comment above */ } Tcl_DecrRefCount(infoPtr->typeDestructorArgumentPtr); Tcl_EvalEx(infoPtr->interp, "::oo::define ::itcl::clazz deletemethod unknown", -1, 0); /* first have to look for the remaining memory leaks, then remove the next ifdef */ #ifdef LATER Itcl_RenameCommand(infoPtr->interp, "::itcl::clazz", ""); /* tear down ::itcl namespace (this includes ::itcl::parser namespace) */ nsPtr = Tcl_FindNamespace(infoPtr->interp, "::itcl::parser", NULL, 0); if (nsPtr != NULL) { Tcl_DeleteNamespace(nsPtr); } nsPtr = Tcl_FindNamespace(infoPtr->interp, "::itcl::import", NULL, 0); if (nsPtr != NULL) { Tcl_DeleteNamespace(nsPtr); } nsPtr = Tcl_FindNamespace(infoPtr->interp, "::itcl::methodset", NULL, 0); if (nsPtr != NULL) { Tcl_DeleteNamespace(nsPtr); } nsPtr = Tcl_FindNamespace(infoPtr->interp, "::itcl::internal", NULL, 0); if (nsPtr != NULL) { Tcl_DeleteNamespace(nsPtr); } nsPtr = Tcl_FindNamespace(infoPtr->interp, "::itcl::builtin", NULL, 0); if (nsPtr != NULL) { Tcl_DeleteNamespace(nsPtr); } #endif /* remove the unknown method from top class */ if (infoPtr->unknownNamePtr != NULL) { Tcl_DecrRefCount(infoPtr->unknownNamePtr); } if (infoPtr->unknownArgumentPtr != NULL) { Tcl_DecrRefCount(infoPtr->unknownArgumentPtr); } if (infoPtr->unknownBodyPtr != NULL) { Tcl_DecrRefCount(infoPtr->unknownBodyPtr); } /* cleanup ensemble info */ ItclFinishEnsemble(infoPtr); ckfree((char *)infoPtr->object_meta_type); ckfree((char *)infoPtr->class_meta_type); Itcl_DeleteStack(&infoPtr->clsStack); Itcl_DeleteStack(&infoPtr->contextStack); Itcl_DeleteStack(&infoPtr->constructorStack); /* clean up list pool */ Itcl_FinishList(); Itcl_ReleaseData((ClientData)infoPtr); return result; }