/* ** 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); }