os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclUtil.c
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclUtil.c Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,2579 @@
1.4 +/*
1.5 + * tclUtil.c --
1.6 + *
1.7 + * This file contains utility procedures that are used by many Tcl
1.8 + * commands.
1.9 + *
1.10 + * Copyright (c) 1987-1993 The Regents of the University of California.
1.11 + * Copyright (c) 1994-1998 Sun Microsystems, Inc.
1.12 + * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
1.13 + * Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved.
1.14 + *
1.15 + * See the file "license.terms" for information on usage and redistribution
1.16 + * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.17 + *
1.18 + * RCS: @(#) $Id: tclUtil.c,v 1.36.2.8 2007/05/10 18:23:58 dgp Exp $
1.19 + */
1.20 +
1.21 +#include "tclInt.h"
1.22 +#include "tclPort.h"
1.23 +#if defined(__SYMBIAN32__)
1.24 +#include "tclSymbianGlobals.h"
1.25 +#endif
1.26 +
1.27 +/*
1.28 + * The following variable holds the full path name of the binary
1.29 + * from which this application was executed, or NULL if it isn't
1.30 + * know. The value of the variable is set by the procedure
1.31 + * Tcl_FindExecutable. The storage space is dynamically allocated.
1.32 + */
1.33 +
1.34 +#if !defined(__SYMBIAN32__) || !defined(__WINSCW__)
1.35 +char *tclExecutableName = NULL;
1.36 +char *tclNativeExecutableName = NULL;
1.37 +#endif
1.38 +
1.39 +/*
1.40 + * The following values are used in the flags returned by Tcl_ScanElement
1.41 + * and used by Tcl_ConvertElement. The value TCL_DONT_USE_BRACES is also
1.42 + * defined in tcl.h; make sure its value doesn't overlap with any of the
1.43 + * values below.
1.44 + *
1.45 + * TCL_DONT_USE_BRACES - 1 means the string mustn't be enclosed in
1.46 + * braces (e.g. it contains unmatched braces,
1.47 + * or ends in a backslash character, or user
1.48 + * just doesn't want braces); handle all
1.49 + * special characters by adding backslashes.
1.50 + * USE_BRACES - 1 means the string contains a special
1.51 + * character that can be handled simply by
1.52 + * enclosing the entire argument in braces.
1.53 + * BRACES_UNMATCHED - 1 means that braces aren't properly matched
1.54 + * in the argument.
1.55 + */
1.56 +
1.57 +#define USE_BRACES 2
1.58 +#define BRACES_UNMATCHED 4
1.59 +
1.60 +/*
1.61 + * The following values determine the precision used when converting
1.62 + * floating-point values to strings. This information is linked to all
1.63 + * of the tcl_precision variables in all interpreters via the procedure
1.64 + * TclPrecTraceProc.
1.65 + */
1.66 +
1.67 +static char precisionString[10] = "12";
1.68 + /* The string value of all the tcl_precision
1.69 + * variables. */
1.70 +static char precisionFormat[10] = "%.12g";
1.71 + /* The format string actually used in calls
1.72 + * to sprintf. */
1.73 +TCL_DECLARE_MUTEX(precisionMutex)
1.74 +
1.75 +/*
1.76 + * Prototypes for procedures defined later in this file.
1.77 + */
1.78 +
1.79 +static void UpdateStringOfEndOffset _ANSI_ARGS_((Tcl_Obj* objPtr));
1.80 +static int SetEndOffsetFromAny _ANSI_ARGS_((Tcl_Interp* interp,
1.81 + Tcl_Obj* objPtr));
1.82 +
1.83 +/*
1.84 + * The following is the Tcl object type definition for an object
1.85 + * that represents a list index in the form, "end-offset". It is
1.86 + * used as a performance optimization in TclGetIntForIndex. The
1.87 + * internal rep is an integer, so no memory management is required
1.88 + * for it.
1.89 + */
1.90 +
1.91 +Tcl_ObjType tclEndOffsetType = {
1.92 + "end-offset", /* name */
1.93 + (Tcl_FreeInternalRepProc*) NULL, /* freeIntRepProc */
1.94 + (Tcl_DupInternalRepProc*) NULL, /* dupIntRepProc */
1.95 + UpdateStringOfEndOffset, /* updateStringProc */
1.96 + SetEndOffsetFromAny
1.97 +};
1.98 +
1.99 +
1.100 +/*
1.101 + *----------------------------------------------------------------------
1.102 + *
1.103 + * TclFindElement --
1.104 + *
1.105 + * Given a pointer into a Tcl list, locate the first (or next)
1.106 + * element in the list.
1.107 + *
1.108 + * Results:
1.109 + * The return value is normally TCL_OK, which means that the
1.110 + * element was successfully located. If TCL_ERROR is returned
1.111 + * it means that list didn't have proper list structure;
1.112 + * the interp's result contains a more detailed error message.
1.113 + *
1.114 + * If TCL_OK is returned, then *elementPtr will be set to point to the
1.115 + * first element of list, and *nextPtr will be set to point to the
1.116 + * character just after any white space following the last character
1.117 + * that's part of the element. If this is the last argument in the
1.118 + * list, then *nextPtr will point just after the last character in the
1.119 + * list (i.e., at the character at list+listLength). If sizePtr is
1.120 + * non-NULL, *sizePtr is filled in with the number of characters in the
1.121 + * element. If the element is in braces, then *elementPtr will point
1.122 + * to the character after the opening brace and *sizePtr will not
1.123 + * include either of the braces. If there isn't an element in the list,
1.124 + * *sizePtr will be zero, and both *elementPtr and *termPtr will point
1.125 + * just after the last character in the list. Note: this procedure does
1.126 + * NOT collapse backslash sequences.
1.127 + *
1.128 + * Side effects:
1.129 + * None.
1.130 + *
1.131 + *----------------------------------------------------------------------
1.132 + */
1.133 +
1.134 +int
1.135 +TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr,
1.136 + bracePtr)
1.137 + Tcl_Interp *interp; /* Interpreter to use for error reporting.
1.138 + * If NULL, then no error message is left
1.139 + * after errors. */
1.140 + CONST char *list; /* Points to the first byte of a string
1.141 + * containing a Tcl list with zero or more
1.142 + * elements (possibly in braces). */
1.143 + int listLength; /* Number of bytes in the list's string. */
1.144 + CONST char **elementPtr; /* Where to put address of first significant
1.145 + * character in first element of list. */
1.146 + CONST char **nextPtr; /* Fill in with location of character just
1.147 + * after all white space following end of
1.148 + * argument (next arg or end of list). */
1.149 + int *sizePtr; /* If non-zero, fill in with size of
1.150 + * element. */
1.151 + int *bracePtr; /* If non-zero, fill in with non-zero/zero
1.152 + * to indicate that arg was/wasn't
1.153 + * in braces. */
1.154 +{
1.155 + CONST char *p = list;
1.156 + CONST char *elemStart; /* Points to first byte of first element. */
1.157 + CONST char *limit; /* Points just after list's last byte. */
1.158 + int openBraces = 0; /* Brace nesting level during parse. */
1.159 + int inQuotes = 0;
1.160 + int size = 0; /* lint. */
1.161 + int numChars;
1.162 + CONST char *p2;
1.163 +
1.164 + /*
1.165 + * Skim off leading white space and check for an opening brace or
1.166 + * quote. We treat embedded NULLs in the list as bytes belonging to
1.167 + * a list element.
1.168 + */
1.169 +
1.170 + limit = (list + listLength);
1.171 + while ((p < limit) && (isspace(UCHAR(*p)))) { /* INTL: ISO space. */
1.172 + p++;
1.173 + }
1.174 + if (p == limit) { /* no element found */
1.175 + elemStart = limit;
1.176 + goto done;
1.177 + }
1.178 +
1.179 + if (*p == '{') {
1.180 + openBraces = 1;
1.181 + p++;
1.182 + } else if (*p == '"') {
1.183 + inQuotes = 1;
1.184 + p++;
1.185 + }
1.186 + elemStart = p;
1.187 + if (bracePtr != 0) {
1.188 + *bracePtr = openBraces;
1.189 + }
1.190 +
1.191 + /*
1.192 + * Find element's end (a space, close brace, or the end of the string).
1.193 + */
1.194 +
1.195 + while (p < limit) {
1.196 + switch (*p) {
1.197 +
1.198 + /*
1.199 + * Open brace: don't treat specially unless the element is in
1.200 + * braces. In this case, keep a nesting count.
1.201 + */
1.202 +
1.203 + case '{':
1.204 + if (openBraces != 0) {
1.205 + openBraces++;
1.206 + }
1.207 + break;
1.208 +
1.209 + /*
1.210 + * Close brace: if element is in braces, keep nesting count and
1.211 + * quit when the last close brace is seen.
1.212 + */
1.213 +
1.214 + case '}':
1.215 + if (openBraces > 1) {
1.216 + openBraces--;
1.217 + } else if (openBraces == 1) {
1.218 + size = (p - elemStart);
1.219 + p++;
1.220 + if ((p >= limit)
1.221 + || isspace(UCHAR(*p))) { /* INTL: ISO space. */
1.222 + goto done;
1.223 + }
1.224 +
1.225 + /*
1.226 + * Garbage after the closing brace; return an error.
1.227 + */
1.228 +
1.229 + if (interp != NULL) {
1.230 + char buf[100];
1.231 +
1.232 + p2 = p;
1.233 + while ((p2 < limit)
1.234 + && (!isspace(UCHAR(*p2))) /* INTL: ISO space. */
1.235 + && (p2 < p+20)) {
1.236 + p2++;
1.237 + }
1.238 + sprintf(buf,
1.239 + "list element in braces followed by \"%.*s\" instead of space",
1.240 + (int) (p2-p), p);
1.241 + Tcl_SetResult(interp, buf, TCL_VOLATILE);
1.242 + }
1.243 + return TCL_ERROR;
1.244 + }
1.245 + break;
1.246 +
1.247 + /*
1.248 + * Backslash: skip over everything up to the end of the
1.249 + * backslash sequence.
1.250 + */
1.251 +
1.252 + case '\\': {
1.253 + Tcl_UtfBackslash(p, &numChars, NULL);
1.254 + p += (numChars - 1);
1.255 + break;
1.256 + }
1.257 +
1.258 + /*
1.259 + * Space: ignore if element is in braces or quotes; otherwise
1.260 + * terminate element.
1.261 + */
1.262 +
1.263 + case ' ':
1.264 + case '\f':
1.265 + case '\n':
1.266 + case '\r':
1.267 + case '\t':
1.268 + case '\v':
1.269 + if ((openBraces == 0) && !inQuotes) {
1.270 + size = (p - elemStart);
1.271 + goto done;
1.272 + }
1.273 + break;
1.274 +
1.275 + /*
1.276 + * Double-quote: if element is in quotes then terminate it.
1.277 + */
1.278 +
1.279 + case '"':
1.280 + if (inQuotes) {
1.281 + size = (p - elemStart);
1.282 + p++;
1.283 + if ((p >= limit)
1.284 + || isspace(UCHAR(*p))) { /* INTL: ISO space */
1.285 + goto done;
1.286 + }
1.287 +
1.288 + /*
1.289 + * Garbage after the closing quote; return an error.
1.290 + */
1.291 +
1.292 + if (interp != NULL) {
1.293 + char buf[100];
1.294 +
1.295 + p2 = p;
1.296 + while ((p2 < limit)
1.297 + && (!isspace(UCHAR(*p2))) /* INTL: ISO space */
1.298 + && (p2 < p+20)) {
1.299 + p2++;
1.300 + }
1.301 + sprintf(buf,
1.302 + "list element in quotes followed by \"%.*s\" %s",
1.303 + (int) (p2-p), p, "instead of space");
1.304 + Tcl_SetResult(interp, buf, TCL_VOLATILE);
1.305 + }
1.306 + return TCL_ERROR;
1.307 + }
1.308 + break;
1.309 + }
1.310 + p++;
1.311 + }
1.312 +
1.313 +
1.314 + /*
1.315 + * End of list: terminate element.
1.316 + */
1.317 +
1.318 + if (p == limit) {
1.319 + if (openBraces != 0) {
1.320 + if (interp != NULL) {
1.321 + Tcl_SetResult(interp, "unmatched open brace in list",
1.322 + TCL_STATIC);
1.323 + }
1.324 + return TCL_ERROR;
1.325 + } else if (inQuotes) {
1.326 + if (interp != NULL) {
1.327 + Tcl_SetResult(interp, "unmatched open quote in list",
1.328 + TCL_STATIC);
1.329 + }
1.330 + return TCL_ERROR;
1.331 + }
1.332 + size = (p - elemStart);
1.333 + }
1.334 +
1.335 + done:
1.336 + while ((p < limit) && (isspace(UCHAR(*p)))) { /* INTL: ISO space. */
1.337 + p++;
1.338 + }
1.339 + *elementPtr = elemStart;
1.340 + *nextPtr = p;
1.341 + if (sizePtr != 0) {
1.342 + *sizePtr = size;
1.343 + }
1.344 + return TCL_OK;
1.345 +}
1.346 +
1.347 +/*
1.348 + *----------------------------------------------------------------------
1.349 + *
1.350 + * TclCopyAndCollapse --
1.351 + *
1.352 + * Copy a string and eliminate any backslashes that aren't in braces.
1.353 + *
1.354 + * Results:
1.355 + * Count characters get copied from src to dst. Along the way, if
1.356 + * backslash sequences are found outside braces, the backslashes are
1.357 + * eliminated in the copy. After scanning count chars from source, a
1.358 + * null character is placed at the end of dst. Returns the number
1.359 + * of characters that got copied.
1.360 + *
1.361 + * Side effects:
1.362 + * None.
1.363 + *
1.364 + *----------------------------------------------------------------------
1.365 + */
1.366 +
1.367 +int
1.368 +TclCopyAndCollapse(count, src, dst)
1.369 + int count; /* Number of characters to copy from src. */
1.370 + CONST char *src; /* Copy from here... */
1.371 + char *dst; /* ... to here. */
1.372 +{
1.373 + register char c;
1.374 + int numRead;
1.375 + int newCount = 0;
1.376 + int backslashCount;
1.377 +
1.378 + for (c = *src; count > 0; src++, c = *src, count--) {
1.379 + if (c == '\\') {
1.380 + backslashCount = Tcl_UtfBackslash(src, &numRead, dst);
1.381 + dst += backslashCount;
1.382 + newCount += backslashCount;
1.383 + src += numRead-1;
1.384 + count -= numRead-1;
1.385 + } else {
1.386 + *dst = c;
1.387 + dst++;
1.388 + newCount++;
1.389 + }
1.390 + }
1.391 + *dst = 0;
1.392 + return newCount;
1.393 +}
1.394 +
1.395 +/*
1.396 + *----------------------------------------------------------------------
1.397 + *
1.398 + * Tcl_SplitList --
1.399 + *
1.400 + * Splits a list up into its constituent fields.
1.401 + *
1.402 + * Results
1.403 + * The return value is normally TCL_OK, which means that
1.404 + * the list was successfully split up. If TCL_ERROR is
1.405 + * returned, it means that "list" didn't have proper list
1.406 + * structure; the interp's result will contain a more detailed
1.407 + * error message.
1.408 + *
1.409 + * *argvPtr will be filled in with the address of an array
1.410 + * whose elements point to the elements of list, in order.
1.411 + * *argcPtr will get filled in with the number of valid elements
1.412 + * in the array. A single block of memory is dynamically allocated
1.413 + * to hold both the argv array and a copy of the list (with
1.414 + * backslashes and braces removed in the standard way).
1.415 + * The caller must eventually free this memory by calling free()
1.416 + * on *argvPtr. Note: *argvPtr and *argcPtr are only modified
1.417 + * if the procedure returns normally.
1.418 + *
1.419 + * Side effects:
1.420 + * Memory is allocated.
1.421 + *
1.422 + *----------------------------------------------------------------------
1.423 + */
1.424 +
1.425 +EXPORT_C int
1.426 +Tcl_SplitList(interp, list, argcPtr, argvPtr)
1.427 + Tcl_Interp *interp; /* Interpreter to use for error reporting.
1.428 + * If NULL, no error message is left. */
1.429 + CONST char *list; /* Pointer to string with list structure. */
1.430 + int *argcPtr; /* Pointer to location to fill in with
1.431 + * the number of elements in the list. */
1.432 + CONST char ***argvPtr; /* Pointer to place to store pointer to
1.433 + * array of pointers to list elements. */
1.434 +{
1.435 + CONST char **argv;
1.436 + CONST char *l;
1.437 + char *p;
1.438 + int length, size, i, result, elSize, brace;
1.439 + CONST char *element;
1.440 +
1.441 + /*
1.442 + * Figure out how much space to allocate. There must be enough
1.443 + * space for both the array of pointers and also for a copy of
1.444 + * the list. To estimate the number of pointers needed, count
1.445 + * the number of space characters in the list.
1.446 + */
1.447 +
1.448 + for (size = 2, l = list; *l != 0; l++) {
1.449 + if (isspace(UCHAR(*l))) { /* INTL: ISO space. */
1.450 + size++;
1.451 + /* Consecutive space can only count as a single list delimiter */
1.452 + while (1) {
1.453 + char next = *(l + 1);
1.454 + if (next == '\0') {
1.455 + break;
1.456 + }
1.457 + ++l;
1.458 + if (isspace(UCHAR(next))) {
1.459 + continue;
1.460 + }
1.461 + break;
1.462 + }
1.463 + }
1.464 + }
1.465 + length = l - list;
1.466 + argv = (CONST char **) ckalloc((unsigned)
1.467 + ((size * sizeof(char *)) + length + 1));
1.468 + for (i = 0, p = ((char *) argv) + size*sizeof(char *);
1.469 + *list != 0; i++) {
1.470 + CONST char *prevList = list;
1.471 +
1.472 + result = TclFindElement(interp, list, length, &element,
1.473 + &list, &elSize, &brace);
1.474 + length -= (list - prevList);
1.475 + if (result != TCL_OK) {
1.476 + ckfree((char *) argv);
1.477 + return result;
1.478 + }
1.479 + if (*element == 0) {
1.480 + break;
1.481 + }
1.482 + if (i >= size) {
1.483 + ckfree((char *) argv);
1.484 + if (interp != NULL) {
1.485 + Tcl_SetResult(interp, "internal error in Tcl_SplitList",
1.486 + TCL_STATIC);
1.487 + }
1.488 + return TCL_ERROR;
1.489 + }
1.490 + argv[i] = p;
1.491 + if (brace) {
1.492 + memcpy((VOID *) p, (VOID *) element, (size_t) elSize);
1.493 + p += elSize;
1.494 + *p = 0;
1.495 + p++;
1.496 + } else {
1.497 + TclCopyAndCollapse(elSize, element, p);
1.498 + p += elSize+1;
1.499 + }
1.500 + }
1.501 +
1.502 + argv[i] = NULL;
1.503 + *argvPtr = argv;
1.504 + *argcPtr = i;
1.505 + return TCL_OK;
1.506 +}
1.507 +
1.508 +/*
1.509 + *----------------------------------------------------------------------
1.510 + *
1.511 + * Tcl_ScanElement --
1.512 + *
1.513 + * This procedure is a companion procedure to Tcl_ConvertElement.
1.514 + * It scans a string to see what needs to be done to it (e.g. add
1.515 + * backslashes or enclosing braces) to make the string into a
1.516 + * valid Tcl list element.
1.517 + *
1.518 + * Results:
1.519 + * The return value is an overestimate of the number of characters
1.520 + * that will be needed by Tcl_ConvertElement to produce a valid
1.521 + * list element from string. The word at *flagPtr is filled in
1.522 + * with a value needed by Tcl_ConvertElement when doing the actual
1.523 + * conversion.
1.524 + *
1.525 + * Side effects:
1.526 + * None.
1.527 + *
1.528 + *----------------------------------------------------------------------
1.529 + */
1.530 +
1.531 +EXPORT_C int
1.532 +Tcl_ScanElement(string, flagPtr)
1.533 + register CONST char *string; /* String to convert to list element. */
1.534 + register int *flagPtr; /* Where to store information to guide
1.535 + * Tcl_ConvertCountedElement. */
1.536 +{
1.537 + return Tcl_ScanCountedElement(string, -1, flagPtr);
1.538 +}
1.539 +
1.540 +/*
1.541 + *----------------------------------------------------------------------
1.542 + *
1.543 + * Tcl_ScanCountedElement --
1.544 + *
1.545 + * This procedure is a companion procedure to
1.546 + * Tcl_ConvertCountedElement. It scans a string to see what
1.547 + * needs to be done to it (e.g. add backslashes or enclosing
1.548 + * braces) to make the string into a valid Tcl list element.
1.549 + * If length is -1, then the string is scanned up to the first
1.550 + * null byte.
1.551 + *
1.552 + * Results:
1.553 + * The return value is an overestimate of the number of characters
1.554 + * that will be needed by Tcl_ConvertCountedElement to produce a
1.555 + * valid list element from string. The word at *flagPtr is
1.556 + * filled in with a value needed by Tcl_ConvertCountedElement
1.557 + * when doing the actual conversion.
1.558 + *
1.559 + * Side effects:
1.560 + * None.
1.561 + *
1.562 + *----------------------------------------------------------------------
1.563 + */
1.564 +
1.565 +EXPORT_C int
1.566 +Tcl_ScanCountedElement(string, length, flagPtr)
1.567 + CONST char *string; /* String to convert to Tcl list element. */
1.568 + int length; /* Number of bytes in string, or -1. */
1.569 + int *flagPtr; /* Where to store information to guide
1.570 + * Tcl_ConvertElement. */
1.571 +{
1.572 + int flags, nestingLevel;
1.573 + register CONST char *p, *lastChar;
1.574 +
1.575 + /*
1.576 + * This procedure and Tcl_ConvertElement together do two things:
1.577 + *
1.578 + * 1. They produce a proper list, one that will yield back the
1.579 + * argument strings when evaluated or when disassembled with
1.580 + * Tcl_SplitList. This is the most important thing.
1.581 + *
1.582 + * 2. They try to produce legible output, which means minimizing the
1.583 + * use of backslashes (using braces instead). However, there are
1.584 + * some situations where backslashes must be used (e.g. an element
1.585 + * like "{abc": the leading brace will have to be backslashed.
1.586 + * For each element, one of three things must be done:
1.587 + *
1.588 + * (a) Use the element as-is (it doesn't contain any special
1.589 + * characters). This is the most desirable option.
1.590 + *
1.591 + * (b) Enclose the element in braces, but leave the contents alone.
1.592 + * This happens if the element contains embedded space, or if it
1.593 + * contains characters with special interpretation ($, [, ;, or \),
1.594 + * or if it starts with a brace or double-quote, or if there are
1.595 + * no characters in the element.
1.596 + *
1.597 + * (c) Don't enclose the element in braces, but add backslashes to
1.598 + * prevent special interpretation of special characters. This is a
1.599 + * last resort used when the argument would normally fall under case
1.600 + * (b) but contains unmatched braces. It also occurs if the last
1.601 + * character of the argument is a backslash or if the element contains
1.602 + * a backslash followed by newline.
1.603 + *
1.604 + * The procedure figures out how many bytes will be needed to store
1.605 + * the result (actually, it overestimates). It also collects information
1.606 + * about the element in the form of a flags word.
1.607 + *
1.608 + * Note: list elements produced by this procedure and
1.609 + * Tcl_ConvertCountedElement must have the property that they can be
1.610 + * enclosing in curly braces to make sub-lists. This means, for
1.611 + * example, that we must not leave unmatched curly braces in the
1.612 + * resulting list element. This property is necessary in order for
1.613 + * procedures like Tcl_DStringStartSublist to work.
1.614 + */
1.615 +
1.616 + nestingLevel = 0;
1.617 + flags = 0;
1.618 + if (string == NULL) {
1.619 + string = "";
1.620 + }
1.621 + if (length == -1) {
1.622 + length = strlen(string);
1.623 + }
1.624 + lastChar = string + length;
1.625 + p = string;
1.626 + if ((p == lastChar) || (*p == '{') || (*p == '"')) {
1.627 + flags |= USE_BRACES;
1.628 + }
1.629 + for ( ; p < lastChar; p++) {
1.630 + switch (*p) {
1.631 + case '{':
1.632 + nestingLevel++;
1.633 + break;
1.634 + case '}':
1.635 + nestingLevel--;
1.636 + if (nestingLevel < 0) {
1.637 + flags |= TCL_DONT_USE_BRACES|BRACES_UNMATCHED;
1.638 + }
1.639 + break;
1.640 + case '[':
1.641 + case '$':
1.642 + case ';':
1.643 + case ' ':
1.644 + case '\f':
1.645 + case '\n':
1.646 + case '\r':
1.647 + case '\t':
1.648 + case '\v':
1.649 + flags |= USE_BRACES;
1.650 + break;
1.651 + case '\\':
1.652 + if ((p+1 == lastChar) || (p[1] == '\n')) {
1.653 + flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED;
1.654 + } else {
1.655 + int size;
1.656 +
1.657 + Tcl_UtfBackslash(p, &size, NULL);
1.658 + p += size-1;
1.659 + flags |= USE_BRACES;
1.660 + }
1.661 + break;
1.662 + }
1.663 + }
1.664 + if (nestingLevel != 0) {
1.665 + flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED;
1.666 + }
1.667 + *flagPtr = flags;
1.668 +
1.669 + /*
1.670 + * Allow enough space to backslash every character plus leave
1.671 + * two spaces for braces.
1.672 + */
1.673 +
1.674 + return 2*(p-string) + 2;
1.675 +}
1.676 +
1.677 +/*
1.678 + *----------------------------------------------------------------------
1.679 + *
1.680 + * Tcl_ConvertElement --
1.681 + *
1.682 + * This is a companion procedure to Tcl_ScanElement. Given
1.683 + * the information produced by Tcl_ScanElement, this procedure
1.684 + * converts a string to a list element equal to that string.
1.685 + *
1.686 + * Results:
1.687 + * Information is copied to *dst in the form of a list element
1.688 + * identical to src (i.e. if Tcl_SplitList is applied to dst it
1.689 + * will produce a string identical to src). The return value is
1.690 + * a count of the number of characters copied (not including the
1.691 + * terminating NULL character).
1.692 + *
1.693 + * Side effects:
1.694 + * None.
1.695 + *
1.696 + *----------------------------------------------------------------------
1.697 + */
1.698 +
1.699 +EXPORT_C int
1.700 +Tcl_ConvertElement(src, dst, flags)
1.701 + register CONST char *src; /* Source information for list element. */
1.702 + register char *dst; /* Place to put list-ified element. */
1.703 + register int flags; /* Flags produced by Tcl_ScanElement. */
1.704 +{
1.705 + return Tcl_ConvertCountedElement(src, -1, dst, flags);
1.706 +}
1.707 +
1.708 +/*
1.709 + *----------------------------------------------------------------------
1.710 + *
1.711 + * Tcl_ConvertCountedElement --
1.712 + *
1.713 + * This is a companion procedure to Tcl_ScanCountedElement. Given
1.714 + * the information produced by Tcl_ScanCountedElement, this
1.715 + * procedure converts a string to a list element equal to that
1.716 + * string.
1.717 + *
1.718 + * Results:
1.719 + * Information is copied to *dst in the form of a list element
1.720 + * identical to src (i.e. if Tcl_SplitList is applied to dst it
1.721 + * will produce a string identical to src). The return value is
1.722 + * a count of the number of characters copied (not including the
1.723 + * terminating NULL character).
1.724 + *
1.725 + * Side effects:
1.726 + * None.
1.727 + *
1.728 + *----------------------------------------------------------------------
1.729 + */
1.730 +
1.731 +EXPORT_C int
1.732 +Tcl_ConvertCountedElement(src, length, dst, flags)
1.733 + register CONST char *src; /* Source information for list element. */
1.734 + int length; /* Number of bytes in src, or -1. */
1.735 + char *dst; /* Place to put list-ified element. */
1.736 + int flags; /* Flags produced by Tcl_ScanElement. */
1.737 +{
1.738 + register char *p = dst;
1.739 + register CONST char *lastChar;
1.740 +
1.741 + /*
1.742 + * See the comment block at the beginning of the Tcl_ScanElement
1.743 + * code for details of how this works.
1.744 + */
1.745 +
1.746 + if (src && length == -1) {
1.747 + length = strlen(src);
1.748 + }
1.749 + if ((src == NULL) || (length == 0)) {
1.750 + p[0] = '{';
1.751 + p[1] = '}';
1.752 + p[2] = 0;
1.753 + return 2;
1.754 + }
1.755 + lastChar = src + length;
1.756 + if ((flags & USE_BRACES) && !(flags & TCL_DONT_USE_BRACES)) {
1.757 + *p = '{';
1.758 + p++;
1.759 + for ( ; src != lastChar; src++, p++) {
1.760 + *p = *src;
1.761 + }
1.762 + *p = '}';
1.763 + p++;
1.764 + } else {
1.765 + if (*src == '{') {
1.766 + /*
1.767 + * Can't have a leading brace unless the whole element is
1.768 + * enclosed in braces. Add a backslash before the brace.
1.769 + * Furthermore, this may destroy the balance between open
1.770 + * and close braces, so set BRACES_UNMATCHED.
1.771 + */
1.772 +
1.773 + p[0] = '\\';
1.774 + p[1] = '{';
1.775 + p += 2;
1.776 + src++;
1.777 + flags |= BRACES_UNMATCHED;
1.778 + }
1.779 + for (; src != lastChar; src++) {
1.780 + switch (*src) {
1.781 + case ']':
1.782 + case '[':
1.783 + case '$':
1.784 + case ';':
1.785 + case ' ':
1.786 + case '\\':
1.787 + case '"':
1.788 + *p = '\\';
1.789 + p++;
1.790 + break;
1.791 + case '{':
1.792 + case '}':
1.793 + /*
1.794 + * It may not seem necessary to backslash braces, but
1.795 + * it is. The reason for this is that the resulting
1.796 + * list element may actually be an element of a sub-list
1.797 + * enclosed in braces (e.g. if Tcl_DStringStartSublist
1.798 + * has been invoked), so there may be a brace mismatch
1.799 + * if the braces aren't backslashed.
1.800 + */
1.801 +
1.802 + if (flags & BRACES_UNMATCHED) {
1.803 + *p = '\\';
1.804 + p++;
1.805 + }
1.806 + break;
1.807 + case '\f':
1.808 + *p = '\\';
1.809 + p++;
1.810 + *p = 'f';
1.811 + p++;
1.812 + continue;
1.813 + case '\n':
1.814 + *p = '\\';
1.815 + p++;
1.816 + *p = 'n';
1.817 + p++;
1.818 + continue;
1.819 + case '\r':
1.820 + *p = '\\';
1.821 + p++;
1.822 + *p = 'r';
1.823 + p++;
1.824 + continue;
1.825 + case '\t':
1.826 + *p = '\\';
1.827 + p++;
1.828 + *p = 't';
1.829 + p++;
1.830 + continue;
1.831 + case '\v':
1.832 + *p = '\\';
1.833 + p++;
1.834 + *p = 'v';
1.835 + p++;
1.836 + continue;
1.837 + }
1.838 + *p = *src;
1.839 + p++;
1.840 + }
1.841 + }
1.842 + *p = '\0';
1.843 + return p-dst;
1.844 +}
1.845 +
1.846 +/*
1.847 + *----------------------------------------------------------------------
1.848 + *
1.849 + * Tcl_Merge --
1.850 + *
1.851 + * Given a collection of strings, merge them together into a
1.852 + * single string that has proper Tcl list structured (i.e.
1.853 + * Tcl_SplitList may be used to retrieve strings equal to the
1.854 + * original elements, and Tcl_Eval will parse the string back
1.855 + * into its original elements).
1.856 + *
1.857 + * Results:
1.858 + * The return value is the address of a dynamically-allocated
1.859 + * string containing the merged list.
1.860 + *
1.861 + * Side effects:
1.862 + * None.
1.863 + *
1.864 + *----------------------------------------------------------------------
1.865 + */
1.866 +
1.867 +EXPORT_C char *
1.868 +Tcl_Merge(argc, argv)
1.869 + int argc; /* How many strings to merge. */
1.870 + CONST char * CONST *argv; /* Array of string values. */
1.871 +{
1.872 +# define LOCAL_SIZE 20
1.873 + int localFlags[LOCAL_SIZE], *flagPtr;
1.874 + int numChars;
1.875 + char *result;
1.876 + char *dst;
1.877 + int i;
1.878 +
1.879 + /*
1.880 + * Pass 1: estimate space, gather flags.
1.881 + */
1.882 +
1.883 + if (argc <= LOCAL_SIZE) {
1.884 + flagPtr = localFlags;
1.885 + } else {
1.886 + flagPtr = (int *) ckalloc((unsigned) argc*sizeof(int));
1.887 + }
1.888 + numChars = 1;
1.889 + for (i = 0; i < argc; i++) {
1.890 + numChars += Tcl_ScanElement(argv[i], &flagPtr[i]) + 1;
1.891 + }
1.892 +
1.893 + /*
1.894 + * Pass two: copy into the result area.
1.895 + */
1.896 +
1.897 + result = (char *) ckalloc((unsigned) numChars);
1.898 + dst = result;
1.899 + for (i = 0; i < argc; i++) {
1.900 + numChars = Tcl_ConvertElement(argv[i], dst, flagPtr[i]);
1.901 + dst += numChars;
1.902 + *dst = ' ';
1.903 + dst++;
1.904 + }
1.905 + if (dst == result) {
1.906 + *dst = 0;
1.907 + } else {
1.908 + dst[-1] = 0;
1.909 + }
1.910 +
1.911 + if (flagPtr != localFlags) {
1.912 + ckfree((char *) flagPtr);
1.913 + }
1.914 + return result;
1.915 +}
1.916 +
1.917 +/*
1.918 + *----------------------------------------------------------------------
1.919 + *
1.920 + * Tcl_Backslash --
1.921 + *
1.922 + * Figure out how to handle a backslash sequence.
1.923 + *
1.924 + * Results:
1.925 + * The return value is the character that should be substituted
1.926 + * in place of the backslash sequence that starts at src. If
1.927 + * readPtr isn't NULL then it is filled in with a count of the
1.928 + * number of characters in the backslash sequence.
1.929 + *
1.930 + * Side effects:
1.931 + * None.
1.932 + *
1.933 + *----------------------------------------------------------------------
1.934 + */
1.935 +
1.936 +EXPORT_C char
1.937 +Tcl_Backslash(src, readPtr)
1.938 + CONST char *src; /* Points to the backslash character of
1.939 + * a backslash sequence. */
1.940 + int *readPtr; /* Fill in with number of characters read
1.941 + * from src, unless NULL. */
1.942 +{
1.943 + char buf[TCL_UTF_MAX];
1.944 + Tcl_UniChar ch;
1.945 +
1.946 + Tcl_UtfBackslash(src, readPtr, buf);
1.947 + TclUtfToUniChar(buf, &ch);
1.948 + return (char) ch;
1.949 +}
1.950 +
1.951 +/*
1.952 + *----------------------------------------------------------------------
1.953 + *
1.954 + * Tcl_Concat --
1.955 + *
1.956 + * Concatenate a set of strings into a single large string.
1.957 + *
1.958 + * Results:
1.959 + * The return value is dynamically-allocated string containing
1.960 + * a concatenation of all the strings in argv, with spaces between
1.961 + * the original argv elements.
1.962 + *
1.963 + * Side effects:
1.964 + * Memory is allocated for the result; the caller is responsible
1.965 + * for freeing the memory.
1.966 + *
1.967 + *----------------------------------------------------------------------
1.968 + */
1.969 +
1.970 +EXPORT_C char *
1.971 +Tcl_Concat(argc, argv)
1.972 + int argc; /* Number of strings to concatenate. */
1.973 + CONST char * CONST *argv; /* Array of strings to concatenate. */
1.974 +{
1.975 + int totalSize, i;
1.976 + char *p;
1.977 + char *result;
1.978 +
1.979 + for (totalSize = 1, i = 0; i < argc; i++) {
1.980 + totalSize += strlen(argv[i]) + 1;
1.981 + }
1.982 + result = (char *) ckalloc((unsigned) totalSize);
1.983 + if (argc == 0) {
1.984 + *result = '\0';
1.985 + return result;
1.986 + }
1.987 + for (p = result, i = 0; i < argc; i++) {
1.988 + CONST char *element;
1.989 + int length;
1.990 +
1.991 + /*
1.992 + * Clip white space off the front and back of the string
1.993 + * to generate a neater result, and ignore any empty
1.994 + * elements.
1.995 + */
1.996 +
1.997 + element = argv[i];
1.998 + while (isspace(UCHAR(*element))) { /* INTL: ISO space. */
1.999 + element++;
1.1000 + }
1.1001 + for (length = strlen(element);
1.1002 + (length > 0)
1.1003 + && (isspace(UCHAR(element[length-1]))) /* INTL: ISO space. */
1.1004 + && ((length < 2) || (element[length-2] != '\\'));
1.1005 + length--) {
1.1006 + /* Null loop body. */
1.1007 + }
1.1008 + if (length == 0) {
1.1009 + continue;
1.1010 + }
1.1011 + memcpy((VOID *) p, (VOID *) element, (size_t) length);
1.1012 + p += length;
1.1013 + *p = ' ';
1.1014 + p++;
1.1015 + }
1.1016 + if (p != result) {
1.1017 + p[-1] = 0;
1.1018 + } else {
1.1019 + *p = 0;
1.1020 + }
1.1021 + return result;
1.1022 +}
1.1023 +
1.1024 +/*
1.1025 + *----------------------------------------------------------------------
1.1026 + *
1.1027 + * Tcl_ConcatObj --
1.1028 + *
1.1029 + * Concatenate the strings from a set of objects into a single string
1.1030 + * object with spaces between the original strings.
1.1031 + *
1.1032 + * Results:
1.1033 + * The return value is a new string object containing a concatenation
1.1034 + * of the strings in objv. Its ref count is zero.
1.1035 + *
1.1036 + * Side effects:
1.1037 + * A new object is created.
1.1038 + *
1.1039 + *----------------------------------------------------------------------
1.1040 + */
1.1041 +
1.1042 +EXPORT_C Tcl_Obj *
1.1043 +Tcl_ConcatObj(objc, objv)
1.1044 + int objc; /* Number of objects to concatenate. */
1.1045 + Tcl_Obj *CONST objv[]; /* Array of objects to concatenate. */
1.1046 +{
1.1047 + int allocSize, finalSize, length, elemLength, i;
1.1048 + char *p;
1.1049 + char *element;
1.1050 + char *concatStr;
1.1051 + Tcl_Obj *objPtr;
1.1052 +
1.1053 + /*
1.1054 + * Check first to see if all the items are of list type. If so,
1.1055 + * we will concat them together as lists, and return a list object.
1.1056 + * This is only valid when the lists have no current string
1.1057 + * representation, since we don't know what the original type was.
1.1058 + * An original string rep may have lost some whitespace info when
1.1059 + * converted which could be important.
1.1060 + */
1.1061 + for (i = 0; i < objc; i++) {
1.1062 + objPtr = objv[i];
1.1063 + if ((objPtr->typePtr != &tclListType) || (objPtr->bytes != NULL)) {
1.1064 + break;
1.1065 + }
1.1066 + }
1.1067 + if (i == objc) {
1.1068 + Tcl_Obj **listv;
1.1069 + int listc;
1.1070 +
1.1071 + objPtr = Tcl_NewListObj(0, NULL);
1.1072 + for (i = 0; i < objc; i++) {
1.1073 + /*
1.1074 + * Tcl_ListObjAppendList could be used here, but this saves
1.1075 + * us a bit of type checking (since we've already done it)
1.1076 + * Use of INT_MAX tells us to always put the new stuff on
1.1077 + * the end. It will be set right in Tcl_ListObjReplace.
1.1078 + */
1.1079 + Tcl_ListObjGetElements(NULL, objv[i], &listc, &listv);
1.1080 + Tcl_ListObjReplace(NULL, objPtr, INT_MAX, 0, listc, listv);
1.1081 + }
1.1082 + return objPtr;
1.1083 + }
1.1084 +
1.1085 + allocSize = 0;
1.1086 + for (i = 0; i < objc; i++) {
1.1087 + objPtr = objv[i];
1.1088 + element = Tcl_GetStringFromObj(objPtr, &length);
1.1089 + if ((element != NULL) && (length > 0)) {
1.1090 + allocSize += (length + 1);
1.1091 + }
1.1092 + }
1.1093 + if (allocSize == 0) {
1.1094 + allocSize = 1; /* enough for the NULL byte at end */
1.1095 + }
1.1096 +
1.1097 + /*
1.1098 + * Allocate storage for the concatenated result. Note that allocSize
1.1099 + * is one more than the total number of characters, and so includes
1.1100 + * room for the terminating NULL byte.
1.1101 + */
1.1102 +
1.1103 + concatStr = (char *) ckalloc((unsigned) allocSize);
1.1104 +
1.1105 + /*
1.1106 + * Now concatenate the elements. Clip white space off the front and back
1.1107 + * to generate a neater result, and ignore any empty elements. Also put
1.1108 + * a null byte at the end.
1.1109 + */
1.1110 +
1.1111 + finalSize = 0;
1.1112 + if (objc == 0) {
1.1113 + *concatStr = '\0';
1.1114 + } else {
1.1115 + p = concatStr;
1.1116 + for (i = 0; i < objc; i++) {
1.1117 + objPtr = objv[i];
1.1118 + element = Tcl_GetStringFromObj(objPtr, &elemLength);
1.1119 + while ((elemLength > 0) && (UCHAR(*element) < 127)
1.1120 + && isspace(UCHAR(*element))) { /* INTL: ISO C space. */
1.1121 + element++;
1.1122 + elemLength--;
1.1123 + }
1.1124 +
1.1125 + /*
1.1126 + * Trim trailing white space. But, be careful not to trim
1.1127 + * a space character if it is preceded by a backslash: in
1.1128 + * this case it could be significant.
1.1129 + */
1.1130 +
1.1131 + while ((elemLength > 0) && (UCHAR(element[elemLength-1]) < 127)
1.1132 + && isspace(UCHAR(element[elemLength-1])) /* INTL: ISO C space. */
1.1133 + && ((elemLength < 2) || (element[elemLength-2] != '\\'))) {
1.1134 + elemLength--;
1.1135 + }
1.1136 + if (elemLength == 0) {
1.1137 + continue; /* nothing left of this element */
1.1138 + }
1.1139 + memcpy((VOID *) p, (VOID *) element, (size_t) elemLength);
1.1140 + p += elemLength;
1.1141 + *p = ' ';
1.1142 + p++;
1.1143 + finalSize += (elemLength + 1);
1.1144 + }
1.1145 + if (p != concatStr) {
1.1146 + p[-1] = 0;
1.1147 + finalSize -= 1; /* we overwrote the final ' ' */
1.1148 + } else {
1.1149 + *p = 0;
1.1150 + }
1.1151 + }
1.1152 +
1.1153 + TclNewObj(objPtr);
1.1154 + objPtr->bytes = concatStr;
1.1155 + objPtr->length = finalSize;
1.1156 + return objPtr;
1.1157 +}
1.1158 +
1.1159 +/*
1.1160 + *----------------------------------------------------------------------
1.1161 + *
1.1162 + * Tcl_StringMatch --
1.1163 + *
1.1164 + * See if a particular string matches a particular pattern.
1.1165 + *
1.1166 + * Results:
1.1167 + * The return value is 1 if string matches pattern, and
1.1168 + * 0 otherwise. The matching operation permits the following
1.1169 + * special characters in the pattern: *?\[] (see the manual
1.1170 + * entry for details on what these mean).
1.1171 + *
1.1172 + * Side effects:
1.1173 + * None.
1.1174 + *
1.1175 + *----------------------------------------------------------------------
1.1176 + */
1.1177 +
1.1178 +EXPORT_C int
1.1179 +Tcl_StringMatch(string, pattern)
1.1180 + CONST char *string; /* String. */
1.1181 + CONST char *pattern; /* Pattern, which may contain special
1.1182 + * characters. */
1.1183 +{
1.1184 + return Tcl_StringCaseMatch(string, pattern, 0);
1.1185 +}
1.1186 +
1.1187 +/*
1.1188 + *----------------------------------------------------------------------
1.1189 + *
1.1190 + * Tcl_StringCaseMatch --
1.1191 + *
1.1192 + * See if a particular string matches a particular pattern.
1.1193 + * Allows case insensitivity.
1.1194 + *
1.1195 + * Results:
1.1196 + * The return value is 1 if string matches pattern, and
1.1197 + * 0 otherwise. The matching operation permits the following
1.1198 + * special characters in the pattern: *?\[] (see the manual
1.1199 + * entry for details on what these mean).
1.1200 + *
1.1201 + * Side effects:
1.1202 + * None.
1.1203 + *
1.1204 + *----------------------------------------------------------------------
1.1205 + */
1.1206 +
1.1207 +EXPORT_C int
1.1208 +Tcl_StringCaseMatch(string, pattern, nocase)
1.1209 + CONST char *string; /* String. */
1.1210 + CONST char *pattern; /* Pattern, which may contain special
1.1211 + * characters. */
1.1212 + int nocase; /* 0 for case sensitive, 1 for insensitive */
1.1213 +{
1.1214 + int p, charLen;
1.1215 + CONST char *pstart = pattern;
1.1216 + Tcl_UniChar ch1, ch2;
1.1217 +
1.1218 + while (1) {
1.1219 + p = *pattern;
1.1220 +
1.1221 + /*
1.1222 + * See if we're at the end of both the pattern and the string. If
1.1223 + * so, we succeeded. If we're at the end of the pattern but not at
1.1224 + * the end of the string, we failed.
1.1225 + */
1.1226 +
1.1227 + if (p == '\0') {
1.1228 + return (*string == '\0');
1.1229 + }
1.1230 + if ((*string == '\0') && (p != '*')) {
1.1231 + return 0;
1.1232 + }
1.1233 +
1.1234 + /*
1.1235 + * Check for a "*" as the next pattern character. It matches
1.1236 + * any substring. We handle this by calling ourselves
1.1237 + * recursively for each postfix of string, until either we
1.1238 + * match or we reach the end of the string.
1.1239 + */
1.1240 +
1.1241 + if (p == '*') {
1.1242 + /*
1.1243 + * Skip all successive *'s in the pattern
1.1244 + */
1.1245 + while (*(++pattern) == '*') {}
1.1246 + p = *pattern;
1.1247 + if (p == '\0') {
1.1248 + return 1;
1.1249 + }
1.1250 + /*
1.1251 + * This is a special case optimization for single-byte utf.
1.1252 + */
1.1253 + if (UCHAR(*pattern) < 0x80) {
1.1254 + ch2 = (Tcl_UniChar)
1.1255 + (nocase ? tolower(UCHAR(*pattern)) : UCHAR(*pattern));
1.1256 + } else {
1.1257 + Tcl_UtfToUniChar(pattern, &ch2);
1.1258 + if (nocase) {
1.1259 + ch2 = Tcl_UniCharToLower(ch2);
1.1260 + }
1.1261 + }
1.1262 + while (1) {
1.1263 + /*
1.1264 + * Optimization for matching - cruise through the string
1.1265 + * quickly if the next char in the pattern isn't a special
1.1266 + * character
1.1267 + */
1.1268 + if ((p != '[') && (p != '?') && (p != '\\')) {
1.1269 + if (nocase) {
1.1270 + while (*string) {
1.1271 + charLen = TclUtfToUniChar(string, &ch1);
1.1272 + if (ch2==ch1 || ch2==Tcl_UniCharToLower(ch1)) {
1.1273 + break;
1.1274 + }
1.1275 + string += charLen;
1.1276 + }
1.1277 + } else {
1.1278 + /*
1.1279 + * There's no point in trying to make this code
1.1280 + * shorter, as the number of bytes you want to
1.1281 + * compare each time is non-constant.
1.1282 + */
1.1283 + while (*string) {
1.1284 + charLen = TclUtfToUniChar(string, &ch1);
1.1285 + if (ch2 == ch1) {
1.1286 + break;
1.1287 + }
1.1288 + string += charLen;
1.1289 + }
1.1290 + }
1.1291 + }
1.1292 + if (Tcl_StringCaseMatch(string, pattern, nocase)) {
1.1293 + return 1;
1.1294 + }
1.1295 + if (*string == '\0') {
1.1296 + return 0;
1.1297 + }
1.1298 + string += TclUtfToUniChar(string, &ch1);
1.1299 + }
1.1300 + }
1.1301 +
1.1302 + /*
1.1303 + * Check for a "?" as the next pattern character. It matches
1.1304 + * any single character.
1.1305 + */
1.1306 +
1.1307 + if (p == '?') {
1.1308 + pattern++;
1.1309 + string += TclUtfToUniChar(string, &ch1);
1.1310 + continue;
1.1311 + }
1.1312 +
1.1313 + /*
1.1314 + * Check for a "[" as the next pattern character. It is followed
1.1315 + * by a list of characters that are acceptable, or by a range
1.1316 + * (two characters separated by "-").
1.1317 + */
1.1318 +
1.1319 + if (p == '[') {
1.1320 + Tcl_UniChar startChar, endChar;
1.1321 +
1.1322 + pattern++;
1.1323 + if (UCHAR(*string) < 0x80) {
1.1324 + ch1 = (Tcl_UniChar)
1.1325 + (nocase ? tolower(UCHAR(*string)) : UCHAR(*string));
1.1326 + string++;
1.1327 + } else {
1.1328 + string += Tcl_UtfToUniChar(string, &ch1);
1.1329 + if (nocase) {
1.1330 + ch1 = Tcl_UniCharToLower(ch1);
1.1331 + }
1.1332 + }
1.1333 + while (1) {
1.1334 + if ((*pattern == ']') || (*pattern == '\0')) {
1.1335 + return 0;
1.1336 + }
1.1337 + if (UCHAR(*pattern) < 0x80) {
1.1338 + startChar = (Tcl_UniChar)
1.1339 + (nocase ? tolower(UCHAR(*pattern)) : UCHAR(*pattern));
1.1340 + pattern++;
1.1341 + } else {
1.1342 + pattern += Tcl_UtfToUniChar(pattern, &startChar);
1.1343 + if (nocase) {
1.1344 + startChar = Tcl_UniCharToLower(startChar);
1.1345 + }
1.1346 + }
1.1347 + if (*pattern == '-') {
1.1348 + pattern++;
1.1349 + if (*pattern == '\0') {
1.1350 + return 0;
1.1351 + }
1.1352 + if (UCHAR(*pattern) < 0x80) {
1.1353 + endChar = (Tcl_UniChar)
1.1354 + (nocase ? tolower(UCHAR(*pattern))
1.1355 + : UCHAR(*pattern));
1.1356 + pattern++;
1.1357 + } else {
1.1358 + pattern += Tcl_UtfToUniChar(pattern, &endChar);
1.1359 + if (nocase) {
1.1360 + endChar = Tcl_UniCharToLower(endChar);
1.1361 + }
1.1362 + }
1.1363 + if (((startChar <= ch1) && (ch1 <= endChar))
1.1364 + || ((endChar <= ch1) && (ch1 <= startChar))) {
1.1365 + /*
1.1366 + * Matches ranges of form [a-z] or [z-a].
1.1367 + */
1.1368 +
1.1369 + break;
1.1370 + }
1.1371 + } else if (startChar == ch1) {
1.1372 + break;
1.1373 + }
1.1374 + }
1.1375 + while (*pattern != ']') {
1.1376 + if (*pattern == '\0') {
1.1377 + pattern = Tcl_UtfPrev(pattern, pstart);
1.1378 + break;
1.1379 + }
1.1380 + pattern++;
1.1381 + }
1.1382 + pattern++;
1.1383 + continue;
1.1384 + }
1.1385 +
1.1386 + /*
1.1387 + * If the next pattern character is '\', just strip off the '\'
1.1388 + * so we do exact matching on the character that follows.
1.1389 + */
1.1390 +
1.1391 + if (p == '\\') {
1.1392 + pattern++;
1.1393 + if (*pattern == '\0') {
1.1394 + return 0;
1.1395 + }
1.1396 + }
1.1397 +
1.1398 + /*
1.1399 + * There's no special character. Just make sure that the next
1.1400 + * bytes of each string match.
1.1401 + */
1.1402 +
1.1403 + string += TclUtfToUniChar(string, &ch1);
1.1404 + pattern += TclUtfToUniChar(pattern, &ch2);
1.1405 + if (nocase) {
1.1406 + if (Tcl_UniCharToLower(ch1) != Tcl_UniCharToLower(ch2)) {
1.1407 + return 0;
1.1408 + }
1.1409 + } else if (ch1 != ch2) {
1.1410 + return 0;
1.1411 + }
1.1412 + }
1.1413 +}
1.1414 +
1.1415 +/*
1.1416 + *----------------------------------------------------------------------
1.1417 + *
1.1418 + * TclMatchIsTrivial --
1.1419 + *
1.1420 + * Test whether a particular glob pattern is a trivial pattern.
1.1421 + * (i.e. where matching is the same as equality testing).
1.1422 + *
1.1423 + * Results:
1.1424 + * A boolean indicating whether the pattern is free of all of the
1.1425 + * glob special chars.
1.1426 + *
1.1427 + * Side effects:
1.1428 + * None.
1.1429 + *
1.1430 + *----------------------------------------------------------------------
1.1431 + */
1.1432 +
1.1433 +int
1.1434 +TclMatchIsTrivial(pattern)
1.1435 + CONST char *pattern;
1.1436 +{
1.1437 + CONST char *p = pattern;
1.1438 +
1.1439 + while (1) {
1.1440 + switch (*p++) {
1.1441 + case '\0':
1.1442 + return 1;
1.1443 + case '*':
1.1444 + case '?':
1.1445 + case '[':
1.1446 + case '\\':
1.1447 + return 0;
1.1448 + }
1.1449 + }
1.1450 +}
1.1451 +
1.1452 +/*
1.1453 + *----------------------------------------------------------------------
1.1454 + *
1.1455 + * Tcl_DStringInit --
1.1456 + *
1.1457 + * Initializes a dynamic string, discarding any previous contents
1.1458 + * of the string (Tcl_DStringFree should have been called already
1.1459 + * if the dynamic string was previously in use).
1.1460 + *
1.1461 + * Results:
1.1462 + * None.
1.1463 + *
1.1464 + * Side effects:
1.1465 + * The dynamic string is initialized to be empty.
1.1466 + *
1.1467 + *----------------------------------------------------------------------
1.1468 + */
1.1469 +
1.1470 +EXPORT_C void
1.1471 +Tcl_DStringInit(dsPtr)
1.1472 + Tcl_DString *dsPtr; /* Pointer to structure for dynamic string. */
1.1473 +{
1.1474 + dsPtr->string = dsPtr->staticSpace;
1.1475 + dsPtr->length = 0;
1.1476 + dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
1.1477 + dsPtr->staticSpace[0] = '\0';
1.1478 +}
1.1479 +
1.1480 +/*
1.1481 + *----------------------------------------------------------------------
1.1482 + *
1.1483 + * Tcl_DStringAppend --
1.1484 + *
1.1485 + * Append more characters to the current value of a dynamic string.
1.1486 + *
1.1487 + * Results:
1.1488 + * The return value is a pointer to the dynamic string's new value.
1.1489 + *
1.1490 + * Side effects:
1.1491 + * Length bytes from string (or all of string if length is less
1.1492 + * than zero) are added to the current value of the string. Memory
1.1493 + * gets reallocated if needed to accomodate the string's new size.
1.1494 + *
1.1495 + *----------------------------------------------------------------------
1.1496 + */
1.1497 +
1.1498 +EXPORT_C char *
1.1499 +Tcl_DStringAppend(dsPtr, string, length)
1.1500 + Tcl_DString *dsPtr; /* Structure describing dynamic string. */
1.1501 + CONST char *string; /* String to append. If length is -1 then
1.1502 + * this must be null-terminated. */
1.1503 + int length; /* Number of characters from string to
1.1504 + * append. If < 0, then append all of string,
1.1505 + * up to null at end. */
1.1506 +{
1.1507 + int newSize;
1.1508 + char *dst;
1.1509 + CONST char *end;
1.1510 +
1.1511 + if (length < 0) {
1.1512 + length = strlen(string);
1.1513 + }
1.1514 + newSize = length + dsPtr->length;
1.1515 +
1.1516 + /*
1.1517 + * Allocate a larger buffer for the string if the current one isn't
1.1518 + * large enough. Allocate extra space in the new buffer so that there
1.1519 + * will be room to grow before we have to allocate again.
1.1520 + */
1.1521 +
1.1522 + if (newSize >= dsPtr->spaceAvl) {
1.1523 + dsPtr->spaceAvl = newSize * 2;
1.1524 + if (dsPtr->string == dsPtr->staticSpace) {
1.1525 + char *newString;
1.1526 +
1.1527 + newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl);
1.1528 + memcpy((VOID *) newString, (VOID *) dsPtr->string,
1.1529 + (size_t) dsPtr->length);
1.1530 + dsPtr->string = newString;
1.1531 + } else {
1.1532 + dsPtr->string = (char *) ckrealloc((VOID *) dsPtr->string,
1.1533 + (size_t) dsPtr->spaceAvl);
1.1534 + }
1.1535 + }
1.1536 +
1.1537 + /*
1.1538 + * Copy the new string into the buffer at the end of the old
1.1539 + * one.
1.1540 + */
1.1541 +
1.1542 + for (dst = dsPtr->string + dsPtr->length, end = string+length;
1.1543 + string < end; string++, dst++) {
1.1544 + *dst = *string;
1.1545 + }
1.1546 + *dst = '\0';
1.1547 + dsPtr->length += length;
1.1548 + return dsPtr->string;
1.1549 +}
1.1550 +
1.1551 +/*
1.1552 + *----------------------------------------------------------------------
1.1553 + *
1.1554 + * Tcl_DStringAppendElement --
1.1555 + *
1.1556 + * Append a list element to the current value of a dynamic string.
1.1557 + *
1.1558 + * Results:
1.1559 + * The return value is a pointer to the dynamic string's new value.
1.1560 + *
1.1561 + * Side effects:
1.1562 + * String is reformatted as a list element and added to the current
1.1563 + * value of the string. Memory gets reallocated if needed to
1.1564 + * accomodate the string's new size.
1.1565 + *
1.1566 + *----------------------------------------------------------------------
1.1567 + */
1.1568 +
1.1569 +EXPORT_C char *
1.1570 +Tcl_DStringAppendElement(dsPtr, string)
1.1571 + Tcl_DString *dsPtr; /* Structure describing dynamic string. */
1.1572 + CONST char *string; /* String to append. Must be
1.1573 + * null-terminated. */
1.1574 +{
1.1575 + int newSize, flags, strSize;
1.1576 + char *dst;
1.1577 +
1.1578 + strSize = ((string == NULL) ? 0 : strlen(string));
1.1579 + newSize = Tcl_ScanCountedElement(string, strSize, &flags)
1.1580 + + dsPtr->length + 1;
1.1581 +
1.1582 + /*
1.1583 + * Allocate a larger buffer for the string if the current one isn't
1.1584 + * large enough. Allocate extra space in the new buffer so that there
1.1585 + * will be room to grow before we have to allocate again.
1.1586 + * SPECIAL NOTE: must use memcpy, not strcpy, to copy the string
1.1587 + * to a larger buffer, since there may be embedded NULLs in the
1.1588 + * string in some cases.
1.1589 + */
1.1590 +
1.1591 + if (newSize >= dsPtr->spaceAvl) {
1.1592 + dsPtr->spaceAvl = newSize * 2;
1.1593 + if (dsPtr->string == dsPtr->staticSpace) {
1.1594 + char *newString;
1.1595 +
1.1596 + newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl);
1.1597 + memcpy((VOID *) newString, (VOID *) dsPtr->string,
1.1598 + (size_t) dsPtr->length);
1.1599 + dsPtr->string = newString;
1.1600 + } else {
1.1601 + dsPtr->string = (char *) ckrealloc((VOID *) dsPtr->string,
1.1602 + (size_t) dsPtr->spaceAvl);
1.1603 + }
1.1604 + }
1.1605 +
1.1606 + /*
1.1607 + * Convert the new string to a list element and copy it into the
1.1608 + * buffer at the end, with a space, if needed.
1.1609 + */
1.1610 +
1.1611 + dst = dsPtr->string + dsPtr->length;
1.1612 + if (TclNeedSpace(dsPtr->string, dst)) {
1.1613 + *dst = ' ';
1.1614 + dst++;
1.1615 + dsPtr->length++;
1.1616 + }
1.1617 + dsPtr->length += Tcl_ConvertCountedElement(string, strSize, dst, flags);
1.1618 + return dsPtr->string;
1.1619 +}
1.1620 +
1.1621 +/*
1.1622 + *----------------------------------------------------------------------
1.1623 + *
1.1624 + * Tcl_DStringSetLength --
1.1625 + *
1.1626 + * Change the length of a dynamic string. This can cause the
1.1627 + * string to either grow or shrink, depending on the value of
1.1628 + * length.
1.1629 + *
1.1630 + * Results:
1.1631 + * None.
1.1632 + *
1.1633 + * Side effects:
1.1634 + * The length of dsPtr is changed to length and a null byte is
1.1635 + * stored at that position in the string. If length is larger
1.1636 + * than the space allocated for dsPtr, then a panic occurs.
1.1637 + *
1.1638 + *----------------------------------------------------------------------
1.1639 + */
1.1640 +
1.1641 +EXPORT_C void
1.1642 +Tcl_DStringSetLength(dsPtr, length)
1.1643 + Tcl_DString *dsPtr; /* Structure describing dynamic string. */
1.1644 + int length; /* New length for dynamic string. */
1.1645 +{
1.1646 + int newsize;
1.1647 +
1.1648 + if (length < 0) {
1.1649 + length = 0;
1.1650 + }
1.1651 + if (length >= dsPtr->spaceAvl) {
1.1652 + /*
1.1653 + * There are two interesting cases here. In the first case, the user
1.1654 + * may be trying to allocate a large buffer of a specific size. It
1.1655 + * would be wasteful to overallocate that buffer, so we just allocate
1.1656 + * enough for the requested size plus the trailing null byte. In the
1.1657 + * second case, we are growing the buffer incrementally, so we need
1.1658 + * behavior similar to Tcl_DStringAppend. The requested length will
1.1659 + * usually be a small delta above the current spaceAvl, so we'll end up
1.1660 + * doubling the old size. This won't grow the buffer quite as quickly,
1.1661 + * but it should be close enough.
1.1662 + */
1.1663 +
1.1664 + newsize = dsPtr->spaceAvl * 2;
1.1665 + if (length < newsize) {
1.1666 + dsPtr->spaceAvl = newsize;
1.1667 + } else {
1.1668 + dsPtr->spaceAvl = length + 1;
1.1669 + }
1.1670 + if (dsPtr->string == dsPtr->staticSpace) {
1.1671 + char *newString;
1.1672 +
1.1673 + newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl);
1.1674 + memcpy((VOID *) newString, (VOID *) dsPtr->string,
1.1675 + (size_t) dsPtr->length);
1.1676 + dsPtr->string = newString;
1.1677 + } else {
1.1678 + dsPtr->string = (char *) ckrealloc((VOID *) dsPtr->string,
1.1679 + (size_t) dsPtr->spaceAvl);
1.1680 + }
1.1681 + }
1.1682 + dsPtr->length = length;
1.1683 + dsPtr->string[length] = 0;
1.1684 +}
1.1685 +
1.1686 +/*
1.1687 + *----------------------------------------------------------------------
1.1688 + *
1.1689 + * Tcl_DStringFree --
1.1690 + *
1.1691 + * Frees up any memory allocated for the dynamic string and
1.1692 + * reinitializes the string to an empty state.
1.1693 + *
1.1694 + * Results:
1.1695 + * None.
1.1696 + *
1.1697 + * Side effects:
1.1698 + * The previous contents of the dynamic string are lost, and
1.1699 + * the new value is an empty string.
1.1700 + *
1.1701 + *---------------------------------------------------------------------- */
1.1702 +
1.1703 +EXPORT_C void
1.1704 +Tcl_DStringFree(dsPtr)
1.1705 + Tcl_DString *dsPtr; /* Structure describing dynamic string. */
1.1706 +{
1.1707 + if (dsPtr->string != dsPtr->staticSpace) {
1.1708 + ckfree(dsPtr->string);
1.1709 + }
1.1710 + dsPtr->string = dsPtr->staticSpace;
1.1711 + dsPtr->length = 0;
1.1712 + dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
1.1713 + dsPtr->staticSpace[0] = '\0';
1.1714 +}
1.1715 +
1.1716 +/*
1.1717 + *----------------------------------------------------------------------
1.1718 + *
1.1719 + * Tcl_DStringResult --
1.1720 + *
1.1721 + * This procedure moves the value of a dynamic string into an
1.1722 + * interpreter as its string result. Afterwards, the dynamic string
1.1723 + * is reset to an empty string.
1.1724 + *
1.1725 + * Results:
1.1726 + * None.
1.1727 + *
1.1728 + * Side effects:
1.1729 + * The string is "moved" to interp's result, and any existing
1.1730 + * string result for interp is freed. dsPtr is reinitialized to
1.1731 + * an empty string.
1.1732 + *
1.1733 + *----------------------------------------------------------------------
1.1734 + */
1.1735 +
1.1736 +EXPORT_C void
1.1737 +Tcl_DStringResult(interp, dsPtr)
1.1738 + Tcl_Interp *interp; /* Interpreter whose result is to be reset. */
1.1739 + Tcl_DString *dsPtr; /* Dynamic string that is to become the
1.1740 + * result of interp. */
1.1741 +{
1.1742 + Tcl_ResetResult(interp);
1.1743 +
1.1744 + if (dsPtr->string != dsPtr->staticSpace) {
1.1745 + interp->result = dsPtr->string;
1.1746 + interp->freeProc = TCL_DYNAMIC;
1.1747 + } else if (dsPtr->length < TCL_RESULT_SIZE) {
1.1748 + interp->result = ((Interp *) interp)->resultSpace;
1.1749 + strcpy(interp->result, dsPtr->string);
1.1750 + } else {
1.1751 + Tcl_SetResult(interp, dsPtr->string, TCL_VOLATILE);
1.1752 + }
1.1753 +
1.1754 + dsPtr->string = dsPtr->staticSpace;
1.1755 + dsPtr->length = 0;
1.1756 + dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
1.1757 + dsPtr->staticSpace[0] = '\0';
1.1758 +}
1.1759 +
1.1760 +/*
1.1761 + *----------------------------------------------------------------------
1.1762 + *
1.1763 + * Tcl_DStringGetResult --
1.1764 + *
1.1765 + * This procedure moves an interpreter's result into a dynamic string.
1.1766 + *
1.1767 + * Results:
1.1768 + * None.
1.1769 + *
1.1770 + * Side effects:
1.1771 + * The interpreter's string result is cleared, and the previous
1.1772 + * contents of dsPtr are freed.
1.1773 + *
1.1774 + * If the string result is empty, the object result is moved to the
1.1775 + * string result, then the object result is reset.
1.1776 + *
1.1777 + *----------------------------------------------------------------------
1.1778 + */
1.1779 +
1.1780 +EXPORT_C void
1.1781 +Tcl_DStringGetResult(interp, dsPtr)
1.1782 + Tcl_Interp *interp; /* Interpreter whose result is to be reset. */
1.1783 + Tcl_DString *dsPtr; /* Dynamic string that is to become the
1.1784 + * result of interp. */
1.1785 +{
1.1786 + Interp *iPtr = (Interp *) interp;
1.1787 +
1.1788 + if (dsPtr->string != dsPtr->staticSpace) {
1.1789 + ckfree(dsPtr->string);
1.1790 + }
1.1791 +
1.1792 + /*
1.1793 + * If the string result is empty, move the object result to the
1.1794 + * string result, then reset the object result.
1.1795 + */
1.1796 +
1.1797 + if (*(iPtr->result) == 0) {
1.1798 + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
1.1799 + TCL_VOLATILE);
1.1800 + }
1.1801 +
1.1802 + dsPtr->length = strlen(iPtr->result);
1.1803 + if (iPtr->freeProc != NULL) {
1.1804 + if (iPtr->freeProc == TCL_DYNAMIC) {
1.1805 + dsPtr->string = iPtr->result;
1.1806 + dsPtr->spaceAvl = dsPtr->length+1;
1.1807 + } else {
1.1808 + dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length+1));
1.1809 + strcpy(dsPtr->string, iPtr->result);
1.1810 + (*iPtr->freeProc)(iPtr->result);
1.1811 + }
1.1812 + dsPtr->spaceAvl = dsPtr->length+1;
1.1813 + iPtr->freeProc = NULL;
1.1814 + } else {
1.1815 + if (dsPtr->length < TCL_DSTRING_STATIC_SIZE) {
1.1816 + dsPtr->string = dsPtr->staticSpace;
1.1817 + dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
1.1818 + } else {
1.1819 + dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length + 1));
1.1820 + dsPtr->spaceAvl = dsPtr->length + 1;
1.1821 + }
1.1822 + strcpy(dsPtr->string, iPtr->result);
1.1823 + }
1.1824 +
1.1825 + iPtr->result = iPtr->resultSpace;
1.1826 + iPtr->resultSpace[0] = 0;
1.1827 +}
1.1828 +
1.1829 +/*
1.1830 + *----------------------------------------------------------------------
1.1831 + *
1.1832 + * Tcl_DStringStartSublist --
1.1833 + *
1.1834 + * This procedure adds the necessary information to a dynamic
1.1835 + * string (e.g. " {" to start a sublist. Future element
1.1836 + * appends will be in the sublist rather than the main list.
1.1837 + *
1.1838 + * Results:
1.1839 + * None.
1.1840 + *
1.1841 + * Side effects:
1.1842 + * Characters get added to the dynamic string.
1.1843 + *
1.1844 + *----------------------------------------------------------------------
1.1845 + */
1.1846 +
1.1847 +EXPORT_C void
1.1848 +Tcl_DStringStartSublist(dsPtr)
1.1849 + Tcl_DString *dsPtr; /* Dynamic string. */
1.1850 +{
1.1851 + if (TclNeedSpace(dsPtr->string, dsPtr->string + dsPtr->length)) {
1.1852 + Tcl_DStringAppend(dsPtr, " {", -1);
1.1853 + } else {
1.1854 + Tcl_DStringAppend(dsPtr, "{", -1);
1.1855 + }
1.1856 +}
1.1857 +
1.1858 +/*
1.1859 + *----------------------------------------------------------------------
1.1860 + *
1.1861 + * Tcl_DStringEndSublist --
1.1862 + *
1.1863 + * This procedure adds the necessary characters to a dynamic
1.1864 + * string to end a sublist (e.g. "}"). Future element appends
1.1865 + * will be in the enclosing (sub)list rather than the current
1.1866 + * sublist.
1.1867 + *
1.1868 + * Results:
1.1869 + * None.
1.1870 + *
1.1871 + * Side effects:
1.1872 + * None.
1.1873 + *
1.1874 + *----------------------------------------------------------------------
1.1875 + */
1.1876 +
1.1877 +EXPORT_C void
1.1878 +Tcl_DStringEndSublist(dsPtr)
1.1879 + Tcl_DString *dsPtr; /* Dynamic string. */
1.1880 +{
1.1881 + Tcl_DStringAppend(dsPtr, "}", -1);
1.1882 +}
1.1883 +
1.1884 +/*
1.1885 + *----------------------------------------------------------------------
1.1886 + *
1.1887 + * Tcl_PrintDouble --
1.1888 + *
1.1889 + * Given a floating-point value, this procedure converts it to
1.1890 + * an ASCII string using.
1.1891 + *
1.1892 + * Results:
1.1893 + * The ASCII equivalent of "value" is written at "dst". It is
1.1894 + * written using the current precision, and it is guaranteed to
1.1895 + * contain a decimal point or exponent, so that it looks like
1.1896 + * a floating-point value and not an integer.
1.1897 + *
1.1898 + * Side effects:
1.1899 + * None.
1.1900 + *
1.1901 + *----------------------------------------------------------------------
1.1902 + */
1.1903 +
1.1904 +EXPORT_C void
1.1905 +Tcl_PrintDouble(interp, value, dst)
1.1906 + Tcl_Interp *interp; /* Interpreter whose tcl_precision
1.1907 + * variable used to be used to control
1.1908 + * printing. It's ignored now. */
1.1909 + double value; /* Value to print as string. */
1.1910 + char *dst; /* Where to store converted value;
1.1911 + * must have at least TCL_DOUBLE_SPACE
1.1912 + * characters. */
1.1913 +{
1.1914 + char *p, c;
1.1915 + Tcl_UniChar ch;
1.1916 +
1.1917 + Tcl_MutexLock(&precisionMutex);
1.1918 + sprintf(dst, precisionFormat, value);
1.1919 + Tcl_MutexUnlock(&precisionMutex);
1.1920 +
1.1921 + /*
1.1922 + * If the ASCII result looks like an integer, add ".0" so that it
1.1923 + * doesn't look like an integer anymore. This prevents floating-point
1.1924 + * values from being converted to integers unintentionally.
1.1925 + * Check for ASCII specifically to speed up the function.
1.1926 + */
1.1927 +
1.1928 + for (p = dst; *p != 0; ) {
1.1929 + if (UCHAR(*p) < 0x80) {
1.1930 + c = *p++;
1.1931 + } else {
1.1932 + p += Tcl_UtfToUniChar(p, &ch);
1.1933 + c = UCHAR(ch);
1.1934 + }
1.1935 + if ((c == '.') || isalpha(UCHAR(c))) { /* INTL: ISO only. */
1.1936 + return;
1.1937 + }
1.1938 + }
1.1939 + p[0] = '.';
1.1940 + p[1] = '0';
1.1941 + p[2] = 0;
1.1942 +}
1.1943 +
1.1944 +/*
1.1945 + *----------------------------------------------------------------------
1.1946 + *
1.1947 + * TclPrecTraceProc --
1.1948 + *
1.1949 + * This procedure is invoked whenever the variable "tcl_precision"
1.1950 + * is written.
1.1951 + *
1.1952 + * Results:
1.1953 + * Returns NULL if all went well, or an error message if the
1.1954 + * new value for the variable doesn't make sense.
1.1955 + *
1.1956 + * Side effects:
1.1957 + * If the new value doesn't make sense then this procedure
1.1958 + * undoes the effect of the variable modification. Otherwise
1.1959 + * it modifies the format string that's used by Tcl_PrintDouble.
1.1960 + *
1.1961 + *----------------------------------------------------------------------
1.1962 + */
1.1963 +
1.1964 + /* ARGSUSED */
1.1965 +char *
1.1966 +TclPrecTraceProc(clientData, interp, name1, name2, flags)
1.1967 + ClientData clientData; /* Not used. */
1.1968 + Tcl_Interp *interp; /* Interpreter containing variable. */
1.1969 + CONST char *name1; /* Name of variable. */
1.1970 + CONST char *name2; /* Second part of variable name. */
1.1971 + int flags; /* Information about what happened. */
1.1972 +{
1.1973 + CONST char *value;
1.1974 + char *end;
1.1975 + int prec;
1.1976 +
1.1977 + /*
1.1978 + * If the variable is unset, then recreate the trace.
1.1979 + */
1.1980 +
1.1981 + if (flags & TCL_TRACE_UNSETS) {
1.1982 + if ((flags & TCL_TRACE_DESTROYED) && !Tcl_InterpDeleted(interp)) {
1.1983 + Tcl_TraceVar2(interp, name1, name2,
1.1984 + TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES
1.1985 + |TCL_TRACE_UNSETS, TclPrecTraceProc, clientData);
1.1986 + }
1.1987 + return (char *) NULL;
1.1988 + }
1.1989 +
1.1990 + /*
1.1991 + * When the variable is read, reset its value from our shared
1.1992 + * value. This is needed in case the variable was modified in
1.1993 + * some other interpreter so that this interpreter's value is
1.1994 + * out of date.
1.1995 + */
1.1996 +
1.1997 + Tcl_MutexLock(&precisionMutex);
1.1998 +
1.1999 + if (flags & TCL_TRACE_READS) {
1.2000 + Tcl_SetVar2(interp, name1, name2, precisionString,
1.2001 + flags & TCL_GLOBAL_ONLY);
1.2002 + Tcl_MutexUnlock(&precisionMutex);
1.2003 + return (char *) NULL;
1.2004 + }
1.2005 +
1.2006 + /*
1.2007 + * The variable is being written. Check the new value and disallow
1.2008 + * it if it isn't reasonable or if this is a safe interpreter (we
1.2009 + * don't want safe interpreters messing up the precision of other
1.2010 + * interpreters).
1.2011 + */
1.2012 +
1.2013 + if (Tcl_IsSafe(interp)) {
1.2014 + Tcl_SetVar2(interp, name1, name2, precisionString,
1.2015 + flags & TCL_GLOBAL_ONLY);
1.2016 + Tcl_MutexUnlock(&precisionMutex);
1.2017 + return "can't modify precision from a safe interpreter";
1.2018 + }
1.2019 + value = Tcl_GetVar2(interp, name1, name2, flags & TCL_GLOBAL_ONLY);
1.2020 + if (value == NULL) {
1.2021 + value = "";
1.2022 + }
1.2023 + prec = strtoul(value, &end, 10);
1.2024 + if ((prec <= 0) || (prec > TCL_MAX_PREC) || (prec > 100) ||
1.2025 + (end == value) || (*end != 0)) {
1.2026 + Tcl_SetVar2(interp, name1, name2, precisionString,
1.2027 + flags & TCL_GLOBAL_ONLY);
1.2028 + Tcl_MutexUnlock(&precisionMutex);
1.2029 + return "improper value for precision";
1.2030 + }
1.2031 + TclFormatInt(precisionString, prec);
1.2032 + sprintf(precisionFormat, "%%.%dg", prec);
1.2033 + Tcl_MutexUnlock(&precisionMutex);
1.2034 + return (char *) NULL;
1.2035 +}
1.2036 +
1.2037 +/*
1.2038 + *----------------------------------------------------------------------
1.2039 + *
1.2040 + * TclNeedSpace --
1.2041 + *
1.2042 + * This procedure checks to see whether it is appropriate to
1.2043 + * add a space before appending a new list element to an
1.2044 + * existing string.
1.2045 + *
1.2046 + * Results:
1.2047 + * The return value is 1 if a space is appropriate, 0 otherwise.
1.2048 + *
1.2049 + * Side effects:
1.2050 + * None.
1.2051 + *
1.2052 + *----------------------------------------------------------------------
1.2053 + */
1.2054 +
1.2055 +int
1.2056 +TclNeedSpace(start, end)
1.2057 + CONST char *start; /* First character in string. */
1.2058 + CONST char *end; /* End of string (place where space will
1.2059 + * be added, if appropriate). */
1.2060 +{
1.2061 + /*
1.2062 + * A space is needed unless either
1.2063 + * (a) we're at the start of the string, or
1.2064 + */
1.2065 + if (end == start) {
1.2066 + return 0;
1.2067 + }
1.2068 +
1.2069 + /*
1.2070 + * (b) we're at the start of a nested list-element, quoted with an
1.2071 + * open curly brace; we can be nested arbitrarily deep, so long
1.2072 + * as the first curly brace starts an element, so backtrack over
1.2073 + * open curly braces that are trailing characters of the string; and
1.2074 + */
1.2075 +
1.2076 + end = Tcl_UtfPrev(end, start);
1.2077 + while (*end == '{') {
1.2078 + if (end == start) {
1.2079 + return 0;
1.2080 + }
1.2081 + end = Tcl_UtfPrev(end, start);
1.2082 + }
1.2083 +
1.2084 + /*
1.2085 + * (c) the trailing character of the string is already a list-element
1.2086 + * separator (according to TclFindElement); that is, one of these
1.2087 + * characters:
1.2088 + * \u0009 \t TAB
1.2089 + * \u000A \n NEWLINE
1.2090 + * \u000B \v VERTICAL TAB
1.2091 + * \u000C \f FORM FEED
1.2092 + * \u000D \r CARRIAGE RETURN
1.2093 + * \u0020 SPACE
1.2094 + * with the condition that the penultimate character is not a
1.2095 + * backslash.
1.2096 + */
1.2097 +
1.2098 + if (*end > 0x20) {
1.2099 + /*
1.2100 + * Performance tweak. All ASCII spaces are <= 0x20. So get
1.2101 + * a quick answer for most characters before comparing against
1.2102 + * all spaces in the switch below.
1.2103 + *
1.2104 + * NOTE: Remove this if other Unicode spaces ever get accepted
1.2105 + * as list-element separators.
1.2106 + */
1.2107 + return 1;
1.2108 + }
1.2109 + switch (*end) {
1.2110 + case ' ':
1.2111 + case '\t':
1.2112 + case '\n':
1.2113 + case '\r':
1.2114 + case '\v':
1.2115 + case '\f':
1.2116 + if ((end == start) || (end[-1] != '\\')) {
1.2117 + return 0;
1.2118 + }
1.2119 + }
1.2120 + return 1;
1.2121 +}
1.2122 +
1.2123 +/*
1.2124 + *----------------------------------------------------------------------
1.2125 + *
1.2126 + * TclFormatInt --
1.2127 + *
1.2128 + * This procedure formats an integer into a sequence of decimal digit
1.2129 + * characters in a buffer. If the integer is negative, a minus sign is
1.2130 + * inserted at the start of the buffer. A null character is inserted at
1.2131 + * the end of the formatted characters. It is the caller's
1.2132 + * responsibility to ensure that enough storage is available. This
1.2133 + * procedure has the effect of sprintf(buffer, "%d", n) but is faster.
1.2134 + *
1.2135 + * Results:
1.2136 + * An integer representing the number of characters formatted, not
1.2137 + * including the terminating \0.
1.2138 + *
1.2139 + * Side effects:
1.2140 + * The formatted characters are written into the storage pointer to
1.2141 + * by the "buffer" argument.
1.2142 + *
1.2143 + *----------------------------------------------------------------------
1.2144 + */
1.2145 +
1.2146 +int
1.2147 +TclFormatInt(buffer, n)
1.2148 + char *buffer; /* Points to the storage into which the
1.2149 + * formatted characters are written. */
1.2150 + long n; /* The integer to format. */
1.2151 +{
1.2152 + long intVal;
1.2153 + int i;
1.2154 + int numFormatted, j;
1.2155 + char *digits = "0123456789";
1.2156 +
1.2157 + /*
1.2158 + * Check first whether "n" is zero.
1.2159 + */
1.2160 +
1.2161 + if (n == 0) {
1.2162 + buffer[0] = '0';
1.2163 + buffer[1] = 0;
1.2164 + return 1;
1.2165 + }
1.2166 +
1.2167 + /*
1.2168 + * Check whether "n" is the maximum negative value. This is
1.2169 + * -2^(m-1) for an m-bit word, and has no positive equivalent;
1.2170 + * negating it produces the same value.
1.2171 + */
1.2172 +
1.2173 + if (n == -n) {
1.2174 + sprintf(buffer, "%ld", n);
1.2175 + return strlen(buffer);
1.2176 + }
1.2177 +
1.2178 + /*
1.2179 + * Generate the characters of the result backwards in the buffer.
1.2180 + */
1.2181 +
1.2182 + intVal = (n < 0? -n : n);
1.2183 + i = 0;
1.2184 + buffer[0] = '\0';
1.2185 + do {
1.2186 + i++;
1.2187 + buffer[i] = digits[intVal % 10];
1.2188 + intVal = intVal/10;
1.2189 + } while (intVal > 0);
1.2190 + if (n < 0) {
1.2191 + i++;
1.2192 + buffer[i] = '-';
1.2193 + }
1.2194 + numFormatted = i;
1.2195 +
1.2196 + /*
1.2197 + * Now reverse the characters.
1.2198 + */
1.2199 +
1.2200 + for (j = 0; j < i; j++, i--) {
1.2201 + char tmp = buffer[i];
1.2202 + buffer[i] = buffer[j];
1.2203 + buffer[j] = tmp;
1.2204 + }
1.2205 + return numFormatted;
1.2206 +}
1.2207 +
1.2208 +/*
1.2209 + *----------------------------------------------------------------------
1.2210 + *
1.2211 + * TclLooksLikeInt --
1.2212 + *
1.2213 + * This procedure decides whether the leading characters of a
1.2214 + * string look like an integer or something else (such as a
1.2215 + * floating-point number or string).
1.2216 + *
1.2217 + * Results:
1.2218 + * The return value is 1 if the leading characters of p look
1.2219 + * like a valid Tcl integer. If they look like a floating-point
1.2220 + * number (e.g. "e01" or "2.4"), or if they don't look like a
1.2221 + * number at all, then 0 is returned.
1.2222 + *
1.2223 + * Side effects:
1.2224 + * None.
1.2225 + *
1.2226 + *----------------------------------------------------------------------
1.2227 + */
1.2228 +
1.2229 +int
1.2230 +TclLooksLikeInt(bytes, length)
1.2231 + register CONST char *bytes; /* Points to first byte of the string. */
1.2232 + int length; /* Number of bytes in the string. If < 0
1.2233 + * bytes up to the first null byte are
1.2234 + * considered (if they may appear in an
1.2235 + * integer). */
1.2236 +{
1.2237 + register CONST char *p;
1.2238 +
1.2239 + if ((bytes == NULL) && (length > 0)) {
1.2240 + Tcl_Panic("TclLooksLikeInt: cannot scan %d bytes from NULL", length);
1.2241 + }
1.2242 +
1.2243 + if (length < 0) {
1.2244 + length = (bytes? strlen(bytes) : 0);
1.2245 + }
1.2246 +
1.2247 + p = bytes;
1.2248 + while (length && isspace(UCHAR(*p))) { /* INTL: ISO space. */
1.2249 + length--; p++;
1.2250 + }
1.2251 + if (length == 0) {
1.2252 + return 0;
1.2253 + }
1.2254 + if ((*p == '+') || (*p == '-')) {
1.2255 + p++; length--;
1.2256 + }
1.2257 +
1.2258 + return (0 != TclParseInteger(p, length));
1.2259 +}
1.2260 +
1.2261 +/*
1.2262 + *----------------------------------------------------------------------
1.2263 + *
1.2264 + * TclGetIntForIndex --
1.2265 + *
1.2266 + * This procedure returns an integer corresponding to the list index
1.2267 + * held in a Tcl object. The Tcl object's value is expected to be
1.2268 + * either an integer or a string of the form "end([+-]integer)?".
1.2269 + *
1.2270 + * Results:
1.2271 + * The return value is normally TCL_OK, which means that the index was
1.2272 + * successfully stored into the location referenced by "indexPtr". If
1.2273 + * the Tcl object referenced by "objPtr" has the value "end", the
1.2274 + * value stored is "endValue". If "objPtr"s values is not of the form
1.2275 + * "end([+-]integer)?" and
1.2276 + * can not be converted to an integer, TCL_ERROR is returned and, if
1.2277 + * "interp" is non-NULL, an error message is left in the interpreter's
1.2278 + * result object.
1.2279 + *
1.2280 + * Side effects:
1.2281 + * The object referenced by "objPtr" might be converted to an
1.2282 + * integer, wide integer, or end-based-index object.
1.2283 + *
1.2284 + *----------------------------------------------------------------------
1.2285 + */
1.2286 +
1.2287 +int
1.2288 +TclGetIntForIndex(interp, objPtr, endValue, indexPtr)
1.2289 + Tcl_Interp *interp; /* Interpreter to use for error reporting.
1.2290 + * If NULL, then no error message is left
1.2291 + * after errors. */
1.2292 + Tcl_Obj *objPtr; /* Points to an object containing either
1.2293 + * "end" or an integer. */
1.2294 + int endValue; /* The value to be stored at "indexPtr" if
1.2295 + * "objPtr" holds "end". */
1.2296 + int *indexPtr; /* Location filled in with an integer
1.2297 + * representing an index. */
1.2298 +{
1.2299 + if (Tcl_GetIntFromObj(NULL, objPtr, indexPtr) == TCL_OK) {
1.2300 + return TCL_OK;
1.2301 + }
1.2302 +
1.2303 + if (SetEndOffsetFromAny(NULL, objPtr) == TCL_OK) {
1.2304 + /*
1.2305 + * If the object is already an offset from the end of the
1.2306 + * list, or can be converted to one, use it.
1.2307 + */
1.2308 +
1.2309 + *indexPtr = endValue + objPtr->internalRep.longValue;
1.2310 +
1.2311 + } else {
1.2312 + /*
1.2313 + * Report a parse error.
1.2314 + */
1.2315 +
1.2316 + if (interp != NULL) {
1.2317 + char *bytes = Tcl_GetString(objPtr);
1.2318 + /*
1.2319 + * The result might not be empty; this resets it which
1.2320 + * should be both a cheap operation, and of little problem
1.2321 + * because this is an error-generation path anyway.
1.2322 + */
1.2323 + Tcl_ResetResult(interp);
1.2324 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.2325 + "bad index \"", bytes,
1.2326 + "\": must be integer or end?-integer?",
1.2327 + (char *) NULL);
1.2328 + if (!strncmp(bytes, "end-", 3)) {
1.2329 + bytes += 3;
1.2330 + }
1.2331 + TclCheckBadOctal(interp, bytes);
1.2332 + }
1.2333 +
1.2334 + return TCL_ERROR;
1.2335 + }
1.2336 +
1.2337 + return TCL_OK;
1.2338 +}
1.2339 +
1.2340 +/*
1.2341 + *----------------------------------------------------------------------
1.2342 + *
1.2343 + * UpdateStringOfEndOffset --
1.2344 + *
1.2345 + * Update the string rep of a Tcl object holding an "end-offset"
1.2346 + * expression.
1.2347 + *
1.2348 + * Results:
1.2349 + * None.
1.2350 + *
1.2351 + * Side effects:
1.2352 + * Stores a valid string in the object's string rep.
1.2353 + *
1.2354 + * This procedure does NOT free any earlier string rep. If it is
1.2355 + * called on an object that already has a valid string rep, it will
1.2356 + * leak memory.
1.2357 + *
1.2358 + *----------------------------------------------------------------------
1.2359 + */
1.2360 +
1.2361 +static void
1.2362 +UpdateStringOfEndOffset(objPtr)
1.2363 + register Tcl_Obj* objPtr;
1.2364 +{
1.2365 + char buffer[TCL_INTEGER_SPACE + sizeof("end") + 1];
1.2366 + register int len;
1.2367 +
1.2368 + strcpy(buffer, "end");
1.2369 + len = sizeof("end") - 1;
1.2370 + if (objPtr->internalRep.longValue != 0) {
1.2371 + buffer[len++] = '-';
1.2372 + len += TclFormatInt(buffer+len, -(objPtr->internalRep.longValue));
1.2373 + }
1.2374 + objPtr->bytes = ckalloc((unsigned) (len+1));
1.2375 + strcpy(objPtr->bytes, buffer);
1.2376 + objPtr->length = len;
1.2377 +}
1.2378 +
1.2379 +/*
1.2380 + *----------------------------------------------------------------------
1.2381 + *
1.2382 + * SetEndOffsetFromAny --
1.2383 + *
1.2384 + * Look for a string of the form "end-offset" and convert it
1.2385 + * to an internal representation holding the offset.
1.2386 + *
1.2387 + * Results:
1.2388 + * Returns TCL_OK if ok, TCL_ERROR if the string was badly formed.
1.2389 + *
1.2390 + * Side effects:
1.2391 + * If interp is not NULL, stores an error message in the
1.2392 + * interpreter result.
1.2393 + *
1.2394 + *----------------------------------------------------------------------
1.2395 + */
1.2396 +
1.2397 +static int
1.2398 +SetEndOffsetFromAny(interp, objPtr)
1.2399 + Tcl_Interp* interp; /* Tcl interpreter or NULL */
1.2400 + Tcl_Obj* objPtr; /* Pointer to the object to parse */
1.2401 +{
1.2402 + int offset; /* Offset in the "end-offset" expression */
1.2403 + Tcl_ObjType* oldTypePtr = objPtr->typePtr;
1.2404 + /* Old internal rep type of the object */
1.2405 + register char* bytes; /* String rep of the object */
1.2406 + int length; /* Length of the object's string rep */
1.2407 +
1.2408 + /* If it's already the right type, we're fine. */
1.2409 +
1.2410 + if (objPtr->typePtr == &tclEndOffsetType) {
1.2411 + return TCL_OK;
1.2412 + }
1.2413 +
1.2414 + /* Check for a string rep of the right form. */
1.2415 +
1.2416 + bytes = Tcl_GetStringFromObj(objPtr, &length);
1.2417 + if ((*bytes != 'e') || (strncmp(bytes, "end",
1.2418 + (size_t)((length > 3) ? 3 : length)) != 0)) {
1.2419 + if (interp != NULL) {
1.2420 + Tcl_ResetResult(interp);
1.2421 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.2422 + "bad index \"", bytes,
1.2423 + "\": must be end?-integer?",
1.2424 + (char*) NULL);
1.2425 + }
1.2426 + return TCL_ERROR;
1.2427 + }
1.2428 +
1.2429 + /* Convert the string rep */
1.2430 +
1.2431 + if (length <= 3) {
1.2432 + offset = 0;
1.2433 + } else if ((length > 4) && (bytes[3] == '-')) {
1.2434 + /*
1.2435 + * This is our limited string expression evaluator. Pass everything
1.2436 + * after "end-" to Tcl_GetInt, then reverse for offset.
1.2437 + */
1.2438 + if (Tcl_GetInt(interp, bytes+4, &offset) != TCL_OK) {
1.2439 + return TCL_ERROR;
1.2440 + }
1.2441 + offset = -offset;
1.2442 + } else {
1.2443 + /*
1.2444 + * Conversion failed. Report the error.
1.2445 + */
1.2446 + if (interp != NULL) {
1.2447 + Tcl_ResetResult(interp);
1.2448 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.2449 + "bad index \"", bytes,
1.2450 + "\": must be integer or end?-integer?",
1.2451 + (char *) NULL);
1.2452 + }
1.2453 + return TCL_ERROR;
1.2454 + }
1.2455 +
1.2456 + /*
1.2457 + * The conversion succeeded. Free the old internal rep and set
1.2458 + * the new one.
1.2459 + */
1.2460 +
1.2461 + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
1.2462 + oldTypePtr->freeIntRepProc(objPtr);
1.2463 + }
1.2464 +
1.2465 + objPtr->internalRep.longValue = offset;
1.2466 + objPtr->typePtr = &tclEndOffsetType;
1.2467 +
1.2468 + return TCL_OK;
1.2469 +}
1.2470 +
1.2471 +/*
1.2472 + *----------------------------------------------------------------------
1.2473 + *
1.2474 + * TclCheckBadOctal --
1.2475 + *
1.2476 + * This procedure checks for a bad octal value and appends a
1.2477 + * meaningful error to the interp's result.
1.2478 + *
1.2479 + * Results:
1.2480 + * 1 if the argument was a bad octal, else 0.
1.2481 + *
1.2482 + * Side effects:
1.2483 + * The interpreter's result is modified.
1.2484 + *
1.2485 + *----------------------------------------------------------------------
1.2486 + */
1.2487 +
1.2488 +int
1.2489 +TclCheckBadOctal(interp, value)
1.2490 + Tcl_Interp *interp; /* Interpreter to use for error reporting.
1.2491 + * If NULL, then no error message is left
1.2492 + * after errors. */
1.2493 + CONST char *value; /* String to check. */
1.2494 +{
1.2495 + register CONST char *p = value;
1.2496 +
1.2497 + /*
1.2498 + * A frequent mistake is invalid octal values due to an unwanted
1.2499 + * leading zero. Try to generate a meaningful error message.
1.2500 + */
1.2501 +
1.2502 + while (isspace(UCHAR(*p))) { /* INTL: ISO space. */
1.2503 + p++;
1.2504 + }
1.2505 + if (*p == '+' || *p == '-') {
1.2506 + p++;
1.2507 + }
1.2508 + if (*p == '0') {
1.2509 + while (isdigit(UCHAR(*p))) { /* INTL: digit. */
1.2510 + p++;
1.2511 + }
1.2512 + while (isspace(UCHAR(*p))) { /* INTL: ISO space. */
1.2513 + p++;
1.2514 + }
1.2515 + if (*p == '\0') {
1.2516 + /* Reached end of string */
1.2517 + if (interp != NULL) {
1.2518 + /*
1.2519 + * Don't reset the result here because we want this result
1.2520 + * to be added to an existing error message as extra info.
1.2521 + */
1.2522 + Tcl_AppendResult(interp, " (looks like invalid octal number)",
1.2523 + (char *) NULL);
1.2524 + }
1.2525 + return 1;
1.2526 + }
1.2527 + }
1.2528 + return 0;
1.2529 +}
1.2530 +
1.2531 +/*
1.2532 + *----------------------------------------------------------------------
1.2533 + *
1.2534 + * Tcl_GetNameOfExecutable --
1.2535 + *
1.2536 + * This procedure simply returns a pointer to the internal full
1.2537 + * path name of the executable file as computed by
1.2538 + * Tcl_FindExecutable. This procedure call is the C API
1.2539 + * equivalent to the "info nameofexecutable" command.
1.2540 + *
1.2541 + * Results:
1.2542 + * A pointer to the internal string or NULL if the internal full
1.2543 + * path name has not been computed or unknown.
1.2544 + *
1.2545 + * Side effects:
1.2546 + * The object referenced by "objPtr" might be converted to an
1.2547 + * integer object.
1.2548 + *
1.2549 + *----------------------------------------------------------------------
1.2550 + */
1.2551 +
1.2552 +EXPORT_C CONST char *
1.2553 +Tcl_GetNameOfExecutable()
1.2554 +{
1.2555 + return tclExecutableName;
1.2556 +}
1.2557 +
1.2558 +/*
1.2559 + *----------------------------------------------------------------------
1.2560 + *
1.2561 + * TclpGetTime --
1.2562 + *
1.2563 + * Deprecated synonym for Tcl_GetTime.
1.2564 + *
1.2565 + * Results:
1.2566 + * None.
1.2567 + *
1.2568 + * Side effects:
1.2569 + * Stores current time in the buffer designated by "timePtr"
1.2570 + *
1.2571 + * This procedure is provided for the benefit of extensions written
1.2572 + * before Tcl_GetTime was exported from the library.
1.2573 + *
1.2574 + *----------------------------------------------------------------------
1.2575 + */
1.2576 +
1.2577 +void
1.2578 +TclpGetTime(timePtr)
1.2579 + Tcl_Time* timePtr;
1.2580 +{
1.2581 + Tcl_GetTime(timePtr);
1.2582 +}