static OSErr
ScriptHandler(
const AppleEvent *event,
AppleEvent *reply,
SRefCon handlerRefcon)
{
OSStatus theErr;
AEDescList theDesc;
int tclErr = -1;
Tcl_Interp *interp = (Tcl_Interp *) handlerRefcon;
char errString[128];
/*
* The do script event receives one parameter that should be data or a
* file.
*/
theErr = AEGetParamDesc(event, keyDirectObject, typeWildCard,
&theDesc);
if (theErr != noErr) {
sprintf(errString, "AEDoScriptHandler: GetParamDesc error %d",
(int)theErr);
theErr = AEPutParamPtr(reply, keyErrorString, typeChar, errString,
strlen(errString));
} else if (MissedAnyParameters(event)) {
/*
* Return error if parameter is missing.
*/
sprintf(errString, "AEDoScriptHandler: extra parameters");
AEPutParamPtr(reply, keyErrorString, typeChar, errString,
strlen(errString));
theErr = -1771;
} else if (theDesc.descriptorType == (DescType) typeChar) {
/*
* We've had some data sent to us. Evaluate it.
*/
Tcl_DString encodedText;
short i;
Size size = AEGetDescDataSize(&theDesc);
char *data = ckalloc(size + 1);
AEGetDescData(&theDesc, data, size);
data[size] = 0;
for (i = 0; i < size; i++) {
if (data[i] == '\r') {
data[i] = '\n';
}
}
AEReplaceDescData(theDesc.descriptorType, data, size + 1, &theDesc);
Tcl_ExternalToUtfDString(NULL, data, size, &encodedText);
tclErr = Tcl_EvalEx(interp, Tcl_DStringValue(&encodedText),
Tcl_DStringLength(&encodedText), TCL_EVAL_GLOBAL);
Tcl_DStringFree(&encodedText);
} else if (theDesc.descriptorType == (DescType) typeAlias) {
/*
* We've had a file sent to us. Source it.
*/
Boolean dummy;
FSRef file;
Size theSize = AEGetDescDataSize(&theDesc);
AliasPtr alias = (AliasPtr) ckalloc(theSize);
if (alias) {
AEGetDescData(&theDesc, alias, theSize);
theErr = FSResolveAlias(NULL, &alias, &file, &dummy);
ckfree((char*)alias);
} else {
theErr = memFullErr;
}
if (theErr == noErr) {
Tcl_DString scriptName;
theErr = FSRefToDString(&file, &scriptName);
if (theErr == noErr) {
Tcl_EvalFile(interp, Tcl_DStringValue(&scriptName));
Tcl_DStringFree(&scriptName);
}
} else {
sprintf(errString, "AEDoScriptHandler: file not found");
AEPutParamPtr(reply, keyErrorString, typeChar, errString,
strlen(errString));
}
} else {
/*
* Umm, don't recognize what we've got...
*/
sprintf(errString, "AEDoScriptHandler: invalid script type '%-4.4s',"
" must be 'alis' or 'TEXT'", (char*) &theDesc.descriptorType);
AEPutParamPtr(reply, keyErrorString, typeChar, errString,
strlen(errString));
theErr = -1770;
}
/*
* If we actually go to run Tcl code - put the result in the reply.
*/
if (tclErr >= 0) {
int reslen;
const char *result =
Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &reslen);
if (tclErr == TCL_OK) {
AEPutParamPtr(reply, keyDirectObject, typeChar, result, reslen);
} else {
AEPutParamPtr(reply, keyErrorString, typeChar, result, reslen);
AEPutParamPtr(reply, keyErrorNumber, typeSInt32, (Ptr) &tclErr,
sizeof(int));
}
}
AEDisposeDesc(&theDesc);
return theErr;
}
int
TkSelDefaultSelection(
TkSelectionInfo *infoPtr, /* Info about selection being retrieved. */
Atom target, /* Desired form of selection. */
char *buffer, /* Place to put selection characters. */
int maxBytes, /* Maximum # of bytes to store at buffer. */
Atom *typePtr) /* Store here the type of the selection, for
* use in converting to proper X format. */
{
register TkWindow *winPtr = (TkWindow *) infoPtr->owner;
TkDisplay *dispPtr = winPtr->dispPtr;
if (target == dispPtr->timestampAtom) {
if (maxBytes < 20) {
return -1;
}
sprintf(buffer, "0x%x", (unsigned int) infoPtr->time);
*typePtr = XA_INTEGER;
return strlen(buffer);
}
if (target == dispPtr->targetsAtom) {
register TkSelHandler *selPtr;
int length;
Tcl_DString ds;
if (maxBytes < 50) {
return -1;
}
Tcl_DStringInit(&ds);
Tcl_DStringAppend(&ds,
"MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW", -1);
for (selPtr = winPtr->selHandlerList; selPtr != NULL;
selPtr = selPtr->nextPtr) {
if ((selPtr->selection == infoPtr->selection)
&& (selPtr->target != dispPtr->applicationAtom)
&& (selPtr->target != dispPtr->windowAtom)) {
const char *atomString = Tk_GetAtomName((Tk_Window) winPtr,
selPtr->target);
Tcl_DStringAppendElement(&ds, atomString);
}
}
length = Tcl_DStringLength(&ds);
if (length >= maxBytes) {
Tcl_DStringFree(&ds);
return -1;
}
memcpy(buffer, Tcl_DStringValue(&ds), (unsigned) (1+length));
Tcl_DStringFree(&ds);
*typePtr = XA_ATOM;
return length;
}
if (target == dispPtr->applicationAtom) {
int length;
Tk_Uid name = winPtr->mainPtr->winPtr->nameUid;
length = strlen(name);
if (maxBytes <= length) {
return -1;
}
strcpy(buffer, name);
*typePtr = XA_STRING;
return length;
}
if (target == dispPtr->windowAtom) {
int length;
char *name = winPtr->pathName;
length = strlen(name);
if (maxBytes <= length) {
return -1;
}
strcpy(buffer, name);
*typePtr = XA_STRING;
return length;
}
return -1;
}
static OSErr
PrintHandler(
const AppleEvent * event,
AppleEvent * reply,
long handlerRefcon)
{
Tcl_Interp *interp = (Tcl_Interp *) handlerRefcon;
AEDescList fileSpecList;
FSRef file;
DescType type;
Size actual;
long count, index;
AEKeyword keyword;
Tcl_DString command, pathName;
Tcl_CmdInfo dummy;
/*
* Don't bother if we don't have an interp or the print document procedure
* doesn't exist.
*/
if (!interp ||
!Tcl_GetCommandInfo(interp, "::tk::mac::PrintDocument", &dummy)) {
return noErr;
}
/*
* If we get any errors while retrieving our parameters we just return with
* no error.
*/
if (ChkErr(AEGetParamDesc, event, keyDirectObject, typeAEList,
&fileSpecList) != noErr) {
return noErr;
}
if (ChkErr(MissedAnyParameters, event) != noErr) {
return noErr;
}
if (ChkErr(AECountItems, &fileSpecList, &count) != noErr) {
return noErr;
}
Tcl_DStringInit(&command);
Tcl_DStringAppend(&command, "::tk::mac::PrintDocument", -1);
for (index = 1; index <= count; index++) {
if (ChkErr(AEGetNthPtr, &fileSpecList, index, typeFSRef, &keyword,
&type, (Ptr) &file, sizeof(FSRef), &actual) != noErr) {
continue;
}
if (ChkErr(FSRefToDString, &file, &pathName) == noErr) {
Tcl_DStringAppendElement(&command, Tcl_DStringValue(&pathName));
Tcl_DStringFree(&pathName);
}
}
/*
* Now handle the event by evaluating a script.
*/
if (Tcl_EvalEx(interp, Tcl_DStringValue(&command),
Tcl_DStringLength(&command), TCL_EVAL_GLOBAL) != TCL_OK) {
Tcl_BackgroundError(interp);
}
Tcl_DStringFree(&command);
return noErr;
}
/*
** Called for each row of the result.
**
** This version is used when TCL expects UTF-8 data but the database
** uses the ISO8859 format. A translation must occur from ISO8859 into
** UTF-8.
*/
static int DbEvalCallback(
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 */
){
CallbackData *cbData = (CallbackData*)clientData;
int i, rc;
Tcl_DString dCol;
Tcl_DStringInit(&dCol);
if( cbData->azColName==0 ){
assert( cbData->once );
cbData->once = 0;
if( cbData->zArray[0] ){
Tcl_SetVar2(cbData->interp, cbData->zArray, "*", "", 0);
}
cbData->azColName = malloc( nCol*sizeof(char*) );
if( cbData->azColName==0 ){ return 1; }
cbData->nColName = nCol;
for(i=0; i<nCol; i++){
Tcl_ExternalToUtfDString(NULL, azN[i], -1, &dCol);
cbData->azColName[i] = malloc( Tcl_DStringLength(&dCol) + 1 );
if( cbData->azColName[i] ){
strcpy(cbData->azColName[i], Tcl_DStringValue(&dCol));
}else{
return 1;
}
if( cbData->zArray[0] ){
Tcl_SetVar2(cbData->interp, cbData->zArray, "*",
Tcl_DStringValue(&dCol), TCL_LIST_ELEMENT|TCL_APPEND_VALUE);
if( azN[nCol]!=0 ){
Tcl_DString dType;
Tcl_DStringInit(&dType);
Tcl_DStringAppend(&dType, "typeof:", -1);
Tcl_DStringAppend(&dType, Tcl_DStringValue(&dCol), -1);
Tcl_DStringFree(&dCol);
Tcl_ExternalToUtfDString(NULL, azN[i+nCol], -1, &dCol);
Tcl_SetVar2(cbData->interp, cbData->zArray,
Tcl_DStringValue(&dType), Tcl_DStringValue(&dCol),
TCL_LIST_ELEMENT|TCL_APPEND_VALUE);
Tcl_DStringFree(&dType);
}
}
Tcl_DStringFree(&dCol);
}
}
if( azCol!=0 ){
if( cbData->zArray[0] ){
for(i=0; i<nCol; i++){
char *z = azCol[i];
if( z==0 ) z = "";
Tcl_DStringInit(&dCol);
Tcl_ExternalToUtfDString(NULL, z, -1, &dCol);
Tcl_SetVar2(cbData->interp, cbData->zArray, cbData->azColName[i],
Tcl_DStringValue(&dCol), 0);
Tcl_DStringFree(&dCol);
}
}else{
for(i=0; i<nCol; i++){
char *z = azCol[i];
if( z==0 ) z = "";
Tcl_DStringInit(&dCol);
Tcl_ExternalToUtfDString(NULL, z, -1, &dCol);
Tcl_SetVar(cbData->interp, cbData->azColName[i],
Tcl_DStringValue(&dCol), 0);
Tcl_DStringFree(&dCol);
}
}
}
rc = Tcl_EvalObj(cbData->interp, cbData->pCode);
if( rc==TCL_CONTINUE ) rc = TCL_OK;
cbData->tcl_rc = rc;
return rc!=TCL_OK;
}
void
TclpFindExecutable(
CONST char *argv0) /* The value of the application's argv[0]
* (native). */
{
CONST char *name, *p;
Tcl_StatBuf statBuf;
Tcl_DString buffer, nameString, cwd, utfName;
Tcl_Encoding encoding;
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 (isspace(UCHAR(*p))) { /* INTL: BUG */
p++;
}
name = p;
while ((*p != ':') && (*p != 0)) {
p++;
}
Tcl_DStringSetLength(&buffer, 0);
if (p != name) {
Tcl_DStringAppend(&buffer, name, p - name);
if (p[-1] != '/') {
Tcl_DStringAppend(&buffer, "/", 1);
}
}
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;
}
/*
* 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);
TclpGetCwd(NULL, &cwd);
Tcl_DStringFree(&buffer);
Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(&cwd),
Tcl_DStringLength(&cwd), &buffer);
if (Tcl_DStringValue(&cwd)[Tcl_DStringLength(&cwd) -1] != '/') {
Tcl_DStringAppend(&buffer, "/", 1);
}
Tcl_DStringFree(&cwd);
Tcl_DStringAppend(&buffer, Tcl_DStringValue(&nameString),
Tcl_DStringLength(&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);
}
static void UpdateWinCharsTypeString(Tcl_Obj *objP)
{
int nbytes;
char *utf8;
WinChars *rep;
Tcl_DString ds;
rep = WinCharsGet(objP);
if (rep->nchars == 0) {
objP->bytes = ckalloc(1);
objP->bytes[0] = '\0';
objP->length = 0;
return;
}
#if 0
/* Disabled because XP does not support WC_ERR_INVALID_CHARS and
* will silently discard those characters
*/
/* Note rep->nchars does not include terminating \0 so return values
* will not include it either
*/
nbytes = WideCharToMultiByte(
CP_UTF8, /* CodePag */
WC_ERR_INVALID_CHARS, /* dwFlags */
rep->chars, /* lpWideCharStr */
rep->nchars, /* cchWideChar */
NULL, /* lpMultiByteStr */
NULL, /* cbMultiByte */
NULL, /* lpDefaultChar */
NULL /* lpUsedDefaultChar */
);
if (nbytes != 0) {
utf8 = ckalloc(nbytes+1); /* One extra for terminating \0 */
nbytes = WideCharToMultiByte(
CP_UTF8, /* CodePag */
WC_ERR_INVALID_CHARS, /* dwFlags */
rep->chars, /* lpWideCharStr */
rep->nchars, /* cchWideChar */
utf8, /* lpMultiByteStr */
nbytes, /* cbMultiByte */
NULL, /* lpDefaultChar */
NULL /* lpUsedDefaultChar */
);
if (nbytes != 0) {
utf8[nbytes] = '\0';
objP->bytes = utf8;
objP->length = nbytes;
return;
}
ckfree(utf8);
}
/*
* Failures are possible because of invalid characters like embedded
* nulls which are not illegal in Tcl, so do it the (slower) Tcl way then.
*/
#endif // #if 0
Tcl_WinTCharToUtf(rep->chars, rep->nchars * sizeof(WCHAR), &ds);
nbytes = Tcl_DStringLength(&ds);
utf8 = ckalloc(nbytes+1);
memmove(utf8, Tcl_DStringValue(&ds), nbytes);
Tcl_DStringFree(&ds);
utf8[nbytes] = '\0';
objP->bytes = utf8;
objP->length = nbytes;
}
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);
}
static TclRegexp *
CompileRegexp(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
const char *string, /* The regexp to compile (UTF-8). */
int length, /* The length of the string in bytes. */
int flags) /* Compilation flags. */
{
TclRegexp *regexpPtr;
const Tcl_UniChar *uniString;
int numChars, status, i, exact;
Tcl_DString stringBuf;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!tsdPtr->initialized) {
tsdPtr->initialized = 1;
Tcl_CreateThreadExitHandler(FinalizeRegexp, NULL);
}
/*
* This routine maintains a second-level regular expression cache in
* addition to the per-object regexp cache. The per-thread cache is needed
* to handle the case where for various reasons the object is lost between
* invocations of the regexp command, but the literal pattern is the same.
*/
/*
* Check the per-thread compiled regexp cache. We can only reuse a regexp
* if it has the same pattern and the same flags.
*/
for (i = 0; (i < NUM_REGEXPS) && (tsdPtr->patterns[i] != NULL); i++) {
if ((length == tsdPtr->patLengths[i])
&& (tsdPtr->regexps[i]->flags == flags)
&& (strcmp(string, tsdPtr->patterns[i]) == 0)) {
/*
* Move the matched pattern to the first slot in the cache and
* shift the other patterns down one position.
*/
if (i != 0) {
int j;
char *cachedString;
cachedString = tsdPtr->patterns[i];
regexpPtr = tsdPtr->regexps[i];
for (j = i-1; j >= 0; j--) {
tsdPtr->patterns[j+1] = tsdPtr->patterns[j];
tsdPtr->patLengths[j+1] = tsdPtr->patLengths[j];
tsdPtr->regexps[j+1] = tsdPtr->regexps[j];
}
tsdPtr->patterns[0] = cachedString;
tsdPtr->patLengths[0] = length;
tsdPtr->regexps[0] = regexpPtr;
}
return tsdPtr->regexps[0];
}
}
/*
* This is a new expression, so compile it and add it to the cache.
*/
regexpPtr = ckalloc(sizeof(TclRegexp));
regexpPtr->objPtr = NULL;
regexpPtr->string = NULL;
regexpPtr->details.rm_extend.rm_so = -1;
regexpPtr->details.rm_extend.rm_eo = -1;
/*
* Get the up-to-date string representation and map to unicode.
*/
Tcl_DStringInit(&stringBuf);
uniString = Tcl_UtfToUniCharDString(string, length, &stringBuf);
numChars = Tcl_DStringLength(&stringBuf) / sizeof(Tcl_UniChar);
/*
* Compile the string and check for errors.
*/
regexpPtr->flags = flags;
status = TclReComp(®expPtr->re, uniString, (size_t) numChars, flags);
Tcl_DStringFree(&stringBuf);
if (status != REG_OKAY) {
/*
* Clean up and report errors in the interpreter, if possible.
*/
ckfree(regexpPtr);
if (interp) {
TclRegError(interp,
"couldn't compile regular expression pattern: ", status);
}
return NULL;
}
/*
* Convert RE to a glob pattern equivalent, if any, and cache it. If this
* is not possible, then globObjPtr will be NULL. This is used by
* Tcl_RegExpExecObj to optionally do a fast match (avoids RE engine).
*/
if (TclReToGlob(NULL, string, length, &stringBuf, &exact) == TCL_OK) {
regexpPtr->globObjPtr = TclDStringToObj(&stringBuf);
Tcl_IncrRefCount(regexpPtr->globObjPtr);
} else {
regexpPtr->globObjPtr = NULL;
}
/*
* Allocate enough space for all of the subexpressions, plus one extra for
* the entire pattern.
*/
regexpPtr->matches =
ckalloc(sizeof(regmatch_t) * (regexpPtr->re.re_nsub + 1));
/*
* Initialize the refcount to one initially, since it is in the cache.
*/
regexpPtr->refCount = 1;
/*
* Free the last regexp, if necessary, and make room at the head of the
* list for the new regexp.
*/
if (tsdPtr->patterns[NUM_REGEXPS-1] != NULL) {
TclRegexp *oldRegexpPtr = tsdPtr->regexps[NUM_REGEXPS-1];
if (--(oldRegexpPtr->refCount) <= 0) {
FreeRegexp(oldRegexpPtr);
}
ckfree(tsdPtr->patterns[NUM_REGEXPS-1]);
}
for (i = NUM_REGEXPS - 2; i >= 0; i--) {
tsdPtr->patterns[i+1] = tsdPtr->patterns[i];
tsdPtr->patLengths[i+1] = tsdPtr->patLengths[i];
tsdPtr->regexps[i+1] = tsdPtr->regexps[i];
}
tsdPtr->patterns[0] = ckalloc(length + 1);
memcpy(tsdPtr->patterns[0], string, (unsigned) length + 1);
tsdPtr->patLengths[0] = length;
tsdPtr->regexps[0] = regexpPtr;
return regexpPtr;
}
static void
AppendEnvironment(
Tcl_Obj *pathPtr,
const char *lib)
{
int pathc;
WCHAR wBuf[MAX_PATH];
char buf[MAX_PATH * TCL_UTF_MAX];
Tcl_Obj *objPtr;
Tcl_DString ds;
const char **pathv;
char *shortlib;
/*
* The shortlib value needs to be the tail component of the lib path. For
* example, "lib/tcl8.4" -> "tcl8.4" while "usr/share/tcl8.5" -> "tcl8.5".
*/
for (shortlib = (char *) &lib[strlen(lib)-1]; shortlib>lib ; shortlib--) {
if (*shortlib == '/') {
if ((unsigned)(shortlib - lib) == strlen(lib) - 1) {
Tcl_Panic("last character in lib cannot be '/'");
}
shortlib++;
break;
}
}
if (shortlib == lib) {
Tcl_Panic("no '/' character found in lib");
}
/*
* The "L" preceeding the TCL_LIBRARY string is used to tell VC++ that
* this is a unicode string.
*/
if (GetEnvironmentVariableW(L"TCL_LIBRARY", wBuf, MAX_PATH) == 0) {
buf[0] = '\0';
GetEnvironmentVariableA("TCL_LIBRARY", buf, MAX_PATH);
} else {
ToUtf(wBuf, buf);
}
if (buf[0] != '\0') {
objPtr = Tcl_NewStringObj(buf, -1);
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
TclWinNoBackslash(buf);
Tcl_SplitPath(buf, &pathc, &pathv);
/*
* The lstrcmpi() will work even if pathv[pathc-1] is random UTF-8
* chars because I know shortlib is ascii.
*/
if ((pathc > 0) && (lstrcmpiA(shortlib, pathv[pathc - 1]) != 0)) {
const char *str;
/*
* 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] = shortlib;
Tcl_DStringInit(&ds);
str = Tcl_JoinPath(pathc, pathv, &ds);
objPtr = Tcl_NewStringObj(str, Tcl_DStringLength(&ds));
Tcl_DStringFree(&ds);
} else {
objPtr = Tcl_NewStringObj(buf, -1);
}
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
ckfree((char *) pathv);
}
}
void
TkWinClipboardRender(
TkDisplay *dispPtr,
UINT format)
{
TkClipboardTarget *targetPtr;
TkClipboardBuffer *cbPtr;
HGLOBAL handle;
char *buffer, *p, *rawText, *endPtr;
int length;
Tcl_DString ds;
for (targetPtr = dispPtr->clipTargetPtr; targetPtr != NULL;
targetPtr = targetPtr->nextPtr) {
if (targetPtr->type == XA_STRING) {
break;
}
}
/*
* Count the number of newlines so we can add space for them in the
* resulting string.
*/
length = 0;
if (targetPtr != NULL) {
for (cbPtr = targetPtr->firstBufferPtr; cbPtr != NULL;
cbPtr = cbPtr->nextPtr) {
length += cbPtr->length;
for (p = cbPtr->buffer, endPtr = p + cbPtr->length;
p < endPtr; p++) {
if (*p == '\n') {
length++;
}
}
}
}
/*
* Copy the data and change EOL characters.
*/
buffer = rawText = ckalloc(length + 1);
if (targetPtr != NULL) {
for (cbPtr = targetPtr->firstBufferPtr; cbPtr != NULL;
cbPtr = cbPtr->nextPtr) {
for (p = cbPtr->buffer, endPtr = p + cbPtr->length;
p < endPtr; p++) {
if (*p == '\n') {
*buffer++ = '\r';
}
*buffer++ = *p;
}
}
}
*buffer = '\0';
/*
* Depending on the platform, turn the data into Unicode or the system
* encoding before placing it on the clipboard.
*/
#ifdef UNICODE
Tcl_DStringInit(&ds);
Tcl_UtfToUniCharDString(rawText, -1, &ds);
ckfree(rawText);
handle = GlobalAlloc(GMEM_MOVEABLE|GMEM_DDESHARE,
(unsigned) Tcl_DStringLength(&ds) + 2);
if (!handle) {
Tcl_DStringFree(&ds);
return;
}
buffer = GlobalLock(handle);
memcpy(buffer, Tcl_DStringValue(&ds),
(unsigned) Tcl_DStringLength(&ds) + 2);
GlobalUnlock(handle);
Tcl_DStringFree(&ds);
SetClipboardData(CF_UNICODETEXT, handle);
#else
Tcl_UtfToExternalDString(NULL, rawText, -1, &ds);
ckfree(rawText);
handle = GlobalAlloc(GMEM_MOVEABLE|GMEM_DDESHARE,
(unsigned) Tcl_DStringLength(&ds) + 1);
if (!handle) {
Tcl_DStringFree(&ds);
return;
}
buffer = GlobalLock(handle);
memcpy(buffer, Tcl_DStringValue(&ds),
(unsigned) Tcl_DStringLength(&ds) + 1);
GlobalUnlock(handle);
Tcl_DStringFree(&ds);
SetClipboardData(CF_TEXT, handle);
#endif
}
int
TkSelGetSelection(
Tcl_Interp *interp, /* Interpreter to use for reporting errors. */
Tk_Window tkwin, /* Window on whose behalf to retrieve the
* selection (determines display from which to
* retrieve). */
Atom selection, /* Selection to retrieve. */
Atom target, /* Desired form in which selection is to be
* returned. */
Tk_GetSelProc *proc, /* Procedure to call to process the selection,
* once it has been retrieved. */
ClientData clientData) /* Arbitrary value to pass to proc. */
{
char *data, *destPtr;
Tcl_DString ds;
HGLOBAL handle;
Tcl_Encoding encoding;
int result, locale;
if ((selection != Tk_InternAtom(tkwin, "CLIPBOARD"))
|| (target != XA_STRING)
|| !OpenClipboard(NULL)) {
goto error;
}
/*
* Attempt to get the data in Unicode form if available as this is less
* work that CF_TEXT.
*/
result = TCL_ERROR;
if (IsClipboardFormatAvailable(CF_UNICODETEXT)) {
handle = GetClipboardData(CF_UNICODETEXT);
if (!handle) {
CloseClipboard();
goto error;
}
data = GlobalLock(handle);
Tcl_DStringInit(&ds);
Tcl_UniCharToUtfDString((Tcl_UniChar *)data,
Tcl_UniCharLen((Tcl_UniChar *)data), &ds);
GlobalUnlock(handle);
} else if (IsClipboardFormatAvailable(CF_TEXT)) {
/*
* Determine the encoding to use to convert this text.
*/
if (IsClipboardFormatAvailable(CF_LOCALE)) {
handle = GetClipboardData(CF_LOCALE);
if (!handle) {
CloseClipboard();
goto error;
}
/*
* Get the locale identifier, determine the proper code page to
* use, and find the corresponding encoding.
*/
Tcl_DStringInit(&ds);
Tcl_DStringAppend(&ds, "cp######", -1);
data = GlobalLock(handle);
/*
* Even though the documentation claims that GetLocaleInfo expects
* an LCID, on Windows 9x it really seems to expect a LanguageID.
*/
locale = LANGIDFROMLCID(*((int*)data));
GetLocaleInfoA(locale, LOCALE_IDEFAULTANSICODEPAGE,
Tcl_DStringValue(&ds)+2, Tcl_DStringLength(&ds)-2);
GlobalUnlock(handle);
encoding = Tcl_GetEncoding(NULL, Tcl_DStringValue(&ds));
Tcl_DStringFree(&ds);
} else {
encoding = NULL;
}
/*
* Fetch the text and convert it to UTF.
*/
handle = GetClipboardData(CF_TEXT);
if (!handle) {
if (encoding) {
Tcl_FreeEncoding(encoding);
}
CloseClipboard();
goto error;
}
data = GlobalLock(handle);
Tcl_ExternalToUtfDString(encoding, data, -1, &ds);
GlobalUnlock(handle);
if (encoding) {
Tcl_FreeEncoding(encoding);
}
} else {
CloseClipboard();
goto error;
}
/*
* Translate CR/LF to LF.
*/
data = destPtr = Tcl_DStringValue(&ds);
while (*data) {
if (data[0] == '\r' && data[1] == '\n') {
data++;
} else {
*destPtr++ = *data++;
}
}
*destPtr = '\0';
/*
* Pass the data off to the selection procedure.
*/
result = proc(clientData, interp, Tcl_DStringValue(&ds));
Tcl_DStringFree(&ds);
CloseClipboard();
return result;
error:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s selection doesn't exist or form \"%s\" not defined",
Tk_GetAtomName(tkwin, selection), Tk_GetAtomName(tkwin, target)));
Tcl_SetErrorCode(interp, "TK", "SELECTION", "EXISTS", NULL);
return TCL_ERROR;
}
void
Tk_MainEx(
int argc, /* Number of arguments. */
char **argv, /* Array of argument strings. */
Tcl_AppInitProc *appInitProc,
/* Application-specific initialization
* function to call after most initialization
* but before starting to execute commands. */
Tcl_Interp *interp)
{
Tcl_Obj *path, *argvPtr;
const char *encodingName;
int code, nullStdin = 0;
Tcl_Channel inChannel, outChannel;
ThreadSpecificData *tsdPtr;
#ifdef __WIN32__
HANDLE handle;
#endif
Tcl_DString appName;
/*
* Ensure that we are getting a compatible version of Tcl. This is really
* only an issue when Tk is loaded dynamically.
*/
if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) {
abort();
}
tsdPtr = Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
Tcl_FindExecutable(argv[0]);
tsdPtr->interp = interp;
Tcl_Preserve(interp);
#if defined(__WIN32__)
Tk_InitConsoleChannels(interp);
#endif
#ifdef MAC_OSX_TK
if (Tcl_GetStartupScript(NULL) == NULL) {
TkMacOSXDefaultStartupScript();
}
#endif
#ifdef TCL_MEM_DEBUG
Tcl_InitMemory(interp);
#endif
/*
* If the application has not already set a startup script, parse the
* first few command line arguments to determine the script path and
* encoding.
*/
if (NULL == Tcl_GetStartupScript(NULL)) {
size_t length;
/*
* Check whether first 3 args (argv[1] - argv[3]) look like
* -encoding ENCODING FILENAME
* or like
* FILENAME
* or like
* -file FILENAME (ancient history support only)
*/
if ((argc > 3) && (0 == strcmp("-encoding", argv[1]))
&& ('-' != argv[3][0])) {
Tcl_SetStartupScript(Tcl_NewStringObj(argv[3], -1), argv[2]);
argc -= 3;
argv += 3;
} else if ((argc > 1) && ('-' != argv[1][0])) {
Tcl_SetStartupScript(Tcl_NewStringObj(argv[1], -1), NULL);
argc--;
argv++;
} else if ((argc > 2) && (length = strlen(argv[1]))
&& (length > 1) && (0 == strncmp("-file", argv[1], length))
&& ('-' != argv[2][0])) {
Tcl_SetStartupScript(Tcl_NewStringObj(argv[2], -1), NULL);
argc -= 2;
argv += 2;
}
}
path = Tcl_GetStartupScript(&encodingName);
if (NULL == path) {
Tcl_ExternalToUtfDString(NULL, argv[0], -1, &appName);
} else {
int numBytes;
const char *pathName = Tcl_GetStringFromObj(path, &numBytes);
Tcl_ExternalToUtfDString(NULL, pathName, numBytes, &appName);
path = Tcl_NewStringObj(Tcl_DStringValue(&appName), -1);
Tcl_SetStartupScript(path, encodingName);
}
Tcl_SetVar(interp, "argv0", Tcl_DStringValue(&appName), TCL_GLOBAL_ONLY);
Tcl_DStringFree(&appName);
argc--;
argv++;
Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewIntObj(argc), TCL_GLOBAL_ONLY);
argvPtr = Tcl_NewListObj(0, NULL);
while (argc--) {
Tcl_DString ds;
Tcl_ExternalToUtfDString(NULL, *argv++, -1, &ds);
Tcl_ListObjAppendElement(NULL, argvPtr, Tcl_NewStringObj(
Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)));
Tcl_DStringFree(&ds);
}
Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY);
/*
* Set the "tcl_interactive" variable.
*/
#ifdef __WIN32__
/*
* For now, under Windows, we assume we are not running as a console mode
* app, so we need to use the GUI console. In order to enable this, we
* always claim to be running on a tty. This probably isn't the right way
* to do it.
*/
handle = GetStdHandle(STD_INPUT_HANDLE);
if ((handle == INVALID_HANDLE_VALUE) || (handle == 0)
|| (GetFileType(handle) == FILE_TYPE_UNKNOWN)) {
/*
* If it's a bad or closed handle, then it's been connected to a wish
* console window.
*/
tsdPtr->tty = 1;
} else if (GetFileType(handle) == FILE_TYPE_CHAR) {
/*
* A character file handle is a tty by definition.
*/
tsdPtr->tty = 1;
} else {
tsdPtr->tty = 0;
}
#else
tsdPtr->tty = isatty(0);
#endif
#if defined(MAC_OSX_TK)
/*
* On TkAqua, if we don't have a TTY and stdin is a special character file
* of length 0, (e.g. /dev/null, which is what Finder sets when double
* clicking Wish) then use the GUI console.
*/
if (!tsdPtr->tty) {
struct stat st;
nullStdin = fstat(0, &st) || (S_ISCHR(st.st_mode) && !st.st_blocks);
}
#endif
Tcl_SetVar(interp, "tcl_interactive",
((path == NULL) && (tsdPtr->tty || nullStdin)) ? "1" : "0",
TCL_GLOBAL_ONLY);
/*
* Invoke application-specific initialization.
*/
if (appInitProc(interp) != TCL_OK) {
TkpDisplayWarning(Tcl_GetStringResult(interp),
"Application initialization failed");
}
/*
* Invoke the script specified on the command line, if any. Must fetch it
* again, as the appInitProc might have reset it.
*/
path = Tcl_GetStartupScript(&encodingName);
if (path != NULL) {
Tcl_ResetResult(interp);
code = Tcl_FSEvalFileEx(interp, path, encodingName);
if (code != TCL_OK) {
/*
* The following statement guarantees that the errorInfo variable
* is set properly.
*/
Tcl_AddErrorInfo(interp, "");
TkpDisplayWarning(Tcl_GetVar(interp, "errorInfo",
TCL_GLOBAL_ONLY), "Error in startup script");
Tcl_DeleteInterp(interp);
Tcl_Exit(1);
}
tsdPtr->tty = 0;
} else {
/*
* Evaluate the .rc file, if one has been specified.
*/
Tcl_SourceRCFile(interp);
/*
* Establish a channel handler for stdin.
*/
inChannel = Tcl_GetStdChannel(TCL_STDIN);
if (inChannel) {
Tcl_CreateChannelHandler(inChannel, TCL_READABLE, StdinProc,
inChannel);
}
if (tsdPtr->tty) {
Prompt(interp, 0);
}
}
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
if (outChannel) {
Tcl_Flush(outChannel);
}
Tcl_DStringInit(&tsdPtr->command);
Tcl_DStringInit(&tsdPtr->line);
Tcl_ResetResult(interp);
/*
* Loop infinitely, waiting for commands to execute. When there are no
* windows left, Tk_MainLoop returns and we exit.
*/
Tk_MainLoop();
Tcl_DeleteInterp(interp);
Tcl_Release(interp);
Tcl_SetStartupScript(NULL, NULL);
Tcl_Exit(0);
}
int
Ns_ConnFlush(Ns_Conn *conn, char *buf, int len, int stream)
{
Conn *connPtr = (Conn *) conn;
NsServer *servPtr = connPtr->servPtr;
Tcl_Encoding encoding;
Tcl_DString enc, gzip;
char *ahdr;
int status;
connPtr->sbuf=buf;
if (NsRunFilters((Ns_Conn *) connPtr, NS_FILTER_PRE_WRITE) != NS_OK) {
return NS_ERROR;
}
if (connPtr->rbuf != NULL) {
/* the content was set by pre-write filters */
buf=Tcl_DStringValue(connPtr->rbuf);
len=Tcl_DStringLength(connPtr->rbuf);
}
Tcl_DStringInit(&enc);
Tcl_DStringInit(&gzip);
if (len < 0) {
len = strlen(buf);
}
/*
* Encode content to the expected charset.
*/
encoding = Ns_ConnGetEncoding(conn);
if (encoding != NULL) {
Tcl_UtfToExternalDString(encoding, buf, len, &enc);
buf = enc.string;
len = enc.length;
}
/*
* GZIP the content when not streaming if enabled and the content
* length is above the minimum.
*/
if (!stream
&& (conn->flags & NS_CONN_GZIP)
&& (servPtr->opts.flags & SERV_GZIP)
&& (len > (int) servPtr->opts.gzipmin)
&& (ahdr = Ns_SetIGet(conn->headers, "Accept-Encoding")) != NULL
&& strstr(ahdr, "gzip") != NULL
&& Ns_Gzip(buf, len, servPtr->opts.gziplevel, &gzip) == NS_OK) {
buf = gzip.string;
len = gzip.length;
Ns_ConnCondSetHeaders(conn, "Content-Encoding", "gzip");
}
/*
* Flush content.
*/
status = Ns_ConnFlushDirect(conn, buf, len, stream);
Tcl_DStringFree(&enc);
Tcl_DStringFree(&gzip);
return status;
}
static int Remove_Path(Tcl_Interp *interp, char *variable, char *item,
char *sw_marker, const char *delim)
{
char *oldpath, /** current path **/
*olditem; /** item from path **/
int i = 0, /** counter **/
found = 0, /** flag to indicate item was found **/
pcount = 0, /** count of items in path **/
addsep = 0, /** flag to add separator **/
marked = 0, /** flag path contains sw_marker **/
oldpathlen = 0;
Tcl_DString _newpath;
Tcl_DString *newpath = &_newpath;
Tcl_DStringInit(newpath);
/**
** Get the current value of the "PATH" environment variable
**/
oldpath = (char *)EMGetEnv(interp, variable);
if (!oldpath || !*oldpath) {
null_free((void *)&oldpath);
_TCLCHK(interp);
goto success0; /** -------- EXIT (SUCCESS) -------> **/
}
/* copy oldpath to not mess with the TCL value of env(PATH) */
if (!(oldpath = stringer(NULL,0, oldpath, NULL))) {
if (OK != ErrorLogger(ERR_STRING, LOC, NULL)) {
goto unwind0;
}
}
/* get length of oldpath before it gets modified by xstrtok */
oldpathlen = (int)strlen(oldpath);
/* determine if sw_marker is in the path */
olditem = xstrtok(oldpath, delim);
while (olditem) {
if (!strcmp(olditem, sw_marker)) {
marked = 1;
}
pcount++;
olditem = xstrtok(NULL, delim);
}
/** pointer arithmetic on oldpath
** if olditem starts at terminating null string of oldpath,
** it means the last character in oldpath was ":", meaning
** the last element was the empty string. use <= to catch
** this case and process the last empty element
*/
for (olditem = oldpath; olditem <= oldpath + oldpathlen;
olditem += strlen(olditem) + 1) {
if (strcmp(olditem, item)) {
/* not the droids we're looking for */
if (Tcl_DStringLength(newpath)) {
if (!Tcl_DStringAppend(newpath, delim, 1))
if (OK !=
ErrorLogger(ERR_STRING, LOC, NULL))
goto unwind1;
}
if (!Tcl_DStringAppend(newpath, olditem, -1))
if (OK != ErrorLogger(ERR_STRING, LOC, NULL))
goto unwind1;
} else {
/* bingo! Don't add it to new path */
found++;
if ((g_flags & M_SWSTATE1) && !marked) {
/**
** In state1, we're actually replacing old paths with
** the markers for future appends and prepends.
**
** We only want to do this once to mark the location
** the module was formed around.
**/
marked = 1;
if (Tcl_DStringLength(newpath)) {
if (!Tcl_DStringAppend
(newpath, delim, 1))
if (OK !=
ErrorLogger(ERR_STRING, LOC,
NULL))
goto unwind1;
}
if (!Tcl_DStringAppend(newpath, sw_marker, -1))
if (OK !=
ErrorLogger(ERR_STRING, LOC, NULL))
goto unwind1;
}
}
}
if (!found) {
goto success1;
}
if (Tcl_DStringLength(newpath)) {
/**
** Cache the set. Clear the variable from the unset table just
** in case it was previously unset.
**/
store_hash_value(setenvHashTable, variable,
Tcl_DStringValue(newpath));
clear_hash_value(unsetenvHashTable, variable);
/**
** Store the new PATH value into the environment.
**/
(void) EMSetEnv( interp, variable, Tcl_DStringValue(newpath));
_TCLCHK(interp);
} else {
/**
** In this case, I should go ahead and unset the variable
** from the environment because I'm removing the very last
** path.
**
** First I'm going to clear the variable from the
** setenvHashTable just in case its already been altered
** and had a significant value at the time. It's very
** possible that I'm removing the only two or three paths
** from this variable. If that's the case, then all the
** earlier paths were marked for output in this hashTable.
**
** Secondly, I actually mark the the environment variable
** to be unset when output.
**/
clear_hash_value(setenvHashTable, variable);
moduleUnsetenv(interp, variable);
/**
** moduleUnsetenv doesn't unset the variable in the Tcl
** space because the $env variable might need to be
** used again in the modulefile for locating other
** paths. BUT, since this was a path-type environment
** variable, the user is expecting this to be empty
** after removing the only remaining path. So, I set
** the variable empty here.
**/
(void) EMSetEnv( interp, variable, "");
_TCLCHK(interp);
}
/**
** Free what has been used and return on success
**/
success1:
null_free((void *)&oldpath);
success0:
Tcl_DStringFree(newpath);
return (TCL_OK); /** -------- EXIT (SUCCESS) -------> **/
unwind1:
null_free((void *)&oldpath);
unwind0:
Tcl_DStringFree(newpath);
return (TCL_ERROR); /** -------- EXIT (FAILURE) -------> **/
} /** End of 'Remove_Path' **/
int fbsql_fetchrow(Tcl_Interp *interp, int sql_number, int argc, char **argv) {
int i, field_type, length;
MYSQL_ROW row;
MYSQL_FIELD *field;
Tcl_Obj *obj_result;
Tcl_Obj *obj_col;
Tcl_Obj *obj_array;
Tcl_Obj *obj_element;
#if UTF_ENCODING
Tcl_DString ds;
#endif
/* check we are connected? */
if (!connection[sql_number].CONNECTED) {
Tcl_SetResult(interp, "Not connected to a server.", TCL_STATIC);
return TCL_ERROR;
}
/* check we had a query started? */
if (!connection[sql_number].query_flag) {
Tcl_SetResult(interp, "No query has been started.", TCL_STATIC);
return TCL_ERROR;
}
/* fetch some data? */
row = mysql_fetch_row(connection[sql_number].result);
if (row == NULL) {
/* if we come to the end of the data return nothing */
/* if using an array set the array elements to default/NULL values */
if (connection[sql_number].use_array) {
obj_array = Tcl_NewStringObj(connection[sql_number].array_name,strlen(connection[sql_number].array_name));
for (i = 0; i < connection[sql_number].field_count; i++) {
/* get field information */
field = mysql_fetch_field_direct(connection[sql_number].result,i);
if (field == NULL) continue;
obj_element = Tcl_NewStringObj(field->name,strlen(field->name));
/* 0 = char, 1 = numeric, 2 = datetime */
field_type = determine_field_type(field->type);
/* if the type is numeric then store 0.00 as the result */
if (field_type == 1) {
obj_col = Tcl_NewDoubleObj(0);
} else {
obj_col = Tcl_NewStringObj(NULL,0);
}
Tcl_ObjSetVar2(interp,obj_array,obj_element,obj_col,0);
/* we no longer have any use for the element object */
Tcl_DecrRefCount(obj_element);
}
/* we no longer have any use for the array object */
Tcl_DecrRefCount(obj_array);
}
return TCL_OK;
}
/* if an array name was specified on the sql command line then we */
/* transfer all results to that array - special FastBase conversions */
/* otherwise return the row as a list of columns */
if (connection[sql_number].use_array) {
obj_array = Tcl_NewStringObj(connection[sql_number].array_name,strlen(connection[sql_number].array_name));
for (i = 0; i < connection[sql_number].field_count; i++) {
/* get field information */
field = mysql_fetch_field_direct(connection[sql_number].result,i);
if (field == NULL) continue;
obj_element = Tcl_NewStringObj(field->name,strlen(field->name));
/* 0 = char, 1 = numeric, 2 = datetime */
field_type = determine_field_type(field->type);
if (row[i] == NULL) {
/* if the field is NULL and the type is numeric then store 0.00 as the result */
if (field_type == 1) {
obj_col = Tcl_NewDoubleObj(0);
} else {
obj_col = Tcl_NewStringObj(NULL,0);
}
} else {
/* if date field check for the value "0000-00-00" */
/* replace this with NULL */
if (field_type == 2 && strlen(row[i]) >= 10) {
if (strncmp(row[i],"0000-00-00",10) == 0) {
obj_col = Tcl_NewStringObj(NULL,0);
} else {
obj_col = Tcl_NewStringObj(row[i],strlen(row[i]));
}
} else {
#if UTF_ENCODING
Tcl_DStringInit(&ds);
Tcl_ExternalToUtfDString(NULL, row[i], strlen(row[i]), &ds);
obj_col = Tcl_NewStringObj(Tcl_DStringValue(&ds),
Tcl_DStringLength(&ds));
Tcl_DStringFree(&ds);
#else
obj_col = Tcl_NewStringObj(row[i],strlen(row[i]));
#endif
}
}
Tcl_ObjSetVar2(interp,obj_array,obj_element,obj_col,0);
/* we no longer have any use for the element object */
Tcl_DecrRefCount(obj_element);
}
/* we no longer have any use for the array object */
Tcl_DecrRefCount(obj_array);
/* set result object pointer */
obj_result = Tcl_GetObjResult(interp);
/* return result = array name */
Tcl_SetStringObj(obj_result,connection[sql_number].array_name,strlen(connection[sql_number].array_name));
return TCL_OK;
} else {
/* set result object pointer */
obj_result = Tcl_GetObjResult(interp);
/* process all columns from query row */
for (i = 0; i < connection[sql_number].field_count; i++) {
if (row[i] == NULL) {
length = 0;
} else {
length = strlen(row[i]);
}
#if UTF_ENCODING
Tcl_DStringInit(&ds);
Tcl_ExternalToUtfDString(NULL, row[i], length, &ds);
obj_col = Tcl_NewStringObj(Tcl_DStringValue(&ds),
Tcl_DStringLength(&ds));
Tcl_ListObjAppendElement(interp, obj_result, obj_col);
Tcl_DStringFree(&ds);
#else
obj_col = Tcl_NewStringObj(row[i],length);
Tcl_ListObjAppendElement(interp,obj_result,obj_col);
#endif
}
return TCL_OK;
}
}
void
TclpSetVariables(
Tcl_Interp *interp) /* Interp to initialize. */
{
const char *ptr;
char buffer[TCL_INTEGER_SPACE * 2];
SYSTEM_INFO sysInfo, *sysInfoPtr = &sysInfo;
OemId *oemId;
OSVERSIONINFOA osInfo;
Tcl_DString ds;
WCHAR szUserName[UNLEN+1];
DWORD cchUserNameLen = UNLEN;
Tcl_SetVar2Ex(interp, "tclDefaultLibrary", NULL,
TclGetProcessGlobalValue(&defaultLibraryDir), TCL_GLOBAL_ONLY);
osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
GetVersionExA(&osInfo);
oemId = (OemId *) sysInfoPtr;
GetSystemInfo(&sysInfo);
/*
* Define the tcl_platform array.
*/
Tcl_SetVar2(interp, "tcl_platform", "platform", "windows",
TCL_GLOBAL_ONLY);
if (osInfo.dwPlatformId < NUMPLATFORMS) {
Tcl_SetVar2(interp, "tcl_platform", "os",
platforms[osInfo.dwPlatformId], TCL_GLOBAL_ONLY);
}
wsprintfA(buffer, "%d.%d", osInfo.dwMajorVersion, osInfo.dwMinorVersion);
Tcl_SetVar2(interp, "tcl_platform", "osVersion", buffer, TCL_GLOBAL_ONLY);
if (oemId->wProcessorArchitecture < NUMPROCESSORS) {
Tcl_SetVar2(interp, "tcl_platform", "machine",
processors[oemId->wProcessorArchitecture],
TCL_GLOBAL_ONLY);
}
#ifdef _DEBUG
/*
* The existence of the "debug" element of the tcl_platform array
* indicates that this particular Tcl shell has been compiled with debug
* information. Using "info exists tcl_platform(debug)" a Tcl script can
* direct the interpreter to load debug versions of DLLs with the load
* command.
*/
Tcl_SetVar2(interp, "tcl_platform", "debug", "1",
TCL_GLOBAL_ONLY);
#endif
/*
* Set up the HOME environment variable from the HOMEDRIVE & HOMEPATH
* environment variables, if necessary.
*/
Tcl_DStringInit(&ds);
ptr = Tcl_GetVar2(interp, "env", "HOME", TCL_GLOBAL_ONLY);
if (ptr == NULL) {
ptr = Tcl_GetVar2(interp, "env", "HOMEDRIVE", TCL_GLOBAL_ONLY);
if (ptr != NULL) {
Tcl_DStringAppend(&ds, ptr, -1);
}
ptr = Tcl_GetVar2(interp, "env", "HOMEPATH", TCL_GLOBAL_ONLY);
if (ptr != NULL) {
Tcl_DStringAppend(&ds, ptr, -1);
}
if (Tcl_DStringLength(&ds) > 0) {
Tcl_SetVar2(interp, "env", "HOME", Tcl_DStringValue(&ds),
TCL_GLOBAL_ONLY);
} else {
Tcl_SetVar2(interp, "env", "HOME", "c:\\", TCL_GLOBAL_ONLY);
}
}
/*
* Initialize the user name from the environment first, since this is much
* faster than asking the system.
* Note: cchUserNameLen is number of characters including nul terminator.
*/
Tcl_DStringInit(&ds);
if (TclGetEnv("USERNAME", &ds) == NULL) {
if (tclWinProcs->getUserName((LPTSTR)szUserName, &cchUserNameLen) != 0) {
int cbUserNameLen = cchUserNameLen - 1;
if (tclWinProcs->useWide) cbUserNameLen *= sizeof(WCHAR);
Tcl_WinTCharToUtf((LPTSTR)szUserName, cbUserNameLen, &ds);
}
}
Tcl_SetVar2(interp, "tcl_platform", "user", Tcl_DStringValue(&ds),
TCL_GLOBAL_ONLY);
Tcl_DStringFree(&ds);
/*
* Define what the platform PATH separator is. [TIP #315]
*/
Tcl_SetVar2(interp, "tcl_platform","pathSeparator", ";", TCL_GLOBAL_ONLY);
}
void
TkSuspendClipboard()
{
TkClipboardTarget *targetPtr;
TkClipboardBuffer *cbPtr;
TkDisplay *dispPtr;
char *buffer, *p, *endPtr, *buffPtr;
long length;
ScrapRef scrapRef;
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;
}
}
}
ClearCurrentScrap();
GetCurrentScrap(&scrapRef);
Tcl_UtfToExternalDString(TkMacOSXCarbonEncoding, buffer, length, &encodedText);
PutScrapFlavor(scrapRef, 'TEXT', 0, Tcl_DStringLength(&encodedText), 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;
}
static int
AddClause(
Tcl_Interp *interp, /* Interpreter to use for error reporting. */
FileFilter *filterPtr, /* Stores the new filter clause */
Tcl_Obj *patternsObj, /* A Tcl list of glob patterns. */
Tcl_Obj *ostypesObj, /* A Tcl list of Mac OSType strings. */
int isWindows) /* True if we are running on Windows; False if
* we are running on the Mac; Glob patterns
* need to be processed differently on these
* two platforms */
{
Tcl_Obj **globList = NULL, **ostypeList = NULL;
int globCount, ostypeCount, i, code = TCL_OK;
FileFilterClause *clausePtr;
Tcl_Encoding macRoman = NULL;
if (Tcl_ListObjGetElements(interp, patternsObj,
&globCount, &globList) != TCL_OK) {
code = TCL_ERROR;
goto done;
}
if (ostypesObj != NULL) {
if (Tcl_ListObjGetElements(interp, ostypesObj,
&ostypeCount, &ostypeList) != TCL_OK) {
code = TCL_ERROR;
goto done;
}
/*
* We probably need this encoding now...
*/
macRoman = Tcl_GetEncoding(NULL, "macRoman");
/*
* Might be cleaner to use 'Tcl_GetOSTypeFromObj' but that is actually
* static to the MacOS X/Darwin version of Tcl, and would therefore
* require further code refactoring.
*/
for (i=0; i<ostypeCount; i++) {
int len;
const char *strType = Tcl_GetStringFromObj(ostypeList[i], &len);
/*
* If len is < 4, it is definitely an error. If equal or longer,
* we need to use the macRoman encoding to determine the correct
* length (assuming there may be non-ascii characters, e.g.,
* embedded nulls or accented characters in the string, the
* macRoman length will be different).
*
* If we couldn't load the encoding, then we can't actually check
* the correct length. But here we assume we're probably operating
* on unix/windows with a minimal set of encodings and so don't
* care about MacOS types. So we won't signal an error.
*/
if (len >= 4 && macRoman != NULL) {
Tcl_DString osTypeDS;
/*
* Convert utf to macRoman, since MacOS types are defined to
* be 4 macRoman characters long
*/
Tcl_UtfToExternalDString(macRoman, strType, len, &osTypeDS);
len = Tcl_DStringLength(&osTypeDS);
Tcl_DStringFree(&osTypeDS);
}
if (len != 4) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad Macintosh file type \"%s\"",
Tcl_GetString(ostypeList[i])));
Tcl_SetErrorCode(interp, "TK", "VALUE", "MAC_TYPE", NULL);
code = TCL_ERROR;
goto done;
}
}
}
/*
* Add the clause into the list of clauses
*/
clausePtr = ckalloc(sizeof(FileFilterClause));
clausePtr->patterns = NULL;
clausePtr->patternsTail = NULL;
clausePtr->macTypes = NULL;
clausePtr->macTypesTail = NULL;
if (filterPtr->clauses == NULL) {
filterPtr->clauses = filterPtr->clausesTail = clausePtr;
} else {
filterPtr->clausesTail->next = clausePtr;
filterPtr->clausesTail = clausePtr;
}
clausePtr->next = NULL;
if (globCount > 0 && globList != NULL) {
for (i=0; i<globCount; i++) {
GlobPattern *globPtr = ckalloc(sizeof(GlobPattern));
int len;
const char *str = Tcl_GetStringFromObj(globList[i], &len);
len = (len + 1) * sizeof(char);
if (str[0] && str[0] != '*') {
/*
* Prepend a "*" to patterns that do not have a leading "*"
*/
globPtr->pattern = ckalloc(len + 1);
globPtr->pattern[0] = '*';
strcpy(globPtr->pattern+1, str);
} else if (isWindows) {
if (strcmp(str, "*") == 0) {
globPtr->pattern = ckalloc(4);
strcpy(globPtr->pattern, "*.*");
} else if (strcmp(str, "") == 0) {
/*
* An empty string means "match all files with no
* extensions"
* TODO: "*." actually matches with all files on Win95
*/
globPtr->pattern = ckalloc(3);
strcpy(globPtr->pattern, "*.");
} else {
globPtr->pattern = ckalloc(len);
strcpy(globPtr->pattern, str);
}
} else {
globPtr->pattern = ckalloc(len);
strcpy(globPtr->pattern, str);
}
/*
* Add the glob pattern into the list of patterns.
*/
if (clausePtr->patterns == NULL) {
clausePtr->patterns = clausePtr->patternsTail = globPtr;
} else {
clausePtr->patternsTail->next = globPtr;
clausePtr->patternsTail = globPtr;
}
globPtr->next = NULL;
}
}
if (ostypeList != NULL && ostypeCount > 0) {
if (macRoman == NULL) {
macRoman = Tcl_GetEncoding(NULL, "macRoman");
}
for (i=0; i<ostypeCount; i++) {
Tcl_DString osTypeDS;
int len;
MacFileType *mfPtr = ckalloc(sizeof(MacFileType));
const char *strType = Tcl_GetStringFromObj(ostypeList[i], &len);
char *string;
/*
* Convert utf to macRoman, since MacOS types are defined to be 4
* macRoman characters long
*/
Tcl_UtfToExternalDString(macRoman, strType, len, &osTypeDS);
string = Tcl_DStringValue(&osTypeDS);
mfPtr->type = (OSType) string[0] << 24 | (OSType) string[1] << 16 |
(OSType) string[2] << 8 | (OSType) string[3];
Tcl_DStringFree(&osTypeDS);
/*
* Add the Mac type pattern into the list of Mac types
*/
if (clausePtr->macTypes == NULL) {
clausePtr->macTypes = clausePtr->macTypesTail = mfPtr;
} else {
clausePtr->macTypesTail->next = mfPtr;
clausePtr->macTypesTail = mfPtr;
}
mfPtr->next = NULL;
}
}
done:
if (macRoman != NULL) {
Tcl_FreeEncoding(macRoman);
}
return code;
}
/*ARGSUSED*/
static int
EmbWinLayoutProc(
TkText *textPtr, /* Text widget being layed out. */
TkTextIndex *indexPtr, /* Identifies first character in chunk. */
TkTextSegment *ewPtr, /* Segment corresponding to indexPtr. */
int offset, /* Offset within segPtr corresponding to
* indexPtr (always 0). */
int maxX, /* Chunk must not occupy pixels at this
* position or higher. */
int maxChars, /* Chunk must not include more than this many
* characters. */
int noCharsYet, /* Non-zero means no characters have been
* assigned to this line yet. */
TkWrapMode wrapMode, /* Wrap mode to use for line:
* TEXT_WRAPMODE_CHAR, TEXT_WRAPMODE_NONE, or
* TEXT_WRAPMODE_WORD. */
register TkTextDispChunk *chunkPtr)
/* Structure to fill in with information about
* this chunk. The x field has already been
* set by the caller. */
{
int width, height;
TkTextEmbWindowClient *client;
if (offset != 0) {
Tcl_Panic("Non-zero offset in EmbWinLayoutProc");
}
client = EmbWinGetClient(textPtr, ewPtr);
if (client == NULL) {
ewPtr->body.ew.tkwin = NULL;
} else {
ewPtr->body.ew.tkwin = client->tkwin;
}
if ((ewPtr->body.ew.tkwin == NULL) && (ewPtr->body.ew.create != NULL)) {
int code, isNew;
Tk_Window ancestor;
Tcl_HashEntry *hPtr;
const char *before, *string;
Tcl_DString name, buf, *dsPtr = NULL;
before = ewPtr->body.ew.create;
/*
* Find everything up to the next % character and append it to the
* result string.
*/
string = before;
while (*string != 0) {
if ((*string == '%') && (string[1] == '%' || string[1] == 'W')) {
if (dsPtr == NULL) {
Tcl_DStringInit(&buf);
dsPtr = &buf;
}
if (string != before) {
Tcl_DStringAppend(dsPtr, before, (int) (string-before));
before = string;
}
if (string[1] == '%') {
Tcl_DStringAppend(dsPtr, "%", 1);
} else {
/*
* Substitute string as proper Tcl list element.
*/
int spaceNeeded, cvtFlags, length;
const char *str = Tk_PathName(textPtr->tkwin);
spaceNeeded = Tcl_ScanElement(str, &cvtFlags);
length = Tcl_DStringLength(dsPtr);
Tcl_DStringSetLength(dsPtr, length + spaceNeeded);
spaceNeeded = Tcl_ConvertElement(str,
Tcl_DStringValue(dsPtr) + length,
cvtFlags | TCL_DONT_USE_BRACES);
Tcl_DStringSetLength(dsPtr, length + spaceNeeded);
}
before += 2;
string++;
}
string++;
}
/*
* The window doesn't currently exist. Create it by evaluating the
* creation script. The script must return the window's path name:
* look up that name to get back to the window token. Then register
* ourselves as the geometry manager for the window.
*/
if (dsPtr != NULL) {
Tcl_DStringAppend(dsPtr, before, (int) (string-before));
code = Tcl_GlobalEval(textPtr->interp, Tcl_DStringValue(dsPtr));
Tcl_DStringFree(dsPtr);
} else {
code = Tcl_GlobalEval(textPtr->interp, ewPtr->body.ew.create);
}
if (code != TCL_OK) {
createError:
Tcl_BackgroundException(textPtr->interp, code);
goto gotWindow;
}
Tcl_DStringInit(&name);
Tcl_DStringAppend(&name, Tcl_GetStringResult(textPtr->interp), -1);
Tcl_ResetResult(textPtr->interp);
ewPtr->body.ew.tkwin = Tk_NameToWindow(textPtr->interp,
Tcl_DStringValue(&name), textPtr->tkwin);
Tcl_DStringFree(&name);
if (ewPtr->body.ew.tkwin == NULL) {
goto createError;
}
for (ancestor = textPtr->tkwin; ; ancestor = Tk_Parent(ancestor)) {
if (ancestor == Tk_Parent(ewPtr->body.ew.tkwin)) {
break;
}
if (Tk_TopWinHierarchy(ancestor)) {
badMaster:
Tcl_AppendResult(textPtr->interp, "can't embed ",
Tk_PathName(ewPtr->body.ew.tkwin), " relative to ",
Tk_PathName(textPtr->tkwin), NULL);
Tcl_BackgroundError(textPtr->interp);
ewPtr->body.ew.tkwin = NULL;
goto gotWindow;
}
}
if (Tk_TopWinHierarchy(ewPtr->body.ew.tkwin)
|| (textPtr->tkwin == ewPtr->body.ew.tkwin)) {
goto badMaster;
}
if (client == NULL) {
/*
* We just used a '-create' script to make a new window, which we
* now need to add to our client list.
*/
client = (TkTextEmbWindowClient *)
ckalloc(sizeof(TkTextEmbWindowClient));
client->next = ewPtr->body.ew.clients;
client->textPtr = textPtr;
client->tkwin = NULL;
client->chunkCount = 0;
client->displayed = 0;
client->parent = ewPtr;
ewPtr->body.ew.clients = client;
}
client->tkwin = ewPtr->body.ew.tkwin;
Tk_ManageGeometry(client->tkwin, &textGeomType,
(ClientData) client);
Tk_CreateEventHandler(client->tkwin, StructureNotifyMask,
EmbWinStructureProc, (ClientData) client);
/*
* Special trick! Must enter into the hash table *after* calling
* Tk_ManageGeometry: if the window was already managed elsewhere in
* this text, the Tk_ManageGeometry call will cause the entry to be
* removed, which could potentially lose the new entry.
*/
hPtr = Tcl_CreateHashEntry(&textPtr->sharedTextPtr->windowTable,
Tk_PathName(client->tkwin), &isNew);
Tcl_SetHashValue(hPtr, ewPtr);
}
/*
* See if there's room for this window on this line.
*/
gotWindow:
if (ewPtr->body.ew.tkwin == NULL) {
width = 0;
height = 0;
} else {
width = Tk_ReqWidth(ewPtr->body.ew.tkwin) + 2*ewPtr->body.ew.padX;
height = Tk_ReqHeight(ewPtr->body.ew.tkwin) + 2*ewPtr->body.ew.padY;
}
if ((width > (maxX - chunkPtr->x))
&& !noCharsYet && (textPtr->wrapMode != TEXT_WRAPMODE_NONE)) {
return 0;
}
/*
* Fill in the chunk structure.
*/
chunkPtr->displayProc = TkTextEmbWinDisplayProc;
chunkPtr->undisplayProc = EmbWinUndisplayProc;
chunkPtr->measureProc = NULL;
chunkPtr->bboxProc = EmbWinBboxProc;
chunkPtr->numBytes = 1;
if (ewPtr->body.ew.align == ALIGN_BASELINE) {
chunkPtr->minAscent = height - ewPtr->body.ew.padY;
chunkPtr->minDescent = ewPtr->body.ew.padY;
chunkPtr->minHeight = 0;
} else {
chunkPtr->minAscent = 0;
chunkPtr->minDescent = 0;
chunkPtr->minHeight = height;
}
chunkPtr->width = width;
chunkPtr->breakIndex = -1;
chunkPtr->breakIndex = 1;
chunkPtr->clientData = (ClientData) ewPtr;
if (client != NULL) {
client->chunkCount += 1;
}
return 1;
}
static int
QueryConfigObjCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
struct Tcl_Obj *const *objv)
{
QCCD *cdPtr = clientData;
Tcl_Obj *pkgName = cdPtr->pkg;
Tcl_Obj *pDB, *pkgDict, *val, *listPtr;
int n, index;
static const char *const subcmdStrings[] = {
"get", "list", NULL
};
enum subcmds {
CFG_GET, CFG_LIST
};
Tcl_DString conv;
Tcl_Encoding venc = NULL;
const char *value;
if ((objc < 2) || (objc > 3)) {
Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], subcmdStrings, "subcommand", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
pDB = GetConfigDict(interp);
if (Tcl_DictObjGet(interp, pDB, pkgName, &pkgDict) != TCL_OK
|| pkgDict == NULL) {
/*
* Maybe a Tcl_Panic is better, because the package data has to be
* present.
*/
Tcl_SetObjResult(interp, Tcl_NewStringObj("package not known", -1));
Tcl_SetErrorCode(interp, "TCL", "FATAL", "PKGCFG_BASE",
TclGetString(pkgName), NULL);
return TCL_ERROR;
}
switch ((enum subcmds) index) {
case CFG_GET:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "key");
return TCL_ERROR;
}
if (Tcl_DictObjGet(interp, pkgDict, objv[2], &val) != TCL_OK
|| val == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("key not known", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONFIG",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
if (cdPtr->encoding) {
venc = Tcl_GetEncoding(interp, cdPtr->encoding);
if (!venc) {
return TCL_ERROR;
}
}
/*
* Value is stored as-is in a byte array, see Bug [9b2e636361],
* so we have to decode it first.
*/
value = (const char *) Tcl_GetByteArrayFromObj(val, &n);
value = Tcl_ExternalToUtfDString(venc, value, n, &conv);
Tcl_SetObjResult(interp, Tcl_NewStringObj(value,
Tcl_DStringLength(&conv)));
Tcl_DStringFree(&conv);
return TCL_OK;
case CFG_LIST:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
Tcl_DictObjSize(interp, pkgDict, &n);
listPtr = Tcl_NewListObj(n, NULL);
if (!listPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"insufficient memory to create list", -1));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
return TCL_ERROR;
}
if (n) {
Tcl_DictSearch s;
Tcl_Obj *key;
int done;
for (Tcl_DictObjFirst(interp, pkgDict, &s, &key, NULL, &done);
!done; Tcl_DictObjNext(&s, &key, NULL, &done)) {
Tcl_ListObjAppendElement(NULL, listPtr, key);
}
}
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
default:
Tcl_Panic("QueryConfigObjCmd: Unknown subcommand to 'pkgconfig'. This can't happen");
break;
}
return TCL_ERROR;
}
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);
}
const 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. */
const 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;
RegisteredInterp *riPtr, *prevPtr;
const 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 (result != TCL_OK || interpNamePtr == NULL) {
break;
}
interpName = Tcl_GetString(interpNamePtr);
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(Tcl_DStringValue(&dString) + 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 = ckalloc(sizeof(RegisteredInterp));
riPtr->interp = interp;
riPtr->name = ckalloc(strlen(actualName) + 1);
riPtr->nextPtr = interpListPtr;
interpListPtr = riPtr;
strcpy(riPtr->name, actualName);
/*
* TODO: DeleteProc
*/
Tcl_CreateObjCommand(interp, "send", Tk_SendObjCmd, riPtr, NULL);
if (Tcl_IsSafe(interp)) {
Tcl_HideCommand(interp, "send", "send");
}
Tcl_DStringFree(&dString);
return riPtr->name;
}
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 = (CONST char*) Tcl_FSGetNativePath(pathPtr);
tailPtr = TclPathPart(interp, pathPtr, TCL_PATH_TAIL);
nativeTail = (CONST char*) 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;
int matchHidden, matchHiddenPat;
int nativeDirLen;
Tcl_StatBuf statBuf;
Tcl_DString ds; /* native encoding of dir */
Tcl_DString dsOrig; /* utf-8 encoding of dir */
Tcl_DStringInit(&dsOrig);
dirName = Tcl_GetStringFromObj(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 = Tcl_DStringAppend(&dsOrig, "/", 1);
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_ResetResult(interp);
Tcl_AppendResult(interp, "couldn't read directory \"",
Tcl_DStringValue(&dsOrig), "\": ",
Tcl_PosixError(interp), (char *) NULL);
}
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;
} else {
return TCL_OK;
}
}
const char *
TkpGetString(
TkWindow *winPtr, /* Window where event occurred */
XEvent *eventPtr, /* X keyboard event. */
Tcl_DString *dsPtr) /* Initialized, empty string to hold result. */
{
int len;
Tcl_DString buf;
TkKeyEvent *kePtr = (TkKeyEvent *) eventPtr;
/*
* If we have the value cached already, use it now. [Bug 1373712]
*/
if (kePtr->charValuePtr != NULL) {
Tcl_DStringSetLength(dsPtr, kePtr->charValueLen);
memcpy(Tcl_DStringValue(dsPtr), kePtr->charValuePtr,
(unsigned) kePtr->charValueLen+1);
return Tcl_DStringValue(dsPtr);
}
#ifdef TK_USE_INPUT_METHODS
if ((winPtr->dispPtr->flags & TK_DISPLAY_USE_IM)
&& (winPtr->inputContext != NULL)
&& (eventPtr->type == KeyPress)) {
Status status;
#if X_HAVE_UTF8_STRING
Tcl_DStringSetLength(dsPtr, TCL_DSTRING_STATIC_SIZE-1);
len = Xutf8LookupString(winPtr->inputContext, &eventPtr->xkey,
Tcl_DStringValue(dsPtr), Tcl_DStringLength(dsPtr),
&kePtr->keysym, &status);
if (status == XBufferOverflow) {
/*
* Expand buffer and try again.
*/
Tcl_DStringSetLength(dsPtr, len);
len = Xutf8LookupString(winPtr->inputContext, &eventPtr->xkey,
Tcl_DStringValue(dsPtr), Tcl_DStringLength(dsPtr),
&kePtr->keysym, &status);
}
if ((status != XLookupChars) && (status != XLookupBoth)) {
len = 0;
}
Tcl_DStringSetLength(dsPtr, len);
#else /* !X_HAVE_UTF8_STRING */
/*
* Overallocate the dstring to the maximum stack amount.
*/
Tcl_DStringInit(&buf);
Tcl_DStringSetLength(&buf, TCL_DSTRING_STATIC_SIZE-1);
len = XmbLookupString(winPtr->inputContext, &eventPtr->xkey,
Tcl_DStringValue(&buf), Tcl_DStringLength(&buf),
&kePtr->keysym, &status);
/*
* If the buffer wasn't big enough, grow the buffer and try again.
*/
if (status == XBufferOverflow) {
Tcl_DStringSetLength(&buf, len);
len = XmbLookupString(winPtr->inputContext, &eventPtr->xkey,
Tcl_DStringValue(&buf), len, &kePtr->keysym, &status);
}
if ((status != XLookupChars) && (status != XLookupBoth)) {
len = 0;
}
Tcl_DStringSetLength(&buf, len);
Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&buf), len, dsPtr);
Tcl_DStringFree(&buf);
#endif /* X_HAVE_UTF8_STRING */
} else
#endif /* TK_USE_INPUT_METHODS */
{
/*
* Fall back to convert a keyboard event to a UTF-8 string using
* XLookupString. This is used when input methods are turned off and
* for KeyRelease events.
*
* Note: XLookupString() normally returns a single ISO Latin 1 or
* ASCII control character.
*/
Tcl_DStringInit(&buf);
Tcl_DStringSetLength(&buf, TCL_DSTRING_STATIC_SIZE-1);
len = XLookupString(&eventPtr->xkey, Tcl_DStringValue(&buf),
TCL_DSTRING_STATIC_SIZE, &kePtr->keysym, 0);
Tcl_DStringValue(&buf)[len] = '\0';
if (len == 1) {
len = Tcl_UniCharToUtf((unsigned char) Tcl_DStringValue(&buf)[0],
Tcl_DStringValue(dsPtr));
Tcl_DStringSetLength(dsPtr, len);
} else {
/*
* len > 1 should only happen if someone has called XRebindKeysym.
* Assume UTF-8.
*/
Tcl_DStringSetLength(dsPtr, len);
strncpy(Tcl_DStringValue(dsPtr), Tcl_DStringValue(&buf), len);
}
}
/*
* Cache the string in the event so that if/when we return to this
* function, we will be able to produce it without asking X. This stops us
* from having to reenter the XIM engine. [Bug 1373712]
*/
kePtr->charValuePtr = ckalloc(len + 1);
kePtr->charValueLen = len;
memcpy(kePtr->charValuePtr, Tcl_DStringValue(dsPtr), (unsigned) len + 1);
return Tcl_DStringValue(dsPtr);
}
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 = Tcl_GetStringFromObj(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 = Tcl_NewStringObj(Tcl_DStringValue(&ds),
Tcl_DStringLength(&ds));
Tcl_DStringFree(&ds);
if (linkPtr != NULL) {
Tcl_IncrRefCount(linkPtr);
}
return linkPtr;
}
}
static void
AppendSystemError(
Tcl_Interp *interp, /* Current interpreter. */
DWORD error) /* Result code from error. */
{
int length;
WCHAR *wMsgPtr, **wMsgPtrPtr = &wMsgPtr;
const char *msg;
char id[TCL_INTEGER_SPACE], msgBuf[24 + TCL_INTEGER_SPACE];
Tcl_DString ds;
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
if (Tcl_IsShared(resultPtr)) {
resultPtr = Tcl_DuplicateObj(resultPtr);
}
length = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM
| FORMAT_MESSAGE_IGNORE_INSERTS
| FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error,
MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (WCHAR *) wMsgPtrPtr,
0, NULL);
if (length == 0) {
char *msgPtr;
length = FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM
| FORMAT_MESSAGE_IGNORE_INSERTS
| FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error,
MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (char *) &msgPtr,
0, NULL);
if (length > 0) {
wMsgPtr = (WCHAR *) LocalAlloc(LPTR, (length + 1) * sizeof(WCHAR));
MultiByteToWideChar(CP_ACP, 0, msgPtr, length + 1, wMsgPtr,
length + 1);
LocalFree(msgPtr);
}
}
if (length == 0) {
if (error == ERROR_CALL_NOT_IMPLEMENTED) {
strcpy(msgBuf, "function not supported under Win32s");
} else {
sprintf(msgBuf, "unknown error: %ld", error);
}
msg = msgBuf;
} else {
Tcl_Encoding encoding;
char *msgPtr;
encoding = Tcl_GetEncoding(NULL, "unicode");
Tcl_ExternalToUtfDString(encoding, (char *) wMsgPtr, -1, &ds);
Tcl_FreeEncoding(encoding);
LocalFree(wMsgPtr);
msgPtr = Tcl_DStringValue(&ds);
length = Tcl_DStringLength(&ds);
/*
* Trim the trailing CR/LF from the system message.
*/
if (msgPtr[length-1] == '\n') {
--length;
}
if (msgPtr[length-1] == '\r') {
--length;
}
msgPtr[length] = 0;
msg = msgPtr;
}
sprintf(id, "%ld", error);
Tcl_SetErrorCode(interp, "WINDOWS", id, msg, NULL);
Tcl_AppendToObj(resultPtr, msg, length);
Tcl_SetObjResult(interp, resultPtr);
if (length != 0) {
Tcl_DStringFree(&ds);
}
}
void
TclUnsetEnv(
const char *name) /* Name of variable to remove (UTF-8). */
{
char *oldValue;
int length;
int index;
#ifdef USE_PUTENV_FOR_UNSET
Tcl_DString envString;
char *string;
#else
char **envPtr;
#endif /* USE_PUTENV_FOR_UNSET */
Tcl_MutexLock(&envMutex);
index = TclpFindVariable(name, &length);
/*
* First make sure that the environment variable exists to avoid doing
* needless work and to avoid recursion on the unset.
*/
if (index == -1) {
Tcl_MutexUnlock(&envMutex);
return;
}
/*
* Remember the old value so we can free it if Tcl created the string.
*/
oldValue = environ[index];
/*
* Update the system environment. This must be done before we update the
* interpreters or we will recurse.
*/
#ifdef USE_PUTENV_FOR_UNSET
/*
* For those platforms that support putenv to unset, Linux indicates
* that no = should be included, and Windows requires it.
*/
#if defined(__WIN32__) || defined(__CYGWIN__)
string = ckalloc((unsigned) length+2);
memcpy(string, name, (size_t) length);
string[length] = '=';
string[length+1] = '\0';
#else
string = ckalloc((unsigned) length+1);
memcpy(string, name, (size_t) length);
string[length] = '\0';
#endif /* WIN32 */
Tcl_UtfToExternalDString(NULL, string, -1, &envString);
string = ckrealloc(string, (unsigned) Tcl_DStringLength(&envString)+1);
strcpy(string, Tcl_DStringValue(&envString));
Tcl_DStringFree(&envString);
putenv(string);
/*
* Watch out for versions of putenv that copy the string (e.g. VC++). In
* this case we need to free the string immediately. Otherwise update the
* string in the cache.
*/
if (environ[index] == string) {
ReplaceString(oldValue, string);
#ifdef HAVE_PUTENV_THAT_COPIES
} else {
/*
* This putenv() copies instead of taking ownership.
*/
ckfree(string);
#endif /* HAVE_PUTENV_THAT_COPIES */
}
#else /* !USE_PUTENV_FOR_UNSET */
for (envPtr = environ+index+1; ; envPtr++) {
envPtr[-1] = *envPtr;
if (*envPtr == NULL) {
break;
}
}
ReplaceString(oldValue, NULL);
#endif /* USE_PUTENV_FOR_UNSET */
Tcl_MutexUnlock(&envMutex);
}
int fbsql_query(Tcl_Interp *interp, int sql_number, int argc, char **argv) {
char *query = NULL;
int i, length, field_count;
MYSQL_RES *result;
MYSQL_ROW row;
Tcl_Obj *obj_result;
Tcl_Obj *obj_row;
Tcl_Obj *obj_col;
#if UTF_ENCODING
Tcl_DString ds;
#endif
if (!connection[sql_number].CONNECTED) {
Tcl_SetResult(interp, "sql query statement; you are not connected to a mysql server yet (sql connect).", TCL_STATIC);
return TCL_ERROR;
}
/* check there is no other active query? */
if (connection[sql_number].query_flag) {
Tcl_SetResult(interp, "Another query cannot be made until the current query has been finished with \"sql endquery\".", TCL_STATIC);
return TCL_ERROR;
}
if (argc <= 0 || argv[0] == NULL) {
Tcl_SetResult(interp, "sql query statement; no sql query was specified.", TCL_STATIC);
return TCL_ERROR;
}
#if UTF_ENCODING
Tcl_DStringInit(&ds);
Tcl_UtfToExternalDString(NULL, argv[0], strlen(argv[0]), &ds);
query = Tcl_DStringValue(&ds);
/* execute the sql query statement */
if (mysql_query(&connection[sql_number].mysql,query)) {
output_error(interp,sql_number);
Tcl_DStringFree(&ds);
return TCL_ERROR;
}
Tcl_DStringFree(&ds);
#else
query = argv[0];
/* execute the sql query statement */
if (mysql_query(&connection[sql_number].mysql,query)) {
output_error(interp,sql_number);
return TCL_ERROR;
}
#endif
result = mysql_use_result(&connection[sql_number].mysql);
field_count = mysql_field_count(&connection[sql_number].mysql);
/* if no results were found and none expected then all ok */
/* otherwise we assume the query worked ok, now get the results */
if (result == NULL) {
if (field_count) {
output_error(interp,sql_number);
return TCL_ERROR;
}
connection[sql_number].NUMROWS = (int)mysql_affected_rows(&connection[sql_number].mysql);
return TCL_OK;
} else {
/* set result object pointer */
obj_result = Tcl_GetObjResult(interp);
/* process all rows from query */
while ((row = mysql_fetch_row(result)) != NULL) {
obj_row = Tcl_NewListObj(0,NULL);
for (i = 0; i < field_count; i++) {
if (row[i] == NULL) {
length = 0;
} else {
length = strlen(row[i]);
}
#if UTF_ENCODING
Tcl_DStringInit(&ds);
Tcl_ExternalToUtfDString(NULL, row[i], length, &ds);
obj_col = Tcl_NewStringObj(Tcl_DStringValue(&ds),
Tcl_DStringLength(&ds));
Tcl_ListObjAppendElement(interp, obj_row, obj_col);
Tcl_DStringFree(&ds);
#else
obj_col = Tcl_NewStringObj(row[i],length);
Tcl_ListObjAppendElement(interp,obj_row,obj_col);
#endif
}
Tcl_ListObjAppendElement(interp,obj_result,obj_row);
}
connection[sql_number].NUMROWS = (int)mysql_num_rows(result);
mysql_free_result(result);
return TCL_OK;
}
}
void
Tcl_Main(
int argc, /* Number of arguments. */
char **argv, /* Array of argument strings. */
Tcl_AppInitProc *appInitProc)
/* Application-specific initialization
* function to call after most initialization
* but before starting to execute commands. */
{
Tcl_Obj *path, *resultPtr, *argvPtr, *commandPtr = NULL;
const char *encodingName = NULL;
PromptType prompt = PROMPT_START;
int code, length, tty, exitCode = 0;
Tcl_Channel inChannel, outChannel, errChannel;
Tcl_Interp *interp;
Tcl_DString appName;
Tcl_FindExecutable(argv[0]);
interp = Tcl_CreateInterp();
Tcl_InitMemory(interp);
/*
* If the application has not already set a startup script, parse the
* first few command line arguments to determine the script path and
* encoding.
*/
if (NULL == Tcl_GetStartupScript(NULL)) {
/*
* Check whether first 3 args (argv[1] - argv[3]) look like
* -encoding ENCODING FILENAME
* or like
* FILENAME
*/
if ((argc > 3) && (0 == strcmp("-encoding", argv[1]))
&& ('-' != argv[3][0])) {
Tcl_SetStartupScript(Tcl_NewStringObj(argv[3], -1), argv[2]);
argc -= 3;
argv += 3;
} else if ((argc > 1) && ('-' != argv[1][0])) {
Tcl_SetStartupScript(Tcl_NewStringObj(argv[1], -1), NULL);
argc--;
argv++;
}
}
path = Tcl_GetStartupScript(&encodingName);
if (path == NULL) {
Tcl_ExternalToUtfDString(NULL, argv[0], -1, &appName);
} else {
const char *pathName = Tcl_GetStringFromObj(path, &length);
Tcl_ExternalToUtfDString(NULL, pathName, length, &appName);
path = Tcl_NewStringObj(Tcl_DStringValue(&appName), -1);
Tcl_SetStartupScript(path, encodingName);
}
Tcl_SetVar(interp, "argv0", Tcl_DStringValue(&appName), TCL_GLOBAL_ONLY);
Tcl_DStringFree(&appName);
argc--;
argv++;
Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewIntObj(argc), TCL_GLOBAL_ONLY);
argvPtr = Tcl_NewListObj(0, NULL);
while (argc--) {
Tcl_DString ds;
Tcl_ExternalToUtfDString(NULL, *argv++, -1, &ds);
Tcl_ListObjAppendElement(NULL, argvPtr, Tcl_NewStringObj(
Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)));
Tcl_DStringFree(&ds);
}
Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY);
/*
* Set the "tcl_interactive" variable.
*/
tty = isatty(0);
Tcl_SetVar(interp, "tcl_interactive", ((path == NULL) && tty) ? "1" : "0",
TCL_GLOBAL_ONLY);
/*
* Invoke application-specific initialization.
*/
Tcl_Preserve(interp);
if (appInitProc(interp) != TCL_OK) {
errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel) {
Tcl_WriteChars(errChannel,
"application-specific initialization failed: ", -1);
Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
Tcl_WriteChars(errChannel, "\n", 1);
}
}
if (Tcl_InterpDeleted(interp)) {
goto done;
}
if (Tcl_LimitExceeded(interp)) {
goto done;
}
/*
* If a script file was specified then just source that file and quit.
* Must fetch it again, as the appInitProc might have reset it.
*/
path = Tcl_GetStartupScript(&encodingName);
if (path != NULL) {
code = Tcl_FSEvalFileEx(interp, path, encodingName);
if (code != TCL_OK) {
errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel) {
Tcl_Obj *options = Tcl_GetReturnOptions(interp, code);
Tcl_Obj *keyPtr, *valuePtr;
TclNewLiteralStringObj(keyPtr, "-errorinfo");
Tcl_IncrRefCount(keyPtr);
Tcl_DictObjGet(NULL, options, keyPtr, &valuePtr);
Tcl_DecrRefCount(keyPtr);
if (valuePtr) {
Tcl_WriteObj(errChannel, valuePtr);
}
Tcl_WriteChars(errChannel, "\n", 1);
}
exitCode = 1;
}
goto done;
}
/*
* We're running interactively. Source a user-specific startup file if the
* application specified one and if the file exists.
*/
Tcl_SourceRCFile(interp);
if (Tcl_LimitExceeded(interp)) {
goto done;
}
/*
* Process commands from stdin until there's an end-of-file. Note that we
* need to fetch the standard channels again after every eval, since they
* may have been changed.
*/
commandPtr = Tcl_NewObj();
Tcl_IncrRefCount(commandPtr);
/*
* Get a new value for tty if anyone writes to ::tcl_interactive
*/
Tcl_LinkVar(interp, "tcl_interactive", (char *) &tty, TCL_LINK_BOOLEAN);
inChannel = Tcl_GetStdChannel(TCL_STDIN);
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
while ((inChannel != NULL) && !Tcl_InterpDeleted(interp)) {
if (mainLoopProc == NULL) {
if (tty) {
Prompt(interp, &prompt);
if (Tcl_InterpDeleted(interp)) {
break;
}
if (Tcl_LimitExceeded(interp)) {
break;
}
inChannel = Tcl_GetStdChannel(TCL_STDIN);
if (inChannel == NULL) {
break;
}
}
if (Tcl_IsShared(commandPtr)) {
Tcl_DecrRefCount(commandPtr);
commandPtr = Tcl_DuplicateObj(commandPtr);
Tcl_IncrRefCount(commandPtr);
}
length = Tcl_GetsObj(inChannel, commandPtr);
if (length < 0) {
if (Tcl_InputBlocked(inChannel)) {
/*
* This can only happen if stdin has been set to
* non-blocking. In that case cycle back and try again.
* This sets up a tight polling loop (since we have no
* event loop running). If this causes bad CPU hogging, we
* might try toggling the blocking on stdin instead.
*/
continue;
}
/*
* Either EOF, or an error on stdin; we're done
*/
break;
}
/*
* Add the newline removed by Tcl_GetsObj back to the string. Have
* to add it back before testing completeness, because it can make
* a difference. [Bug 1775878]
*/
if (Tcl_IsShared(commandPtr)) {
Tcl_DecrRefCount(commandPtr);
commandPtr = Tcl_DuplicateObj(commandPtr);
Tcl_IncrRefCount(commandPtr);
}
Tcl_AppendToObj(commandPtr, "\n", 1);
if (!TclObjCommandComplete(commandPtr)) {
prompt = PROMPT_CONTINUE;
continue;
}
prompt = PROMPT_START;
/*
* The final newline is syntactically redundant, and causes some
* error messages troubles deeper in, so lop it back off.
*/
Tcl_GetStringFromObj(commandPtr, &length);
Tcl_SetObjLength(commandPtr, --length);
code = Tcl_RecordAndEvalObj(interp, commandPtr, TCL_EVAL_GLOBAL);
inChannel = Tcl_GetStdChannel(TCL_STDIN);
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
errChannel = Tcl_GetStdChannel(TCL_STDERR);
Tcl_DecrRefCount(commandPtr);
commandPtr = Tcl_NewObj();
Tcl_IncrRefCount(commandPtr);
if (code != TCL_OK) {
if (errChannel) {
Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
Tcl_WriteChars(errChannel, "\n", 1);
}
} else if (tty) {
resultPtr = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(resultPtr);
Tcl_GetStringFromObj(resultPtr, &length);
if ((length > 0) && outChannel) {
Tcl_WriteObj(outChannel, resultPtr);
Tcl_WriteChars(outChannel, "\n", 1);
}
Tcl_DecrRefCount(resultPtr);
}
} else { /* (mainLoopProc != NULL) */
/*
* If a main loop has been defined while running interactively, we
* want to start a fileevent based prompt by establishing a
* channel handler for stdin.
*/
InteractiveState *isPtr = NULL;
if (inChannel) {
if (tty) {
Prompt(interp, &prompt);
}
isPtr = (InteractiveState *)
ckalloc(sizeof(InteractiveState));
isPtr->input = inChannel;
isPtr->tty = tty;
isPtr->commandPtr = commandPtr;
isPtr->prompt = prompt;
isPtr->interp = interp;
Tcl_UnlinkVar(interp, "tcl_interactive");
Tcl_LinkVar(interp, "tcl_interactive", (char *) &(isPtr->tty),
TCL_LINK_BOOLEAN);
Tcl_CreateChannelHandler(inChannel, TCL_READABLE, StdinProc,
isPtr);
}
mainLoopProc();
mainLoopProc = NULL;
if (inChannel) {
tty = isPtr->tty;
Tcl_UnlinkVar(interp, "tcl_interactive");
Tcl_LinkVar(interp, "tcl_interactive", (char *) &tty,
TCL_LINK_BOOLEAN);
prompt = isPtr->prompt;
commandPtr = isPtr->commandPtr;
if (isPtr->input != NULL) {
Tcl_DeleteChannelHandler(isPtr->input, StdinProc, isPtr);
}
ckfree((char *) isPtr);
}
inChannel = Tcl_GetStdChannel(TCL_STDIN);
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
errChannel = Tcl_GetStdChannel(TCL_STDERR);
}
#ifdef TCL_MEM_DEBUG
/*
* This code here only for the (unsupported and deprecated) [checkmem]
* command.
*/
if (tclMemDumpFileName != NULL) {
mainLoopProc = NULL;
Tcl_DeleteInterp(interp);
}
#endif
}
done:
if ((exitCode == 0) && (mainLoopProc != NULL)
&& !Tcl_LimitExceeded(interp)) {
/*
* If everything has gone OK so far, call the main loop proc, if it
* exists. Packages (like Tk) can set it to start processing events at
* this point.
*/
mainLoopProc();
mainLoopProc = NULL;
}
if (commandPtr != NULL) {
Tcl_DecrRefCount(commandPtr);
}
/*
* Rather than calling exit, invoke the "exit" command so that users can
* replace "exit" with some other command to do additional cleanup on
* exit. The Tcl_EvalObjEx call should never return.
*/
if (!Tcl_InterpDeleted(interp)) {
if (!Tcl_LimitExceeded(interp)) {
Tcl_Obj *cmd = Tcl_ObjPrintf("exit %d", exitCode);
Tcl_IncrRefCount(cmd);
Tcl_EvalObjEx(interp, cmd, TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(cmd);
}
/*
* If Tcl_EvalObjEx returns, trying to eval [exit], something unusual
* is happening. Maybe interp has been deleted; maybe [exit] was
* redefined, maybe we've blown up because of an exceeded limit. We
* still want to cleanup and exit.
*/
if (!Tcl_InterpDeleted(interp)) {
Tcl_DeleteInterp(interp);
}
}
Tcl_SetStartupScript(NULL, NULL);
/*
* If we get here, the master interp has been deleted. Allow its
* destruction with the last matching Tcl_Release.
*/
Tcl_Release(interp);
Tcl_Exit(exitCode);
}
void
TclSetEnv(
const char *name, /* Name of variable whose value is to be set
* (UTF-8). */
const char *value) /* New value for variable (UTF-8). */
{
Tcl_DString envString;
unsigned nameLength, valueLength;
int index, length;
char *p, *oldValue;
const char *p2;
/*
* Figure out where the entry is going to go. If the name doesn't already
* exist, enlarge the array if necessary to make room. If the name exists,
* free its old entry.
*/
Tcl_MutexLock(&envMutex);
index = TclpFindVariable(name, &length);
if (index == -1) {
#ifndef USE_PUTENV
/*
* We need to handle the case where the environment may be changed
* outside our control. ourEnvironSize is only valid if the current
* environment is the one we allocated. [Bug 979640]
*/
if ((env.ourEnviron != environ) || (length+2 > env.ourEnvironSize)) {
char **newEnviron = ckalloc((length + 5) * sizeof(char *));
memcpy(newEnviron, environ, length * sizeof(char *));
if ((env.ourEnvironSize != 0) && (env.ourEnviron != NULL)) {
ckfree(env.ourEnviron);
}
environ = env.ourEnviron = newEnviron;
env.ourEnvironSize = length + 5;
}
index = length;
environ[index + 1] = NULL;
#endif /* USE_PUTENV */
oldValue = NULL;
nameLength = strlen(name);
} else {
const char *env;
/*
* Compare the new value to the existing value. If they're the same
* then quit immediately (e.g. don't rewrite the value or propagate it
* to other interpreters). Otherwise, when there are N interpreters
* there will be N! propagations of the same value among the
* interpreters.
*/
env = Tcl_ExternalToUtfDString(NULL, environ[index], -1, &envString);
if (strcmp(value, env + (length + 1)) == 0) {
Tcl_DStringFree(&envString);
Tcl_MutexUnlock(&envMutex);
return;
}
Tcl_DStringFree(&envString);
oldValue = environ[index];
nameLength = (unsigned) length;
}
/*
* Create a new entry. Build a complete UTF string that contains a
* "name=value" pattern. Then convert the string to the native encoding,
* and set the environ array value.
*/
valueLength = strlen(value);
p = ckalloc(nameLength + valueLength + 2);
memcpy(p, name, nameLength);
p[nameLength] = '=';
memcpy(p+nameLength+1, value, valueLength+1);
p2 = Tcl_UtfToExternalDString(NULL, p, -1, &envString);
/*
* Copy the native string to heap memory.
*/
p = ckrealloc(p, Tcl_DStringLength(&envString) + 1);
memcpy(p, p2, (unsigned) Tcl_DStringLength(&envString) + 1);
Tcl_DStringFree(&envString);
#ifdef USE_PUTENV
/*
* Update the system environment.
*/
putenv(p);
index = TclpFindVariable(name, &length);
#else
environ[index] = p;
#endif /* USE_PUTENV */
/*
* Watch out for versions of putenv that copy the string (e.g. VC++). In
* this case we need to free the string immediately. Otherwise update the
* string in the cache.
*/
if ((index != -1) && (environ[index] == p)) {
ReplaceString(oldValue, p);
#ifdef HAVE_PUTENV_THAT_COPIES
} else {
/*
* This putenv() copies instead of taking ownership.
*/
ckfree(p);
#endif /* HAVE_PUTENV_THAT_COPIES */
}
Tcl_MutexUnlock(&envMutex);
if (!strcmp(name, "HOME")) {
/*
* If the user's home directory has changed, we must invalidate the
* filesystem cache, because '~' expansions will now be incorrect.
*/
Tcl_FSMountsChanged(NULL);
}
}
