/*
** This routine is called when a database file is locked while trying
** to execute SQL.
*/
static int DbBusyHandler(void *cd, const char *zTable, int nTries){
SqliteDb *pDb = (SqliteDb*)cd;
int rc;
char zVal[30];
char *zCmd;
Tcl_DString cmd;
Tcl_DStringInit(&cmd);
Tcl_DStringAppend(&cmd, pDb->zBusy, -1);
Tcl_DStringAppendElement(&cmd, zTable);
sprintf(zVal, " %d", nTries);
Tcl_DStringAppend(&cmd, zVal, -1);
zCmd = Tcl_DStringValue(&cmd);
rc = Tcl_Eval(pDb->interp, zCmd);
Tcl_DStringFree(&cmd);
if( rc!=TCL_OK || atoi(Tcl_GetStringResult(pDb->interp)) ){
return 0;
}
return 1;
}
void
Tcl_SourceRCFile(
Tcl_Interp *interp) /* Interpreter to source rc file into. */
{
Tcl_DString temp;
const char *fileName;
Tcl_Channel chan;
fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY);
if (fileName != NULL) {
Tcl_Channel c;
const char *fullName;
Tcl_DStringInit(&temp);
fullName = Tcl_TranslateFileName(interp, fileName, &temp);
if (fullName == NULL) {
/*
* Couldn't translate the file name (e.g. it referred to a bogus
* user or there was no HOME environment variable). Just do
* nothing.
*/
} else {
/*
* Test for the existence of the rc file before trying to read it.
*/
c = Tcl_OpenFileChannel(NULL, fullName, "r", 0);
if (c != NULL) {
Tcl_Close(NULL, c);
if (Tcl_EvalFile(interp, fullName) != TCL_OK) {
chan = Tcl_GetStdChannel(TCL_STDERR);
if (chan) {
Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
Tcl_WriteChars(chan, "\n", 1);
}
}
}
}
Tcl_DStringFree(&temp);
}
}
/*-----------------------------------------------------------------------------
* ChmodFileNameObj --
* Change the mode of a file by name.
*
* Parameters:
* o interp - Pointer to the current interpreter, error messages will be
* returned in the result.
* o modeInfo - Infomation with the mode to set the file to.
* o fileName - Name of the file to change.
* Returns:
* TCL_OK or TCL_ERROR.
*-----------------------------------------------------------------------------
*/
static int
ChmodFileNameObj (Tcl_Interp *interp, modeInfo_t modeInfo, Tcl_Obj *fileNameObj)
{
char *filePath;
struct stat fileStat;
Tcl_DString pathBuf;
int newMode;
char *fileName;
Tcl_DStringInit (&pathBuf);
fileName = Tcl_GetStringFromObj (fileNameObj, NULL);
filePath = Tcl_TranslateFileName (interp, fileName, &pathBuf);
if (filePath == NULL) {
Tcl_DStringFree (&pathBuf);
return TCL_ERROR;
}
if (modeInfo.symMode != NULL) {
if (stat (filePath, &fileStat) != 0)
goto fileError;
newMode = ConvSymMode (interp, modeInfo.symMode,
fileStat.st_mode & 07777);
if (newMode < 0)
goto errorExit;
} else {
newMode = modeInfo.absMode;
}
if (TclXOSchmod (interp, filePath, (unsigned short) newMode) < 0)
return TCL_ERROR;
Tcl_DStringFree (&pathBuf);
return TCL_OK;
fileError:
TclX_AppendObjResult (interp, filePath, ": ",
Tcl_PosixError (interp), (char *) NULL);
errorExit:
Tcl_DStringFree (&pathBuf);
return TCL_ERROR;
}
char*
Tnm_SnmpMergeVBList(int varBindSize, SNMP_VarBind *varBindPtr)
{
static Tcl_DString list;
int i;
Tcl_DStringInit(&list);
for (i = 0; i < varBindSize; i++) {
Tcl_DStringStartSublist(&list);
Tcl_DStringAppendElement(&list,
varBindPtr[i].soid ? varBindPtr[i].soid : "");
Tcl_DStringAppendElement(&list,
varBindPtr[i].syntax ? varBindPtr[i].syntax : "");
Tcl_DStringAppendElement(&list,
varBindPtr[i].value ? varBindPtr[i].value : "");
Tcl_DStringEndSublist(&list);
}
return ckstrdup(Tcl_DStringValue(&list));
}
/*
** Usage: sqlite_get_table_printf DB FORMAT STRING
**
** Invoke the sqlite_get_table_printf() interface using the open database
** DB. The SQL is the string FORMAT. The format string should contain
** one %s or %q. STRING is the value inserted into %s or %q.
*/
static int test_get_table_printf(
void *NotUsed,
Tcl_Interp *interp, /* The TCL interpreter that invoked this command */
int argc, /* Number of arguments */
char **argv /* Text of each argument */
){
sqlite *db;
Tcl_DString str;
int rc;
char *zErr = 0;
int nRow, nCol;
char **aResult;
int i;
char zBuf[30];
if( argc!=4 ){
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" DB FORMAT STRING", 0);
return TCL_ERROR;
}
if( getDbPointer(interp, argv[1], &db) ) return TCL_ERROR;
Tcl_DStringInit(&str);
rc = sqlite_get_table_printf(db, argv[2], &aResult, &nRow, &nCol,
&zErr, argv[3]);
sprintf(zBuf, "%d", rc);
Tcl_AppendElement(interp, zBuf);
if( rc==SQLITE_OK ){
sprintf(zBuf, "%d", nRow);
Tcl_AppendElement(interp, zBuf);
sprintf(zBuf, "%d", nCol);
Tcl_AppendElement(interp, zBuf);
for(i=0; i<(nRow+1)*nCol; i++){
Tcl_AppendElement(interp, aResult[i] ? aResult[i] : "NULL");
}
}else{
Tcl_AppendElement(interp, zErr);
}
sqlite_free_table(aResult);
if( zErr ) free(zErr);
return TCL_OK;
}
SEXP dotTclcallback(SEXP args)
{
SEXP ans, callback = CADR(args), env;
char buff[BUFFLEN];
char *s;
Tcl_DString s_ds;
if (isFunction(callback))
callback_closure(buff, BUFFLEN, callback);
else if (isLanguage(callback)) {
env = CADDR(args);
callback_lang(buff, BUFFLEN, callback, env);
}
else
error(_("argument is not of correct type"));
Tcl_DStringInit(&s_ds);
s = Tcl_UtfToExternalDString(NULL, buff, -1, &s_ds);
ans = mkString(s);
Tcl_DStringFree(&s_ds);
return ans;
}
int ScriptTcl::Tcl_replicaEval(ClientData, Tcl_Interp *interp, int argc, char **argv) {
if ( argc != 3 ) {
Tcl_SetResult(interp,"args: dest script",TCL_VOLATILE);
return TCL_ERROR;
}
int dest = atoi(argv[1]);
CHECK_REPLICA(dest);
#if CMK_HAS_PARTITION
Tcl_DString recvstr;
Tcl_DStringInit(&recvstr);
DataMessage *recvMsg = NULL;
replica_eval(argv[2], dest, CkMyPe(), &recvMsg);
CmiAssert(recvMsg != NULL);
int code = recvMsg->code;
Tcl_DStringAppend(&recvstr, recvMsg->data, recvMsg->size);
Tcl_DStringResult(interp, &recvstr);
Tcl_DStringFree(&recvstr);
CmiFree(recvMsg);
return code;
#else
return Tcl_EvalEx(interp,argv[2],-1,TCL_EVAL_GLOBAL);
#endif
}
/* Provide mechanism for simulator to report which instruction
is being executed */
void report_pc(unsigned pc)
{
int status;
char addr[10];
char code[12];
Tcl_DString cmd;
Tcl_DStringInit(&cmd);
Tcl_DStringAppend(&cmd, "simLabel ", -1);
Tcl_DStringStartSublist(&cmd);
sprintf(addr, "%u", pc);
Tcl_DStringAppendElement(&cmd, addr);
Tcl_DStringEndSublist(&cmd);
Tcl_DStringStartSublist(&cmd);
sprintf(code, "%s","*");
Tcl_DStringAppend(&cmd, code, -1);
Tcl_DStringEndSublist(&cmd);
status = Tcl_Eval(sim_interp, Tcl_DStringValue(&cmd));
if (status != TCL_OK) {
fprintf(stderr, "Failed to report code '%s'\n", code);
fprintf(stderr, "Error Message was '%s'\n", sim_interp->result);
}
}
static Tcl_HashEntry *get_new_handle(Tcl_Interp *interp,
char *type)
{
static unsigned long int id_counter = 0;
Tcl_DString *handle;
char int_buf[ID_BUF_SIZE];
if (! (handle = malloc(sizeof(*handle)))) {
Tcl_SetResult(interp, memory_error, TCL_STATIC);
return 0;
}
Tcl_DStringInit(handle);
assert(id_counter <= MAX_ID);
sprintf(int_buf, "%d", id_counter++);
Tcl_DStringAppend(handle, type, -1);
Tcl_DStringAppend(handle, SEP_STR, -1);
Tcl_DStringAppend(handle, int_buf, -1);
return handle;
}
static int
SourceInitFiles(Tcl_Interp *interp)
{
char *fileName;
const char *library;
Tcl_DString dst;
library = Tcl_GetVar2(interp, "tnm", "library", TCL_GLOBAL_ONLY);
if (! library) {
Tcl_Panic("Tnm Tcl variable tnm(library) undefined.");
}
Tcl_DStringInit(&dst);
Tcl_DStringAppend(&dst, library, -1);
Tcl_DStringAppend(&dst, "/library/init.tcl", -1);
if (Tcl_EvalFile(interp, Tcl_DStringValue(&dst)) != TCL_OK) {
Tcl_DStringFree(&dst);
return TCL_ERROR;
}
Tcl_DStringFree(&dst);
/*
* Load the user specific startup file. Check whether we
* have a readable startup file so that we only complain
* about errors when we are expected to complain.
*/
fileName = getenv("TNM_RCFILE");
if (fileName) {
SourceRcFile(interp, fileName);
} else {
if (! SourceRcFile(interp, "~/.tnmrc")) {
SourceRcFile(interp, "~/.scottyrc");
}
}
return TCL_OK;
}
/********************************************************************************************
* test_File
* purpose : This function replaces the "file" command of the TCL, to ensure that
* when checking if a file exists, we also look inside our buffers.
* input : clientData - used for creating new command in tcl
* interp - interpreter for tcl commands
* argc - number of parameters entered to the new command
* argv - the parameters entered to the tcl command
* output : none
* return : TCL_OK
********************************************************************************************/
int test_File(ClientData clientData, Tcl_Interp *interp,int argc, char *argv[])
{
int i, retCode;
Tcl_DString str;
if ((argc == 3) && (strncmp(argv[1], "exis", 4)) == 0)
{
/* "file exist" command - overloaded... */
if (tclGetFile(argv[2]) != NULL)
{
Tcl_SetResult(interp, (char *)"1", TCL_STATIC);
return TCL_OK;
}
}
/* Continue executing the real "file" command */
Tcl_DStringInit(&str);
Tcl_DStringAppendElement(&str, "fileOverloaded");
for(i = 1; i < argc; i++)
Tcl_DStringAppendElement(&str, argv[i]);
retCode = Tcl_Eval(interp, Tcl_DStringValue(&str));
Tcl_DStringFree(&str);
return retCode;
}
static void dns_tcl_iporhostres(sockname_t *ip, char *hostn, int ok, void *other)
{
devent_tclinfo_t *tclinfo = (devent_tclinfo_t *) other;
Tcl_DString list;
Tcl_DStringInit(&list);
Tcl_DStringAppendElement(&list, tclinfo->proc);
Tcl_DStringAppendElement(&list, iptostr(&ip->addr.sa));
Tcl_DStringAppendElement(&list, hostn);
Tcl_DStringAppendElement(&list, ok ? "1" : "0");
if (tclinfo->paras) {
EGG_CONST char *argv[2];
char *output;
argv[0] = Tcl_DStringValue(&list);
argv[1] = tclinfo->paras;
output = Tcl_Concat(2, argv);
if (Tcl_Eval(interp, output) == TCL_ERROR) {
putlog(LOG_MISC, "*", DCC_TCLERROR, tclinfo->proc, tcl_resultstring());
Tcl_BackgroundError(interp);
}
Tcl_Free(output);
} else if (Tcl_Eval(interp, Tcl_DStringValue(&list)) == TCL_ERROR) {
putlog(LOG_MISC, "*", DCC_TCLERROR, tclinfo->proc, tcl_resultstring());
Tcl_BackgroundError(interp);
}
Tcl_DStringFree(&list);
nfree(tclinfo->proc);
if (tclinfo->paras)
nfree(tclinfo->paras);
nfree(tclinfo);
}
/*
** This is a second alternative callback for database queries. A the
** first column of the first row of the result is made the TCL result.
*/
static int DbEvalCallback3(
void *clientData, /* An instance of CallbackData */
int nCol, /* Number of columns in the result */
char ** azCol, /* Data for each column */
char ** azN /* Name for each column */
){
Tcl_Interp *interp = (Tcl_Interp*)clientData;
Tcl_Obj *pElem;
if( azCol==0 ) return 1;
if( nCol==0 ) return 1;
#ifdef UTF_TRANSLATION_NEEDED
{
Tcl_DString dCol;
Tcl_DStringInit(&dCol);
Tcl_ExternalToUtfDString(NULL, azCol[0], -1, &dCol);
pElem = Tcl_NewStringObj(Tcl_DStringValue(&dCol), -1);
Tcl_DStringFree(&dCol);
}
#else
pElem = Tcl_NewStringObj(azCol[0], -1);
#endif
Tcl_SetObjResult(interp, pElem);
return 1;
}
/*int GetRenzInfo(ClientData clientData, Tcl_Interp *interp, int argc, char **argv) {
int num_entry;
int i;
char buf[1024];
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"",
argv[0], " filename\"", (char*)NULL);
return TCL_ERROR;
}
if (!renzymes) {
free_renzymes (renzymes);
}
renzymes = get_enzyme(argv[1]);
printf("num_entry=%d\n", renzymes->used);
if (!renzymes)
return TCL_OK;
num_entry = renzymes->used;
Tcl_ResetResult(interp);
for (i = 0; i < num_entry; i++) {
sprintf(buf, "%s {%s} %s %s %.0f",renzymes->renzyme[i]->name,
renzymes->renzyme[i]->rec_seq_text,
renzymes->renzyme[i]->prototype,
renzymes->renzyme[i]->supplier_codes,
renzymes->renzyme[i]->av_frag_size);
Tcl_AppendElement(interp, buf);
}
return TCL_OK;
}
*/
int GetRenzInfo(ClientData clientData, Tcl_Interp *interp, int argc, char **argv) {
int num_entry;
int i;
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"",
argv[0], " filename\"", (char*)NULL);
return TCL_ERROR;
}
if (!renzymes) {
free_renzymes (renzymes);
}
renzymes = get_enzyme(argv[1]);
/* printf("num_entry=%d\n", renzymes->used); */
if (!renzymes)
return TCL_OK;
num_entry = renzymes->used;
Tcl_ResetResult(interp);
for (i = 0; i < num_entry; i++) {
Tcl_DString dstr;
Tcl_DStringInit(&dstr);
vTcl_DStringAppendElement(&dstr, "%s", renzymes->renzyme[i]->name);
vTcl_DStringAppendElement(&dstr, "%s", renzymes->renzyme[i]->rec_seq_text);
vTcl_DStringAppendElement(&dstr, "%s", renzymes->renzyme[i]->prototype);
vTcl_DStringAppendElement(&dstr, "%s", renzymes->renzyme[i]->supplier_codes);
vTcl_DStringAppendElement(&dstr, "%.f", renzymes->renzyme[i]->av_frag_size);
Tcl_AppendElement(interp, Tcl_DStringValue(&dstr));
Tcl_DStringFree(&dstr);
}
return TCL_OK;
}
static void overloadedGlobFunction(
sqlite3_context *pContext,
int nArg,
sqlite3_value **apArg
){
Tcl_Interp *interp = sqlite3_user_data(pContext);
Tcl_DString str;
int i;
int rc;
Tcl_DStringInit(&str);
Tcl_DStringAppendElement(&str, "::echo_glob_overload");
for(i=0; i<nArg; i++){
Tcl_DStringAppendElement(&str, (char*)sqlite3_value_text(apArg[i]));
}
rc = Tcl_Eval(interp, Tcl_DStringValue(&str));
Tcl_DStringFree(&str);
if( rc ){
sqlite3_result_error(pContext, Tcl_GetStringResult(interp), -1);
}else{
sqlite3_result_text(pContext, Tcl_GetStringResult(interp),
-1, SQLITE_TRANSIENT);
}
Tcl_ResetResult(interp);
}
static HRESULT
BuildMoniker(
const char *name,
LPMONIKER *ppmk)
{
LPMONIKER pmkClass = NULL;
HRESULT hr = CreateFileMoniker(TKWINSEND_REGISTRATION_BASE, &pmkClass);
if (SUCCEEDED(hr)) {
LPMONIKER pmkItem = NULL;
Tcl_DString dString;
Tcl_DStringInit(&dString);
Tcl_UtfToUniCharDString(name, -1, &dString);
hr = CreateFileMoniker((LPOLESTR)Tcl_DStringValue(&dString), &pmkItem);
Tcl_DStringFree(&dString);
if (SUCCEEDED(hr)) {
hr = pmkClass->lpVtbl->ComposeWith(pmkClass, pmkItem, FALSE, ppmk);
pmkItem->lpVtbl->Release(pmkItem);
}
pmkClass->lpVtbl->Release(pmkClass);
}
return hr;
}
int
TclpFindVariable(
CONST char *name, /* Name of desired environment variable
* (native). */
int *lengthPtr) /* Used to return length of name (for
* successful searches) or number of non-NULL
* entries in environ (for unsuccessful
* searches). */
{
int i, result = -1;
register CONST char *env, *p1, *p2;
Tcl_DString envString;
Tcl_DStringInit(&envString);
for (i = 0, env = environ[i]; env != NULL; i++, env = environ[i]) {
p1 = Tcl_ExternalToUtfDString(NULL, env, -1, &envString);
p2 = name;
for (; *p2 == *p1; p1++, p2++) {
/* NULL loop body. */
}
if ((*p1 == '=') && (*p2 == '\0')) {
*lengthPtr = p2 - name;
result = i;
goto done;
}
Tcl_DStringFree(&envString);
}
*lengthPtr = i;
done:
Tcl_DStringFree(&envString);
return result;
}
int
TclpMatchInDirectory(
Tcl_Interp *interp, /* Interpreter to receive errors. */
Tcl_Obj *resultPtr, /* List object to lappend results. */
Tcl_Obj *pathPtr, /* Contains path to directory to search. */
const char *pattern, /* Pattern to match against. */
Tcl_GlobTypeData *types) /* Object containing list of acceptable types.
* May be NULL. In particular the directory
* flag is very important. */
{
const char *native;
Tcl_Obj *fileNamePtr;
int matchResult = 0;
if (types != NULL && types->type == TCL_GLOB_TYPE_MOUNT) {
/*
* The native filesystem never adds mounts.
*/
return TCL_OK;
}
fileNamePtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
if (fileNamePtr == NULL) {
return TCL_ERROR;
}
if (pattern == NULL || (*pattern == '\0')) {
/*
* Match a file directly.
*/
Tcl_Obj *tailPtr;
const char *nativeTail;
native = Tcl_FSGetNativePath(pathPtr);
tailPtr = TclPathPart(interp, pathPtr, TCL_PATH_TAIL);
nativeTail = Tcl_FSGetNativePath(tailPtr);
matchResult = NativeMatchType(interp, native, nativeTail, types);
if (matchResult == 1) {
Tcl_ListObjAppendElement(interp, resultPtr, pathPtr);
}
Tcl_DecrRefCount(tailPtr);
Tcl_DecrRefCount(fileNamePtr);
} else {
DIR *d;
Tcl_DirEntry *entryPtr;
const char *dirName;
int dirLength, nativeDirLen;
int matchHidden, matchHiddenPat;
Tcl_StatBuf statBuf;
Tcl_DString ds; /* native encoding of dir */
Tcl_DString dsOrig; /* utf-8 encoding of dir */
Tcl_DStringInit(&dsOrig);
dirName = TclGetStringFromObj(fileNamePtr, &dirLength);
Tcl_DStringAppend(&dsOrig, dirName, dirLength);
/*
* Make sure that the directory part of the name really is a
* directory. If the directory name is "", use the name "." instead,
* because some UNIX systems don't treat "" like "." automatically.
* Keep the "" for use in generating file names, otherwise "glob
* foo.c" would return "./foo.c".
*/
if (dirLength == 0) {
dirName = ".";
} else {
dirName = Tcl_DStringValue(&dsOrig);
/*
* Make sure we have a trailing directory delimiter.
*/
if (dirName[dirLength-1] != '/') {
dirName = TclDStringAppendLiteral(&dsOrig, "/");
dirLength++;
}
}
/*
* Now open the directory for reading and iterate over the contents.
*/
native = Tcl_UtfToExternalDString(NULL, dirName, -1, &ds);
if ((TclOSstat(native, &statBuf) != 0) /* INTL: Native. */
|| !S_ISDIR(statBuf.st_mode)) {
Tcl_DStringFree(&dsOrig);
Tcl_DStringFree(&ds);
Tcl_DecrRefCount(fileNamePtr);
return TCL_OK;
}
d = opendir(native); /* INTL: Native. */
if (d == NULL) {
Tcl_DStringFree(&ds);
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read directory \"%s\": %s",
Tcl_DStringValue(&dsOrig), Tcl_PosixError(interp)));
}
Tcl_DStringFree(&dsOrig);
Tcl_DecrRefCount(fileNamePtr);
return TCL_ERROR;
}
nativeDirLen = Tcl_DStringLength(&ds);
/*
* Check to see if -type or the pattern requests hidden files.
*/
matchHiddenPat = (pattern[0] == '.')
|| ((pattern[0] == '\\') && (pattern[1] == '.'));
matchHidden = matchHiddenPat
|| (types && (types->perm & TCL_GLOB_PERM_HIDDEN));
while ((entryPtr = TclOSreaddir(d)) != NULL) { /* INTL: Native. */
Tcl_DString utfDs;
const char *utfname;
/*
* Skip this file if it doesn't agree with the hidden parameters
* requested by the user (via -type or pattern).
*/
if (*entryPtr->d_name == '.') {
if (!matchHidden) {
continue;
}
} else {
#ifdef MAC_OSX_TCL
if (matchHiddenPat) {
continue;
}
/* Also need to check HFS hidden flag in TclMacOSXMatchType. */
#else
if (matchHidden) {
continue;
}
#endif
}
/*
* Now check to see if the file matches, according to both type
* and pattern. If so, add the file to the result.
*/
utfname = Tcl_ExternalToUtfDString(NULL, entryPtr->d_name, -1,
&utfDs);
if (Tcl_StringCaseMatch(utfname, pattern, 0)) {
int typeOk = 1;
if (types != NULL) {
Tcl_DStringSetLength(&ds, nativeDirLen);
native = Tcl_DStringAppend(&ds, entryPtr->d_name, -1);
matchResult = NativeMatchType(interp, native,
entryPtr->d_name, types);
typeOk = (matchResult == 1);
}
if (typeOk) {
Tcl_ListObjAppendElement(interp, resultPtr,
TclNewFSPathObj(pathPtr, utfname,
Tcl_DStringLength(&utfDs)));
}
}
Tcl_DStringFree(&utfDs);
if (matchResult < 0) {
break;
}
}
closedir(d);
Tcl_DStringFree(&ds);
Tcl_DStringFree(&dsOrig);
Tcl_DecrRefCount(fileNamePtr);
}
if (matchResult < 0) {
return TCL_ERROR;
}
return TCL_OK;
}
int init_sip_similar_spans_create(Tcl_Interp *interp,
int seq_id_h,
int seq_id_v,
int start_h,
int end_h,
int start_v,
int end_v,
int win_len,
int min_match,
int *id)
{
in_comp_spans *input = NULL;
int *seq1_match = NULL;
int *seq2_match = NULL;
int *match_score = NULL;
int n_matches;
char *seq1, *seq2;
int seq1_len, seq2_len;
int same_seq;
int max_matches = get_max_matches();
int seq1_num, seq2_num;
int seq1_type, seq2_type;
int sub1_len, sub2_len;
Tcl_DString input_params;
vfuncheader("find similar spans");
if (NULL == (seq1_match = (int *)xmalloc(max_matches * sizeof(int))))
goto error;
if (NULL == (seq2_match = (int *)xmalloc(max_matches * sizeof(int))))
goto error;
if (NULL == (match_score = (int *)xmalloc(max_matches * sizeof(int))))
goto error;
if (NULL == (input = (in_comp_spans *)xmalloc(sizeof(in_comp_spans))))
goto error;
/* get first and second sequence saved using extract_sequence */
seq1_num = GetSeqNum(seq_id_h);
seq2_num = GetSeqNum(seq_id_v);
if (seq1_num == -1) {
verror(ERR_WARN, "find similar spans", "horizontal sequence undefined");
goto error;
} else if (seq2_num == -1) {
verror(ERR_WARN, "find similar spans", "vertical sequence undefined");
goto error;
}
seq1 = GetSeqSequence(seq1_num);
seq2 = GetSeqSequence(seq2_num);
seq1_len = GetSeqLength(seq1_num);
seq2_len = GetSeqLength(seq2_num);
seq1_type = GetSeqType(seq1_num);
seq2_type = GetSeqType(seq2_num);
if (end_h == -1)
end_h = seq1_len;
if (end_v == -1)
end_v = seq2_len;
if (seq1_type != seq2_type) {
verror(ERR_WARN, "find similar spans", "sequences must both be either DNA or protein");
return TCL_OK;
} else if (seq1_type == PROTEIN) {
set_char_set(PROTEIN);
set_score_matrix(get_matrix_file(PROTEIN));
} else if (seq1_type == DNA) {
set_char_set(DNA);
set_score_matrix(get_matrix_file(DNA));
}
/*
* first check if seq lengths are equal, if not the seqs cannot be the
* same
*/
/*
* Should check length of sub sequences only. These lengths are not
* stored, so have to calculate them here. Not storing them in
* seq1_len and seq2_len as I'm unsure whether subsequent functions
* expect the length of the whole sequence. Anyway, the compare_spans
* function recalculates the lengths of the sub sequences before doing
* the comparison.
*/
sub1_len = end_h - start_h + 1;
sub2_len = end_v - start_v + 1;
if (sub1_len == sub2_len) {
if (strncmp(seq1 + start_h - 1, seq2 + start_v - 1, sub1_len) == 0) {
same_seq = 1;
} else {
same_seq = 0;
}
} else {
same_seq = 0;
}
if (!get_remove_dup() && same_seq)
same_seq = 0;
Compare_Spans(seq1, seq2, seq1_len, seq2_len, start_h, end_h,
start_v, end_v, max_matches, same_seq,
win_len, min_match, 1, 0,
&seq1_match, &seq2_match, &match_score, &n_matches);
/* n_matches == -1 if malloc problem or -2 if too many matches */
if (n_matches == -2) {
verror(ERR_WARN, "find similar spans", "too many matches");
goto error;
} else if (n_matches == -1) {
goto error;
} else if (n_matches == 0) {
verror(ERR_WARN, "Find similar spans", "no matches found\n");
if (seq1_match)
xfree (seq1_match);
if (seq2_match)
xfree (seq2_match);
if (match_score)
xfree(match_score);
if (input)
xfree(input);
return -1;
}
/* create inputs parameters */
Tcl_DStringInit(&input_params);
vTcl_DStringAppend(&input_params, "horizontal %s: %s \nvertical %s: %s\n"
"window length %d min match %d number of matches %d",
GetSeqLibraryName(seq1_num),
GetSeqName(seq1_num),
GetSeqLibraryName(seq2_num),
GetSeqName(seq2_num),
win_len, min_match, n_matches);
vfuncparams("%s", Tcl_DStringValue(&input_params));
input->params = strdup(Tcl_DStringValue(&input_params));
Tcl_DStringFree(&input_params);
if (-1 == (*id = store_sip_similar_spans(seq1_num, seq2_num, win_len,
min_match, start_h, end_h,
start_v, end_v,
seq1_match, seq2_match,
match_score, n_matches,
input))) {
goto error;
}
if (seq1_match)
xfree (seq1_match);
if (seq2_match)
xfree (seq2_match);
if (match_score)
xfree(match_score);
return 0;
error:
verror(ERR_WARN, "find similar spans", "failure in find similar spans");
if (seq1_match)
xfree (seq1_match);
if (seq2_match)
xfree (seq2_match);
if (match_score)
xfree(match_score);
if (input)
xfree(input);
return -1;
}
void
TkpDisplayScale(
ClientData clientData) /* Widget record for scale. */
{
TkScale *scalePtr = (TkScale *) clientData;
Tk_Window tkwin = scalePtr->tkwin;
Tcl_Interp *interp = scalePtr->interp;
Pixmap pixmap;
int result;
char string[PRINT_CHARS];
XRectangle drawnArea;
Tcl_DString buf;
scalePtr->flags &= ~REDRAW_PENDING;
if ((scalePtr->tkwin == NULL) || !Tk_IsMapped(scalePtr->tkwin)) {
goto done;
}
/*
* Invoke the scale's command if needed.
*/
Tcl_Preserve(scalePtr);
if ((scalePtr->flags & INVOKE_COMMAND) && (scalePtr->command != NULL)) {
Tcl_Preserve(interp);
sprintf(string, scalePtr->format, scalePtr->value);
Tcl_DStringInit(&buf);
Tcl_DStringAppend(&buf, scalePtr->command, -1);
Tcl_DStringAppend(&buf, " ", -1);
Tcl_DStringAppend(&buf, string, -1);
result = Tcl_EvalEx(interp, Tcl_DStringValue(&buf), -1, 0);
Tcl_DStringFree(&buf);
if (result != TCL_OK) {
Tcl_AddErrorInfo(interp, "\n (command executed by scale)");
Tcl_BackgroundException(interp, result);
}
Tcl_Release(interp);
}
scalePtr->flags &= ~INVOKE_COMMAND;
if (scalePtr->flags & SCALE_DELETED) {
Tcl_Release(scalePtr);
return;
}
Tcl_Release(scalePtr);
#ifndef TK_NO_DOUBLE_BUFFERING
/*
* In order to avoid screen flashes, this function redraws the scale in a
* pixmap, then copies the pixmap to the screen in a single operation.
* This means that there's no point in time where the on-sreen image has
* been cleared.
*/
pixmap = Tk_GetPixmap(scalePtr->display, Tk_WindowId(tkwin),
Tk_Width(tkwin), Tk_Height(tkwin), Tk_Depth(tkwin));
#else
pixmap = Tk_WindowId(tkwin);
#endif /* TK_NO_DOUBLE_BUFFERING */
drawnArea.x = 0;
drawnArea.y = 0;
drawnArea.width = Tk_Width(tkwin);
drawnArea.height = Tk_Height(tkwin);
/*
* Much of the redisplay is done totally differently for horizontal and
* vertical scales. Handle the part that's different.
*/
if (scalePtr->orient == ORIENT_VERTICAL) {
DisplayVerticalScale(scalePtr, pixmap, &drawnArea);
} else {
DisplayHorizontalScale(scalePtr, pixmap, &drawnArea);
}
/*
* Now handle the part of redisplay that is the same for horizontal and
* vertical scales: border and traversal highlight.
*/
if (scalePtr->flags & REDRAW_OTHER) {
if (scalePtr->relief != TK_RELIEF_FLAT) {
Tk_Draw3DRectangle(tkwin, pixmap, scalePtr->bgBorder,
scalePtr->highlightWidth, scalePtr->highlightWidth,
Tk_Width(tkwin) - 2*scalePtr->highlightWidth,
Tk_Height(tkwin) - 2*scalePtr->highlightWidth,
scalePtr->borderWidth, scalePtr->relief);
}
if (scalePtr->highlightWidth != 0) {
GC gc;
if (scalePtr->flags & GOT_FOCUS) {
gc = Tk_GCForColor(scalePtr->highlightColorPtr, pixmap);
} else {
gc = Tk_GCForColor(
Tk_3DBorderColor(scalePtr->highlightBorder), pixmap);
}
Tk_DrawFocusHighlight(tkwin, gc, scalePtr->highlightWidth, pixmap);
}
}
#ifndef TK_NO_DOUBLE_BUFFERING
/*
* Copy the information from the off-screen pixmap onto the screen, then
* delete the pixmap.
*/
XCopyArea(scalePtr->display, pixmap, Tk_WindowId(tkwin),
scalePtr->copyGC, drawnArea.x, drawnArea.y, drawnArea.width,
drawnArea.height, drawnArea.x, drawnArea.y);
Tk_FreePixmap(scalePtr->display, pixmap);
#endif /* TK_NO_DOUBLE_BUFFERING */
done:
scalePtr->flags &= ~REDRAW_ALL;
}
int
NsTclEnvCmd(ClientData dummy, Tcl_Interp *interp, int argc, char **argv)
{
char *name, *value, **envp;
int status, i;
Tcl_DString ds;
if (argc < 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"",
argv[0], " command ?args ...?\"", NULL);
return TCL_ERROR;
}
status = TCL_OK;
Ns_MutexLock(&lock);
if (STREQ(argv[1], "names")) {
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"",
argv[0], " names\"", NULL);
status = TCL_ERROR;
} else {
Tcl_DStringInit(&ds);
envp = Ns_GetEnviron();
for (i = 0; envp[i] != NULL; ++i) {
name = envp[i];
value = strchr(name, '=');
Tcl_DStringAppend(&ds, name, value ? value - name : -1);
Tcl_AppendElement(interp, ds.string);
Tcl_DStringTrunc(&ds, 0);
}
Tcl_DStringFree(&ds);
}
} else if (STREQ(argv[1], "exists")) {
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"",
argv[0], " exists name\"", NULL);
status = TCL_ERROR;
} else {
Tcl_SetResult(interp, getenv(argv[2]) ? "1" : "0", TCL_STATIC);
}
} else if (STREQ(argv[1], "get")) {
if ((argc != 3 && argc != 4) ||
(argc == 4 && !STREQ(argv[2], "-nocomplain"))) {
badargs:
Tcl_AppendResult(interp, "wrong # args: should be \"",
argv[0], " ", argv[1], " ?-nocomplain? name\"", NULL);
status = TCL_ERROR;
}
name = argv[argc-1];
value = getenv(name);
if (value != NULL) {
Tcl_SetResult(interp, value, TCL_VOLATILE);
} else if (argc == 4) {
Tcl_AppendResult(interp, "no such environment variable: ",
argv[argc-1], NULL);
status = TCL_ERROR;
}
} else if (STREQ(argv[1], "set")) {
if (argc != 4) {
Tcl_AppendResult(interp, "wrong # args: should be \"",
argv[0], " set name value\"", NULL);
status = TCL_ERROR;
} else {
status = PutEnv(interp, argv[2], argv[3]);
}
} else if (STREQ(argv[1], "unset")) {
if ((argc != 3 && argc != 4) ||
(argc == 4 && !STREQ(argv[2], "-nocomplain"))) {
goto badargs;
}
name = argv[argc-1];
if (argc == 3 && getenv(name) == NULL) {
Tcl_AppendResult(interp, "no such environment variable: ", name,
NULL);
status = TCL_ERROR;
} else {
status = PutEnv(interp, name, "");
}
} else {
Tcl_AppendResult(interp, "unknown command \"",
argv[1], "\": should be exists, names, get, set, or unset", NULL);
status = TCL_ERROR;
}
Ns_MutexUnlock(&lock);
return status;
}
/* v is an array of TkArg */
CAMLprim value camltk_tcl_direct_eval(value v)
{
int i;
int size; /* size of argv */
char **argv, **allocated;
int result;
Tcl_CmdInfo info;
CheckInit();
/* walk the array to compute final size for Tcl */
for(i=0, size=0; i<Wosize_val(v); i++)
size += argv_size(Field(v,i));
/* +2: one slot for NULL
one slot for "unknown" if command not found */
argv = (char **)stat_alloc((size + 2) * sizeof(char *));
allocated = (char **)stat_alloc(size * sizeof(char *));
/* Copy -- argv[i] must be freed by stat_free */
{
int where;
for(i=0, where=0; i<Wosize_val(v); i++){
where = fill_args(argv,where,Field(v,i));
}
if( size != where ){ tk_error("fill_args error!!! Call the CamlTk maintainer!"); }
for(i=0; i<where; i++){ allocated[i] = argv[i]; }
argv[size] = NULL;
argv[size + 1] = NULL;
}
/* Eval */
Tcl_ResetResult(cltclinterp);
if (Tcl_GetCommandInfo(cltclinterp,argv[0],&info)) { /* command found */
#if (TCL_MAJOR_VERSION >= 8)
/* info.proc might be a NULL pointer
* We should probably attempt an Obj invocation, but the following quick
* hack is easier.
*/
if (info.proc == NULL) {
Tcl_DString buf;
Tcl_DStringInit(&buf);
Tcl_DStringAppend(&buf, argv[0], -1);
for (i=1; i<size; i++) {
Tcl_DStringAppend(&buf, " ", -1);
Tcl_DStringAppend(&buf, argv[i], -1);
}
result = Tcl_Eval(cltclinterp, Tcl_DStringValue(&buf));
Tcl_DStringFree(&buf);
} else {
result = (*info.proc)(info.clientData,cltclinterp,size,argv);
}
#else
result = (*info.proc)(info.clientData,cltclinterp,size,argv);
#endif
} else { /* implement the autoload stuff */
if (Tcl_GetCommandInfo(cltclinterp,"unknown",&info)) { /* unknown found */
for (i = size; i >= 0; i--)
argv[i+1] = argv[i];
argv[0] = "unknown";
result = (*info.proc)(info.clientData,cltclinterp,size+1,argv);
} else { /* ah, it isn't there at all */
result = TCL_ERROR;
Tcl_AppendResult(cltclinterp, "Unknown command \"",
argv[0], "\"", NULL);
}
}
/* Free the various things we allocated */
for(i=0; i< size; i ++){
stat_free((char *) allocated[i]);
}
stat_free((char *)argv);
stat_free((char *)allocated);
switch (result) {
case TCL_OK:
return tcl_string_to_caml (Tcl_GetStringResult(cltclinterp));
case TCL_ERROR:
tk_error(Tcl_GetStringResult(cltclinterp));
default: /* TCL_BREAK, TCL_CONTINUE, TCL_RETURN */
tk_error("bad tcl result");
}
}
/* Implement ide_winprint print_text. */
static int
winprint_print_command (ClientData cd, Tcl_Interp *interp, int argc,
char **argv)
{
struct winprint_data *wd = (struct winprint_data *) cd;
char *queryproc;
char *textproc;
struct print_text_options pto;
PRINTDLG pd;
int cancelled;
int top, bottom, left;
TEXTMETRIC tm;
POINT pt;
int lineheight;
int pageno;
int error=0, done, needquery;
struct {
short len; /* Defined to be 16 bits.... */
char buffer[PRINT_BUFSIZE+1];
} indata;
queryproc = argv[2];
textproc = argv[3];
if (winprint_print_text_options (wd, interp, argc, argv, &pto) != TCL_OK)
return TCL_ERROR;
if (winprint_print_text_dialog (wd, interp, &pto, &pd, &cancelled) != TCL_OK)
return TCL_ERROR;
if (cancelled)
return TCL_OK;
if (pto.postscript)
{
int eps_printing = 33;
int result;
short bresult = 1; /* EPS printing download suppressed */
result = Escape (pd.hDC, eps_printing, sizeof (BOOL), (LPCSTR)&bresult, NULL);
if ( result < 0 )
{
/* The EPSPRINTING escape failed! */
Tcl_AppendElement(interp,
"ide_winprint: EPSPRINTING escape implemented but failed");
DeleteDC (pd.hDC);
return TCL_ERROR;
}
}
else
{
winprint_get_margins(wd, &pd, &top, &left, &bottom);
}
if (winprint_start (wd, interp, &pd, &pto, &cancelled) != TCL_OK)
{
DeleteDC (pd.hDC);
return TCL_ERROR;
}
if (cancelled)
{
DeleteDC (pd.hDC);
return TCL_OK;
}
/* init and start init-procedure if available */
if (pto.initproc != NULL)
{
Tcl_DString initStr;
char buf[64];
Tcl_DStringInit (&initStr);
Tcl_DStringAppend (&initStr, pto.initproc, -1);
/* Here we must pass the customer selection from the PrintDialog
* as parameters for the init command, */
/* From page */
Tcl_DStringAppendElement (&initStr, "-frompage");
sprintf (buf, "%i", pd.nFromPage);
Tcl_DStringAppendElement (&initStr, buf);
/* To Page */
Tcl_DStringAppendElement (&initStr, "-topage");
sprintf (buf, "%i", pd.nToPage);
Tcl_DStringAppendElement (&initStr, buf);
/* # Copies */
Tcl_DStringAppendElement (&initStr, "-copies");
sprintf (buf, "%i", pd.nCopies);
Tcl_DStringAppendElement (&initStr, buf);
/* Print Selection? */
Tcl_DStringAppendElement (&initStr, "-selection");
Tcl_DStringAppendElement (&initStr, (pd.Flags&PD_SELECTION) ? "1" : "0");
/* Execute tcl/command */
if (Tcl_Eval (interp, Tcl_DStringValue(&initStr)) != TCL_OK)
{
Tcl_DStringFree (&initStr);
return TCL_ERROR;
}
Tcl_DStringFree (&initStr);
}
if (pto.postscript)
{
Tcl_DString pageStr;
int status, retval, len, i;
char *l, msgbuf[128];
enum winprint_query q = 0;
/* Note: NT 4.0 seems to leave the default CTM quite tiny! */
strcpy (indata.buffer, "\r\nsave\r\ninitmatrix\r\n");
indata.len = strlen(indata.buffer);
Escape(pd.hDC, PASSTHROUGH, 0, (LPCSTR)&indata, NULL);
/* Init command for page-procedure */
if (pto.pageproc != NULL)
{
Tcl_DStringInit (&pageStr);
Tcl_DStringAppend (&pageStr, pto.pageproc, -1);
Tcl_DStringAppendElement (&pageStr, "-1");
}
/* Start printing */
while (1)
{
/* Run page-procedure to update the display */
status = winprint_print_text_invoke (interp, Tcl_DStringValue(&pageStr), "page", &q);
if (status != TCL_OK || q == Q_DONE)
{
error = 1;
break;
}
/* query next characters to send to printer */
if (winprint_print_text_invoke (interp, queryproc, "query", &q) != TCL_OK)
{
error = 1;
break;
}
if (q != Q_CONTINUE)
{
done = 1;
break;
}
if (Tcl_Eval (interp, textproc) == TCL_ERROR)
{
error = 1;
break;
}
l = Tcl_GetStringFromObj (Tcl_GetObjResult (interp), &len);
for (i=0; i<len; i+=PRINT_BUFSIZE)
{
int lpos = min (PRINT_BUFSIZE, len-i);
strncpy (indata.buffer, l+i, lpos);
indata.buffer[lpos] = 0;
indata.len = lpos;
retval = Escape (pd.hDC, PASSTHROUGH, 0, (LPCSTR)&indata, NULL);
if (retval < 0)
{
Tcl_AppendElement(interp, "ide_winprint: PASSTHROUGH Escape failed");
error = 1;
break;
}
else if (retval != indata.len)
{
sprintf(msgbuf, "ide_winprint: Short write (%d vs. %d)", retval, indata.len);
Tcl_AppendElement(interp, msgbuf);
error = 1;
break;
}
}
}
strcpy (indata.buffer, "\r\nrestore\r\n");
indata.len = strlen(indata.buffer);
Escape(pd.hDC, PASSTHROUGH, 0, (LPCSTR)&indata, NULL);
}
else
{
GetTextMetrics (pd.hDC, &tm);
pt.x = 0;
pt.y = tm.tmHeight + tm.tmExternalLeading;
LPtoDP (pd.hDC, &pt, 1);
lineheight = pt.y;
pageno = 1;
/* The main print loop. */
done = 0;
error = 0;
needquery = 1;
while (1)
{
int y;
if (wd->aborted)
break;
/* Start a new page. */
if (pto.pageproc != NULL)
{
Tcl_DString ds;
char buf[20];
enum winprint_query q;
int status;
Tcl_DStringInit (&ds);
Tcl_DStringAppend (&ds, pto.pageproc, -1);
sprintf (buf, "%d", pageno);
Tcl_DStringAppendElement (&ds, buf);
status = winprint_print_text_invoke (interp, Tcl_DStringValue (&ds),
"page", &q);
Tcl_DStringFree (&ds);
if (status != TCL_OK)
{
error = 1;
break;
}
if (q == Q_DONE)
{
done = 1;
break;
}
}
if (needquery)
{
enum winprint_query q;
if (winprint_print_text_invoke (interp, queryproc, "query", &q)
!= TCL_OK)
{
error = 1;
break;
}
if (q == Q_DONE)
{
done = 1;
break;
}
/* Ignore Q_NEWPAGE, since we're about to start a new page
anyhow. */
needquery = 0;
}
if (StartPage (pd.hDC) <= 0)
{
windows_error (interp, "StartPage");
error = 1;
break;
}
y = top;
/* Print a page. */
while (1)
{
char *l;
int len;
enum winprint_query q;
if (Tcl_Eval (interp, textproc) == TCL_ERROR)
{
error = 1;
break;
}
l = Tcl_GetStringFromObj (Tcl_GetObjResult (interp), &len);
TextOut (pd.hDC, left, y, l, len);
y += lineheight;
if (y >= bottom)
{
needquery = 1;
break;
}
if (winprint_print_text_invoke (interp, queryproc, "query", &q)
!= TCL_OK)
{
error = 1;
break;
}
if (q == Q_DONE)
{
done = 1;
break;
}
else if (q == Q_NEWPAGE)
break;
}
if (error)
break;
if (EndPage (pd.hDC) <= 0)
{
/* It's OK for EndPage to return an error if the print job
was cancelled. */
if (! wd->aborted)
{
windows_error (interp, "EndPage");
error = 1;
}
break;
}
if (done)
break;
++pageno;
}
}
if (winprint_finish (wd, interp, &pd, error) != TCL_OK)
error = 1;
if (error)
return TCL_ERROR;
Tcl_ResetResult (interp);
return TCL_OK;
}
void
TclpSetVariables(
Tcl_Interp *interp)
{
#ifndef NO_UNAME
struct utsname name;
#endif
int unameOK;
Tcl_DString ds;
#ifdef HAVE_COREFOUNDATION
char tclLibPath[MAXPATHLEN + 1];
#if MAC_OS_X_VERSION_MAX_ALLOWED > 1020
/*
* Set msgcat fallback locale to current CFLocale identifier.
*/
CFLocaleRef localeRef;
if (CFLocaleCopyCurrent != NULL && CFLocaleGetIdentifier != NULL &&
(localeRef = CFLocaleCopyCurrent())) {
CFStringRef locale = CFLocaleGetIdentifier(localeRef);
if (locale) {
char loc[256];
if (CFStringGetCString(locale, loc, 256, kCFStringEncodingUTF8)) {
if (!Tcl_CreateNamespace(interp, "::tcl::mac", NULL, NULL)) {
Tcl_ResetResult(interp);
}
Tcl_SetVar(interp, "::tcl::mac::locale", loc, TCL_GLOBAL_ONLY);
}
}
CFRelease(localeRef);
}
#endif /* MAC_OS_X_VERSION_MAX_ALLOWED > 1020 */
if (MacOSXGetLibraryPath(interp, MAXPATHLEN, tclLibPath) == TCL_OK) {
CONST char *str;
CFBundleRef bundleRef;
Tcl_SetVar(interp, "tclDefaultLibrary", tclLibPath, TCL_GLOBAL_ONLY);
Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath, TCL_GLOBAL_ONLY);
Tcl_SetVar(interp, "tcl_pkgPath", " ",
TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
str = TclGetEnv("DYLD_FRAMEWORK_PATH", &ds);
if ((str != NULL) && (str[0] != '\0')) {
char *p = Tcl_DStringValue(&ds);
/*
* Convert DYLD_FRAMEWORK_PATH from colon to space separated.
*/
do {
if (*p == ':') {
*p = ' ';
}
} while (*p++);
Tcl_SetVar(interp, "tcl_pkgPath", Tcl_DStringValue(&ds),
TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
Tcl_SetVar(interp, "tcl_pkgPath", " ",
TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
Tcl_DStringFree(&ds);
}
bundleRef = CFBundleGetMainBundle();
if (bundleRef) {
CFURLRef frameworksURL;
Tcl_StatBuf statBuf;
frameworksURL = CFBundleCopyPrivateFrameworksURL(bundleRef);
if (frameworksURL) {
if (CFURLGetFileSystemRepresentation(frameworksURL, TRUE,
(unsigned char*) tclLibPath, MAXPATHLEN) &&
! TclOSstat(tclLibPath, &statBuf) &&
S_ISDIR(statBuf.st_mode)) {
Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath,
TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
Tcl_SetVar(interp, "tcl_pkgPath", " ",
TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
}
CFRelease(frameworksURL);
}
frameworksURL = CFBundleCopySharedFrameworksURL(bundleRef);
if (frameworksURL) {
if (CFURLGetFileSystemRepresentation(frameworksURL, TRUE,
(unsigned char*) tclLibPath, MAXPATHLEN) &&
! TclOSstat(tclLibPath, &statBuf) &&
S_ISDIR(statBuf.st_mode)) {
Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath,
TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
Tcl_SetVar(interp, "tcl_pkgPath", " ",
TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
}
CFRelease(frameworksURL);
}
}
Tcl_SetVar(interp, "tcl_pkgPath", pkgPath,
TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
} else
#endif /* HAVE_COREFOUNDATION */
{
Tcl_SetVar(interp, "tcl_pkgPath", pkgPath, TCL_GLOBAL_ONLY);
}
#ifdef DJGPP
Tcl_SetVar2(interp, "tcl_platform", "platform", "dos", TCL_GLOBAL_ONLY);
#else
Tcl_SetVar2(interp, "tcl_platform", "platform", "unix", TCL_GLOBAL_ONLY);
#endif
unameOK = 0;
#ifndef NO_UNAME
if (uname(&name) >= 0) {
CONST char *native;
unameOK = 1;
native = Tcl_ExternalToUtfDString(NULL, name.sysname, -1, &ds);
Tcl_SetVar2(interp, "tcl_platform", "os", native, TCL_GLOBAL_ONLY);
Tcl_DStringFree(&ds);
/*
* The following code is a special hack to handle differences in the
* way version information is returned by uname. On most systems the
* full version number is available in name.release. However, under
* AIX the major version number is in name.version and the minor
* version number is in name.release.
*/
if ((strchr(name.release, '.') != NULL)
|| !isdigit(UCHAR(name.version[0]))) { /* INTL: digit */
Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.release,
TCL_GLOBAL_ONLY);
} else {
#ifdef DJGPP
/*
* For some obscure reason DJGPP puts major version into
* name.release and minor into name.version. As of DJGPP 2.04 this
* is documented in djgpp libc.info file.
*/
Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.release,
TCL_GLOBAL_ONLY);
Tcl_SetVar2(interp, "tcl_platform", "osVersion", ".",
TCL_GLOBAL_ONLY|TCL_APPEND_VALUE);
Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.version,
TCL_GLOBAL_ONLY|TCL_APPEND_VALUE);
#else
Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.version,
TCL_GLOBAL_ONLY);
Tcl_SetVar2(interp, "tcl_platform", "osVersion", ".",
TCL_GLOBAL_ONLY|TCL_APPEND_VALUE);
Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.release,
TCL_GLOBAL_ONLY|TCL_APPEND_VALUE);
#endif /* DJGPP */
}
Tcl_SetVar2(interp, "tcl_platform", "machine", name.machine,
TCL_GLOBAL_ONLY);
}
#endif /* !NO_UNAME */
if (!unameOK) {
Tcl_SetVar2(interp, "tcl_platform", "os", "", TCL_GLOBAL_ONLY);
Tcl_SetVar2(interp, "tcl_platform", "osVersion", "", TCL_GLOBAL_ONLY);
Tcl_SetVar2(interp, "tcl_platform", "machine", "", TCL_GLOBAL_ONLY);
}
/*
* Copy the username of the real user (according to getuid()) into
* tcl_platform(user).
*/
{
struct passwd *pwEnt = TclpGetPwUid(getuid());
const char *user;
if (pwEnt == NULL) {
user = "";
Tcl_DStringInit(&ds); /* ensure cleanliness */
} else {
user = Tcl_ExternalToUtfDString(NULL, pwEnt->pw_name, -1, &ds);
}
Tcl_SetVar2(interp, "tcl_platform", "user", user, TCL_GLOBAL_ONLY);
Tcl_DStringFree(&ds);
}
}
CONST char *
Tcl_GetEncodingNameFromEnvironment(
Tcl_DString *bufPtr)
{
CONST char *encoding;
CONST char *knownEncoding;
Tcl_DStringInit(bufPtr);
/*
* Determine the current encoding from the LC_* or LANG environment
* variables. We previously used setlocale() to determine the locale, but
* this does not work on some systems (e.g. Linux/i386 RH 5.0).
*/
#ifdef HAVE_LANGINFO
if (
#ifdef WEAK_IMPORT_NL_LANGINFO
nl_langinfo != NULL &&
#endif
setlocale(LC_CTYPE, "") != NULL) {
Tcl_DString ds;
/*
* Use a DString so we can modify case.
*/
Tcl_DStringInit(&ds);
encoding = Tcl_DStringAppend(&ds, nl_langinfo(CODESET), -1);
Tcl_UtfToLower(Tcl_DStringValue(&ds));
knownEncoding = SearchKnownEncodings(encoding);
if (knownEncoding != NULL) {
Tcl_DStringAppend(bufPtr, knownEncoding, -1);
} else if (NULL != Tcl_GetEncoding(NULL, encoding)) {
Tcl_DStringAppend(bufPtr, encoding, -1);
}
Tcl_DStringFree(&ds);
if (Tcl_DStringLength(bufPtr)) {
return Tcl_DStringValue(bufPtr);
}
}
#endif /* HAVE_LANGINFO */
/*
* Classic fallback check. This tries a homebrew algorithm to determine
* what encoding should be used based on env vars.
*/
encoding = getenv("LC_ALL");
if (encoding == NULL || encoding[0] == '\0') {
encoding = getenv("LC_CTYPE");
}
if (encoding == NULL || encoding[0] == '\0') {
encoding = getenv("LANG");
}
if (encoding == NULL || encoding[0] == '\0') {
encoding = NULL;
}
if (encoding != NULL) {
CONST char *p;
Tcl_DString ds;
Tcl_DStringInit(&ds);
p = encoding;
encoding = Tcl_DStringAppend(&ds, p, -1);
Tcl_UtfToLower(Tcl_DStringValue(&ds));
knownEncoding = SearchKnownEncodings(encoding);
if (knownEncoding != NULL) {
Tcl_DStringAppend(bufPtr, knownEncoding, -1);
} else if (NULL != Tcl_GetEncoding(NULL, encoding)) {
Tcl_DStringAppend(bufPtr, encoding, -1);
}
if (Tcl_DStringLength(bufPtr)) {
Tcl_DStringFree(&ds);
return Tcl_DStringValue(bufPtr);
}
/*
* We didn't recognize the full value as an encoding name. If there is
* an encoding subfield, we can try to guess from that.
*/
for (p = encoding; *p != '\0'; p++) {
if (*p == '.') {
p++;
break;
}
}
if (*p != '\0') {
knownEncoding = SearchKnownEncodings(p);
if (knownEncoding != NULL) {
Tcl_DStringAppend(bufPtr, knownEncoding, -1);
} else if (NULL != Tcl_GetEncoding(NULL, p)) {
Tcl_DStringAppend(bufPtr, p, -1);
}
}
Tcl_DStringFree(&ds);
if (Tcl_DStringLength(bufPtr)) {
return Tcl_DStringValue(bufPtr);
}
}
return Tcl_DStringAppend(bufPtr, TCL_DEFAULT_ENCODING, -1);
}
void
TclpFindExecutable(
const char *argv0) /* The value of the application's argv[0]
* (native). */
{
Tcl_Encoding encoding;
#ifdef __CYGWIN__
int length;
char buf[PATH_MAX * 2];
char name[PATH_MAX * TCL_UTF_MAX + 1];
GetModuleFileNameW(NULL, buf, PATH_MAX);
cygwin_conv_path(3, buf, name, PATH_MAX);
length = strlen(name);
if ((length > 4) && !strcasecmp(name + length - 4, ".exe")) {
/* Strip '.exe' part. */
length -= 4;
}
encoding = Tcl_GetEncoding(NULL, NULL);
TclSetObjNameOfExecutable(
Tcl_NewStringObj(name, length), encoding);
#else
const char *name, *p;
Tcl_StatBuf statBuf;
Tcl_DString buffer, nameString, cwd, utfName;
if (argv0 == NULL) {
return;
}
Tcl_DStringInit(&buffer);
name = argv0;
for (p = name; *p != '\0'; p++) {
if (*p == '/') {
/*
* The name contains a slash, so use the name directly without
* doing a path search.
*/
goto gotName;
}
}
p = getenv("PATH"); /* INTL: Native. */
if (p == NULL) {
/*
* There's no PATH environment variable; use the default that is used
* by sh.
*/
p = ":/bin:/usr/bin";
} else if (*p == '\0') {
/*
* An empty path is equivalent to ".".
*/
p = "./";
}
/*
* Search through all the directories named in the PATH variable to see if
* argv[0] is in one of them. If so, use that file name.
*/
while (1) {
while (TclIsSpaceProc(*p)) {
p++;
}
name = p;
while ((*p != ':') && (*p != 0)) {
p++;
}
TclDStringClear(&buffer);
if (p != name) {
Tcl_DStringAppend(&buffer, name, p - name);
if (p[-1] != '/') {
TclDStringAppendLiteral(&buffer, "/");
}
}
name = Tcl_DStringAppend(&buffer, argv0, -1);
/*
* INTL: The following calls to access() and stat() should not be
* converted to Tclp routines because they need to operate on native
* strings directly.
*/
if ((access(name, X_OK) == 0) /* INTL: Native. */
&& (TclOSstat(name, &statBuf) == 0) /* INTL: Native. */
&& S_ISREG(statBuf.st_mode)) {
goto gotName;
}
if (*p == '\0') {
break;
} else if (*(p+1) == 0) {
p = "./";
} else {
p++;
}
}
TclSetObjNameOfExecutable(Tcl_NewObj(), NULL);
goto done;
/*
* If the name starts with "/" then just store it
*/
gotName:
#ifdef DJGPP
if (name[1] == ':')
#else
if (name[0] == '/')
#endif
{
encoding = Tcl_GetEncoding(NULL, NULL);
Tcl_ExternalToUtfDString(encoding, name, -1, &utfName);
TclSetObjNameOfExecutable(
Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), encoding);
Tcl_DStringFree(&utfName);
goto done;
}
if (TclpGetCwd(NULL, &cwd) == NULL) {
TclSetObjNameOfExecutable(Tcl_NewObj(), NULL);
goto done;
}
/*
* The name is relative to the current working directory. First strip off
* a leading "./", if any, then add the full path name of the current
* working directory.
*/
if ((name[0] == '.') && (name[1] == '/')) {
name += 2;
}
Tcl_DStringInit(&nameString);
Tcl_DStringAppend(&nameString, name, -1);
Tcl_DStringFree(&buffer);
Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(&cwd),
Tcl_DStringLength(&cwd), &buffer);
if (Tcl_DStringValue(&cwd)[Tcl_DStringLength(&cwd) -1] != '/') {
TclDStringAppendLiteral(&buffer, "/");
}
Tcl_DStringFree(&cwd);
TclDStringAppendDString(&buffer, &nameString);
Tcl_DStringFree(&nameString);
encoding = Tcl_GetEncoding(NULL, NULL);
Tcl_ExternalToUtfDString(encoding, Tcl_DStringValue(&buffer), -1,
&utfName);
TclSetObjNameOfExecutable(
Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), encoding);
Tcl_DStringFree(&utfName);
done:
Tcl_DStringFree(&buffer);
#endif
}
static void
TransferXEventsToTcl(
Display *display)
{
union {
int type;
XEvent x;
TkKeyEvent k;
} event;
Window w;
TkDisplay *dispPtr = NULL;
/*
* Transfer events from the X event queue to the Tk event queue after XIM
* event filtering. KeyPress and KeyRelease events need special treatment
* so that they get directed according to Tk's focus rules during XIM
* handling. Theoretically they can go to the wrong place still (if
* there's a focus change in the queue) but if we push the handling off
* until Tk_HandleEvent then many input methods actually cease to work
* correctly. Most of the time, Tk processes its event queue fast enough
* for this to not be an issue anyway. [Bug 1924761]
*/
while (QLength(display) > 0) {
XNextEvent(display, &event.x);
w = None;
if (event.type == KeyPress || event.type == KeyRelease) {
for (dispPtr = TkGetDisplayList(); ; dispPtr = dispPtr->nextPtr) {
if (dispPtr == NULL) {
break;
} else if (dispPtr->display == event.x.xany.display) {
if (dispPtr->focusPtr != NULL) {
w = dispPtr->focusPtr->window;
}
break;
}
}
}
if (XFilterEvent(&event.x, w)) {
continue;
}
if (event.type == KeyPress || event.type == KeyRelease) {
event.k.charValuePtr = NULL;
event.k.charValueLen = 0;
event.k.keysym = NoSymbol;
/*
* Force the calling of the input method engine now. The results
* from it will be cached in the event so that they don't get lost
* (to a race condition with other XIM-handled key events) between
* entering the event queue and getting serviced. [Bug 1924761]
*/
#ifdef TK_USE_INPUT_METHODS
if (event.type == KeyPress && dispPtr &&
(dispPtr->flags & TK_DISPLAY_USE_IM)) {
if (dispPtr->focusPtr && dispPtr->focusPtr->inputContext) {
Tcl_DString ds;
Tcl_DStringInit(&ds);
(void) TkpGetString(dispPtr->focusPtr, &event.x, &ds);
Tcl_DStringFree(&ds);
}
}
#endif
}
Tk_QueueWindowEvent(&event.x, TCL_QUEUE_TAIL);
}
}
int
cross_services(ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
char **argv) /* Argument strings. */
{
Tcl_CmdInfo infoPtr;
ClientData wcdata;
Tcl_CmdProc* wcmd;
char *wname;
char *command, *contents;
int pargc, i, size;
char *pline, *q;
int result, ret = TCL_OK;
wname = argv[1];
if (wname[0])
{
if (!Tcl_GetCommandInfo(interp, wname, &infoPtr))
{
Tcl_AppendResult(interp, "wrong # \"",
wname, "\" does not exist", (char *) NULL);
return TCL_ERROR;
}
wcdata = infoPtr.clientData;
wcmd = (Tcl_CmdProc *)infoPtr.proc;
}
Tcl_ResetResult (interp);
pargc = 2;
command = argv[pargc++];
contents = argv[pargc++];
if (argc == 12 && *command == 'f' && strcmp (command, "filter") == 0)
{
char *refartStr, *testline, *shown_scopes, *ref_access;
char *file = NULL;
enum RefTypes refart;
char **tfields, **lfields=NULL, **oldfields=NULL;
char *tmpline;
int tmpline_size = 512;
int uniq, have, accept_static, accept_param, fsize, tsize;
int AddRefArt=0;
int length;
char *line[line_arg_count], AddRefartStr[16] = {0};
Tcl_DString res, erg;
refartStr = argv[pargc++];
testline = argv[pargc++];
uniq = atoi (argv[pargc++]);
have = atoi (argv[pargc++]);
accept_param = atoi (argv[pargc++]);
accept_static= atoi (argv[pargc++]);
shown_scopes = argv[pargc++];
ref_access = argv[pargc++];
if (accept_static)
{
/* Information to the actual scope */
if (Tcl_SplitList (interp, testline, &tsize, &tfields) != TCL_OK)
{
return TCL_ERROR;
}
file = tfields[file1_pos];
}
if (strcmp (refartStr, "to") == 0)
{
refart = REF_TO;
}
else
{
refart = REF_BY;
}
/* init some variables */
for (i=0; i<line_arg_count; i++)
{
line[i] = "";
}
Tcl_DStringInit(&res);
Tcl_DStringInit(&erg);
tmpline = (char*)ckalloc (tmpline_size); tmpline[0] = 0;
for (length=strlen(contents), q = contents; 1;)
{
char *prevlist = q;
result = TclFindElement(interp, q, length, &pline, &q, &size, NULL);
if (result != TCL_OK || size == 0)
{
break;
}
length -= q - prevlist;
if (size > tmpline_size)
{
tmpline_size += size;
tmpline = ckrealloc (tmpline, tmpline_size);
}
memcpy (tmpline, pline, size);
tmpline[size] = 0;
if (Tcl_SplitList (interp, tmpline, &fsize, &lfields) != TCL_OK)
{
continue;
}
if (fsize != DB_COUNT)
{
ckfree ((char*)lfields);
continue;
}
if (*shown_scopes && strstr (shown_scopes, lfields[DB_SCP2]) == NULL)
{
continue;
}
if (*ref_access && strstr (ref_access, lfields[DB_REFA]) == NULL)
{
continue;
}
if (uniq && oldfields)
{
if (strcmp (oldfields[DB_CLS2], lfields[DB_CLS2]) == 0 &&
strcmp (oldfields[DB_SYM2], lfields[DB_SYM2]) == 0 &&
strcmp (oldfields[DB_SCP2], lfields[DB_SCP2]) == 0 &&
(! accept_param ||
(accept_param && strcmp (oldfields[DB_PRM2], lfields[DB_PRM2]) == 0)))
{
if (!AddRefartStr[0] ||
(lfields[DB_REFA][0] && strchr (AddRefartStr, lfields[DB_REFA][0]) == NULL))
{
strcat (AddRefartStr, lfields[DB_REFA]);
}
ckfree ((char *) lfields);
continue;
}
}
/* Static functions and variables */
if (accept_static && refart == REF_TO && lfields[DB_REFA][0] != 0 && ! cross_is_type_with_classes(lfields[DB_SCP2]))
{
int attr;
if (Tcl_GetInt(interp, lfields[DB_REFA], &attr) == TCL_OK &&
(! (attr&PAF_STATIC) || strcmp (lfields[DB_FILE], file) != 0))
{
ckfree ((char*)lfields);
continue;
}
}
if (have)
{
ckfree ((char *) lfields);
Tcl_DStringAppendElement (&erg, "yes");
break;
}
if (AddRefArt)
{
Tcl_DStringAppendElement(&res, AddRefartStr);
Tcl_DStringAppendElement(&erg, Tcl_DStringValue(&res));
}
else
{
AddRefArt = 1;
}
strcpy (AddRefartStr, lfields[DB_REFA]);
line[class1_pos] = lfields[DB_CLS2];
line[item1_pos] = lfields[DB_SYM2];
line[what1_pos] = lfields[DB_SCP2];
line[param1_pos] = lfields[DB_PRM2];
line[file_pos] = lfields[DB_FILE];
line[file_line_pos] = lfields[DB_LINE];
Tcl_DStringFree (&res);
for (i=0; i<refart_pos; i++)
{
Tcl_DStringAppendElement (&res, line[i]);
}
/* Store last line */
if (oldfields)
{
ckfree ((char*)oldfields);
}
oldfields = lfields;
}
if (AddRefArt)
{
Tcl_DStringAppendElement(&res, AddRefartStr);
Tcl_DStringAppendElement(&erg, Tcl_DStringValue(&res));
AddRefartStr[0] = 0;
}
Tcl_DStringFree (&res);
if (accept_static)
{
ckfree ((char*)tfields);
}
if (oldfields)
{
ckfree ((char*)oldfields);
}
ckfree (tmpline);
Tcl_DStringResult(interp, &erg);
Tcl_DStringFree (&erg);
}
else if (argc == 7 && *command == 'i' && strcmp (command, "insert") == 0)
{
}
else
{
char tmp[32];
sprintf (tmp, "%i", argc);
Tcl_AppendResult(interp, "wrong # args(", tmp, "): should be \"", argv[0],
" filter \"\" contents RefArt line unique have accept_param accept_static shown_scopes ref_access |\n"
"insert widget contents RefArt id line\n",
"\"",
(char *) NULL);
ret = TCL_ERROR;
}
return ret;
}
char *
Tk_SetAppName(
Tk_Window tkwin, /* Token for any window in the application
* to be named: it is just used to identify
* the application and the display. */
char *name) /* The name that will be used to
* refer to the interpreter in later
* "send" commands. Must be globally
* unique. */
{
TkWindow *winPtr = (TkWindow *) tkwin;
Tcl_Interp *interp = winPtr->mainPtr->interp;
int i, suffix, offset, result;
int createCommand = 0;
RegisteredInterp *riPtr, *prevPtr;
char *actualName;
Tcl_DString dString;
Tcl_Obj *resultObjPtr, *interpNamePtr;
char *interpName;
if (!initialized) {
SendInit(interp);
}
/*
* See if the application is already registered; if so, remove its
* current name from the registry. The deletion of the command
* will take care of disposing of this entry.
*/
for (riPtr = interpListPtr, prevPtr = NULL; riPtr != NULL;
prevPtr = riPtr, riPtr = riPtr->nextPtr) {
if (riPtr->interp == interp) {
if (prevPtr == NULL) {
interpListPtr = interpListPtr->nextPtr;
} else {
prevPtr->nextPtr = riPtr->nextPtr;
}
break;
}
}
/*
* Pick a name to use for the application. Use "name" if it's not
* already in use. Otherwise add a suffix such as " #2", trying
* larger and larger numbers until we eventually find one that is
* unique.
*/
actualName = name;
suffix = 1;
offset = 0;
Tcl_DStringInit(&dString);
TkGetInterpNames(interp, tkwin);
resultObjPtr = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(resultObjPtr);
for (i = 0; ; ) {
result = Tcl_ListObjIndex(NULL, resultObjPtr, i, &interpNamePtr);
if (interpNamePtr == NULL) {
break;
}
interpName = Tcl_GetStringFromObj(interpNamePtr, NULL);
if (strcmp(actualName, interpName) == 0) {
if (suffix == 1) {
Tcl_DStringAppend(&dString, name, -1);
Tcl_DStringAppend(&dString, " #", 2);
offset = Tcl_DStringLength(&dString);
Tcl_DStringSetLength(&dString, offset + 10);
actualName = Tcl_DStringValue(&dString);
}
suffix++;
sprintf(actualName + offset, "%d", suffix);
i = 0;
} else {
i++;
}
}
Tcl_DecrRefCount(resultObjPtr);
Tcl_ResetResult(interp);
/*
* We have found a unique name. Now add it to the registry.
*/
riPtr = (RegisteredInterp *) ckalloc(sizeof(RegisteredInterp));
riPtr->interp = interp;
riPtr->name = ckalloc(strlen(actualName) + 1);
riPtr->nextPtr = interpListPtr;
interpListPtr = riPtr;
strcpy(riPtr->name, actualName);
Tcl_CreateObjCommand(interp, "send", Tk_SendObjCmd,
(ClientData) riPtr, NULL /* TODO: DeleteProc */);
if (Tcl_IsSafe(interp)) {
Tcl_HideCommand(interp, "send", "send");
}
Tcl_DStringFree(&dString);
return riPtr->name;
}
void
TclpInitLibraryPath(
char **valuePtr,
int *lengthPtr,
Tcl_Encoding *encodingPtr)
{
#define LIBRARY_SIZE 32
Tcl_Obj *pathPtr, *objPtr;
CONST char *str;
Tcl_DString buffer;
pathPtr = Tcl_NewObj();
/*
* Look for the library relative to the TCL_LIBRARY env variable. If the
* last dirname in the TCL_LIBRARY path does not match the last dirname in
* the installLib variable, use the last dir name of installLib in
* addition to the orginal TCL_LIBRARY path.
*/
str = getenv("TCL_LIBRARY"); /* INTL: Native. */
Tcl_ExternalToUtfDString(NULL, str, -1, &buffer);
str = Tcl_DStringValue(&buffer);
if ((str != NULL) && (str[0] != '\0')) {
Tcl_DString ds;
int pathc;
CONST char **pathv;
char installLib[LIBRARY_SIZE];
Tcl_DStringInit(&ds);
/*
* Initialize the substrings used when locating an executable. The
* installLib variable computes the path as though the executable is
* installed.
*/
sprintf(installLib, "lib/tcl%s", TCL_VERSION);
/*
* If TCL_LIBRARY is set, search there.
*/
objPtr = Tcl_NewStringObj(str, -1);
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
Tcl_SplitPath(str, &pathc, &pathv);
if ((pathc > 0) && (strcasecmp(installLib + 4, pathv[pathc-1]) != 0)) {
/*
* If TCL_LIBRARY is set but refers to a different tcl
* installation than the current version, try fiddling with the
* specified directory to make it refer to this installation by
* removing the old "tclX.Y" and substituting the current version
* string.
*/
pathv[pathc - 1] = installLib + 4;
str = Tcl_JoinPath(pathc, pathv, &ds);
objPtr = Tcl_NewStringObj(str, Tcl_DStringLength(&ds));
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
Tcl_DStringFree(&ds);
}
ckfree((char *) pathv);
}
/*
* Finally, look for the library relative to the compiled-in path. This is
* needed when users install Tcl with an exec-prefix that is different
* from the prefix.
*/
{
#ifdef HAVE_COREFOUNDATION
char tclLibPath[MAXPATHLEN + 1];
if (MacOSXGetLibraryPath(NULL, MAXPATHLEN, tclLibPath) == TCL_OK) {
str = tclLibPath;
} else
#endif /* HAVE_COREFOUNDATION */
{
/*
* TODO: Pull this value from the TIP 59 table.
*/
str = defaultLibraryDir;
}
if (str[0] != '\0') {
objPtr = Tcl_NewStringObj(str, -1);
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
}
}
Tcl_DStringFree(&buffer);
*encodingPtr = Tcl_GetEncoding(NULL, NULL);
str = Tcl_GetStringFromObj(pathPtr, lengthPtr);
*valuePtr = ckalloc((unsigned int) (*lengthPtr)+1);
memcpy(*valuePtr, str, (size_t)(*lengthPtr)+1);
Tcl_DecrRefCount(pathPtr);
}
