os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclFileName.c
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclFileName.c Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,2762 @@
1.4 +/*
1.5 + * tclFileName.c --
1.6 + *
1.7 + * This file contains routines for converting file names betwen
1.8 + * native and network form.
1.9 + *
1.10 + * Copyright (c) 1995-1998 Sun Microsystems, Inc.
1.11 + * Copyright (c) 1998-1999 by Scriptics Corporation.
1.12 + * Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved.
1.13 + *
1.14 + * See the file "license.terms" for information on usage and redistribution
1.15 + * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.16 + *
1.17 + * RCS: @(#) $Id: tclFileName.c,v 1.40.2.15 2006/10/03 18:20:33 dgp Exp $
1.18 + */
1.19 +
1.20 +#include "tclInt.h"
1.21 +#include "tclPort.h"
1.22 +#include "tclRegexp.h"
1.23 +#if defined(__SYMBIAN32__) && defined(__WINSCW__)
1.24 +#include "tclSymbianGlobals.h"
1.25 +#define dataKey getdataKey(2)
1.26 +#endif
1.27 +
1.28 +/*
1.29 + * This define is used to activate Tcl's interpretation of Unix-style
1.30 + * paths (containing forward slashes, '.' and '..') on MacOS. A
1.31 + * side-effect of this is that some paths become ambiguous.
1.32 + */
1.33 +#define MAC_UNDERSTANDS_UNIX_PATHS
1.34 +
1.35 +#ifdef MAC_UNDERSTANDS_UNIX_PATHS
1.36 +/*
1.37 + * The following regular expression matches the root portion of a Macintosh
1.38 + * absolute path. It will match degenerate Unix-style paths, tilde paths,
1.39 + * Unix-style paths, and Mac paths. The various subexpressions in this
1.40 + * can be summarised as follows: ^(/..|~user/unix|~user:mac|/unix|mac:dir).
1.41 + * The subexpression indices which match the root portions, are as follows:
1.42 + *
1.43 + * degenerate unix-style: 2
1.44 + * unix-tilde: 5
1.45 + * mac-tilde: 7
1.46 + * unix-style: 9 (or 10 to cut off the irrelevant header).
1.47 + * mac: 12
1.48 + *
1.49 + */
1.50 +
1.51 +#define MAC_ROOT_PATTERN "^((/+([.][.]?/+)*([.][.]?)?)|(~[^:/]*)(/[^:]*)?|(~[^:]*)(:.*)?|/+([.][.]?/+)*([^:/]+)(/[^:]*)?|([^:]+):.*)$"
1.52 +
1.53 +/*
1.54 + * The following variables are used to hold precompiled regular expressions
1.55 + * for use in filename matching.
1.56 + */
1.57 +
1.58 +typedef struct ThreadSpecificData {
1.59 + int initialized;
1.60 + Tcl_Obj *macRootPatternPtr;
1.61 +} ThreadSpecificData;
1.62 +
1.63 +static void FileNameCleanup _ANSI_ARGS_((ClientData clientData));
1.64 +static void FileNameInit _ANSI_ARGS_((void));
1.65 +
1.66 +#endif
1.67 +
1.68 +#if !defined(__SYMBIAN32__) || !defined(__WINSCW__)
1.69 +static Tcl_ThreadDataKey dataKey;
1.70 +
1.71 +/*
1.72 + * The following variable is set in the TclPlatformInit call to one
1.73 + * of: TCL_PLATFORM_UNIX, TCL_PLATFORM_MAC, or TCL_PLATFORM_WINDOWS.
1.74 + */
1.75 +
1.76 +TclPlatformType tclPlatform = TCL_PLATFORM_UNIX;
1.77 +#endif
1.78 +/*
1.79 + * Prototypes for local procedures defined in this file:
1.80 + */
1.81 +
1.82 +static CONST char * DoTildeSubst _ANSI_ARGS_((Tcl_Interp *interp,
1.83 + CONST char *user, Tcl_DString *resultPtr));
1.84 +static CONST char * ExtractWinRoot _ANSI_ARGS_((CONST char *path,
1.85 + Tcl_DString *resultPtr, int offset,
1.86 + Tcl_PathType *typePtr));
1.87 +static int SkipToChar _ANSI_ARGS_((char **stringPtr,
1.88 + char *match));
1.89 +static Tcl_Obj* SplitMacPath _ANSI_ARGS_((CONST char *path));
1.90 +static Tcl_Obj* SplitWinPath _ANSI_ARGS_((CONST char *path));
1.91 +static Tcl_Obj* SplitUnixPath _ANSI_ARGS_((CONST char *path));
1.92 +#ifdef MAC_UNDERSTANDS_UNIX_PATHS
1.93 +
1.94 +/*
1.95 + *----------------------------------------------------------------------
1.96 + *
1.97 + * FileNameInit --
1.98 + *
1.99 + * This procedure initializes the patterns used by this module.
1.100 + *
1.101 + * Results:
1.102 + * None.
1.103 + *
1.104 + * Side effects:
1.105 + * Compiles the regular expressions.
1.106 + *
1.107 + *----------------------------------------------------------------------
1.108 + */
1.109 +
1.110 +static void
1.111 +FileNameInit()
1.112 +{
1.113 + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
1.114 + if (!tsdPtr->initialized) {
1.115 + tsdPtr->initialized = 1;
1.116 + tsdPtr->macRootPatternPtr = Tcl_NewStringObj(MAC_ROOT_PATTERN, -1);
1.117 + Tcl_CreateThreadExitHandler(FileNameCleanup, NULL);
1.118 + }
1.119 +}
1.120 +
1.121 +/*
1.122 + *----------------------------------------------------------------------
1.123 + *
1.124 + * FileNameCleanup --
1.125 + *
1.126 + * This procedure is a Tcl_ExitProc used to clean up the static
1.127 + * data structures used in this file.
1.128 + *
1.129 + * Results:
1.130 + * None.
1.131 + *
1.132 + * Side effects:
1.133 + * Deallocates storage used by the procedures in this file.
1.134 + *
1.135 + *----------------------------------------------------------------------
1.136 + */
1.137 +
1.138 +static void
1.139 +FileNameCleanup(clientData)
1.140 + ClientData clientData; /* Not used. */
1.141 +{
1.142 + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
1.143 + Tcl_DecrRefCount(tsdPtr->macRootPatternPtr);
1.144 + tsdPtr->initialized = 0;
1.145 +}
1.146 +#endif
1.147 +
1.148 +/*
1.149 + *----------------------------------------------------------------------
1.150 + *
1.151 + * ExtractWinRoot --
1.152 + *
1.153 + * Matches the root portion of a Windows path and appends it
1.154 + * to the specified Tcl_DString.
1.155 + *
1.156 + * Results:
1.157 + * Returns the position in the path immediately after the root
1.158 + * including any trailing slashes.
1.159 + * Appends a cleaned up version of the root to the Tcl_DString
1.160 + * at the specified offest.
1.161 + *
1.162 + * Side effects:
1.163 + * Modifies the specified Tcl_DString.
1.164 + *
1.165 + *----------------------------------------------------------------------
1.166 + */
1.167 +
1.168 +static CONST char *
1.169 +ExtractWinRoot(path, resultPtr, offset, typePtr)
1.170 + CONST char *path; /* Path to parse. */
1.171 + Tcl_DString *resultPtr; /* Buffer to hold result. */
1.172 + int offset; /* Offset in buffer where result should be
1.173 + * stored. */
1.174 + Tcl_PathType *typePtr; /* Where to store pathType result */
1.175 +{
1.176 + if (path[0] == '/' || path[0] == '\\') {
1.177 + /* Might be a UNC or Vol-Relative path */
1.178 + CONST char *host, *share, *tail;
1.179 + int hlen, slen;
1.180 + if (path[1] != '/' && path[1] != '\\') {
1.181 + Tcl_DStringSetLength(resultPtr, offset);
1.182 + *typePtr = TCL_PATH_VOLUME_RELATIVE;
1.183 + Tcl_DStringAppend(resultPtr, "/", 1);
1.184 + return &path[1];
1.185 + }
1.186 + host = &path[2];
1.187 +
1.188 + /* Skip separators */
1.189 + while (host[0] == '/' || host[0] == '\\') host++;
1.190 +
1.191 + for (hlen = 0; host[hlen];hlen++) {
1.192 + if (host[hlen] == '/' || host[hlen] == '\\')
1.193 + break;
1.194 + }
1.195 + if (host[hlen] == 0 || host[hlen+1] == 0) {
1.196 + /*
1.197 + * The path given is simply of the form
1.198 + * '/foo', '//foo', '/////foo' or the same
1.199 + * with backslashes. If there is exactly
1.200 + * one leading '/' the path is volume relative
1.201 + * (see filename man page). If there are more
1.202 + * than one, we are simply assuming they
1.203 + * are superfluous and we trim them away.
1.204 + * (An alternative interpretation would
1.205 + * be that it is a host name, but we have
1.206 + * been documented that that is not the case).
1.207 + */
1.208 + *typePtr = TCL_PATH_VOLUME_RELATIVE;
1.209 + Tcl_DStringAppend(resultPtr, "/", 1);
1.210 + return &path[2];
1.211 + }
1.212 + Tcl_DStringSetLength(resultPtr, offset);
1.213 + share = &host[hlen];
1.214 +
1.215 + /* Skip separators */
1.216 + while (share[0] == '/' || share[0] == '\\') share++;
1.217 +
1.218 + for (slen = 0; share[slen];slen++) {
1.219 + if (share[slen] == '/' || share[slen] == '\\')
1.220 + break;
1.221 + }
1.222 + Tcl_DStringAppend(resultPtr, "//", 2);
1.223 + Tcl_DStringAppend(resultPtr, host, hlen);
1.224 + Tcl_DStringAppend(resultPtr, "/", 1);
1.225 + Tcl_DStringAppend(resultPtr, share, slen);
1.226 +
1.227 + tail = &share[slen];
1.228 +
1.229 + /* Skip separators */
1.230 + while (tail[0] == '/' || tail[0] == '\\') tail++;
1.231 +
1.232 + *typePtr = TCL_PATH_ABSOLUTE;
1.233 + return tail;
1.234 + } else if (*path && path[1] == ':') {
1.235 + /* Might be a drive sep */
1.236 + Tcl_DStringSetLength(resultPtr, offset);
1.237 +
1.238 + if (path[2] != '/' && path[2] != '\\') {
1.239 + *typePtr = TCL_PATH_VOLUME_RELATIVE;
1.240 + Tcl_DStringAppend(resultPtr, path, 2);
1.241 + return &path[2];
1.242 + } else {
1.243 + char *tail = (char*)&path[3];
1.244 +
1.245 + /* Skip separators */
1.246 + while (*tail && (tail[0] == '/' || tail[0] == '\\')) tail++;
1.247 +
1.248 + *typePtr = TCL_PATH_ABSOLUTE;
1.249 + Tcl_DStringAppend(resultPtr, path, 2);
1.250 + Tcl_DStringAppend(resultPtr, "/", 1);
1.251 +
1.252 + return tail;
1.253 + }
1.254 + } else {
1.255 + int abs = 0;
1.256 + if ((path[0] == 'c' || path[0] == 'C')
1.257 + && (path[1] == 'o' || path[1] == 'O')) {
1.258 + if ((path[2] == 'm' || path[2] == 'M')
1.259 + && path[3] >= '1' && path[3] <= '4') {
1.260 + /* May have match for 'com[1-4]:?', which is a serial port */
1.261 + if (path[4] == '\0') {
1.262 + abs = 4;
1.263 + } else if (path [4] == ':' && path[5] == '\0') {
1.264 + abs = 5;
1.265 + }
1.266 + } else if ((path[2] == 'n' || path[2] == 'N') && path[3] == '\0') {
1.267 + /* Have match for 'con' */
1.268 + abs = 3;
1.269 + }
1.270 + } else if ((path[0] == 'l' || path[0] == 'L')
1.271 + && (path[1] == 'p' || path[1] == 'P')
1.272 + && (path[2] == 't' || path[2] == 'T')) {
1.273 + if (path[3] >= '1' && path[3] <= '3') {
1.274 + /* May have match for 'lpt[1-3]:?' */
1.275 + if (path[4] == '\0') {
1.276 + abs = 4;
1.277 + } else if (path [4] == ':' && path[5] == '\0') {
1.278 + abs = 5;
1.279 + }
1.280 + }
1.281 + } else if ((path[0] == 'p' || path[0] == 'P')
1.282 + && (path[1] == 'r' || path[1] == 'R')
1.283 + && (path[2] == 'n' || path[2] == 'N')
1.284 + && path[3] == '\0') {
1.285 + /* Have match for 'prn' */
1.286 + abs = 3;
1.287 + } else if ((path[0] == 'n' || path[0] == 'N')
1.288 + && (path[1] == 'u' || path[1] == 'U')
1.289 + && (path[2] == 'l' || path[2] == 'L')
1.290 + && path[3] == '\0') {
1.291 + /* Have match for 'nul' */
1.292 + abs = 3;
1.293 + } else if ((path[0] == 'a' || path[0] == 'A')
1.294 + && (path[1] == 'u' || path[1] == 'U')
1.295 + && (path[2] == 'x' || path[2] == 'X')
1.296 + && path[3] == '\0') {
1.297 + /* Have match for 'aux' */
1.298 + abs = 3;
1.299 + }
1.300 + if (abs != 0) {
1.301 + *typePtr = TCL_PATH_ABSOLUTE;
1.302 + Tcl_DStringSetLength(resultPtr, offset);
1.303 + Tcl_DStringAppend(resultPtr, path, abs);
1.304 + return path + abs;
1.305 + }
1.306 + }
1.307 + /* Anything else is treated as relative */
1.308 + *typePtr = TCL_PATH_RELATIVE;
1.309 + return path;
1.310 +}
1.311 +
1.312 +/*
1.313 + *----------------------------------------------------------------------
1.314 + *
1.315 + * Tcl_GetPathType --
1.316 + *
1.317 + * Determines whether a given path is relative to the current
1.318 + * directory, relative to the current volume, or absolute.
1.319 + *
1.320 + * The objectified Tcl_FSGetPathType should be used in
1.321 + * preference to this function (as you can see below, this
1.322 + * is just a wrapper around that other function).
1.323 + *
1.324 + * Results:
1.325 + * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
1.326 + * TCL_PATH_VOLUME_RELATIVE.
1.327 + *
1.328 + * Side effects:
1.329 + * None.
1.330 + *
1.331 + *----------------------------------------------------------------------
1.332 + */
1.333 +
1.334 +EXPORT_C Tcl_PathType
1.335 +Tcl_GetPathType(path)
1.336 + CONST char *path;
1.337 +{
1.338 + Tcl_PathType type;
1.339 + Tcl_Obj *tempObj = Tcl_NewStringObj(path,-1);
1.340 + Tcl_IncrRefCount(tempObj);
1.341 + type = Tcl_FSGetPathType(tempObj);
1.342 + Tcl_DecrRefCount(tempObj);
1.343 + return type;
1.344 +}
1.345 +
1.346 +/*
1.347 + *----------------------------------------------------------------------
1.348 + *
1.349 + * TclpGetNativePathType --
1.350 + *
1.351 + * Determines whether a given path is relative to the current
1.352 + * directory, relative to the current volume, or absolute, but
1.353 + * ONLY FOR THE NATIVE FILESYSTEM. This function is called from
1.354 + * tclIOUtil.c (but needs to be here due to its dependence on
1.355 + * static variables/functions in this file). The exported
1.356 + * function Tcl_FSGetPathType should be used by extensions.
1.357 + *
1.358 + * Results:
1.359 + * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
1.360 + * TCL_PATH_VOLUME_RELATIVE.
1.361 + *
1.362 + * Side effects:
1.363 + * None.
1.364 + *
1.365 + *----------------------------------------------------------------------
1.366 + */
1.367 +
1.368 +Tcl_PathType
1.369 +TclpGetNativePathType(pathObjPtr, driveNameLengthPtr, driveNameRef)
1.370 + Tcl_Obj *pathObjPtr;
1.371 + int *driveNameLengthPtr;
1.372 + Tcl_Obj **driveNameRef;
1.373 +{
1.374 + Tcl_PathType type = TCL_PATH_ABSOLUTE;
1.375 + int pathLen;
1.376 + char *path = Tcl_GetStringFromObj(pathObjPtr, &pathLen);
1.377 +
1.378 + if (path[0] == '~') {
1.379 + /*
1.380 + * This case is common to all platforms.
1.381 + * Paths that begin with ~ are absolute.
1.382 + */
1.383 + if (driveNameLengthPtr != NULL) {
1.384 + char *end = path + 1;
1.385 + while ((*end != '\0') && (*end != '/')) {
1.386 + end++;
1.387 + }
1.388 + *driveNameLengthPtr = end - path;
1.389 + }
1.390 + } else {
1.391 + switch (tclPlatform) {
1.392 + case TCL_PLATFORM_UNIX: {
1.393 + char *origPath = path;
1.394 +
1.395 + /*
1.396 + * Paths that begin with / are absolute.
1.397 + */
1.398 +
1.399 +#ifdef __QNX__
1.400 + /*
1.401 + * Check for QNX //<node id> prefix
1.402 + */
1.403 + if (*path && (pathLen > 3) && (path[0] == '/')
1.404 + && (path[1] == '/') && isdigit(UCHAR(path[2]))) {
1.405 + path += 3;
1.406 + while (isdigit(UCHAR(*path))) {
1.407 + ++path;
1.408 + }
1.409 + }
1.410 +#endif
1.411 + if (path[0] == '/') {
1.412 + if (driveNameLengthPtr != NULL) {
1.413 + /*
1.414 + * We need this addition in case the QNX code
1.415 + * was used
1.416 + */
1.417 + *driveNameLengthPtr = (1 + path - origPath);
1.418 + }
1.419 + } else {
1.420 + type = TCL_PATH_RELATIVE;
1.421 + }
1.422 + break;
1.423 + }
1.424 + case TCL_PLATFORM_MAC:
1.425 + if (path[0] == ':') {
1.426 + type = TCL_PATH_RELATIVE;
1.427 + } else {
1.428 +#ifdef MAC_UNDERSTANDS_UNIX_PATHS
1.429 + ThreadSpecificData *tsdPtr;
1.430 + Tcl_RegExp re;
1.431 +
1.432 + tsdPtr = TCL_TSD_INIT(&dataKey);
1.433 +
1.434 + /*
1.435 + * Since we have eliminated the easy cases, use the
1.436 + * root pattern to look for the other types.
1.437 + */
1.438 +
1.439 + FileNameInit();
1.440 + re = Tcl_GetRegExpFromObj(NULL, tsdPtr->macRootPatternPtr,
1.441 + REG_ADVANCED);
1.442 +
1.443 + if (!Tcl_RegExpExec(NULL, re, path, path)) {
1.444 + type = TCL_PATH_RELATIVE;
1.445 + } else {
1.446 + CONST char *root, *end;
1.447 + Tcl_RegExpRange(re, 2, &root, &end);
1.448 + if (root != NULL) {
1.449 + type = TCL_PATH_RELATIVE;
1.450 + } else {
1.451 + if (driveNameLengthPtr != NULL) {
1.452 + Tcl_RegExpRange(re, 0, &root, &end);
1.453 + *driveNameLengthPtr = end - root;
1.454 + }
1.455 + if (driveNameRef != NULL) {
1.456 + if (*root == '/') {
1.457 + char *c;
1.458 + int gotColon = 0;
1.459 + *driveNameRef = Tcl_NewStringObj(root + 1,
1.460 + end - root -1);
1.461 + c = Tcl_GetString(*driveNameRef);
1.462 + while (*c != '\0') {
1.463 + if (*c == '/') {
1.464 + gotColon++;
1.465 + *c = ':';
1.466 + }
1.467 + c++;
1.468 + }
1.469 + /*
1.470 + * If there is no colon, we have just a
1.471 + * volume name so we must add a colon so
1.472 + * it is an absolute path.
1.473 + */
1.474 + if (gotColon == 0) {
1.475 + Tcl_AppendToObj(*driveNameRef, ":", 1);
1.476 + } else if ((gotColon > 1) &&
1.477 + (*(c-1) == ':')) {
1.478 + /* We have an extra colon */
1.479 + Tcl_SetObjLength(*driveNameRef,
1.480 + c - Tcl_GetString(*driveNameRef) - 1);
1.481 + }
1.482 + }
1.483 + }
1.484 + }
1.485 + }
1.486 +#else
1.487 + if (path[0] == '~') {
1.488 + } else if (path[0] == ':') {
1.489 + type = TCL_PATH_RELATIVE;
1.490 + } else {
1.491 + char *colonPos = strchr(path,':');
1.492 + if (colonPos == NULL) {
1.493 + type = TCL_PATH_RELATIVE;
1.494 + } else {
1.495 + }
1.496 + }
1.497 + if (type == TCL_PATH_ABSOLUTE) {
1.498 + if (driveNameLengthPtr != NULL) {
1.499 + *driveNameLengthPtr = strlen(path);
1.500 + }
1.501 + }
1.502 +#endif
1.503 + }
1.504 + break;
1.505 +
1.506 + case TCL_PLATFORM_WINDOWS: {
1.507 + Tcl_DString ds;
1.508 + CONST char *rootEnd;
1.509 +
1.510 + Tcl_DStringInit(&ds);
1.511 + rootEnd = ExtractWinRoot(path, &ds, 0, &type);
1.512 + if ((rootEnd != path) && (driveNameLengthPtr != NULL)) {
1.513 + *driveNameLengthPtr = rootEnd - path;
1.514 + if (driveNameRef != NULL) {
1.515 + *driveNameRef = Tcl_NewStringObj(Tcl_DStringValue(&ds),
1.516 + Tcl_DStringLength(&ds));
1.517 + Tcl_IncrRefCount(*driveNameRef);
1.518 + }
1.519 + }
1.520 + Tcl_DStringFree(&ds);
1.521 + break;
1.522 + }
1.523 + }
1.524 + }
1.525 + return type;
1.526 +}
1.527 +
1.528 +/*
1.529 + *---------------------------------------------------------------------------
1.530 + *
1.531 + * TclpNativeSplitPath --
1.532 + *
1.533 + * This function takes the given Tcl_Obj, which should be a valid
1.534 + * path, and returns a Tcl List object containing each segment
1.535 + * of that path as an element.
1.536 + *
1.537 + * Note this function currently calls the older Split(Plat)Path
1.538 + * functions, which require more memory allocation than is
1.539 + * desirable.
1.540 + *
1.541 + * Results:
1.542 + * Returns list object with refCount of zero. If the passed in
1.543 + * lenPtr is non-NULL, we use it to return the number of elements
1.544 + * in the returned list.
1.545 + *
1.546 + * Side effects:
1.547 + * None.
1.548 + *
1.549 + *---------------------------------------------------------------------------
1.550 + */
1.551 +
1.552 +Tcl_Obj*
1.553 +TclpNativeSplitPath(pathPtr, lenPtr)
1.554 + Tcl_Obj *pathPtr; /* Path to split. */
1.555 + int *lenPtr; /* int to store number of path elements. */
1.556 +{
1.557 + Tcl_Obj *resultPtr = NULL; /* Needed only to prevent gcc warnings. */
1.558 +
1.559 + /*
1.560 + * Perform platform specific splitting.
1.561 + */
1.562 +
1.563 + switch (tclPlatform) {
1.564 + case TCL_PLATFORM_UNIX:
1.565 + resultPtr = SplitUnixPath(Tcl_GetString(pathPtr));
1.566 + break;
1.567 +
1.568 + case TCL_PLATFORM_WINDOWS:
1.569 + resultPtr = SplitWinPath(Tcl_GetString(pathPtr));
1.570 + break;
1.571 +
1.572 + case TCL_PLATFORM_MAC:
1.573 + resultPtr = SplitMacPath(Tcl_GetString(pathPtr));
1.574 + break;
1.575 + }
1.576 +
1.577 + /*
1.578 + * Compute the number of elements in the result.
1.579 + */
1.580 +
1.581 + if (lenPtr != NULL) {
1.582 + Tcl_ListObjLength(NULL, resultPtr, lenPtr);
1.583 + }
1.584 + return resultPtr;
1.585 +}
1.586 +
1.587 +/*
1.588 + *----------------------------------------------------------------------
1.589 + *
1.590 + * Tcl_SplitPath --
1.591 + *
1.592 + * Split a path into a list of path components. The first element
1.593 + * of the list will have the same path type as the original path.
1.594 + *
1.595 + * Results:
1.596 + * Returns a standard Tcl result. The interpreter result contains
1.597 + * a list of path components.
1.598 + * *argvPtr will be filled in with the address of an array
1.599 + * whose elements point to the elements of path, in order.
1.600 + * *argcPtr will get filled in with the number of valid elements
1.601 + * in the array. A single block of memory is dynamically allocated
1.602 + * to hold both the argv array and a copy of the path elements.
1.603 + * The caller must eventually free this memory by calling ckfree()
1.604 + * on *argvPtr. Note: *argvPtr and *argcPtr are only modified
1.605 + * if the procedure returns normally.
1.606 + *
1.607 + * Side effects:
1.608 + * Allocates memory.
1.609 + *
1.610 + *----------------------------------------------------------------------
1.611 + */
1.612 +
1.613 +EXPORT_C void
1.614 +Tcl_SplitPath(path, argcPtr, argvPtr)
1.615 + CONST char *path; /* Pointer to string containing a path. */
1.616 + int *argcPtr; /* Pointer to location to fill in with
1.617 + * the number of elements in the path. */
1.618 + CONST char ***argvPtr; /* Pointer to place to store pointer to array
1.619 + * of pointers to path elements. */
1.620 +{
1.621 + Tcl_Obj *resultPtr = NULL; /* Needed only to prevent gcc warnings. */
1.622 + Tcl_Obj *tmpPtr, *eltPtr;
1.623 + int i, size, len;
1.624 + char *p, *str;
1.625 +
1.626 + /*
1.627 + * Perform the splitting, using objectified, vfs-aware code.
1.628 + */
1.629 +
1.630 + tmpPtr = Tcl_NewStringObj(path, -1);
1.631 + Tcl_IncrRefCount(tmpPtr);
1.632 + resultPtr = Tcl_FSSplitPath(tmpPtr, argcPtr);
1.633 + Tcl_DecrRefCount(tmpPtr);
1.634 +
1.635 + /* Calculate space required for the result */
1.636 +
1.637 + size = 1;
1.638 + for (i = 0; i < *argcPtr; i++) {
1.639 + Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr);
1.640 + Tcl_GetStringFromObj(eltPtr, &len);
1.641 + size += len + 1;
1.642 + }
1.643 +
1.644 + /*
1.645 + * Allocate a buffer large enough to hold the contents of all of
1.646 + * the list plus the argv pointers and the terminating NULL pointer.
1.647 + */
1.648 +
1.649 + *argvPtr = (CONST char **) ckalloc((unsigned)
1.650 + ((((*argcPtr) + 1) * sizeof(char *)) + size));
1.651 +
1.652 + /*
1.653 + * Position p after the last argv pointer and copy the contents of
1.654 + * the list in, piece by piece.
1.655 + */
1.656 +
1.657 + p = (char *) &(*argvPtr)[(*argcPtr) + 1];
1.658 + for (i = 0; i < *argcPtr; i++) {
1.659 + Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr);
1.660 + str = Tcl_GetStringFromObj(eltPtr, &len);
1.661 + memcpy((VOID *) p, (VOID *) str, (size_t) len+1);
1.662 + p += len+1;
1.663 + }
1.664 +
1.665 + /*
1.666 + * Now set up the argv pointers.
1.667 + */
1.668 +
1.669 + p = (char *) &(*argvPtr)[(*argcPtr) + 1];
1.670 +
1.671 + for (i = 0; i < *argcPtr; i++) {
1.672 + (*argvPtr)[i] = p;
1.673 + while ((*p++) != '\0') {}
1.674 + }
1.675 + (*argvPtr)[i] = NULL;
1.676 +
1.677 + /*
1.678 + * Free the result ptr given to us by Tcl_FSSplitPath
1.679 + */
1.680 +
1.681 + Tcl_DecrRefCount(resultPtr);
1.682 +}
1.683 +
1.684 +/*
1.685 + *----------------------------------------------------------------------
1.686 + *
1.687 + * SplitUnixPath --
1.688 + *
1.689 + * This routine is used by Tcl_(FS)SplitPath to handle splitting
1.690 + * Unix paths.
1.691 + *
1.692 + * Results:
1.693 + * Returns a newly allocated Tcl list object.
1.694 + *
1.695 + * Side effects:
1.696 + * None.
1.697 + *
1.698 + *----------------------------------------------------------------------
1.699 + */
1.700 +
1.701 +static Tcl_Obj*
1.702 +SplitUnixPath(path)
1.703 + CONST char *path; /* Pointer to string containing a path. */
1.704 +{
1.705 + int length;
1.706 + CONST char *p, *elementStart;
1.707 + Tcl_Obj *result = Tcl_NewObj();
1.708 +
1.709 + /*
1.710 + * Deal with the root directory as a special case.
1.711 + */
1.712 +
1.713 +#ifdef __QNX__
1.714 + /*
1.715 + * Check for QNX //<node id> prefix
1.716 + */
1.717 + if ((path[0] == '/') && (path[1] == '/')
1.718 + && isdigit(UCHAR(path[2]))) { /* INTL: digit */
1.719 + path += 3;
1.720 + while (isdigit(UCHAR(*path))) { /* INTL: digit */
1.721 + ++path;
1.722 + }
1.723 + }
1.724 +#endif
1.725 +
1.726 + if (path[0] == '/') {
1.727 + Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj("/",1));
1.728 + p = path+1;
1.729 + } else {
1.730 + p = path;
1.731 + }
1.732 +
1.733 + /*
1.734 + * Split on slashes. Embedded elements that start with tilde will be
1.735 + * prefixed with "./" so they are not affected by tilde substitution.
1.736 + */
1.737 +
1.738 + for (;;) {
1.739 + elementStart = p;
1.740 + while ((*p != '\0') && (*p != '/')) {
1.741 + p++;
1.742 + }
1.743 + length = p - elementStart;
1.744 + if (length > 0) {
1.745 + Tcl_Obj *nextElt;
1.746 + if ((elementStart[0] == '~') && (elementStart != path)) {
1.747 + nextElt = Tcl_NewStringObj("./",2);
1.748 + Tcl_AppendToObj(nextElt, elementStart, length);
1.749 + } else {
1.750 + nextElt = Tcl_NewStringObj(elementStart, length);
1.751 + }
1.752 + Tcl_ListObjAppendElement(NULL, result, nextElt);
1.753 + }
1.754 + if (*p++ == '\0') {
1.755 + break;
1.756 + }
1.757 + }
1.758 + return result;
1.759 +}
1.760 +
1.761 +
1.762 +/*
1.763 + *----------------------------------------------------------------------
1.764 + *
1.765 + * SplitWinPath --
1.766 + *
1.767 + * This routine is used by Tcl_(FS)SplitPath to handle splitting
1.768 + * Windows paths.
1.769 + *
1.770 + * Results:
1.771 + * Returns a newly allocated Tcl list object.
1.772 + *
1.773 + * Side effects:
1.774 + * None.
1.775 + *
1.776 + *----------------------------------------------------------------------
1.777 + */
1.778 +
1.779 +static Tcl_Obj*
1.780 +SplitWinPath(path)
1.781 + CONST char *path; /* Pointer to string containing a path. */
1.782 +{
1.783 + int length;
1.784 + CONST char *p, *elementStart;
1.785 + Tcl_PathType type = TCL_PATH_ABSOLUTE;
1.786 + Tcl_DString buf;
1.787 + Tcl_Obj *result = Tcl_NewObj();
1.788 + Tcl_DStringInit(&buf);
1.789 +
1.790 + p = ExtractWinRoot(path, &buf, 0, &type);
1.791 +
1.792 + /*
1.793 + * Terminate the root portion, if we matched something.
1.794 + */
1.795 +
1.796 + if (p != path) {
1.797 + Tcl_ListObjAppendElement(NULL, result,
1.798 + Tcl_NewStringObj(Tcl_DStringValue(&buf),
1.799 + Tcl_DStringLength(&buf)));
1.800 + }
1.801 + Tcl_DStringFree(&buf);
1.802 +
1.803 + /*
1.804 + * Split on slashes. Embedded elements that start with tilde
1.805 + * or a drive letter will be prefixed with "./" so they are not
1.806 + * affected by tilde substitution.
1.807 + */
1.808 +
1.809 + do {
1.810 + elementStart = p;
1.811 + while ((*p != '\0') && (*p != '/') && (*p != '\\')) {
1.812 + p++;
1.813 + }
1.814 + length = p - elementStart;
1.815 + if (length > 0) {
1.816 + Tcl_Obj *nextElt;
1.817 + if ((elementStart != path)
1.818 + && ((elementStart[0] == '~')
1.819 + || (isalpha(UCHAR(elementStart[0]))
1.820 + && elementStart[1] == ':'))) {
1.821 + nextElt = Tcl_NewStringObj("./",2);
1.822 + Tcl_AppendToObj(nextElt, elementStart, length);
1.823 + } else {
1.824 + nextElt = Tcl_NewStringObj(elementStart, length);
1.825 + }
1.826 + Tcl_ListObjAppendElement(NULL, result, nextElt);
1.827 + }
1.828 + } while (*p++ != '\0');
1.829 +
1.830 + return result;
1.831 +}
1.832 +
1.833 +/*
1.834 + *----------------------------------------------------------------------
1.835 + *
1.836 + * SplitMacPath --
1.837 + *
1.838 + * This routine is used by Tcl_(FS)SplitPath to handle splitting
1.839 + * Macintosh paths.
1.840 + *
1.841 + * Results:
1.842 + * Returns a newly allocated Tcl list object.
1.843 + *
1.844 + * Side effects:
1.845 + * None.
1.846 + *
1.847 + *----------------------------------------------------------------------
1.848 + */
1.849 +
1.850 +static Tcl_Obj*
1.851 +SplitMacPath(path)
1.852 + CONST char *path; /* Pointer to string containing a path. */
1.853 +{
1.854 + int isMac = 0; /* 1 if is Mac-style, 0 if Unix-style path. */
1.855 + int length;
1.856 + CONST char *p, *elementStart;
1.857 + Tcl_Obj *result;
1.858 +#ifdef MAC_UNDERSTANDS_UNIX_PATHS
1.859 + Tcl_RegExp re;
1.860 + int i;
1.861 + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
1.862 +#endif
1.863 +
1.864 + result = Tcl_NewObj();
1.865 +
1.866 +#ifdef MAC_UNDERSTANDS_UNIX_PATHS
1.867 + /*
1.868 + * Initialize the path name parser for Macintosh path names.
1.869 + */
1.870 +
1.871 + FileNameInit();
1.872 +
1.873 + /*
1.874 + * Match the root portion of a Mac path name.
1.875 + */
1.876 +
1.877 + i = 0; /* Needed only to prevent gcc warnings. */
1.878 +
1.879 + re = Tcl_GetRegExpFromObj(NULL, tsdPtr->macRootPatternPtr, REG_ADVANCED);
1.880 +
1.881 + if (Tcl_RegExpExec(NULL, re, path, path) == 1) {
1.882 + CONST char *start, *end;
1.883 + Tcl_Obj *nextElt;
1.884 +
1.885 + /*
1.886 + * Treat degenerate absolute paths like / and /../.. as
1.887 + * Mac relative file names for lack of anything else to do.
1.888 + */
1.889 +
1.890 + Tcl_RegExpRange(re, 2, &start, &end);
1.891 + if (start) {
1.892 + Tcl_Obj *elt = Tcl_NewStringObj(":", 1);
1.893 + Tcl_RegExpRange(re, 0, &start, &end);
1.894 + Tcl_AppendToObj(elt, path, end - start);
1.895 + Tcl_ListObjAppendElement(NULL, result, elt);
1.896 + return result;
1.897 + }
1.898 +
1.899 + Tcl_RegExpRange(re, 5, &start, &end);
1.900 + if (start) {
1.901 + /*
1.902 + * Unix-style tilde prefixed paths.
1.903 + */
1.904 +
1.905 + isMac = 0;
1.906 + i = 5;
1.907 + } else {
1.908 + Tcl_RegExpRange(re, 7, &start, &end);
1.909 + if (start) {
1.910 + /*
1.911 + * Mac-style tilde prefixed paths.
1.912 + */
1.913 +
1.914 + isMac = 1;
1.915 + i = 7;
1.916 + } else {
1.917 + Tcl_RegExpRange(re, 10, &start, &end);
1.918 + if (start) {
1.919 + /*
1.920 + * Normal Unix style paths.
1.921 + */
1.922 +
1.923 + isMac = 0;
1.924 + i = 10;
1.925 + } else {
1.926 + Tcl_RegExpRange(re, 12, &start, &end);
1.927 + if (start) {
1.928 + /*
1.929 + * Normal Mac style paths.
1.930 + */
1.931 +
1.932 + isMac = 1;
1.933 + i = 12;
1.934 + }
1.935 + }
1.936 + }
1.937 + }
1.938 + Tcl_RegExpRange(re, i, &start, &end);
1.939 + length = end - start;
1.940 +
1.941 + /*
1.942 + * Append the element and terminate it with a :
1.943 + */
1.944 +
1.945 + nextElt = Tcl_NewStringObj(start, length);
1.946 + Tcl_AppendToObj(nextElt, ":", 1);
1.947 + Tcl_ListObjAppendElement(NULL, result, nextElt);
1.948 + p = end;
1.949 + } else {
1.950 + isMac = (strchr(path, ':') != NULL);
1.951 + p = path;
1.952 + }
1.953 +#else
1.954 + if ((path[0] != ':') && (path[0] == '~' || (strchr(path,':') != NULL))) {
1.955 + CONST char *end;
1.956 + Tcl_Obj *nextElt;
1.957 +
1.958 + isMac = 1;
1.959 +
1.960 + end = strchr(path,':');
1.961 + if (end == NULL) {
1.962 + length = strlen(path);
1.963 + } else {
1.964 + length = end - path;
1.965 + }
1.966 +
1.967 + /*
1.968 + * Append the element and terminate it with a :
1.969 + */
1.970 +
1.971 + nextElt = Tcl_NewStringObj(path, length);
1.972 + Tcl_AppendToObj(nextElt, ":", 1);
1.973 + Tcl_ListObjAppendElement(NULL, result, nextElt);
1.974 + p = path + length;
1.975 + } else {
1.976 + isMac = (strchr(path, ':') != NULL);
1.977 + isMac = 1;
1.978 + p = path;
1.979 + }
1.980 +#endif
1.981 +
1.982 + if (isMac) {
1.983 +
1.984 + /*
1.985 + * p is pointing at the first colon in the path. There
1.986 + * will always be one, since this is a Mac-style path.
1.987 + * (This is no longer true if MAC_UNDERSTANDS_UNIX_PATHS
1.988 + * is false, so we must check whether 'p' points to the
1.989 + * end of the string.)
1.990 + */
1.991 + elementStart = p;
1.992 + if (*p == ':') {
1.993 + p++;
1.994 + }
1.995 +
1.996 + while ((p = strchr(p, ':')) != NULL) {
1.997 + length = p - elementStart;
1.998 + if (length == 1) {
1.999 + while (*p == ':') {
1.1000 + Tcl_ListObjAppendElement(NULL, result,
1.1001 + Tcl_NewStringObj("::", 2));
1.1002 + elementStart = p++;
1.1003 + }
1.1004 + } else {
1.1005 + /*
1.1006 + * If this is a simple component, drop the leading colon.
1.1007 + */
1.1008 +
1.1009 + if ((elementStart[1] != '~')
1.1010 + && (strchr(elementStart+1, '/') == NULL)) {
1.1011 + elementStart++;
1.1012 + length--;
1.1013 + }
1.1014 + Tcl_ListObjAppendElement(NULL, result,
1.1015 + Tcl_NewStringObj(elementStart, length));
1.1016 + elementStart = p++;
1.1017 + }
1.1018 + }
1.1019 + if (elementStart[0] != ':') {
1.1020 + if (elementStart[0] != '\0') {
1.1021 + Tcl_ListObjAppendElement(NULL, result,
1.1022 + Tcl_NewStringObj(elementStart, -1));
1.1023 + }
1.1024 + } else {
1.1025 + if (elementStart[1] != '\0' || elementStart == path) {
1.1026 + if ((elementStart[1] != '~') && (elementStart[1] != '\0')
1.1027 + && (strchr(elementStart+1, '/') == NULL)) {
1.1028 + elementStart++;
1.1029 + }
1.1030 + Tcl_ListObjAppendElement(NULL, result,
1.1031 + Tcl_NewStringObj(elementStart, -1));
1.1032 + }
1.1033 + }
1.1034 + } else {
1.1035 +
1.1036 + /*
1.1037 + * Split on slashes, suppress extra /'s, and convert .. to ::.
1.1038 + */
1.1039 +
1.1040 + for (;;) {
1.1041 + elementStart = p;
1.1042 + while ((*p != '\0') && (*p != '/')) {
1.1043 + p++;
1.1044 + }
1.1045 + length = p - elementStart;
1.1046 + if (length > 0) {
1.1047 + if ((length == 1) && (elementStart[0] == '.')) {
1.1048 + Tcl_ListObjAppendElement(NULL, result,
1.1049 + Tcl_NewStringObj(":", 1));
1.1050 + } else if ((length == 2) && (elementStart[0] == '.')
1.1051 + && (elementStart[1] == '.')) {
1.1052 + Tcl_ListObjAppendElement(NULL, result,
1.1053 + Tcl_NewStringObj("::", 2));
1.1054 + } else {
1.1055 + Tcl_Obj *nextElt;
1.1056 + if (*elementStart == '~') {
1.1057 + nextElt = Tcl_NewStringObj(":",1);
1.1058 + Tcl_AppendToObj(nextElt, elementStart, length);
1.1059 + } else {
1.1060 + nextElt = Tcl_NewStringObj(elementStart, length);
1.1061 + }
1.1062 + Tcl_ListObjAppendElement(NULL, result, nextElt);
1.1063 + }
1.1064 + }
1.1065 + if (*p++ == '\0') {
1.1066 + break;
1.1067 + }
1.1068 + }
1.1069 + }
1.1070 + return result;
1.1071 +}
1.1072 +
1.1073 +/*
1.1074 + *---------------------------------------------------------------------------
1.1075 + *
1.1076 + * Tcl_FSJoinToPath --
1.1077 + *
1.1078 + * This function takes the given object, which should usually be a
1.1079 + * valid path or NULL, and joins onto it the array of paths
1.1080 + * segments given.
1.1081 + *
1.1082 + * Results:
1.1083 + * Returns object with refCount of zero
1.1084 + *
1.1085 + * Side effects:
1.1086 + * None.
1.1087 + *
1.1088 + *---------------------------------------------------------------------------
1.1089 + */
1.1090 +
1.1091 +EXPORT_C Tcl_Obj*
1.1092 +Tcl_FSJoinToPath(basePtr, objc, objv)
1.1093 + Tcl_Obj *basePtr;
1.1094 + int objc;
1.1095 + Tcl_Obj *CONST objv[];
1.1096 +{
1.1097 + int i;
1.1098 + Tcl_Obj *lobj, *ret;
1.1099 +
1.1100 + if (basePtr == NULL) {
1.1101 + lobj = Tcl_NewListObj(0, NULL);
1.1102 + } else {
1.1103 + lobj = Tcl_NewListObj(1, &basePtr);
1.1104 + }
1.1105 +
1.1106 + for (i = 0; i<objc;i++) {
1.1107 + Tcl_ListObjAppendElement(NULL, lobj, objv[i]);
1.1108 + }
1.1109 + ret = Tcl_FSJoinPath(lobj, -1);
1.1110 + Tcl_DecrRefCount(lobj);
1.1111 + return ret;
1.1112 +}
1.1113 +
1.1114 +/*
1.1115 + *---------------------------------------------------------------------------
1.1116 + *
1.1117 + * TclpNativeJoinPath --
1.1118 + *
1.1119 + * 'prefix' is absolute, 'joining' is relative to prefix.
1.1120 + *
1.1121 + * Results:
1.1122 + * modifies prefix
1.1123 + *
1.1124 + * Side effects:
1.1125 + * None.
1.1126 + *
1.1127 + *---------------------------------------------------------------------------
1.1128 + */
1.1129 +
1.1130 +void
1.1131 +TclpNativeJoinPath(prefix, joining)
1.1132 + Tcl_Obj *prefix;
1.1133 + char* joining;
1.1134 +{
1.1135 + int length, needsSep;
1.1136 + char *dest, *p, *start;
1.1137 +
1.1138 + start = Tcl_GetStringFromObj(prefix, &length);
1.1139 +
1.1140 + /*
1.1141 + * Remove the ./ from tilde prefixed elements, and drive-letter
1.1142 + * prefixed elements on Windows, unless it is the first component.
1.1143 + */
1.1144 +
1.1145 + p = joining;
1.1146 +
1.1147 + if (length != 0) {
1.1148 + if ((p[0] == '.') && (p[1] == '/')
1.1149 + && ((p[2] == '~')
1.1150 + || ((tclPlatform == TCL_PLATFORM_WINDOWS)
1.1151 + && isalpha(UCHAR(p[2]))
1.1152 + && (p[3] == ':')))) {
1.1153 + p += 2;
1.1154 + }
1.1155 + }
1.1156 + if (*p == '\0') {
1.1157 + return;
1.1158 + }
1.1159 +
1.1160 + switch (tclPlatform) {
1.1161 + case TCL_PLATFORM_UNIX:
1.1162 + /*
1.1163 + * Append a separator if needed.
1.1164 + */
1.1165 +
1.1166 + if (length > 0 && (start[length-1] != '/')) {
1.1167 + Tcl_AppendToObj(prefix, "/", 1);
1.1168 + length++;
1.1169 + }
1.1170 + needsSep = 0;
1.1171 +
1.1172 + /*
1.1173 + * Append the element, eliminating duplicate and trailing
1.1174 + * slashes.
1.1175 + */
1.1176 +
1.1177 + Tcl_SetObjLength(prefix, length + (int) strlen(p));
1.1178 +
1.1179 + dest = Tcl_GetString(prefix) + length;
1.1180 + for (; *p != '\0'; p++) {
1.1181 + if (*p == '/') {
1.1182 + while (p[1] == '/') {
1.1183 + p++;
1.1184 + }
1.1185 + if (p[1] != '\0') {
1.1186 + if (needsSep) {
1.1187 + *dest++ = '/';
1.1188 + }
1.1189 + }
1.1190 + } else {
1.1191 + *dest++ = *p;
1.1192 + needsSep = 1;
1.1193 + }
1.1194 + }
1.1195 + length = dest - Tcl_GetString(prefix);
1.1196 + Tcl_SetObjLength(prefix, length);
1.1197 + break;
1.1198 +
1.1199 + case TCL_PLATFORM_WINDOWS:
1.1200 + /*
1.1201 + * Check to see if we need to append a separator.
1.1202 + */
1.1203 +
1.1204 + if ((length > 0) &&
1.1205 + (start[length-1] != '/') && (start[length-1] != ':')) {
1.1206 + Tcl_AppendToObj(prefix, "/", 1);
1.1207 + length++;
1.1208 + }
1.1209 + needsSep = 0;
1.1210 +
1.1211 + /*
1.1212 + * Append the element, eliminating duplicate and
1.1213 + * trailing slashes.
1.1214 + */
1.1215 +
1.1216 + Tcl_SetObjLength(prefix, length + (int) strlen(p));
1.1217 + dest = Tcl_GetString(prefix) + length;
1.1218 + for (; *p != '\0'; p++) {
1.1219 + if ((*p == '/') || (*p == '\\')) {
1.1220 + while ((p[1] == '/') || (p[1] == '\\')) {
1.1221 + p++;
1.1222 + }
1.1223 + if ((p[1] != '\0') && needsSep) {
1.1224 + *dest++ = '/';
1.1225 + }
1.1226 + } else {
1.1227 + *dest++ = *p;
1.1228 + needsSep = 1;
1.1229 + }
1.1230 + }
1.1231 + length = dest - Tcl_GetString(prefix);
1.1232 + Tcl_SetObjLength(prefix, length);
1.1233 + break;
1.1234 +
1.1235 + case TCL_PLATFORM_MAC: {
1.1236 + int newLength;
1.1237 +
1.1238 + /*
1.1239 + * Sort out separators. We basically add the object we've
1.1240 + * been given, but we have to make sure that there is
1.1241 + * exactly one separator inbetween (unless the object we're
1.1242 + * adding contains multiple contiguous colons, all of which
1.1243 + * we must add). Also if an object is just ':' we don't
1.1244 + * bother to add it unless it's the very first element.
1.1245 + */
1.1246 +
1.1247 +#ifdef MAC_UNDERSTANDS_UNIX_PATHS
1.1248 + int adjustedPath = 0;
1.1249 + if ((strchr(p, ':') == NULL) && (strchr(p, '/') != NULL)) {
1.1250 + char *start = p;
1.1251 + adjustedPath = 1;
1.1252 + while (*start != '\0') {
1.1253 + if (*start == '/') {
1.1254 + *start = ':';
1.1255 + }
1.1256 + start++;
1.1257 + }
1.1258 + }
1.1259 +#endif
1.1260 + if (length > 0) {
1.1261 + if ((p[0] == ':') && (p[1] == '\0')) {
1.1262 + return;
1.1263 + }
1.1264 + if (start[length-1] != ':') {
1.1265 + if (*p != '\0' && *p != ':') {
1.1266 + Tcl_AppendToObj(prefix, ":", 1);
1.1267 + length++;
1.1268 + }
1.1269 + } else if (*p == ':') {
1.1270 + p++;
1.1271 + }
1.1272 + } else {
1.1273 + if (*p != '\0' && *p != ':') {
1.1274 + Tcl_AppendToObj(prefix, ":", 1);
1.1275 + length++;
1.1276 + }
1.1277 + }
1.1278 +
1.1279 + /*
1.1280 + * Append the element
1.1281 + */
1.1282 +
1.1283 + newLength = strlen(p);
1.1284 + /*
1.1285 + * It may not be good to just do 'Tcl_AppendToObj(prefix,
1.1286 + * p, newLength)' because the object may contain duplicate
1.1287 + * colons which we want to get rid of.
1.1288 + */
1.1289 + Tcl_AppendToObj(prefix, p, newLength);
1.1290 +
1.1291 + /* Remove spurious trailing single ':' */
1.1292 + dest = Tcl_GetString(prefix) + length + newLength;
1.1293 + if (*(dest-1) == ':') {
1.1294 + if (dest-1 > Tcl_GetString(prefix)) {
1.1295 + if (*(dest-2) != ':') {
1.1296 + Tcl_SetObjLength(prefix, length + newLength -1);
1.1297 + }
1.1298 + }
1.1299 + }
1.1300 +#ifdef MAC_UNDERSTANDS_UNIX_PATHS
1.1301 + /* Revert the path to what it was */
1.1302 + if (adjustedPath) {
1.1303 + char *start = joining;
1.1304 + while (*start != '\0') {
1.1305 + if (*start == ':') {
1.1306 + *start = '/';
1.1307 + }
1.1308 + start++;
1.1309 + }
1.1310 + }
1.1311 +#endif
1.1312 + break;
1.1313 + }
1.1314 + }
1.1315 + return;
1.1316 +}
1.1317 +
1.1318 +/*
1.1319 + *----------------------------------------------------------------------
1.1320 + *
1.1321 + * Tcl_JoinPath --
1.1322 + *
1.1323 + * Combine a list of paths in a platform specific manner. The
1.1324 + * function 'Tcl_FSJoinPath' should be used in preference where
1.1325 + * possible.
1.1326 + *
1.1327 + * Results:
1.1328 + * Appends the joined path to the end of the specified
1.1329 + * Tcl_DString returning a pointer to the resulting string. Note
1.1330 + * that the Tcl_DString must already be initialized.
1.1331 + *
1.1332 + * Side effects:
1.1333 + * Modifies the Tcl_DString.
1.1334 + *
1.1335 + *----------------------------------------------------------------------
1.1336 + */
1.1337 +
1.1338 +EXPORT_C char *
1.1339 +Tcl_JoinPath(argc, argv, resultPtr)
1.1340 + int argc;
1.1341 + CONST char * CONST *argv;
1.1342 + Tcl_DString *resultPtr; /* Pointer to previously initialized DString */
1.1343 +{
1.1344 + int i, len;
1.1345 + Tcl_Obj *listObj = Tcl_NewObj();
1.1346 + Tcl_Obj *resultObj;
1.1347 + char *resultStr;
1.1348 +
1.1349 + /* Build the list of paths */
1.1350 + for (i = 0; i < argc; i++) {
1.1351 + Tcl_ListObjAppendElement(NULL, listObj,
1.1352 + Tcl_NewStringObj(argv[i], -1));
1.1353 + }
1.1354 +
1.1355 + /* Ask the objectified code to join the paths */
1.1356 + Tcl_IncrRefCount(listObj);
1.1357 + resultObj = Tcl_FSJoinPath(listObj, argc);
1.1358 + Tcl_IncrRefCount(resultObj);
1.1359 + Tcl_DecrRefCount(listObj);
1.1360 +
1.1361 + /* Store the result */
1.1362 + resultStr = Tcl_GetStringFromObj(resultObj, &len);
1.1363 + Tcl_DStringAppend(resultPtr, resultStr, len);
1.1364 + Tcl_DecrRefCount(resultObj);
1.1365 +
1.1366 + /* Return a pointer to the result */
1.1367 + return Tcl_DStringValue(resultPtr);
1.1368 +}
1.1369 +
1.1370 +/*
1.1371 + *---------------------------------------------------------------------------
1.1372 + *
1.1373 + * Tcl_TranslateFileName --
1.1374 + *
1.1375 + * Converts a file name into a form usable by the native system
1.1376 + * interfaces. If the name starts with a tilde, it will produce a
1.1377 + * name where the tilde and following characters have been replaced
1.1378 + * by the home directory location for the named user.
1.1379 + *
1.1380 + * Results:
1.1381 + * The return value is a pointer to a string containing the name
1.1382 + * after tilde substitution. If there was no tilde substitution,
1.1383 + * the return value is a pointer to a copy of the original string.
1.1384 + * If there was an error in processing the name, then an error
1.1385 + * message is left in the interp's result (if interp was not NULL)
1.1386 + * and the return value is NULL. Space for the return value is
1.1387 + * allocated in bufferPtr; the caller must call Tcl_DStringFree()
1.1388 + * to free the space if the return value was not NULL.
1.1389 + *
1.1390 + * Side effects:
1.1391 + * None.
1.1392 + *
1.1393 + *----------------------------------------------------------------------
1.1394 + */
1.1395 +
1.1396 +EXPORT_C char *
1.1397 +Tcl_TranslateFileName(interp, name, bufferPtr)
1.1398 + Tcl_Interp *interp; /* Interpreter in which to store error
1.1399 + * message (if necessary). */
1.1400 + CONST char *name; /* File name, which may begin with "~" (to
1.1401 + * indicate current user's home directory) or
1.1402 + * "~<user>" (to indicate any user's home
1.1403 + * directory). */
1.1404 + Tcl_DString *bufferPtr; /* Uninitialized or free DString filled
1.1405 + * with name after tilde substitution. */
1.1406 +{
1.1407 + Tcl_Obj *path = Tcl_NewStringObj(name, -1);
1.1408 + Tcl_Obj *transPtr;
1.1409 +
1.1410 + Tcl_IncrRefCount(path);
1.1411 + transPtr = Tcl_FSGetTranslatedPath(interp, path);
1.1412 + if (transPtr == NULL) {
1.1413 + Tcl_DecrRefCount(path);
1.1414 + return NULL;
1.1415 + }
1.1416 +
1.1417 + Tcl_DStringInit(bufferPtr);
1.1418 + Tcl_DStringAppend(bufferPtr, Tcl_GetString(transPtr), -1);
1.1419 + Tcl_DecrRefCount(path);
1.1420 + Tcl_DecrRefCount(transPtr);
1.1421 +
1.1422 + /*
1.1423 + * Convert forward slashes to backslashes in Windows paths because
1.1424 + * some system interfaces don't accept forward slashes.
1.1425 + */
1.1426 +
1.1427 + if (tclPlatform == TCL_PLATFORM_WINDOWS) {
1.1428 + register char *p;
1.1429 + for (p = Tcl_DStringValue(bufferPtr); *p != '\0'; p++) {
1.1430 + if (*p == '/') {
1.1431 + *p = '\\';
1.1432 + }
1.1433 + }
1.1434 + }
1.1435 + return Tcl_DStringValue(bufferPtr);
1.1436 +}
1.1437 +
1.1438 +/*
1.1439 + *----------------------------------------------------------------------
1.1440 + *
1.1441 + * TclGetExtension --
1.1442 + *
1.1443 + * This function returns a pointer to the beginning of the
1.1444 + * extension part of a file name.
1.1445 + *
1.1446 + * Results:
1.1447 + * Returns a pointer into name which indicates where the extension
1.1448 + * starts. If there is no extension, returns NULL.
1.1449 + *
1.1450 + * Side effects:
1.1451 + * None.
1.1452 + *
1.1453 + *----------------------------------------------------------------------
1.1454 + */
1.1455 +
1.1456 +char *
1.1457 +TclGetExtension(name)
1.1458 + char *name; /* File name to parse. */
1.1459 +{
1.1460 + char *p, *lastSep;
1.1461 +
1.1462 + /*
1.1463 + * First find the last directory separator.
1.1464 + */
1.1465 +
1.1466 + lastSep = NULL; /* Needed only to prevent gcc warnings. */
1.1467 + switch (tclPlatform) {
1.1468 + case TCL_PLATFORM_UNIX:
1.1469 + lastSep = strrchr(name, '/');
1.1470 + break;
1.1471 +
1.1472 + case TCL_PLATFORM_MAC:
1.1473 +#ifdef MAC_UNDERSTANDS_UNIX_PATHS
1.1474 + if (strchr(name, ':') == NULL) {
1.1475 + lastSep = strrchr(name, '/');
1.1476 + } else {
1.1477 + lastSep = strrchr(name, ':');
1.1478 + }
1.1479 +#else
1.1480 + lastSep = strrchr(name, ':');
1.1481 +#endif
1.1482 + break;
1.1483 +
1.1484 + case TCL_PLATFORM_WINDOWS:
1.1485 + lastSep = NULL;
1.1486 + for (p = name; *p != '\0'; p++) {
1.1487 + if (strchr("/\\:", *p) != NULL) {
1.1488 + lastSep = p;
1.1489 + }
1.1490 + }
1.1491 + break;
1.1492 + }
1.1493 + p = strrchr(name, '.');
1.1494 + if ((p != NULL) && (lastSep != NULL) && (lastSep > p)) {
1.1495 + p = NULL;
1.1496 + }
1.1497 +
1.1498 + /*
1.1499 + * In earlier versions, we used to back up to the first period in a series
1.1500 + * so that "foo..o" would be split into "foo" and "..o". This is a
1.1501 + * confusing and usually incorrect behavior, so now we split at the last
1.1502 + * period in the name.
1.1503 + */
1.1504 +
1.1505 + return p;
1.1506 +}
1.1507 +
1.1508 +/*
1.1509 + *----------------------------------------------------------------------
1.1510 + *
1.1511 + * DoTildeSubst --
1.1512 + *
1.1513 + * Given a string following a tilde, this routine returns the
1.1514 + * corresponding home directory.
1.1515 + *
1.1516 + * Results:
1.1517 + * The result is a pointer to a static string containing the home
1.1518 + * directory in native format. If there was an error in processing
1.1519 + * the substitution, then an error message is left in the interp's
1.1520 + * result and the return value is NULL. On success, the results
1.1521 + * are appended to resultPtr, and the contents of resultPtr are
1.1522 + * returned.
1.1523 + *
1.1524 + * Side effects:
1.1525 + * Information may be left in resultPtr.
1.1526 + *
1.1527 + *----------------------------------------------------------------------
1.1528 + */
1.1529 +
1.1530 +static CONST char *
1.1531 +DoTildeSubst(interp, user, resultPtr)
1.1532 + Tcl_Interp *interp; /* Interpreter in which to store error
1.1533 + * message (if necessary). */
1.1534 + CONST char *user; /* Name of user whose home directory should be
1.1535 + * substituted, or "" for current user. */
1.1536 + Tcl_DString *resultPtr; /* Initialized DString filled with name
1.1537 + * after tilde substitution. */
1.1538 +{
1.1539 + CONST char *dir;
1.1540 +
1.1541 + if (*user == '\0') {
1.1542 + Tcl_DString dirString;
1.1543 +
1.1544 + dir = TclGetEnv("HOME", &dirString);
1.1545 + if (dir == NULL) {
1.1546 + if (interp) {
1.1547 + Tcl_ResetResult(interp);
1.1548 + Tcl_AppendResult(interp, "couldn't find HOME environment ",
1.1549 + "variable to expand path", (char *) NULL);
1.1550 + }
1.1551 + return NULL;
1.1552 + }
1.1553 + Tcl_JoinPath(1, &dir, resultPtr);
1.1554 + Tcl_DStringFree(&dirString);
1.1555 + } else {
1.1556 + if (TclpGetUserHome(user, resultPtr) == NULL) {
1.1557 + if (interp) {
1.1558 + Tcl_ResetResult(interp);
1.1559 + Tcl_AppendResult(interp, "user \"", user, "\" doesn't exist",
1.1560 + (char *) NULL);
1.1561 + }
1.1562 + return NULL;
1.1563 + }
1.1564 + }
1.1565 + return Tcl_DStringValue(resultPtr);
1.1566 +}
1.1567 +
1.1568 +/*
1.1569 + *----------------------------------------------------------------------
1.1570 + *
1.1571 + * Tcl_GlobObjCmd --
1.1572 + *
1.1573 + * This procedure is invoked to process the "glob" Tcl command.
1.1574 + * See the user documentation for details on what it does.
1.1575 + *
1.1576 + * Results:
1.1577 + * A standard Tcl result.
1.1578 + *
1.1579 + * Side effects:
1.1580 + * See the user documentation.
1.1581 + *
1.1582 + *----------------------------------------------------------------------
1.1583 + */
1.1584 +
1.1585 + /* ARGSUSED */
1.1586 +int
1.1587 +Tcl_GlobObjCmd(dummy, interp, objc, objv)
1.1588 + ClientData dummy; /* Not used. */
1.1589 + Tcl_Interp *interp; /* Current interpreter. */
1.1590 + int objc; /* Number of arguments. */
1.1591 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.1592 +{
1.1593 + int index, i, globFlags, length, join, dir, result;
1.1594 + char *string, *separators;
1.1595 + Tcl_Obj *typePtr, *resultPtr, *look;
1.1596 + Tcl_Obj *pathOrDir = NULL;
1.1597 + Tcl_DString prefix;
1.1598 + static CONST char *options[] = {
1.1599 + "-directory", "-join", "-nocomplain", "-path", "-tails",
1.1600 + "-types", "--", NULL
1.1601 + };
1.1602 + enum options {
1.1603 + GLOB_DIR, GLOB_JOIN, GLOB_NOCOMPLAIN, GLOB_PATH, GLOB_TAILS,
1.1604 + GLOB_TYPE, GLOB_LAST
1.1605 + };
1.1606 + enum pathDirOptions {PATH_NONE = -1 , PATH_GENERAL = 0, PATH_DIR = 1};
1.1607 + Tcl_GlobTypeData *globTypes = NULL;
1.1608 +
1.1609 + globFlags = 0;
1.1610 + join = 0;
1.1611 + dir = PATH_NONE;
1.1612 + typePtr = NULL;
1.1613 + for (i = 1; i < objc; i++) {
1.1614 + if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index)
1.1615 + != TCL_OK) {
1.1616 + string = Tcl_GetStringFromObj(objv[i], &length);
1.1617 + if (string[0] == '-') {
1.1618 + /*
1.1619 + * It looks like the command contains an option so signal
1.1620 + * an error
1.1621 + */
1.1622 + return TCL_ERROR;
1.1623 + } else {
1.1624 + /*
1.1625 + * This clearly isn't an option; assume it's the first
1.1626 + * glob pattern. We must clear the error
1.1627 + */
1.1628 + Tcl_ResetResult(interp);
1.1629 + break;
1.1630 + }
1.1631 + }
1.1632 + switch (index) {
1.1633 + case GLOB_NOCOMPLAIN: /* -nocomplain */
1.1634 + globFlags |= TCL_GLOBMODE_NO_COMPLAIN;
1.1635 + break;
1.1636 + case GLOB_DIR: /* -dir */
1.1637 + if (i == (objc-1)) {
1.1638 + Tcl_SetObjResult(interp, Tcl_NewStringObj(
1.1639 + "missing argument to \"-directory\"", -1));
1.1640 + return TCL_ERROR;
1.1641 + }
1.1642 + if (dir != PATH_NONE) {
1.1643 + Tcl_SetObjResult(interp, Tcl_NewStringObj(
1.1644 + "\"-directory\" cannot be used with \"-path\"",
1.1645 + -1));
1.1646 + return TCL_ERROR;
1.1647 + }
1.1648 + dir = PATH_DIR;
1.1649 + globFlags |= TCL_GLOBMODE_DIR;
1.1650 + pathOrDir = objv[i+1];
1.1651 + i++;
1.1652 + break;
1.1653 + case GLOB_JOIN: /* -join */
1.1654 + join = 1;
1.1655 + break;
1.1656 + case GLOB_TAILS: /* -tails */
1.1657 + globFlags |= TCL_GLOBMODE_TAILS;
1.1658 + break;
1.1659 + case GLOB_PATH: /* -path */
1.1660 + if (i == (objc-1)) {
1.1661 + Tcl_SetObjResult(interp, Tcl_NewStringObj(
1.1662 + "missing argument to \"-path\"", -1));
1.1663 + return TCL_ERROR;
1.1664 + }
1.1665 + if (dir != PATH_NONE) {
1.1666 + Tcl_SetObjResult(interp, Tcl_NewStringObj(
1.1667 + "\"-path\" cannot be used with \"-directory\"",
1.1668 + -1));
1.1669 + return TCL_ERROR;
1.1670 + }
1.1671 + dir = PATH_GENERAL;
1.1672 + pathOrDir = objv[i+1];
1.1673 + i++;
1.1674 + break;
1.1675 + case GLOB_TYPE: /* -types */
1.1676 + if (i == (objc-1)) {
1.1677 + Tcl_SetObjResult(interp, Tcl_NewStringObj(
1.1678 + "missing argument to \"-types\"", -1));
1.1679 + return TCL_ERROR;
1.1680 + }
1.1681 + typePtr = objv[i+1];
1.1682 + if (Tcl_ListObjLength(interp, typePtr, &length) != TCL_OK) {
1.1683 + return TCL_ERROR;
1.1684 + }
1.1685 + i++;
1.1686 + break;
1.1687 + case GLOB_LAST: /* -- */
1.1688 + i++;
1.1689 + goto endOfForLoop;
1.1690 + }
1.1691 + }
1.1692 + endOfForLoop:
1.1693 + if (objc - i < 1) {
1.1694 + Tcl_WrongNumArgs(interp, 1, objv, "?switches? name ?name ...?");
1.1695 + return TCL_ERROR;
1.1696 + }
1.1697 + if ((globFlags & TCL_GLOBMODE_TAILS) && (pathOrDir == NULL)) {
1.1698 + Tcl_SetObjResult(interp, Tcl_NewStringObj(
1.1699 + "\"-tails\" must be used with either \"-directory\" or \"-path\"",
1.1700 + -1));
1.1701 + return TCL_ERROR;
1.1702 + }
1.1703 +
1.1704 + separators = NULL; /* lint. */
1.1705 + switch (tclPlatform) {
1.1706 + case TCL_PLATFORM_UNIX:
1.1707 + separators = "/";
1.1708 + break;
1.1709 + case TCL_PLATFORM_WINDOWS:
1.1710 + separators = "/\\:";
1.1711 + break;
1.1712 + case TCL_PLATFORM_MAC:
1.1713 + separators = ":";
1.1714 + break;
1.1715 + }
1.1716 + if (dir == PATH_GENERAL) {
1.1717 + int pathlength;
1.1718 + char *last;
1.1719 + char *first = Tcl_GetStringFromObj(pathOrDir,&pathlength);
1.1720 +
1.1721 + /*
1.1722 + * Find the last path separator in the path
1.1723 + */
1.1724 + last = first + pathlength;
1.1725 + for (; last != first; last--) {
1.1726 + if (strchr(separators, *(last-1)) != NULL) {
1.1727 + break;
1.1728 + }
1.1729 + }
1.1730 + if (last == first + pathlength) {
1.1731 + /* It's really a directory */
1.1732 + dir = PATH_DIR;
1.1733 + } else {
1.1734 + Tcl_DString pref;
1.1735 + char *search, *find;
1.1736 + Tcl_DStringInit(&pref);
1.1737 + if (last == first) {
1.1738 + /* The whole thing is a prefix */
1.1739 + Tcl_DStringAppend(&pref, first, -1);
1.1740 + pathOrDir = NULL;
1.1741 + } else {
1.1742 + /* Have to split off the end */
1.1743 + Tcl_DStringAppend(&pref, last, first+pathlength-last);
1.1744 + pathOrDir = Tcl_NewStringObj(first, last-first-1);
1.1745 + /*
1.1746 + * We must ensure that we haven't cut off too much,
1.1747 + * and turned a valid path like '/' or 'C:/' into
1.1748 + * an incorrect path like '' or 'C:'. The way we
1.1749 + * do this is to add a separator if there are none
1.1750 + * presently in the prefix.
1.1751 + */
1.1752 + if (strpbrk(Tcl_GetString(pathOrDir), "\\/") == NULL) {
1.1753 + Tcl_AppendToObj(pathOrDir, last-1, 1);
1.1754 + }
1.1755 + }
1.1756 + /* Need to quote 'prefix' */
1.1757 + Tcl_DStringInit(&prefix);
1.1758 + search = Tcl_DStringValue(&pref);
1.1759 + while ((find = (strpbrk(search, "\\[]*?{}"))) != NULL) {
1.1760 + Tcl_DStringAppend(&prefix, search, find-search);
1.1761 + Tcl_DStringAppend(&prefix, "\\", 1);
1.1762 + Tcl_DStringAppend(&prefix, find, 1);
1.1763 + search = find+1;
1.1764 + if (*search == '\0') {
1.1765 + break;
1.1766 + }
1.1767 + }
1.1768 + if (*search != '\0') {
1.1769 + Tcl_DStringAppend(&prefix, search, -1);
1.1770 + }
1.1771 + Tcl_DStringFree(&pref);
1.1772 + }
1.1773 + }
1.1774 +
1.1775 + if (pathOrDir != NULL) {
1.1776 + Tcl_IncrRefCount(pathOrDir);
1.1777 + }
1.1778 +
1.1779 + if (typePtr != NULL) {
1.1780 + /*
1.1781 + * The rest of the possible type arguments (except 'd') are
1.1782 + * platform specific. We don't complain when they are used
1.1783 + * on an incompatible platform.
1.1784 + */
1.1785 + Tcl_ListObjLength(interp, typePtr, &length);
1.1786 + globTypes = (Tcl_GlobTypeData*) ckalloc(sizeof(Tcl_GlobTypeData));
1.1787 + globTypes->type = 0;
1.1788 + globTypes->perm = 0;
1.1789 + globTypes->macType = NULL;
1.1790 + globTypes->macCreator = NULL;
1.1791 + while(--length >= 0) {
1.1792 + int len;
1.1793 + char *str;
1.1794 + Tcl_ListObjIndex(interp, typePtr, length, &look);
1.1795 + str = Tcl_GetStringFromObj(look, &len);
1.1796 + if (strcmp("readonly", str) == 0) {
1.1797 + globTypes->perm |= TCL_GLOB_PERM_RONLY;
1.1798 + } else if (strcmp("hidden", str) == 0) {
1.1799 + globTypes->perm |= TCL_GLOB_PERM_HIDDEN;
1.1800 + } else if (len == 1) {
1.1801 + switch (str[0]) {
1.1802 + case 'r':
1.1803 + globTypes->perm |= TCL_GLOB_PERM_R;
1.1804 + break;
1.1805 + case 'w':
1.1806 + globTypes->perm |= TCL_GLOB_PERM_W;
1.1807 + break;
1.1808 + case 'x':
1.1809 + globTypes->perm |= TCL_GLOB_PERM_X;
1.1810 + break;
1.1811 + case 'b':
1.1812 + globTypes->type |= TCL_GLOB_TYPE_BLOCK;
1.1813 + break;
1.1814 + case 'c':
1.1815 + globTypes->type |= TCL_GLOB_TYPE_CHAR;
1.1816 + break;
1.1817 + case 'd':
1.1818 + globTypes->type |= TCL_GLOB_TYPE_DIR;
1.1819 + break;
1.1820 + case 'p':
1.1821 + globTypes->type |= TCL_GLOB_TYPE_PIPE;
1.1822 + break;
1.1823 + case 'f':
1.1824 + globTypes->type |= TCL_GLOB_TYPE_FILE;
1.1825 + break;
1.1826 + case 'l':
1.1827 + globTypes->type |= TCL_GLOB_TYPE_LINK;
1.1828 + break;
1.1829 + case 's':
1.1830 + globTypes->type |= TCL_GLOB_TYPE_SOCK;
1.1831 + break;
1.1832 + default:
1.1833 + goto badTypesArg;
1.1834 + }
1.1835 + } else if (len == 4) {
1.1836 + /* This is assumed to be a MacOS file type */
1.1837 + if (globTypes->macType != NULL) {
1.1838 + goto badMacTypesArg;
1.1839 + }
1.1840 + globTypes->macType = look;
1.1841 + Tcl_IncrRefCount(look);
1.1842 + } else {
1.1843 + Tcl_Obj* item;
1.1844 + if ((Tcl_ListObjLength(NULL, look, &len) == TCL_OK) &&
1.1845 + (len == 3)) {
1.1846 + Tcl_ListObjIndex(interp, look, 0, &item);
1.1847 + if (!strcmp("macintosh", Tcl_GetString(item))) {
1.1848 + Tcl_ListObjIndex(interp, look, 1, &item);
1.1849 + if (!strcmp("type", Tcl_GetString(item))) {
1.1850 + Tcl_ListObjIndex(interp, look, 2, &item);
1.1851 + if (globTypes->macType != NULL) {
1.1852 + goto badMacTypesArg;
1.1853 + }
1.1854 + globTypes->macType = item;
1.1855 + Tcl_IncrRefCount(item);
1.1856 + continue;
1.1857 + } else if (!strcmp("creator", Tcl_GetString(item))) {
1.1858 + Tcl_ListObjIndex(interp, look, 2, &item);
1.1859 + if (globTypes->macCreator != NULL) {
1.1860 + goto badMacTypesArg;
1.1861 + }
1.1862 + globTypes->macCreator = item;
1.1863 + Tcl_IncrRefCount(item);
1.1864 + continue;
1.1865 + }
1.1866 + }
1.1867 + }
1.1868 + /*
1.1869 + * Error cases. We reset
1.1870 + * the 'join' flag to zero, since we haven't yet
1.1871 + * made use of it.
1.1872 + */
1.1873 + badTypesArg:
1.1874 + resultPtr = Tcl_GetObjResult(interp);
1.1875 + Tcl_AppendToObj(resultPtr, "bad argument to \"-types\": ", -1);
1.1876 + Tcl_AppendObjToObj(resultPtr, look);
1.1877 + result = TCL_ERROR;
1.1878 + join = 0;
1.1879 + goto endOfGlob;
1.1880 + badMacTypesArg:
1.1881 + Tcl_SetObjResult(interp, Tcl_NewStringObj(
1.1882 + "only one MacOS type or creator argument"
1.1883 + " to \"-types\" allowed", -1));
1.1884 + result = TCL_ERROR;
1.1885 + join = 0;
1.1886 + goto endOfGlob;
1.1887 + }
1.1888 + }
1.1889 + }
1.1890 +
1.1891 + /*
1.1892 + * Now we perform the actual glob below. This may involve joining
1.1893 + * together the pattern arguments, dealing with particular file types
1.1894 + * etc. We use a 'goto' to ensure we free any memory allocated along
1.1895 + * the way.
1.1896 + */
1.1897 + objc -= i;
1.1898 + objv += i;
1.1899 + result = TCL_OK;
1.1900 + if (join) {
1.1901 + if (dir != PATH_GENERAL) {
1.1902 + Tcl_DStringInit(&prefix);
1.1903 + }
1.1904 + for (i = 0; i < objc; i++) {
1.1905 + string = Tcl_GetStringFromObj(objv[i], &length);
1.1906 + Tcl_DStringAppend(&prefix, string, length);
1.1907 + if (i != objc -1) {
1.1908 + Tcl_DStringAppend(&prefix, separators, 1);
1.1909 + }
1.1910 + }
1.1911 + if (TclGlob(interp, Tcl_DStringValue(&prefix), pathOrDir,
1.1912 + globFlags, globTypes) != TCL_OK) {
1.1913 + result = TCL_ERROR;
1.1914 + goto endOfGlob;
1.1915 + }
1.1916 + } else {
1.1917 + if (dir == PATH_GENERAL) {
1.1918 + Tcl_DString str;
1.1919 + for (i = 0; i < objc; i++) {
1.1920 + Tcl_DStringInit(&str);
1.1921 + if (dir == PATH_GENERAL) {
1.1922 + Tcl_DStringAppend(&str, Tcl_DStringValue(&prefix),
1.1923 + Tcl_DStringLength(&prefix));
1.1924 + }
1.1925 + string = Tcl_GetStringFromObj(objv[i], &length);
1.1926 + Tcl_DStringAppend(&str, string, length);
1.1927 + if (TclGlob(interp, Tcl_DStringValue(&str), pathOrDir,
1.1928 + globFlags, globTypes) != TCL_OK) {
1.1929 + result = TCL_ERROR;
1.1930 + Tcl_DStringFree(&str);
1.1931 + goto endOfGlob;
1.1932 + }
1.1933 + }
1.1934 + Tcl_DStringFree(&str);
1.1935 + } else {
1.1936 + for (i = 0; i < objc; i++) {
1.1937 + string = Tcl_GetString(objv[i]);
1.1938 + if (TclGlob(interp, string, pathOrDir,
1.1939 + globFlags, globTypes) != TCL_OK) {
1.1940 + result = TCL_ERROR;
1.1941 + goto endOfGlob;
1.1942 + }
1.1943 + }
1.1944 + }
1.1945 + }
1.1946 + if ((globFlags & TCL_GLOBMODE_NO_COMPLAIN) == 0) {
1.1947 + if (Tcl_ListObjLength(interp, Tcl_GetObjResult(interp),
1.1948 + &length) != TCL_OK) {
1.1949 + /* This should never happen. Maybe we should be more dramatic */
1.1950 + result = TCL_ERROR;
1.1951 + goto endOfGlob;
1.1952 + }
1.1953 + if (length == 0) {
1.1954 + Tcl_AppendResult(interp, "no files matched glob pattern",
1.1955 + (join || (objc == 1)) ? " \"" : "s \"", (char *) NULL);
1.1956 + if (join) {
1.1957 + Tcl_AppendResult(interp, Tcl_DStringValue(&prefix),
1.1958 + (char *) NULL);
1.1959 + } else {
1.1960 + char *sep = "";
1.1961 + for (i = 0; i < objc; i++) {
1.1962 + string = Tcl_GetString(objv[i]);
1.1963 + Tcl_AppendResult(interp, sep, string, (char *) NULL);
1.1964 + sep = " ";
1.1965 + }
1.1966 + }
1.1967 + Tcl_AppendResult(interp, "\"", (char *) NULL);
1.1968 + result = TCL_ERROR;
1.1969 + }
1.1970 + }
1.1971 + endOfGlob:
1.1972 + if (join || (dir == PATH_GENERAL)) {
1.1973 + Tcl_DStringFree(&prefix);
1.1974 + }
1.1975 + if (pathOrDir != NULL) {
1.1976 + Tcl_DecrRefCount(pathOrDir);
1.1977 + }
1.1978 + if (globTypes != NULL) {
1.1979 + if (globTypes->macType != NULL) {
1.1980 + Tcl_DecrRefCount(globTypes->macType);
1.1981 + }
1.1982 + if (globTypes->macCreator != NULL) {
1.1983 + Tcl_DecrRefCount(globTypes->macCreator);
1.1984 + }
1.1985 + ckfree((char *) globTypes);
1.1986 + }
1.1987 + return result;
1.1988 +}
1.1989 +
1.1990 +/*
1.1991 + *----------------------------------------------------------------------
1.1992 + *
1.1993 + * TclGlob --
1.1994 + *
1.1995 + * This procedure prepares arguments for the TclDoGlob call.
1.1996 + * It sets the separator string based on the platform, performs
1.1997 + * tilde substitution, and calls TclDoGlob.
1.1998 + *
1.1999 + * The interpreter's result, on entry to this function, must
1.2000 + * be a valid Tcl list (e.g. it could be empty), since we will
1.2001 + * lappend any new results to that list. If it is not a valid
1.2002 + * list, this function will fail to do anything very meaningful.
1.2003 + *
1.2004 + * Results:
1.2005 + * The return value is a standard Tcl result indicating whether
1.2006 + * an error occurred in globbing. After a normal return the
1.2007 + * result in interp (set by TclDoGlob) holds all of the file names
1.2008 + * given by the pattern and unquotedPrefix arguments. After an
1.2009 + * error the result in interp will hold an error message, unless
1.2010 + * the 'TCL_GLOBMODE_NO_COMPLAIN' flag was given, in which case
1.2011 + * an error results in a TCL_OK return leaving the interpreter's
1.2012 + * result unmodified.
1.2013 + *
1.2014 + * Side effects:
1.2015 + * The 'pattern' is written to.
1.2016 + *
1.2017 + *----------------------------------------------------------------------
1.2018 + */
1.2019 +
1.2020 + /* ARGSUSED */
1.2021 +int
1.2022 +TclGlob(interp, pattern, unquotedPrefix, globFlags, types)
1.2023 + Tcl_Interp *interp; /* Interpreter for returning error message
1.2024 + * or appending list of matching file names. */
1.2025 + char *pattern; /* Glob pattern to match. Must not refer
1.2026 + * to a static string. */
1.2027 + Tcl_Obj *unquotedPrefix; /* Prefix to glob pattern, if non-null, which
1.2028 + * is considered literally. */
1.2029 + int globFlags; /* Stores or'ed combination of flags */
1.2030 + Tcl_GlobTypeData *types; /* Struct containing acceptable types.
1.2031 + * May be NULL. */
1.2032 +{
1.2033 + char *separators;
1.2034 + CONST char *head;
1.2035 + char *tail, *start;
1.2036 + char c;
1.2037 + int result, prefixLen;
1.2038 + Tcl_DString buffer;
1.2039 + Tcl_Obj *oldResult;
1.2040 +
1.2041 + separators = NULL; /* lint. */
1.2042 + switch (tclPlatform) {
1.2043 + case TCL_PLATFORM_UNIX:
1.2044 + separators = "/";
1.2045 + break;
1.2046 + case TCL_PLATFORM_WINDOWS:
1.2047 + separators = "/\\:";
1.2048 + break;
1.2049 + case TCL_PLATFORM_MAC:
1.2050 +#ifdef MAC_UNDERSTANDS_UNIX_PATHS
1.2051 + if (unquotedPrefix == NULL) {
1.2052 + separators = (strchr(pattern, ':') == NULL) ? "/" : ":";
1.2053 + } else {
1.2054 + separators = ":";
1.2055 + }
1.2056 +#else
1.2057 + separators = ":";
1.2058 +#endif
1.2059 + break;
1.2060 + }
1.2061 +
1.2062 + Tcl_DStringInit(&buffer);
1.2063 + if (unquotedPrefix != NULL) {
1.2064 + start = Tcl_GetString(unquotedPrefix);
1.2065 + } else {
1.2066 + start = pattern;
1.2067 + }
1.2068 +
1.2069 + /*
1.2070 + * Perform tilde substitution, if needed.
1.2071 + */
1.2072 +
1.2073 + if (start[0] == '~') {
1.2074 +
1.2075 + /*
1.2076 + * Find the first path separator after the tilde.
1.2077 + */
1.2078 + for (tail = start; *tail != '\0'; tail++) {
1.2079 + if (*tail == '\\') {
1.2080 + if (strchr(separators, tail[1]) != NULL) {
1.2081 + break;
1.2082 + }
1.2083 + } else if (strchr(separators, *tail) != NULL) {
1.2084 + break;
1.2085 + }
1.2086 + }
1.2087 +
1.2088 + /*
1.2089 + * Determine the home directory for the specified user.
1.2090 + */
1.2091 +
1.2092 + c = *tail;
1.2093 + *tail = '\0';
1.2094 + if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) {
1.2095 + /*
1.2096 + * We will ignore any error message here, and we
1.2097 + * don't want to mess up the interpreter's result.
1.2098 + */
1.2099 + head = DoTildeSubst(NULL, start+1, &buffer);
1.2100 + } else {
1.2101 + head = DoTildeSubst(interp, start+1, &buffer);
1.2102 + }
1.2103 + *tail = c;
1.2104 + if (head == NULL) {
1.2105 + if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) {
1.2106 + return TCL_OK;
1.2107 + } else {
1.2108 + return TCL_ERROR;
1.2109 + }
1.2110 + }
1.2111 + if (head != Tcl_DStringValue(&buffer)) {
1.2112 + Tcl_DStringAppend(&buffer, head, -1);
1.2113 + }
1.2114 + if (unquotedPrefix != NULL) {
1.2115 + Tcl_DStringAppend(&buffer, tail, -1);
1.2116 + tail = pattern;
1.2117 + }
1.2118 + } else {
1.2119 + tail = pattern;
1.2120 + if (unquotedPrefix != NULL) {
1.2121 + Tcl_DStringAppend(&buffer,Tcl_GetString(unquotedPrefix),-1);
1.2122 + }
1.2123 + }
1.2124 +
1.2125 + /*
1.2126 + * We want to remember the length of the current prefix,
1.2127 + * in case we are using TCL_GLOBMODE_TAILS. Also if we
1.2128 + * are using TCL_GLOBMODE_DIR, we must make sure the
1.2129 + * prefix ends in a directory separator.
1.2130 + */
1.2131 + prefixLen = Tcl_DStringLength(&buffer);
1.2132 +
1.2133 + if (prefixLen > 0) {
1.2134 + c = Tcl_DStringValue(&buffer)[prefixLen-1];
1.2135 + if (strchr(separators, c) == NULL) {
1.2136 + /*
1.2137 + * If the prefix is a directory, make sure it ends in a
1.2138 + * directory separator.
1.2139 + */
1.2140 + if (globFlags & TCL_GLOBMODE_DIR) {
1.2141 + Tcl_DStringAppend(&buffer,separators,1);
1.2142 + /* Try to borrow that separator from the tail */
1.2143 + if (*tail == *separators) {
1.2144 + tail++;
1.2145 + }
1.2146 + }
1.2147 + prefixLen++;
1.2148 + }
1.2149 + }
1.2150 +
1.2151 + /*
1.2152 + * We need to get the old result, in case it is over-written
1.2153 + * below when we still need it.
1.2154 + */
1.2155 + oldResult = Tcl_GetObjResult(interp);
1.2156 + Tcl_IncrRefCount(oldResult);
1.2157 + Tcl_ResetResult(interp);
1.2158 +
1.2159 + result = TclDoGlob(interp, separators, &buffer, tail, types);
1.2160 +
1.2161 + if (result != TCL_OK) {
1.2162 + if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) {
1.2163 + /* Put back the old result and reset the return code */
1.2164 + Tcl_SetObjResult(interp, oldResult);
1.2165 + result = TCL_OK;
1.2166 + }
1.2167 + } else {
1.2168 + /*
1.2169 + * Now we must concatenate the 'oldResult' and the current
1.2170 + * result, and then place that into the interpreter.
1.2171 + *
1.2172 + * If we only want the tails, we must strip off the prefix now.
1.2173 + * It may seem more efficient to pass the tails flag down into
1.2174 + * TclDoGlob, Tcl_FSMatchInDirectory, but those functions are
1.2175 + * continually adjusting the prefix as the various pieces of
1.2176 + * the pattern are assimilated, so that would add a lot of
1.2177 + * complexity to the code. This way is a little slower (when
1.2178 + * the -tails flag is given), but much simpler to code.
1.2179 + */
1.2180 + int objc, i;
1.2181 + Tcl_Obj **objv;
1.2182 +
1.2183 + /* Ensure sole ownership */
1.2184 + if (Tcl_IsShared(oldResult)) {
1.2185 + Tcl_DecrRefCount(oldResult);
1.2186 + oldResult = Tcl_DuplicateObj(oldResult);
1.2187 + Tcl_IncrRefCount(oldResult);
1.2188 + }
1.2189 +
1.2190 + Tcl_ListObjGetElements(NULL, Tcl_GetObjResult(interp),
1.2191 + &objc, &objv);
1.2192 +#ifdef MAC_TCL
1.2193 + /* adjust prefixLen if TclDoGlob prepended a ':' */
1.2194 + if ((prefixLen > 0) && (objc > 0)
1.2195 + && (Tcl_DStringValue(&buffer)[0] != ':')) {
1.2196 + char *str = Tcl_GetStringFromObj(objv[0],NULL);
1.2197 + if (str[0] == ':') {
1.2198 + prefixLen++;
1.2199 + }
1.2200 + }
1.2201 +#endif
1.2202 + for (i = 0; i< objc; i++) {
1.2203 + Tcl_Obj* elt;
1.2204 + if (globFlags & TCL_GLOBMODE_TAILS) {
1.2205 + int len;
1.2206 + char *oldStr = Tcl_GetStringFromObj(objv[i],&len);
1.2207 + if (len == prefixLen) {
1.2208 + if ((pattern[0] == '\0')
1.2209 + || (strchr(separators, pattern[0]) == NULL)) {
1.2210 + elt = Tcl_NewStringObj(".",1);
1.2211 + } else {
1.2212 + elt = Tcl_NewStringObj("/",1);
1.2213 + }
1.2214 + } else {
1.2215 + elt = Tcl_NewStringObj(oldStr + prefixLen,
1.2216 + len - prefixLen);
1.2217 + }
1.2218 + } else {
1.2219 + elt = objv[i];
1.2220 + }
1.2221 + /* Assumption that 'oldResult' is a valid list */
1.2222 + Tcl_ListObjAppendElement(interp, oldResult, elt);
1.2223 + }
1.2224 + Tcl_SetObjResult(interp, oldResult);
1.2225 + }
1.2226 + /*
1.2227 + * Release our temporary copy. All code paths above must
1.2228 + * end here so we free our reference.
1.2229 + */
1.2230 + Tcl_DecrRefCount(oldResult);
1.2231 + Tcl_DStringFree(&buffer);
1.2232 + return result;
1.2233 +}
1.2234 +
1.2235 +/*
1.2236 + *----------------------------------------------------------------------
1.2237 + *
1.2238 + * SkipToChar --
1.2239 + *
1.2240 + * This function traverses a glob pattern looking for the next
1.2241 + * unquoted occurance of the specified character at the same braces
1.2242 + * nesting level.
1.2243 + *
1.2244 + * Results:
1.2245 + * Updates stringPtr to point to the matching character, or to
1.2246 + * the end of the string if nothing matched. The return value
1.2247 + * is 1 if a match was found at the top level, otherwise it is 0.
1.2248 + *
1.2249 + * Side effects:
1.2250 + * None.
1.2251 + *
1.2252 + *----------------------------------------------------------------------
1.2253 + */
1.2254 +
1.2255 +static int
1.2256 +SkipToChar(stringPtr, match)
1.2257 + char **stringPtr; /* Pointer string to check. */
1.2258 + char *match; /* Pointer to character to find. */
1.2259 +{
1.2260 + int quoted, level;
1.2261 + register char *p;
1.2262 +
1.2263 + quoted = 0;
1.2264 + level = 0;
1.2265 +
1.2266 + for (p = *stringPtr; *p != '\0'; p++) {
1.2267 + if (quoted) {
1.2268 + quoted = 0;
1.2269 + continue;
1.2270 + }
1.2271 + if ((level == 0) && (*p == *match)) {
1.2272 + *stringPtr = p;
1.2273 + return 1;
1.2274 + }
1.2275 + if (*p == '{') {
1.2276 + level++;
1.2277 + } else if (*p == '}') {
1.2278 + level--;
1.2279 + } else if (*p == '\\') {
1.2280 + quoted = 1;
1.2281 + }
1.2282 + }
1.2283 + *stringPtr = p;
1.2284 + return 0;
1.2285 +}
1.2286 +
1.2287 +/*
1.2288 + *----------------------------------------------------------------------
1.2289 + *
1.2290 + * TclDoGlob --
1.2291 + *
1.2292 + * This recursive procedure forms the heart of the globbing
1.2293 + * code. It performs a depth-first traversal of the tree
1.2294 + * given by the path name to be globbed. The directory and
1.2295 + * remainder are assumed to be native format paths. The prefix
1.2296 + * contained in 'headPtr' is not used as a glob pattern, simply
1.2297 + * as a path specifier, so it can contain unquoted glob-sensitive
1.2298 + * characters (if the directories to which it points contain
1.2299 + * such strange characters).
1.2300 + *
1.2301 + * Results:
1.2302 + * The return value is a standard Tcl result indicating whether
1.2303 + * an error occurred in globbing. After a normal return the
1.2304 + * result in interp will be set to hold all of the file names
1.2305 + * given by the dir and rem arguments. After an error the
1.2306 + * result in interp will hold an error message.
1.2307 + *
1.2308 + * Side effects:
1.2309 + * None.
1.2310 + *
1.2311 + *----------------------------------------------------------------------
1.2312 + */
1.2313 +
1.2314 +int
1.2315 +TclDoGlob(interp, separators, headPtr, tail, types)
1.2316 + Tcl_Interp *interp; /* Interpreter to use for error reporting
1.2317 + * (e.g. unmatched brace). */
1.2318 + char *separators; /* String containing separator characters
1.2319 + * that should be used to identify globbing
1.2320 + * boundaries. */
1.2321 + Tcl_DString *headPtr; /* Completely expanded prefix. */
1.2322 + char *tail; /* The unexpanded remainder of the path.
1.2323 + * Must not be a pointer to a static string. */
1.2324 + Tcl_GlobTypeData *types; /* List object containing list of acceptable
1.2325 + * types. May be NULL. */
1.2326 +{
1.2327 + int baseLength, quoted, count;
1.2328 + int result = TCL_OK;
1.2329 + char *name, *p, *openBrace, *closeBrace, *firstSpecialChar, savedChar;
1.2330 + char lastChar = 0;
1.2331 +
1.2332 + int length = Tcl_DStringLength(headPtr);
1.2333 +
1.2334 + if (length > 0) {
1.2335 + lastChar = Tcl_DStringValue(headPtr)[length-1];
1.2336 + }
1.2337 +
1.2338 + /*
1.2339 + * Consume any leading directory separators, leaving tail pointing
1.2340 + * just past the last initial separator.
1.2341 + */
1.2342 +
1.2343 + count = 0;
1.2344 + name = tail;
1.2345 + for (; *tail != '\0'; tail++) {
1.2346 + if (*tail == '\\') {
1.2347 + /*
1.2348 + * If the first character is escaped, either we have a directory
1.2349 + * separator, or we have any other character. In the latter case
1.2350 + * the rest of tail is a pattern, and we must break from the loop.
1.2351 + * This is particularly important on Windows where '\' is both
1.2352 + * the escaping character and a directory separator.
1.2353 + */
1.2354 + if (strchr(separators, tail[1]) != NULL) {
1.2355 + tail++;
1.2356 + } else {
1.2357 + break;
1.2358 + }
1.2359 + } else if (strchr(separators, *tail) == NULL) {
1.2360 + break;
1.2361 + }
1.2362 + if (tclPlatform != TCL_PLATFORM_MAC) {
1.2363 + if (*tail == '\\') {
1.2364 + Tcl_DStringAppend(headPtr, separators, 1);
1.2365 + } else {
1.2366 + Tcl_DStringAppend(headPtr, tail, 1);
1.2367 + }
1.2368 + }
1.2369 + count++;
1.2370 + }
1.2371 +
1.2372 + /*
1.2373 + * Deal with path separators. On the Mac, we have to watch out
1.2374 + * for multiple separators, since they are special in Mac-style
1.2375 + * paths.
1.2376 + */
1.2377 +
1.2378 + switch (tclPlatform) {
1.2379 + case TCL_PLATFORM_MAC:
1.2380 +#ifdef MAC_UNDERSTANDS_UNIX_PATHS
1.2381 + if (*separators == '/') {
1.2382 + if (((length == 0) && (count == 0))
1.2383 + || ((length > 0) && (lastChar != ':'))) {
1.2384 + Tcl_DStringAppend(headPtr, ":", 1);
1.2385 + }
1.2386 + } else {
1.2387 +#endif
1.2388 + if (count == 0) {
1.2389 + if ((length > 0) && (lastChar != ':')) {
1.2390 + Tcl_DStringAppend(headPtr, ":", 1);
1.2391 + }
1.2392 + } else {
1.2393 + if (lastChar == ':') {
1.2394 + count--;
1.2395 + }
1.2396 + while (count-- > 0) {
1.2397 + Tcl_DStringAppend(headPtr, ":", 1);
1.2398 + }
1.2399 + }
1.2400 +#ifdef MAC_UNDERSTANDS_UNIX_PATHS
1.2401 + }
1.2402 +#endif
1.2403 + break;
1.2404 + case TCL_PLATFORM_WINDOWS:
1.2405 + /*
1.2406 + * If this is a drive relative path, add the colon and the
1.2407 + * trailing slash if needed. Otherwise add the slash if
1.2408 + * this is the first absolute element, or a later relative
1.2409 + * element. Add an extra slash if this is a UNC path.
1.2410 +
1.2411 + if (*name == ':') {
1.2412 + Tcl_DStringAppend(headPtr, ":", 1);
1.2413 + if (count > 1) {
1.2414 + Tcl_DStringAppend(headPtr, "/", 1);
1.2415 + }
1.2416 + } else if ((*tail != '\0')
1.2417 + && (((length > 0)
1.2418 + && (strchr(separators, lastChar) == NULL))
1.2419 + || ((length == 0) && (count > 0)))) {
1.2420 + Tcl_DStringAppend(headPtr, "/", 1);
1.2421 + if ((length == 0) && (count > 1)) {
1.2422 + Tcl_DStringAppend(headPtr, "/", 1);
1.2423 + }
1.2424 + }
1.2425 + */
1.2426 +
1.2427 + break;
1.2428 + case TCL_PLATFORM_UNIX: {
1.2429 + /*
1.2430 + * Add a separator if this is the first absolute element, or
1.2431 + * a later relative element.
1.2432 +
1.2433 + if ((*tail != '\0')
1.2434 + && (((length > 0)
1.2435 + && (strchr(separators, lastChar) == NULL))
1.2436 + || ((length == 0) && (count > 0)))) {
1.2437 + Tcl_DStringAppend(headPtr, "/", 1);
1.2438 + }
1.2439 + */
1.2440 + break;
1.2441 + }
1.2442 + }
1.2443 +
1.2444 + /*
1.2445 + * Look for the first matching pair of braces or the first
1.2446 + * directory separator that is not inside a pair of braces.
1.2447 + */
1.2448 +
1.2449 + openBrace = closeBrace = NULL;
1.2450 + quoted = 0;
1.2451 + for (p = tail; *p != '\0'; p++) {
1.2452 + if (quoted) {
1.2453 + quoted = 0;
1.2454 + } else if (*p == '\\') {
1.2455 + quoted = 1;
1.2456 + if (strchr(separators, p[1]) != NULL) {
1.2457 + break; /* Quoted directory separator. */
1.2458 + }
1.2459 + } else if (strchr(separators, *p) != NULL) {
1.2460 + break; /* Unquoted directory separator. */
1.2461 + } else if (*p == '{') {
1.2462 + openBrace = p;
1.2463 + p++;
1.2464 + if (SkipToChar(&p, "}")) {
1.2465 + closeBrace = p; /* Balanced braces. */
1.2466 + break;
1.2467 + }
1.2468 + Tcl_SetResult(interp, "unmatched open-brace in file name",
1.2469 + TCL_STATIC);
1.2470 + return TCL_ERROR;
1.2471 + } else if (*p == '}') {
1.2472 + Tcl_SetResult(interp, "unmatched close-brace in file name",
1.2473 + TCL_STATIC);
1.2474 + return TCL_ERROR;
1.2475 + }
1.2476 + }
1.2477 +
1.2478 + /*
1.2479 + * Substitute the alternate patterns from the braces and recurse.
1.2480 + */
1.2481 +
1.2482 + if (openBrace != NULL) {
1.2483 + char *element;
1.2484 + Tcl_DString newName;
1.2485 + Tcl_DStringInit(&newName);
1.2486 +
1.2487 + /*
1.2488 + * For each element within in the outermost pair of braces,
1.2489 + * append the element and the remainder to the fixed portion
1.2490 + * before the first brace and recursively call TclDoGlob.
1.2491 + */
1.2492 +
1.2493 + Tcl_DStringAppend(&newName, tail, openBrace-tail);
1.2494 + baseLength = Tcl_DStringLength(&newName);
1.2495 + length = Tcl_DStringLength(headPtr);
1.2496 + *closeBrace = '\0';
1.2497 + for (p = openBrace; p != closeBrace; ) {
1.2498 + p++;
1.2499 + element = p;
1.2500 + SkipToChar(&p, ",");
1.2501 + Tcl_DStringSetLength(headPtr, length);
1.2502 + Tcl_DStringSetLength(&newName, baseLength);
1.2503 + Tcl_DStringAppend(&newName, element, p-element);
1.2504 + Tcl_DStringAppend(&newName, closeBrace+1, -1);
1.2505 + result = TclDoGlob(interp, separators, headPtr,
1.2506 + Tcl_DStringValue(&newName), types);
1.2507 + if (result != TCL_OK) {
1.2508 + break;
1.2509 + }
1.2510 + }
1.2511 + *closeBrace = '}';
1.2512 + Tcl_DStringFree(&newName);
1.2513 + return result;
1.2514 + }
1.2515 +
1.2516 + /*
1.2517 + * At this point, there are no more brace substitutions to perform on
1.2518 + * this path component. The variable p is pointing at a quoted or
1.2519 + * unquoted directory separator or the end of the string. So we need
1.2520 + * to check for special globbing characters in the current pattern.
1.2521 + * We avoid modifying tail if p is pointing at the end of the string.
1.2522 + */
1.2523 +
1.2524 + if (*p != '\0') {
1.2525 +
1.2526 + /*
1.2527 + * Note that we are modifying the string in place. This won't work
1.2528 + * if the string is a static.
1.2529 + */
1.2530 +
1.2531 + savedChar = *p;
1.2532 + *p = '\0';
1.2533 + firstSpecialChar = strpbrk(tail, "*[]?\\");
1.2534 + *p = savedChar;
1.2535 + } else {
1.2536 + firstSpecialChar = strpbrk(tail, "*[]?\\");
1.2537 + }
1.2538 +
1.2539 + if (firstSpecialChar != NULL) {
1.2540 + int ret;
1.2541 + Tcl_Obj *head = Tcl_NewStringObj(Tcl_DStringValue(headPtr),-1);
1.2542 + Tcl_IncrRefCount(head);
1.2543 + /*
1.2544 + * Look for matching files in the given directory. The
1.2545 + * implementation of this function is platform specific. For
1.2546 + * each file that matches, it will add the match onto the
1.2547 + * resultPtr given.
1.2548 + */
1.2549 + if (*p == '\0') {
1.2550 + ret = Tcl_FSMatchInDirectory(interp, Tcl_GetObjResult(interp),
1.2551 + head, tail, types);
1.2552 + } else {
1.2553 + /*
1.2554 + * We do the recursion ourselves. This makes implementing
1.2555 + * Tcl_FSMatchInDirectory for each filesystem much easier.
1.2556 + */
1.2557 + Tcl_GlobTypeData dirOnly = { TCL_GLOB_TYPE_DIR, 0, NULL, NULL };
1.2558 + char save = *p;
1.2559 + Tcl_Obj *resultPtr;
1.2560 +
1.2561 + resultPtr = Tcl_NewListObj(0, NULL);
1.2562 + Tcl_IncrRefCount(resultPtr);
1.2563 + *p = '\0';
1.2564 + ret = Tcl_FSMatchInDirectory(interp, resultPtr,
1.2565 + head, tail, &dirOnly);
1.2566 + *p = save;
1.2567 + if (ret == TCL_OK) {
1.2568 + int resLength;
1.2569 + ret = Tcl_ListObjLength(interp, resultPtr, &resLength);
1.2570 + if (ret == TCL_OK) {
1.2571 + int i;
1.2572 + for (i =0; i< resLength; i++) {
1.2573 + Tcl_Obj *elt;
1.2574 + Tcl_DString ds;
1.2575 + Tcl_ListObjIndex(interp, resultPtr, i, &elt);
1.2576 + Tcl_DStringInit(&ds);
1.2577 + Tcl_DStringAppend(&ds, Tcl_GetString(elt), -1);
1.2578 + if(tclPlatform == TCL_PLATFORM_MAC) {
1.2579 + Tcl_DStringAppend(&ds, ":",1);
1.2580 + } else {
1.2581 + Tcl_DStringAppend(&ds, "/",1);
1.2582 + }
1.2583 + ret = TclDoGlob(interp, separators, &ds, p+1, types);
1.2584 + Tcl_DStringFree(&ds);
1.2585 + if (ret != TCL_OK) {
1.2586 + break;
1.2587 + }
1.2588 + }
1.2589 + }
1.2590 + }
1.2591 + Tcl_DecrRefCount(resultPtr);
1.2592 + }
1.2593 + Tcl_DecrRefCount(head);
1.2594 + return ret;
1.2595 + }
1.2596 + Tcl_DStringAppend(headPtr, tail, p-tail);
1.2597 + if (*p != '\0') {
1.2598 + return TclDoGlob(interp, separators, headPtr, p, types);
1.2599 + } else {
1.2600 + /*
1.2601 + * This is the code path reached by a command like 'glob foo'.
1.2602 + *
1.2603 + * There are no more wildcards in the pattern and no more
1.2604 + * unprocessed characters in the tail, so now we can construct
1.2605 + * the path, and pass it to Tcl_FSMatchInDirectory with an
1.2606 + * empty pattern to verify the existence of the file and check
1.2607 + * it is of the correct type (if a 'types' flag it given -- if
1.2608 + * no such flag was given, we could just use 'Tcl_FSLStat', but
1.2609 + * for simplicity we keep to a common approach).
1.2610 + */
1.2611 +
1.2612 + Tcl_Obj *nameObj;
1.2613 +
1.2614 + switch (tclPlatform) {
1.2615 + case TCL_PLATFORM_MAC: {
1.2616 + if (strchr(Tcl_DStringValue(headPtr), ':') == NULL) {
1.2617 + Tcl_DStringAppend(headPtr, ":", 1);
1.2618 + }
1.2619 + break;
1.2620 + }
1.2621 + case TCL_PLATFORM_WINDOWS: {
1.2622 + if (Tcl_DStringLength(headPtr) == 0) {
1.2623 + if (((*name == '\\') && (name[1] == '/' || name[1] == '\\'))
1.2624 + || (*name == '/')) {
1.2625 + Tcl_DStringAppend(headPtr, "/", 1);
1.2626 + } else {
1.2627 + Tcl_DStringAppend(headPtr, ".", 1);
1.2628 + }
1.2629 + }
1.2630 +#if defined(__CYGWIN__) && defined(__WIN32__)
1.2631 + {
1.2632 + extern int cygwin_conv_to_win32_path
1.2633 + _ANSI_ARGS_((CONST char *, char *));
1.2634 + char winbuf[MAX_PATH+1];
1.2635 +
1.2636 + cygwin_conv_to_win32_path(Tcl_DStringValue(headPtr), winbuf);
1.2637 + Tcl_DStringFree(headPtr);
1.2638 + Tcl_DStringAppend(headPtr, winbuf, -1);
1.2639 + }
1.2640 +#endif /* __CYGWIN__ && __WIN32__ */
1.2641 + /*
1.2642 + * Convert to forward slashes. This is required to pass
1.2643 + * some Tcl tests. We should probably remove the conversions
1.2644 + * here and in tclWinFile.c, since they aren't needed since
1.2645 + * the dropping of support for Win32s.
1.2646 + */
1.2647 + for (p = Tcl_DStringValue(headPtr); *p != '\0'; p++) {
1.2648 + if (*p == '\\') {
1.2649 + *p = '/';
1.2650 + }
1.2651 + }
1.2652 + break;
1.2653 + }
1.2654 + case TCL_PLATFORM_UNIX: {
1.2655 + if (Tcl_DStringLength(headPtr) == 0) {
1.2656 + if ((*name == '\\' && name[1] == '/') || (*name == '/')) {
1.2657 + Tcl_DStringAppend(headPtr, "/", 1);
1.2658 + } else {
1.2659 + Tcl_DStringAppend(headPtr, ".", 1);
1.2660 + }
1.2661 + }
1.2662 + break;
1.2663 + }
1.2664 + }
1.2665 + /* Common for all platforms */
1.2666 + name = Tcl_DStringValue(headPtr);
1.2667 + nameObj = Tcl_NewStringObj(name, Tcl_DStringLength(headPtr));
1.2668 +
1.2669 + Tcl_IncrRefCount(nameObj);
1.2670 + Tcl_FSMatchInDirectory(interp, Tcl_GetObjResult(interp), nameObj,
1.2671 + NULL, types);
1.2672 + Tcl_DecrRefCount(nameObj);
1.2673 + return TCL_OK;
1.2674 + }
1.2675 +}
1.2676 +
1.2677 +
1.2678 +/*
1.2679 + *---------------------------------------------------------------------------
1.2680 + *
1.2681 + * TclFileDirname
1.2682 + *
1.2683 + * This procedure calculates the directory above a given
1.2684 + * path: basically 'file dirname'. It is used both by
1.2685 + * the 'dirname' subcommand of file and by code in tclIOUtil.c.
1.2686 + *
1.2687 + * Results:
1.2688 + * NULL if an error occurred, otherwise a Tcl_Obj owned by
1.2689 + * the caller (i.e. most likely with refCount 1).
1.2690 + *
1.2691 + * Side effects:
1.2692 + * None.
1.2693 + *
1.2694 + *---------------------------------------------------------------------------
1.2695 + */
1.2696 +
1.2697 +Tcl_Obj*
1.2698 +TclFileDirname(interp, pathPtr)
1.2699 + Tcl_Interp *interp; /* Used for error reporting */
1.2700 + Tcl_Obj *pathPtr; /* Path to take dirname of */
1.2701 +{
1.2702 + int splitElements;
1.2703 + Tcl_Obj *splitPtr;
1.2704 + Tcl_Obj *splitResultPtr = NULL;
1.2705 +
1.2706 + /*
1.2707 + * The behaviour we want here is slightly different to
1.2708 + * the standard Tcl_FSSplitPath in the handling of home
1.2709 + * directories; Tcl_FSSplitPath preserves the "~" while
1.2710 + * this code computes the actual full path name, if we
1.2711 + * had just a single component.
1.2712 + */
1.2713 + splitPtr = Tcl_FSSplitPath(pathPtr, &splitElements);
1.2714 + if ((splitElements == 1) && (Tcl_GetString(pathPtr)[0] == '~')) {
1.2715 + Tcl_DecrRefCount(splitPtr);
1.2716 + splitPtr = Tcl_FSGetNormalizedPath(interp, pathPtr);
1.2717 + if (splitPtr == NULL) {
1.2718 + return NULL;
1.2719 + }
1.2720 + splitPtr = Tcl_FSSplitPath(splitPtr, &splitElements);
1.2721 + }
1.2722 +
1.2723 + /*
1.2724 + * Return all but the last component. If there is only one
1.2725 + * component, return it if the path was non-relative, otherwise
1.2726 + * return the current directory.
1.2727 + */
1.2728 +
1.2729 + if (splitElements > 1) {
1.2730 + splitResultPtr = Tcl_FSJoinPath(splitPtr, splitElements - 1);
1.2731 + } else if (splitElements == 0 ||
1.2732 + (Tcl_FSGetPathType(pathPtr) == TCL_PATH_RELATIVE)) {
1.2733 + splitResultPtr = Tcl_NewStringObj(
1.2734 + ((tclPlatform == TCL_PLATFORM_MAC) ? ":" : "."), 1);
1.2735 + } else {
1.2736 + Tcl_ListObjIndex(NULL, splitPtr, 0, &splitResultPtr);
1.2737 + }
1.2738 + Tcl_IncrRefCount(splitResultPtr);
1.2739 + Tcl_DecrRefCount(splitPtr);
1.2740 + return splitResultPtr;
1.2741 +}
1.2742 +
1.2743 +/*
1.2744 + *---------------------------------------------------------------------------
1.2745 + *
1.2746 + * Tcl_AllocStatBuf
1.2747 + *
1.2748 + * This procedure allocates a Tcl_StatBuf on the heap. It exists
1.2749 + * so that extensions may be used unchanged on systems where
1.2750 + * largefile support is optional.
1.2751 + *
1.2752 + * Results:
1.2753 + * A pointer to a Tcl_StatBuf which may be deallocated by being
1.2754 + * passed to ckfree().
1.2755 + *
1.2756 + * Side effects:
1.2757 + * None.
1.2758 + *
1.2759 + *---------------------------------------------------------------------------
1.2760 + */
1.2761 +
1.2762 +EXPORT_C Tcl_StatBuf *
1.2763 +Tcl_AllocStatBuf() {
1.2764 + return (Tcl_StatBuf *) ckalloc(sizeof(Tcl_StatBuf));
1.2765 +}