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;
}
static int
TestchmodCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
int i, mode;
char *rest;
if (argc < 2) {
usage:
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" mode file ?file ...?", NULL);
return TCL_ERROR;
}
mode = (int) strtol(argv[1], &rest, 8);
if ((rest == argv[1]) || (*rest != '\0')) {
goto usage;
}
for (i = 2; i < argc; i++) {
Tcl_DString buffer;
const char *translated;
translated = Tcl_TranslateFileName(interp, argv[i], &buffer);
if (translated == NULL) {
return TCL_ERROR;
}
if (TestplatformChmod(translated, mode) != 0) {
Tcl_AppendResult(interp, translated, ": ", Tcl_PosixError(interp),
NULL);
return TCL_ERROR;
}
Tcl_DStringFree(&buffer);
}
return TCL_OK;
}
char *
TclpGetUserHome(
CONST char *name, /* User name for desired home directory. */
Tcl_DString *bufferPtr) /* Uninitialized or free DString filled with
* name of user's home directory. */
{
struct passwd *pwPtr;
Tcl_DString ds;
CONST char *native;
native = Tcl_UtfToExternalDString(NULL, name, -1, &ds);
pwPtr = getpwnam(native); /* INTL: Native. */
Tcl_DStringFree(&ds);
if (pwPtr == NULL) {
endpwent();
return NULL;
}
Tcl_ExternalToUtfDString(NULL, pwPtr->pw_dir, -1, bufferPtr);
endpwent();
return Tcl_DStringValue(bufferPtr);
}
TWAPI_EXTERN WCHAR *ObjToWinChars(Tcl_Obj *objP)
{
WinChars *rep;
Tcl_DString ds;
int nbytes, len;
char *utf8;
if (objP->typePtr == &gWinCharsType)
return WinCharsGet(objP)->chars;
utf8 = ObjToStringN(objP, &nbytes);
Tcl_WinUtfToTChar(utf8, nbytes, &ds);
len = Tcl_DStringLength(&ds) / sizeof(WCHAR);
rep = WinCharsNew((WCHAR *) Tcl_DStringValue(&ds), len);
Tcl_DStringFree(&ds);
/* Convert the passed object's internal rep */
if (objP->typePtr && objP->typePtr->freeIntRepProc)
objP->typePtr->freeIntRepProc(objP);
WinCharsSet(objP, rep);
return rep->chars;
}
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
}
static int
GetWinFileAttributes(
Tcl_Interp *interp, /* The interp we are using for errors. */
int objIndex, /* The index of the attribute. */
CONST char *fileName, /* The name of the file. */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
DWORD result;
Tcl_DString ds;
TCHAR *nativeName;
nativeName = Tcl_WinUtfToTChar(fileName, -1, &ds);
result = (*tclWinProcs->getFileAttributesProc)(nativeName);
Tcl_DStringFree(&ds);
if (result == 0xffffffff) {
StatError(interp, fileName);
return TCL_ERROR;
}
*attributePtrPtr = Tcl_NewBooleanObj(result & attributeArray[objIndex]);
return TCL_OK;
}
/*-----------------------------------------------------------------------------
* EvalTrapCode --
* Run code as the result of a signal. The symbolic signal name is
* formatted into the command replacing %S with the symbolic signal name.
*
* Parameters:
* o interp - The interpreter to run the signal in. If an error
* occures, then the result will be left in the interp.
* o signalNum - The signal number of the signal that occured.
* Return:
* TCL_OK or TCL_ERROR.
*-----------------------------------------------------------------------------
*/
static int
EvalTrapCode (Tcl_Interp *interp, int signalNum)
{
int result;
Tcl_DString command;
Tcl_Obj *saveObjPtr;
saveObjPtr = TclX_SaveResultErrorInfo (interp);
Tcl_ResetResult (interp);
/*
* Format the signal name into the command. This also allows the signal
* to be reset in the command.
*/
result = FormatTrapCode (interp,
signalNum,
&command);
if (result == TCL_OK)
result = Tcl_GlobalEval (interp,
command.string);
Tcl_DStringFree (&command);
if (result == TCL_ERROR) {
char errorInfo [128];
sprintf (errorInfo, "\n while executing signal trap code for %s%s",
Tcl_SignalId (signalNum), " signal");
Tcl_AddErrorInfo (interp, errorInfo);
return TCL_ERROR;
}
TclX_RestoreResultErrorInfo (interp, saveObjPtr);
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;
}
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);
}
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);
}
}
Tcl_Obj *
TclpObjLink(
Tcl_Obj *pathPtr,
Tcl_Obj *toPtr,
int linkAction)
{
if (toPtr != NULL) {
const char *src = Tcl_FSGetNativePath(pathPtr);
const char *target = NULL;
if (src == NULL) {
return NULL;
}
/*
* If we're making a symbolic link and the path is relative, then we
* must check whether it exists _relative_ to the directory in which
* the src is found (not relative to the current cwd which is just not
* relevant in this case).
*
* If we're making a hard link, then a relative path is just converted
* to absolute relative to the cwd.
*/
if ((linkAction & TCL_CREATE_SYMBOLIC_LINK)
&& (Tcl_FSGetPathType(toPtr) == TCL_PATH_RELATIVE)) {
Tcl_Obj *dirPtr, *absPtr;
dirPtr = TclPathPart(NULL, pathPtr, TCL_PATH_DIRNAME);
if (dirPtr == NULL) {
return NULL;
}
absPtr = Tcl_FSJoinToPath(dirPtr, 1, &toPtr);
Tcl_IncrRefCount(absPtr);
if (Tcl_FSAccess(absPtr, F_OK) == -1) {
Tcl_DecrRefCount(absPtr);
Tcl_DecrRefCount(dirPtr);
/*
* Target doesn't exist.
*/
errno = ENOENT;
return NULL;
}
/*
* Target exists; we'll construct the relative path we want below.
*/
Tcl_DecrRefCount(absPtr);
Tcl_DecrRefCount(dirPtr);
} else {
target = Tcl_FSGetNativePath(toPtr);
if (target == NULL) {
return NULL;
}
if (access(target, F_OK) == -1) {
/*
* Target doesn't exist.
*/
errno = ENOENT;
return NULL;
}
}
if (access(src, F_OK) != -1) {
/*
* Src exists.
*/
errno = EEXIST;
return NULL;
}
/*
* Check symbolic link flag first, since we prefer to create these.
*/
if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
int targetLen;
Tcl_DString ds;
Tcl_Obj *transPtr;
/*
* Now we don't want to link to the absolute, normalized path.
* Relative links are quite acceptable (but links to ~user are not
* -- these must be expanded first).
*/
transPtr = Tcl_FSGetTranslatedPath(NULL, toPtr);
if (transPtr == NULL) {
return NULL;
}
target = TclGetStringFromObj(transPtr, &targetLen);
target = Tcl_UtfToExternalDString(NULL, target, targetLen, &ds);
Tcl_DecrRefCount(transPtr);
if (symlink(target, src) != 0) {
toPtr = NULL;
}
Tcl_DStringFree(&ds);
} else if (linkAction & TCL_CREATE_HARD_LINK) {
if (link(target, src) != 0) {
return NULL;
}
} else {
errno = ENODEV;
return NULL;
}
return toPtr;
} else {
Tcl_Obj *linkPtr = NULL;
char link[MAXPATHLEN];
int length;
Tcl_DString ds;
Tcl_Obj *transPtr;
transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
if (transPtr == NULL) {
return NULL;
}
Tcl_DecrRefCount(transPtr);
length = readlink(Tcl_FSGetNativePath(pathPtr), link, sizeof(link));
if (length < 0) {
return NULL;
}
Tcl_ExternalToUtfDString(NULL, link, length, &ds);
linkPtr = TclDStringToObj(&ds);
Tcl_IncrRefCount(linkPtr);
return linkPtr;
}
}
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
}
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");
}
}
/* ARGSUSED */
int
TclpCreateProcess(
Tcl_Interp *interp, /* Interpreter in which to leave errors that
* occurred when creating the child process.
* Error messages from the child process
* itself are sent to errorFile. */
int argc, /* Number of arguments in following array. */
const char **argv, /* Array of argument strings in UTF-8.
* argv[0] contains the name of the executable
* translated using Tcl_TranslateFileName
* call). Additional arguments have not been
* converted. */
TclFile inputFile, /* If non-NULL, gives the file to use as input
* for the child process. If inputFile file is
* not readable or is NULL, the child will
* receive no standard input. */
TclFile outputFile, /* If non-NULL, gives the file that receives
* output from the child process. If
* outputFile file is not writeable or is
* NULL, output from the child will be
* discarded. */
TclFile errorFile, /* If non-NULL, gives the file that receives
* errors from the child process. If errorFile
* file is not writeable or is NULL, errors
* from the child will be discarded. errorFile
* may be the same as outputFile. */
Tcl_Pid *pidPtr) /* If this function is successful, pidPtr is
* filled with the process id of the child
* process. */
{
TclFile errPipeIn, errPipeOut;
int count, status, fd;
char errSpace[200 + TCL_INTEGER_SPACE];
Tcl_DString *dsArray;
char **newArgv;
int pid, i;
errPipeIn = NULL;
errPipeOut = NULL;
pid = -1;
/*
* Create a pipe that the child can use to return error information if
* anything goes wrong.
*/
if (TclpCreatePipe(&errPipeIn, &errPipeOut) == 0) {
Tcl_AppendResult(interp, "couldn't create pipe: ",
Tcl_PosixError(interp), NULL);
goto error;
}
/*
* We need to allocate and convert this before the fork so it is properly
* deallocated later
*/
dsArray = (Tcl_DString *)
TclStackAlloc(interp, argc * sizeof(Tcl_DString));
newArgv = (char **) TclStackAlloc(interp, (argc+1) * sizeof(char *));
newArgv[argc] = NULL;
for (i = 0; i < argc; i++) {
newArgv[i] = Tcl_UtfToExternalDString(NULL, argv[i], -1, &dsArray[i]);
}
#ifdef USE_VFORK
/*
* After vfork(), do not call code in the child that changes global state,
* because it is using the parent's memory space at that point and writes
* might corrupt the parent: so ensure standard channels are initialized in
* the parent, otherwise SetupStdFile() might initialize them in the child.
*/
if (!inputFile) {
Tcl_GetStdChannel(TCL_STDIN);
}
if (!outputFile) {
Tcl_GetStdChannel(TCL_STDOUT);
}
if (!errorFile) {
Tcl_GetStdChannel(TCL_STDERR);
}
#endif
pid = fork();
if (pid == 0) {
int joinThisError = errorFile && (errorFile == outputFile);
fd = GetFd(errPipeOut);
/*
* Set up stdio file handles for the child process.
*/
if (!SetupStdFile(inputFile, TCL_STDIN)
|| !SetupStdFile(outputFile, TCL_STDOUT)
|| (!joinThisError && !SetupStdFile(errorFile, TCL_STDERR))
|| (joinThisError &&
((dup2(1,2) == -1) || (fcntl(2, F_SETFD, 0) != 0)))) {
sprintf(errSpace,
"%dforked process couldn't set up input/output: ", errno);
(void)write(fd, errSpace, (size_t) strlen(errSpace));
_exit(1);
}
/*
* Close the input side of the error pipe.
*/
RestoreSignals();
execvp(newArgv[0], newArgv); /* INTL: Native. */
sprintf(errSpace, "%dcouldn't execute \"%.150s\": ", errno, argv[0]);
(void)write(fd, errSpace, (size_t) strlen(errSpace));
_exit(1);
}
/*
* Free the mem we used for the fork
*/
for (i = 0; i < argc; i++) {
Tcl_DStringFree(&dsArray[i]);
}
TclStackFree(interp, newArgv);
TclStackFree(interp, dsArray);
if (pid == -1) {
Tcl_AppendResult(interp, "couldn't fork child process: ",
Tcl_PosixError(interp), NULL);
goto error;
}
/*
* Read back from the error pipe to see if the child started up OK. The
* info in the pipe (if any) consists of a decimal errno value followed by
* an error message.
*/
TclpCloseFile(errPipeOut);
errPipeOut = NULL;
fd = GetFd(errPipeIn);
count = read(fd, errSpace, (size_t) (sizeof(errSpace) - 1));
if (count > 0) {
char *end;
errSpace[count] = 0;
errno = strtol(errSpace, &end, 10);
Tcl_AppendResult(interp, end, Tcl_PosixError(interp), NULL);
goto error;
}
TclpCloseFile(errPipeIn);
*pidPtr = (Tcl_Pid) INT2PTR(pid);
return TCL_OK;
error:
if (pid != -1) {
/*
* Reap the child process now if an error occurred during its startup.
* We don't call this with WNOHANG because that can lead to defunct
* processes on an MP system. We shouldn't have to worry about hanging
* here, since this is the error case. [Bug: 6148]
*/
Tcl_WaitPid((Tcl_Pid) INT2PTR(pid), &status, 0);
}
if (errPipeIn) {
TclpCloseFile(errPipeIn);
}
if (errPipeOut) {
TclpCloseFile(errPipeOut);
}
return TCL_ERROR;
}
/* 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;
}
int CreateGraphicEditor (ClientData clientData, Tcl_Interp *interp, int argc, char **argv){
ed_renz_arg args;
cursor_s cursor; /* element is width and colour */
tick_s *tick;
ruler_s *ruler;
int id;
out_canvas_e *output;
Tcl_DString input_params;
int seq_num, seq_id;
cli_args a[] = {
{"-frame", ARG_STR, 1, NULL, offsetof(ed_renz_arg, frame)},
{"-win_names", ARG_STR, 1, NULL, offsetof(ed_renz_arg, win_name)},
{"-window", ARG_STR, 1, NULL, offsetof(ed_renz_arg, plot)},
{"-win_ruler", ARG_STR, 1, NULL, offsetof(ed_renz_arg, win_ruler)},
{"-enzymes", ARG_STR, 1, NULL, offsetof(ed_renz_arg, inlist)},
{"-num_enzymes", ARG_INT, 1, NULL, offsetof(ed_renz_arg, num_items)},
{"-text_offset", ARG_INT, 1, NULL, offsetof(ed_renz_arg, text_offset)},
{"-text_fill", ARG_STR, 1, NULL, offsetof(ed_renz_arg, text_fill)},
{"-tick_height", ARG_INT, 1, "-1", offsetof(ed_renz_arg, tick_ht)},
{"-tick_width", ARG_INT, 1, "-1", offsetof(ed_renz_arg, tick_wd)},
{"-tick_fill", ARG_STR, 1, "", offsetof(ed_renz_arg, tick_fill)},
{"-cursor_width",ARG_INT, 1, "-1", offsetof(ed_renz_arg, cursor_wd)},
{"-cursor_fill", ARG_STR, 1, "", offsetof(ed_renz_arg, cursor_fill)},
{"-yoffset", ARG_INT, 1, NULL, offsetof(ed_renz_arg, yoffset)},
{"-seq_id", ARG_INT, 1, NULL, offsetof(ed_renz_arg, seq_id)},
{"-start", ARG_INT, 1, "1", offsetof(ed_renz_arg, start)},
{"-end", ARG_INT, 1, "-1", offsetof(ed_renz_arg, end)},
{NULL, 0, 0, NULL, 0}
};
if (-1 == parse_args(a, &args, argc, argv))
return TCL_ERROR;
if (NULL == (output = (out_canvas_e *)xmalloc(sizeof(out_canvas_e))))
return TCL_OK;
set_char_set(DNA);
seq_id = args.seq_id;
/* get register num */
seq_num = GetEdenNum (seq_id);
if (args.end == -1) {
args.end = GetEdenLength (seq_num);
}
vfuncheader("restriction enzyme plot");
/* create inputs parameters */
Tcl_DStringInit(&input_params);
/*vTcl_DStringAppend(&input_params, "sequence %s: from %d to %d\n"
"enzymes: %s\n", "NAME", args.start, args.end,args.inlist);*/
vfuncparams("%s", Tcl_DStringValue(&input_params));
Tcl_DStringFree(&input_params);
vfuncparams("%s", Tcl_DStringValue(&input_params));
Tcl_DStringFree(&input_params);
cursor = cursor_struct(interp, tk_utils_defs, "R_ENZ", args.cursor_wd, args.cursor_fill);
tick = tick_struct(interp, tk_utils_defs, "R_ENZ", args.tick_wd, args.tick_ht, args.tick_fill);
/*printf ("line_width=%d\n",tick->line_width); */
ruler = ruler_struct(interp, tk_utils_defs, "R_ENZ", 0);
ruler->start = args.start;
ruler->end = args.end;
strcpy(ruler->window, args.win_ruler);
output->interp = interp;
id = ed_renz_reg(interp, args.seq_id, output, args.frame,
args.win_name, args.plot, args.inlist, args.num_items,
args.start, args.end, args.text_offset, args.text_fill,
tick, args.yoffset, ruler, cursor);
vTcl_SetResult(interp, "%d", id);
return TCL_OK;
}
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);
}
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;
}
void
TkSuspendClipboard()
{
TkClipboardTarget *targetPtr;
TkClipboardBuffer *cbPtr;
TkDisplay *dispPtr;
char *buffer, *p, *endPtr, *buffPtr;
long length;
dispPtr = TkGetDisplayList();
if ((dispPtr == NULL) || !dispPtr->clipboardActive) {
return;
}
for (targetPtr = dispPtr->clipTargetPtr; targetPtr != NULL;
targetPtr = targetPtr->nextPtr) {
if (targetPtr->type == XA_STRING)
break;
}
if (targetPtr != NULL) {
Tcl_DString encodedText;
length = 0;
for (cbPtr = targetPtr->firstBufferPtr; cbPtr != NULL;
cbPtr = cbPtr->nextPtr) {
length += cbPtr->length;
}
buffer = ckalloc(length);
buffPtr = buffer;
for (cbPtr = targetPtr->firstBufferPtr; cbPtr != NULL;
cbPtr = cbPtr->nextPtr) {
for (p = cbPtr->buffer, endPtr = p + cbPtr->length;
p < endPtr; p++) {
if (*p == '\n') {
*buffPtr++ = '\r';
} else {
*buffPtr++ = *p;
}
}
}
ZeroScrap();
Tcl_UtfToExternalDString(NULL, buffer, length, &encodedText);
PutScrap(Tcl_DStringLength(&encodedText), 'TEXT',
Tcl_DStringValue(&encodedText));
Tcl_DStringFree(&encodedText);
ckfree(buffer);
}
/*
* The system now owns the scrap. We tell Tk that it has
* lost the selection so that it will look for it the next time
* it needs it. (Window list NULL if quiting.)
*/
if (TkGetMainInfoList() != NULL) {
Tk_ClearSelection((Tk_Window) TkGetMainInfoList()->winPtr,
Tk_InternAtom((Tk_Window) TkGetMainInfoList()->winPtr,
"CLIPBOARD"));
}
return;
}
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);
}
}
