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;
}
static Tcl_Obj *
GetConfigDict(
Tcl_Interp *interp)
{
Tcl_Obj *pDB = Tcl_GetAssocData(interp, ASSOC_KEY, NULL);
if (pDB == NULL) {
pDB = Tcl_NewDictObj();
Tcl_IncrRefCount(pDB);
Tcl_SetAssocData(interp, ASSOC_KEY, ConfigDictDeleteProc, pDB);
}
return pDB;
}
Tcl_Obj *
weechat_tcl_hashtable_to_dict (Tcl_Interp *interp,
struct t_hashtable *hashtable)
{
Tcl_Obj *dict;
void *data[2];
dict = Tcl_NewDictObj ();
if (!dict)
return NULL;
data[0] = interp;
data[1] = dict;
weechat_hashtable_map_string (hashtable, &weechat_tcl_hashtable_map_cb,
data);
return dict;
}
static int
resolveTypes(Tcl_Interp *interp) {
Tcl_Obj *objv[6];
Tcl_Obj *list;
Tcl_Obj *dict;
// определение типа lambdaExpr
objv[0]=Tcl_NewStringObj("apply",-1);
objv[1]=Tcl_NewStringObj("x { expr $x + 1}",-1);
objv[2]=Tcl_NewIntObj(1),-1;
Tcl_IncrRefCount(objv[0]);
Tcl_IncrRefCount(objv[1]);
Tcl_IncrRefCount(objv[2]);
if (Tcl_EvalObjv(interp,3,objv,0)!=TCL_OK) {
ERR("in call apply");
INSPECT_ARRAY(-1,3,objv,"command");
return TCL_ERROR;
}
cmdNameType=objv[0]->typePtr;
lambdaExprType=objv[1]->typePtr;
// определение типа List
list=Tcl_NewListObj(3,objv);
listType=list->typePtr;
if (listType==NULL || listType->name==NULL || listType->name[0]=='\0') {
ERR("in resolve listType");
return TCL_ERROR;
}
Tcl_DecrRefCount(list);
Tcl_DecrRefCount(objv[0]);
Tcl_DecrRefCount(objv[1]);
Tcl_DecrRefCount(objv[2]);
// определение типа dict
dict=Tcl_NewDictObj();
if (dict==NULL || dict->typePtr==NULL) {
ERR("in resolve dictType");
return TCL_ERROR;
}
dictType=dict->typePtr;
return TCL_OK;
}
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);
}
