/* This function is used instead of the snack_sndfile_ext.tcl script in order
to generate the tcl variables that are needed by snack. Doing it here allows
keeping the formats always up to date with the current version of libsndfile
*/
int CreateTclVariablesForSnack(Tcl_Interp *interp)
{
int k, count ;
SF_FORMAT_INFO format_info ;
Tcl_Obj *scriptPtr = Tcl_NewStringObj("", 0);
Tcl_Obj *scriptPtr1 = Tcl_NewStringObj("", 0);
Tcl_Obj *scriptPtr2 = Tcl_NewStringObj("", 0);
Tcl_Obj *formatExtUC = Tcl_NewStringObj("", 0);
Tcl_AppendStringsToObj(scriptPtr,
"namespace eval snack::snack_sndfile_ext {\n",
" variable extTypes\n",
" variable loadTypes\n",
" variable loadKeys\n\n", (char *) NULL);
Tcl_AppendStringsToObj(scriptPtr1, " set extTypesMC {\n", (char *) NULL);
Tcl_AppendStringsToObj(scriptPtr2, " set loadTypes {\n", (char *) NULL);
sf_command (NULL, SFC_GET_FORMAT_MAJOR_COUNT, &count, sizeof (int));
for (k = 0 ; k < count ; k++) {
format_info.format = k ;
sf_command (NULL, SFC_GET_FORMAT_MAJOR, &format_info, sizeof (SF_FORMAT_INFO));
/* convert extension to upper case */
Tcl_SetStringObj(formatExtUC, format_info.extension, strlen(format_info.extension));
Tcl_UtfToUpper(Tcl_GetString(formatExtUC));
/* append to variable extTypesMC */
Tcl_AppendStringsToObj(scriptPtr1, " {{", format_info.name,
"} .", format_info.extension, "}\n", (char *) NULL);
/* append to variable loadTypes */
Tcl_AppendStringsToObj(scriptPtr2, " {{", format_info.name,
"} {.", format_info.extension,
" .", Tcl_GetString(formatExtUC),
"}}\n", (char *) NULL);
}
Tcl_AppendStringsToObj(scriptPtr1, " }\n\n", (char *) NULL);
Tcl_AppendStringsToObj(scriptPtr2, " }\n\n", (char *) NULL);
Tcl_AppendObjToObj(scriptPtr, scriptPtr1);
Tcl_AppendObjToObj(scriptPtr, scriptPtr2);
Tcl_AppendStringsToObj(scriptPtr,
" set extTypes [list]\n",
" set loadKeys [list]\n",
" foreach pair $extTypesMC {\n",
" set type [string toupper [lindex $pair 0]]\n",
" set ext [lindex $pair 1]\n",
" lappend extTypes [list $type $ext]\n",
" lappend loadKeys $type\n"
" }\n\n",
" snack::addLoadTypes $loadTypes $loadKeys\n",
" snack::addExtTypes $extTypes\n",
"}\n", (char *) NULL);
/* fprintf(stderr, "%s\n", Tcl_GetString(scriptPtr)); */
return Tcl_EvalObjEx(interp, scriptPtr, TCL_EVAL_DIRECT);
}
int
TclpFindVariable(
const char *name, /* Name of desired environment variable
* (UTF-8). */
int *lengthPtr) /* Used to return length of name (for
* successful searches) or number of non-NULL
* entries in environ (for unsuccessful
* searches). */
{
int i, length, result = -1;
register const char *env, *p1, *p2;
char *envUpper, *nameUpper;
Tcl_DString envString;
/*
* Convert the name to all upper case for the case insensitive comparison.
*/
length = strlen(name);
nameUpper = (char *) ckalloc((unsigned) length+1);
memcpy(nameUpper, name, (size_t) length+1);
Tcl_UtfToUpper(nameUpper);
Tcl_DStringInit(&envString);
for (i = 0, env = environ[i]; env != NULL; i++, env = environ[i]) {
/*
* Chop the env string off after the equal sign, then Convert the name
* to all upper case, so we do not have to convert all the characters
* after the equal sign.
*/
envUpper = Tcl_ExternalToUtfDString(NULL, env, -1, &envString);
p1 = strchr(envUpper, '=');
if (p1 == NULL) {
continue;
}
length = (int) (p1 - envUpper);
Tcl_DStringSetLength(&envString, length+1);
Tcl_UtfToUpper(envUpper);
p1 = envUpper;
p2 = nameUpper;
for (; *p2 == *p1; p1++, p2++) {
/* NULL loop body. */
}
if ((*p1 == '=') && (*p2 == '\0')) {
*lengthPtr = length;
result = i;
goto done;
}
Tcl_DStringFree(&envString);
}
*lengthPtr = i;
done:
Tcl_DStringFree(&envString);
ckfree(nameUpper);
return result;
}
