1 /*
2 * tclPathObj.c --
3 *
4 * This file contains the implementation of Tcl's "path" object type used
5 * to represent and manipulate a general (virtual) filesystem entity in
6 * an efficient manner.
7 *
8 * Copyright © 2003 Vince Darley.
9 *
10 * See the file "license.terms" for information on usage and redistribution of
11 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
12 */
13
14 #include "tclInt.h"
15 #include "tclFileSystem.h"
16 #include <assert.h>
17
18 /*
19 * Prototypes for functions defined later in this file.
20 */
21
22 static Tcl_Obj * AppendPath(Tcl_Obj *head, Tcl_Obj *tail);
23 static void DupFsPathInternalRep(Tcl_Obj *srcPtr,
24 Tcl_Obj *copyPtr);
25 static void FreeFsPathInternalRep(Tcl_Obj *pathPtr);
26 static void UpdateStringOfFsPath(Tcl_Obj *pathPtr);
27 static int SetFsPathFromAny(Tcl_Interp *interp, Tcl_Obj *pathPtr);
28 static int FindSplitPos(const char *path, int separator);
29 static int IsSeparatorOrNull(int ch);
30 static Tcl_Obj * GetExtension(Tcl_Obj *pathPtr);
31 static int MakePathFromNormalized(Tcl_Interp *interp,
32 Tcl_Obj *pathPtr);
33
34 /*
35 * Define the 'path' object type, which Tcl uses to represent file paths
36 * internally.
37 */
38
39 static const Tcl_ObjType fsPathType = {
40 "path", /* name */
41 FreeFsPathInternalRep, /* freeIntRepProc */
42 DupFsPathInternalRep, /* dupIntRepProc */
43 UpdateStringOfFsPath, /* updateStringProc */
44 SetFsPathFromAny /* setFromAnyProc */
45 };
46
47 /*
48 * struct FsPath --
49 *
50 * Internal representation of a Tcl_Obj of fsPathType
51 */
52
53 typedef struct FsPath {
54 Tcl_Obj *translatedPathPtr; /* If the path has been normalized (flags ==
55 * 0), this is NULL. Otherwise it is a path
56 * in which any ~user sequences have been
57 * translated away. */
58 Tcl_Obj *normPathPtr; /* If the path has been normalized (flags ==
59 * 0), this is an absolute path without ., ..
60 * or ~user components. Otherwise it is a
61 * path, possibly absolute, to normalize
62 * relative to cwdPtr. */
63 Tcl_Obj *cwdPtr; /* If NULL, either translatedPtr exists or
64 * normPathPtr exists and is absolute. */
65 int flags; /* Flags to describe interpretation - see
66 * below. */
67 ClientData nativePathPtr; /* Native representation of this path, which
68 * is filesystem dependent. */
69 int filesystemEpoch; /* Used to ensure the path representation was
70 * generated during the correct filesystem
71 * epoch. The epoch changes when
72 * filesystem-mounts are changed. */
73 const Tcl_Filesystem *fsPtr;/* The Tcl_Filesystem that claims this path */
74 } FsPath;
75
76 /*
77 * Flag values for FsPath->flags.
78 */
79
80 #define TCLPATH_APPENDED 1
81 #define TCLPATH_NEEDNORM 4
82
83 /*
84 * Define some macros to give us convenient access to path-object specific
85 * fields.
86 */
87
88 #define PATHOBJ(pathPtr) ((FsPath *) (TclFetchIntRep((pathPtr), &fsPathType)->twoPtrValue.ptr1))
89 #define SETPATHOBJ(pathPtr,fsPathPtr) \
90 do { \
91 Tcl_ObjIntRep ir; \
92 ir.twoPtrValue.ptr1 = (void *) (fsPathPtr); \
93 ir.twoPtrValue.ptr2 = NULL; \
94 Tcl_StoreIntRep((pathPtr), &fsPathType, &ir); \
95 } while (0)
96 #define PATHFLAGS(pathPtr) (PATHOBJ(pathPtr)->flags)
97
98 /*
99 *---------------------------------------------------------------------------
100 *
101 * TclFSNormalizeAbsolutePath --
102 *
103 * Takes an absolute path specification and computes a 'normalized' path
104 * from it.
105 *
106 * A normalized path is one which has all '../', './' removed. Also it is
107 * one which is in the 'standard' format for the native platform. On
108 * Unix, this means the path must be free of symbolic links/aliases, and
109 * on Windows it means we want the long form, with that long form's
110 * case-dependence (which gives us a unique, case-dependent path).
111 *
112 * The behaviour of this function if passed a non-absolute path is NOT
113 * defined.
114 *
115 * pathPtr may have a refCount of zero, or may be a shared object.
116 *
117 * Results:
118 * The result is returned in a Tcl_Obj with a refCount already
119 * incremented, which gives the caller ownership of it. The caller must
120 * arrange for Tcl_DecRefCount to be called when the object is no-longer
121 * needed.
122 *
123 * Side effects:
124 * None (beyond the memory allocation for the result).
125 *
126 * Special note:
127 * Originally based on code from Matt Newman and Jean-Claude Wippler.
128 * Totally rewritten later by Vince Darley to handle symbolic links.
129 *
130 *---------------------------------------------------------------------------
131 */
132
133 Tcl_Obj *
TclFSNormalizeAbsolutePath(Tcl_Interp * interp,Tcl_Obj * pathPtr)134 TclFSNormalizeAbsolutePath(
135 Tcl_Interp *interp, /* Interpreter to use */
136 Tcl_Obj *pathPtr) /* Absolute path to normalize */
137 {
138 const char *dirSep, *oldDirSep;
139 int first = 1; /* Set to zero once we've passed the first
140 * directory separator - we can't use '..' to
141 * remove the volume in a path. */
142 Tcl_Obj *retVal = NULL;
143 dirSep = TclGetString(pathPtr);
144
145 if (tclPlatform == TCL_PLATFORM_WINDOWS) {
146 if ( (dirSep[0] == '/' || dirSep[0] == '\\')
147 && (dirSep[1] == '/' || dirSep[1] == '\\')
148 && (dirSep[2] == '?')
149 && (dirSep[3] == '/' || dirSep[3] == '\\')) {
150 /* NT extended path */
151 dirSep += 4;
152
153 if ( (dirSep[0] == 'U' || dirSep[0] == 'u')
154 && (dirSep[1] == 'N' || dirSep[1] == 'n')
155 && (dirSep[2] == 'C' || dirSep[2] == 'c')
156 && (dirSep[3] == '/' || dirSep[3] == '\\')) {
157 /* NT extended UNC path */
158 dirSep += 4;
159 }
160 }
161 if (dirSep[0] != 0 && dirSep[1] == ':' &&
162 (dirSep[2] == '/' || dirSep[2] == '\\')) {
163 /* Do nothing */
164 } else if ((dirSep[0] == '/' || dirSep[0] == '\\')
165 && (dirSep[1] == '/' || dirSep[1] == '\\')) {
166 /*
167 * UNC style path, where we must skip over the first separator,
168 * since the first two segments are actually inseparable.
169 */
170
171 dirSep += 2;
172 dirSep += FindSplitPos(dirSep, '/');
173 if (*dirSep != 0) {
174 dirSep++;
175 }
176 }
177 }
178
179 /*
180 * Scan forward from one directory separator to the next, checking for
181 * '..' and '.' sequences which must be handled specially. In particular
182 * handling of '..' can be complicated if the directory before is a link,
183 * since we will have to expand the link to be able to back up one level.
184 */
185
186 while (*dirSep != 0) {
187 oldDirSep = dirSep;
188 if (!first) {
189 dirSep++;
190 }
191 dirSep += FindSplitPos(dirSep, '/');
192 if (dirSep[0] == 0 || dirSep[1] == 0) {
193 if (retVal != NULL) {
194 Tcl_AppendToObj(retVal, oldDirSep, dirSep - oldDirSep);
195 }
196 break;
197 }
198 if (dirSep[1] == '.') {
199 if (retVal != NULL) {
200 Tcl_AppendToObj(retVal, oldDirSep, dirSep - oldDirSep);
201 oldDirSep = dirSep;
202 }
203 again:
204 if (IsSeparatorOrNull(dirSep[2])) {
205 /*
206 * Need to skip '.' in the path.
207 */
208 int curLen;
209
210 if (retVal == NULL) {
211 const char *path = TclGetString(pathPtr);
212 retVal = Tcl_NewStringObj(path, dirSep - path);
213 Tcl_IncrRefCount(retVal);
214 }
215 TclGetStringFromObj(retVal, &curLen);
216 if (curLen == 0) {
217 Tcl_AppendToObj(retVal, dirSep, 1);
218 }
219 dirSep += 2;
220 oldDirSep = dirSep;
221 if (dirSep[0] != 0 && dirSep[1] == '.') {
222 goto again;
223 }
224 continue;
225 }
226 if (dirSep[2] == '.' && IsSeparatorOrNull(dirSep[3])) {
227 Tcl_Obj *linkObj;
228 int curLen;
229 char *linkStr;
230
231 /*
232 * Have '..' so need to skip previous directory.
233 */
234
235 if (retVal == NULL) {
236 const char *path = TclGetString(pathPtr);
237
238 retVal = Tcl_NewStringObj(path, dirSep - path);
239 Tcl_IncrRefCount(retVal);
240 }
241 TclGetStringFromObj(retVal, &curLen);
242 if (curLen == 0) {
243 Tcl_AppendToObj(retVal, dirSep, 1);
244 }
245 if (!first || (tclPlatform == TCL_PLATFORM_UNIX)) {
246 linkObj = Tcl_FSLink(retVal, NULL, 0);
247
248 /* Safety check in case driver caused sharing */
249 if (Tcl_IsShared(retVal)) {
250 TclDecrRefCount(retVal);
251 retVal = Tcl_DuplicateObj(retVal);
252 Tcl_IncrRefCount(retVal);
253 }
254
255 if (linkObj != NULL) {
256 /*
257 * Got a link. Need to check if the link is relative
258 * or absolute, for those platforms where relative
259 * links exist.
260 */
261
262 if (tclPlatform != TCL_PLATFORM_WINDOWS
263 && Tcl_FSGetPathType(linkObj)
264 == TCL_PATH_RELATIVE) {
265 /*
266 * We need to follow this link which is relative
267 * to retVal's directory. This means concatenating
268 * the link onto the directory of the path so far.
269 */
270
271 const char *path =
272 TclGetStringFromObj(retVal, &curLen);
273
274 while (--curLen >= 0) {
275 if (IsSeparatorOrNull(path[curLen])) {
276 break;
277 }
278 }
279
280 /*
281 * We want the trailing slash.
282 */
283
284 Tcl_SetObjLength(retVal, curLen+1);
285 Tcl_AppendObjToObj(retVal, linkObj);
286 TclDecrRefCount(linkObj);
287 linkStr = TclGetStringFromObj(retVal, &curLen);
288 } else {
289 /*
290 * Absolute link.
291 */
292
293 TclDecrRefCount(retVal);
294 if (Tcl_IsShared(linkObj)) {
295 retVal = Tcl_DuplicateObj(linkObj);
296 TclDecrRefCount(linkObj);
297 } else {
298 retVal = linkObj;
299 }
300 linkStr = TclGetStringFromObj(retVal, &curLen);
301
302 /*
303 * Convert to forward-slashes on windows.
304 */
305
306 if (tclPlatform == TCL_PLATFORM_WINDOWS) {
307 int i;
308
309 for (i = 0; i < curLen; i++) {
310 if (linkStr[i] == '\\') {
311 linkStr[i] = '/';
312 }
313 }
314 }
315 }
316 } else {
317 linkStr = TclGetStringFromObj(retVal, &curLen);
318 }
319
320 /*
321 * Either way, we now remove the last path element (but
322 * not the first character of the path).
323 */
324
325 while (--curLen >= 0) {
326 if (IsSeparatorOrNull(linkStr[curLen])) {
327 if (curLen) {
328 Tcl_SetObjLength(retVal, curLen);
329 } else {
330 Tcl_SetObjLength(retVal, 1);
331 }
332 break;
333 }
334 }
335 }
336 dirSep += 3;
337 oldDirSep = dirSep;
338
339 if ((curLen == 0) && (dirSep[0] != 0)) {
340 Tcl_SetObjLength(retVal, 0);
341 }
342
343 if (dirSep[0] != 0 && dirSep[1] == '.') {
344 goto again;
345 }
346 continue;
347 }
348 }
349 first = 0;
350 if (retVal != NULL) {
351 Tcl_AppendToObj(retVal, oldDirSep, dirSep - oldDirSep);
352 }
353 }
354
355 /*
356 * If we didn't make any changes, just use the input path.
357 */
358
359 if (retVal == NULL) {
360 retVal = pathPtr;
361 Tcl_IncrRefCount(retVal);
362
363 if (Tcl_IsShared(retVal)) {
364 /*
365 * Unfortunately, the platform-specific normalization code which
366 * will be called below has no way of dealing with the case where
367 * an object is shared. It is expecting to modify an object in
368 * place. So, we must duplicate this here to ensure an object with
369 * a single ref-count.
370 *
371 * If that changes in the future (e.g. the normalize proc is given
372 * one object and is able to return a different one), then we
373 * could remove this code.
374 */
375
376 TclDecrRefCount(retVal);
377 retVal = Tcl_DuplicateObj(pathPtr);
378 Tcl_IncrRefCount(retVal);
379 }
380 }
381
382 /*
383 * Ensure a windows drive like C:/ has a trailing separator.
384 */
385
386 if (tclPlatform == TCL_PLATFORM_WINDOWS) {
387 int len;
388 const char *path = TclGetStringFromObj(retVal, &len);
389
390 if (len == 2 && path[0] != 0 && path[1] == ':') {
391 if (Tcl_IsShared(retVal)) {
392 TclDecrRefCount(retVal);
393 retVal = Tcl_DuplicateObj(retVal);
394 Tcl_IncrRefCount(retVal);
395 }
396 Tcl_AppendToObj(retVal, "/", 1);
397 }
398 }
399
400 /*
401 * Now we have an absolute path, with no '..', '.' sequences, but it still
402 * may not be in 'unique' form, depending on the platform. For instance,
403 * Unix is case-sensitive, so the path is ok. Windows is case-insensitive,
404 * and also has the weird 'longname/shortname' thing (e.g. C:/Program
405 * Files/ and C:/Progra~1/ are equivalent).
406 *
407 * Virtual file systems which may be registered may have other criteria
408 * for normalizing a path.
409 */
410
411 TclFSNormalizeToUniquePath(interp, retVal, 0);
412
413 /*
414 * Since we know it is a normalized path, we can actually convert this
415 * object into an FsPath for greater efficiency
416 */
417
418 MakePathFromNormalized(interp, retVal);
419
420 /*
421 * This has a refCount of 1 for the caller, unlike many Tcl_Obj APIs.
422 */
423
424 return retVal;
425 }
426
427 /*
428 *----------------------------------------------------------------------
429 *
430 * Tcl_FSGetPathType --
431 *
432 * Determines whether a given path is relative to the current directory,
433 * relative to the current volume, or absolute.
434 *
435 * Results:
436 * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
437 * TCL_PATH_VOLUME_RELATIVE.
438 *
439 * Side effects:
440 * None.
441 *
442 *----------------------------------------------------------------------
443 */
444
445 Tcl_PathType
Tcl_FSGetPathType(Tcl_Obj * pathPtr)446 Tcl_FSGetPathType(
447 Tcl_Obj *pathPtr)
448 {
449 return TclFSGetPathType(pathPtr, NULL, NULL);
450 }
451
452 /*
453 *----------------------------------------------------------------------
454 *
455 * TclFSGetPathType --
456 *
457 * Determines whether a given path is relative to the current directory,
458 * relative to the current volume, or absolute. If the caller wishes to
459 * know which filesystem claimed the path (in the case for which the path
460 * is absolute), then a reference to a filesystem pointer can be passed
461 * in (but passing NULL is acceptable).
462 *
463 * Results:
464 * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
465 * TCL_PATH_VOLUME_RELATIVE. The filesystem reference will be set if and
466 * only if it is non-NULL and the function's return value is
467 * TCL_PATH_ABSOLUTE.
468 *
469 * Side effects:
470 * None.
471 *
472 *----------------------------------------------------------------------
473 */
474
475 Tcl_PathType
TclFSGetPathType(Tcl_Obj * pathPtr,const Tcl_Filesystem ** filesystemPtrPtr,int * driveNameLengthPtr)476 TclFSGetPathType(
477 Tcl_Obj *pathPtr,
478 const Tcl_Filesystem **filesystemPtrPtr,
479 int *driveNameLengthPtr)
480 {
481 FsPath *fsPathPtr;
482
483 if (Tcl_FSConvertToPathType(NULL, pathPtr) != TCL_OK) {
484 return TclGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr,
485 NULL);
486 }
487
488 fsPathPtr = PATHOBJ(pathPtr);
489 if (fsPathPtr->cwdPtr == NULL) {
490 return TclGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr,
491 NULL);
492 }
493
494 if (PATHFLAGS(pathPtr) == 0) {
495 /* The path is not absolute... */
496 #ifdef _WIN32
497 /* ... on Windows we must make another call to determine whether
498 * it's relative or volumerelative [Bug 2571597]. */
499 return TclGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr,
500 NULL);
501 #else
502 /* On other systems, quickly deduce !absolute -> relative */
503 return TCL_PATH_RELATIVE;
504 #endif
505 }
506 return TclFSGetPathType(fsPathPtr->cwdPtr, filesystemPtrPtr,
507 driveNameLengthPtr);
508 }
509
510 /*
511 *---------------------------------------------------------------------------
512 *
513 * TclPathPart
514 *
515 * This function calculates the requested part of the given path, which
516 * can be:
517 *
518 * - the directory above ('file dirname')
519 * - the tail ('file tail')
520 * - the extension ('file extension')
521 * - the root ('file root')
522 *
523 * The 'portion' parameter dictates which of these to calculate. There
524 * are a number of special cases both to be more efficient, and because
525 * the behaviour when given a path with only a single element is defined
526 * to require the expansion of that single element, where possible.
527 *
528 * Should look into integrating 'FileBasename' in tclFCmd.c into this
529 * function.
530 *
531 * Results:
532 * NULL if an error occurred, otherwise a Tcl_Obj owned by the caller
533 * (i.e. most likely with refCount 1).
534 *
535 * Side effects:
536 * None.
537 *
538 *---------------------------------------------------------------------------
539 */
540
541 Tcl_Obj *
TclPathPart(Tcl_Interp * interp,Tcl_Obj * pathPtr,Tcl_PathPart portion)542 TclPathPart(
543 Tcl_Interp *interp, /* Used for error reporting */
544 Tcl_Obj *pathPtr, /* Path to take dirname of */
545 Tcl_PathPart portion) /* Requested portion of name */
546 {
547 if (TclHasIntRep(pathPtr, &fsPathType)) {
548 FsPath *fsPathPtr = PATHOBJ(pathPtr);
549
550 if (PATHFLAGS(pathPtr) != 0) {
551 switch (portion) {
552 case TCL_PATH_DIRNAME: {
553 /*
554 * Check if the joined-on bit has any directory delimiters in
555 * it. If so, the 'dirname' would be a joining of the main
556 * part with the dirname of the joined-on bit. We could handle
557 * that special case here, but we don't, and instead just use
558 * the standardPath code.
559 */
560
561 int numBytes;
562 const char *rest =
563 TclGetStringFromObj(fsPathPtr->normPathPtr, &numBytes);
564
565 if (strchr(rest, '/') != NULL) {
566 goto standardPath;
567 }
568 /*
569 * If the joined-on bit is empty, then [file dirname] is
570 * documented to return all but the last non-empty element
571 * of the path, so we need to split apart the main part to
572 * get the right answer. We could do that here, but it's
573 * simpler to fall back to the standardPath code.
574 * [Bug 2710920]
575 */
576 if (numBytes == 0) {
577 goto standardPath;
578 }
579 if (tclPlatform == TCL_PLATFORM_WINDOWS
580 && strchr(rest, '\\') != NULL) {
581 goto standardPath;
582 }
583
584 /*
585 * The joined-on path is simple, so we can just return here.
586 */
587
588 Tcl_IncrRefCount(fsPathPtr->cwdPtr);
589 return fsPathPtr->cwdPtr;
590 }
591 case TCL_PATH_TAIL: {
592 /*
593 * Check if the joined-on bit has any directory delimiters in
594 * it. If so, the 'tail' would be only the part following the
595 * last delimiter. We could handle that special case here, but
596 * we don't, and instead just use the standardPath code.
597 */
598
599 int numBytes;
600 const char *rest =
601 TclGetStringFromObj(fsPathPtr->normPathPtr, &numBytes);
602
603 if (strchr(rest, '/') != NULL) {
604 goto standardPath;
605 }
606 /*
607 * If the joined-on bit is empty, then [file tail] is
608 * documented to return the last non-empty element
609 * of the path, so we need to split off the last element
610 * of the main part to get the right answer. We could do
611 * that here, but it's simpler to fall back to the
612 * standardPath code. [Bug 2710920]
613 */
614 if (numBytes == 0) {
615 goto standardPath;
616 }
617 if (tclPlatform == TCL_PLATFORM_WINDOWS
618 && strchr(rest, '\\') != NULL) {
619 goto standardPath;
620 }
621 Tcl_IncrRefCount(fsPathPtr->normPathPtr);
622 return fsPathPtr->normPathPtr;
623 }
624 case TCL_PATH_EXTENSION:
625 return GetExtension(fsPathPtr->normPathPtr);
626 case TCL_PATH_ROOT: {
627 const char *fileName, *extension;
628 int length;
629
630 fileName = TclGetStringFromObj(fsPathPtr->normPathPtr,
631 &length);
632 extension = TclGetExtension(fileName);
633 if (extension == NULL) {
634 /*
635 * There is no extension so the root is the same as the
636 * path we were given.
637 */
638
639 Tcl_IncrRefCount(pathPtr);
640 return pathPtr;
641 } else {
642 /*
643 * Need to return the whole path with the extension
644 * suffix removed. Do that by joining our "head" to
645 * our "tail" with the extension suffix removed from
646 * the tail.
647 */
648
649 Tcl_Obj *resultPtr =
650 TclNewFSPathObj(fsPathPtr->cwdPtr, fileName,
651 (int)(length - strlen(extension)));
652
653 Tcl_IncrRefCount(resultPtr);
654 return resultPtr;
655 }
656 }
657 default:
658 /* We should never get here */
659 Tcl_Panic("Bad portion to TclPathPart");
660 /* For less clever compilers */
661 return NULL;
662 }
663 } else if (fsPathPtr->cwdPtr != NULL) {
664 /* Relative path */
665 goto standardPath;
666 } else {
667 /* Absolute path */
668 goto standardPath;
669 }
670 } else {
671 int splitElements;
672 Tcl_Obj *splitPtr, *resultPtr;
673
674 standardPath:
675 resultPtr = NULL;
676 if (portion == TCL_PATH_EXTENSION) {
677 return GetExtension(pathPtr);
678 } else if (portion == TCL_PATH_ROOT) {
679 int length;
680 const char *fileName, *extension;
681
682 fileName = TclGetStringFromObj(pathPtr, &length);
683 extension = TclGetExtension(fileName);
684 if (extension == NULL) {
685 Tcl_IncrRefCount(pathPtr);
686 return pathPtr;
687 } else {
688 Tcl_Obj *root = Tcl_NewStringObj(fileName,
689 (int) (length - strlen(extension)));
690
691 Tcl_IncrRefCount(root);
692 return root;
693 }
694 }
695
696 /*
697 * Tcl_FSSplitPath in the handling of home directories;
698 * Tcl_FSSplitPath preserves the "~", but this code computes the
699 * actual full path name, if we had just a single component.
700 */
701
702 splitPtr = Tcl_FSSplitPath(pathPtr, &splitElements);
703 Tcl_IncrRefCount(splitPtr);
704 if (splitElements == 1 && TclGetString(pathPtr)[0] == '~') {
705 Tcl_Obj *norm;
706
707 TclDecrRefCount(splitPtr);
708 norm = Tcl_FSGetNormalizedPath(interp, pathPtr);
709 if (norm == NULL) {
710 return NULL;
711 }
712 splitPtr = Tcl_FSSplitPath(norm, &splitElements);
713 Tcl_IncrRefCount(splitPtr);
714 }
715 if (portion == TCL_PATH_TAIL) {
716 /*
717 * Return the last component, unless it is the only component, and
718 * it is the root of an absolute path.
719 */
720
721 if ((splitElements > 0) && ((splitElements > 1) ||
722 (Tcl_FSGetPathType(pathPtr) == TCL_PATH_RELATIVE))) {
723 Tcl_ListObjIndex(NULL, splitPtr, splitElements-1, &resultPtr);
724 } else {
725 TclNewObj(resultPtr);
726 }
727 } else {
728 /*
729 * Return all but the last component. If there is only one
730 * component, return it if the path was non-relative, otherwise
731 * return the current directory.
732 */
733
734 if (splitElements > 1) {
735 resultPtr = Tcl_FSJoinPath(splitPtr, splitElements - 1);
736 } else if (splitElements == 0 ||
737 (Tcl_FSGetPathType(pathPtr) == TCL_PATH_RELATIVE)) {
738 TclNewLiteralStringObj(resultPtr, ".");
739 } else {
740 Tcl_ListObjIndex(NULL, splitPtr, 0, &resultPtr);
741 }
742 }
743 Tcl_IncrRefCount(resultPtr);
744 TclDecrRefCount(splitPtr);
745 return resultPtr;
746 }
747 }
748
749 /*
750 * Simple helper function
751 */
752
753 static Tcl_Obj *
GetExtension(Tcl_Obj * pathPtr)754 GetExtension(
755 Tcl_Obj *pathPtr)
756 {
757 const char *tail, *extension;
758 Tcl_Obj *ret;
759
760 tail = TclGetString(pathPtr);
761 extension = TclGetExtension(tail);
762 if (extension == NULL) {
763 TclNewObj(ret);
764 } else {
765 ret = Tcl_NewStringObj(extension, -1);
766 }
767 Tcl_IncrRefCount(ret);
768 return ret;
769 }
770
771 /*
772 *---------------------------------------------------------------------------
773 *
774 * Tcl_FSJoinPath --
775 *
776 * This function takes the given Tcl_Obj, which should be a valid list,
777 * and returns the path object given by considering the first 'elements'
778 * elements as valid path segments (each path segment may be a complete
779 * path, a partial path or just a single possible directory or file
780 * name). If any path segment is actually an absolute path, then all
781 * prior path segments are discarded.
782 *
783 * If elements < 0, we use the entire list that was given.
784 *
785 * It is possible that the returned object is actually an element of the
786 * given list, so the caller should be careful to store a refCount to it
787 * before freeing the list.
788 *
789 * Results:
790 * Returns object with refCount of zero, (or if non-zero, it has
791 * references elsewhere in Tcl). Either way, the caller must increment
792 * its refCount before use. Note that in the case where the caller has
793 * asked to join zero elements of the list, the return value will be an
794 * empty-string Tcl_Obj.
795 *
796 * If the given listObj was invalid, then the calling routine has a bug,
797 * and this function will just return NULL.
798 *
799 * Side effects:
800 * None.
801 *
802 *---------------------------------------------------------------------------
803 */
804
805 Tcl_Obj *
Tcl_FSJoinPath(Tcl_Obj * listObj,int elements)806 Tcl_FSJoinPath(
807 Tcl_Obj *listObj, /* Path elements to join, may have a zero
808 * reference count. */
809 int elements) /* Number of elements to use (-1 = all) */
810 {
811 Tcl_Obj *res;
812 int objc;
813 Tcl_Obj **objv;
814
815 if (Tcl_ListObjLength(NULL, listObj, &objc) != TCL_OK) {
816 return NULL;
817 }
818
819 elements = ((elements >= 0) && (elements <= objc)) ? elements : objc;
820 Tcl_ListObjGetElements(NULL, listObj, &objc, &objv);
821 res = TclJoinPath(elements, objv, 0);
822 return res;
823 }
824
825 Tcl_Obj *
TclJoinPath(int elements,Tcl_Obj * const objv[],int forceRelative)826 TclJoinPath(
827 int elements, /* Number of elements to use (-1 = all) */
828 Tcl_Obj * const objv[], /* Path elements to join */
829 int forceRelative) /* If non-zero, assume all more paths are
830 * relative (e. g. simple normalization) */
831 {
832 Tcl_Obj *res = NULL;
833 int i;
834 const Tcl_Filesystem *fsPtr = NULL;
835
836 assert ( elements >= 0 );
837
838 if (elements == 0) {
839 return Tcl_NewObj();
840 }
841
842 assert ( elements > 0 );
843
844 if (elements == 2) {
845 Tcl_Obj *elt = objv[0];
846 Tcl_ObjIntRep *eltIr = TclFetchIntRep(elt, &fsPathType);
847
848 /*
849 * This is a special case where we can be much more efficient, where
850 * we are joining a single relative path onto an object that is
851 * already of path type. The 'TclNewFSPathObj' call below creates an
852 * object which can be normalized more efficiently. Currently we only
853 * use the special case when we have exactly two elements, but we
854 * could expand that in the future.
855 *
856 * Bugfix [a47641a0]. TclNewFSPathObj requires first argument
857 * to be an absolute path. Added a check to ensure that elt is absolute.
858 */
859
860 if ((eltIr)
861 && !((elt->bytes != NULL) && (elt->bytes[0] == '\0'))
862 && TclGetPathType(elt, NULL, NULL, NULL) == TCL_PATH_ABSOLUTE) {
863 Tcl_Obj *tailObj = objv[1];
864 Tcl_PathType type;
865
866 /* if forceRelative - second path is relative */
867 type = forceRelative ? TCL_PATH_RELATIVE :
868 TclGetPathType(tailObj, NULL, NULL, NULL);
869 if (type == TCL_PATH_RELATIVE) {
870 const char *str;
871 int len;
872
873 str = TclGetStringFromObj(tailObj, &len);
874 if (len == 0) {
875 /*
876 * This happens if we try to handle the root volume '/'.
877 * There's no need to return a special path object, when
878 * the base itself is just fine!
879 */
880
881 return elt;
882 }
883
884 /*
885 * If it doesn't begin with '.' and is a unix path or it a
886 * windows path without backslashes, then we can be very
887 * efficient here. (In fact even a windows path with
888 * backslashes can be joined efficiently, but the path object
889 * would not have forward slashes only, and this would
890 * therefore contradict our 'file join' documentation).
891 */
892
893 if (str[0] != '.' && ((tclPlatform != TCL_PLATFORM_WINDOWS)
894 || (strchr(str, '\\') == NULL))) {
895 /*
896 * Finally, on Windows, 'file join' is defined to convert
897 * all backslashes to forward slashes, so the base part
898 * cannot have backslashes either.
899 */
900
901 if ((tclPlatform != TCL_PLATFORM_WINDOWS)
902 || (strchr(Tcl_GetString(elt), '\\') == NULL)) {
903
904 if (PATHFLAGS(elt)) {
905 return TclNewFSPathObj(elt, str, len);
906 }
907 if (TCL_PATH_ABSOLUTE != Tcl_FSGetPathType(elt)) {
908 return TclNewFSPathObj(elt, str, len);
909 }
910 (void) Tcl_FSGetNormalizedPath(NULL, elt);
911 if (elt == PATHOBJ(elt)->normPathPtr) {
912 return TclNewFSPathObj(elt, str, len);
913 }
914 }
915 }
916
917 /*
918 * Otherwise we don't have an easy join, and we must let the
919 * more general code below handle things.
920 */
921 } else if (tclPlatform == TCL_PLATFORM_UNIX) {
922 return tailObj;
923 } else {
924 const char *str = TclGetString(tailObj);
925
926 if (tclPlatform == TCL_PLATFORM_WINDOWS) {
927 if (strchr(str, '\\') == NULL) {
928 return tailObj;
929 }
930 }
931 }
932 }
933 }
934
935 assert ( res == NULL );
936
937 for (i = 0; i < elements; i++) {
938 int driveNameLength, strEltLen, length;
939 Tcl_PathType type;
940 char *strElt, *ptr;
941 Tcl_Obj *driveName = NULL;
942 Tcl_Obj *elt = objv[i];
943
944 strElt = TclGetStringFromObj(elt, &strEltLen);
945 driveNameLength = 0;
946 /* if forceRelative - all paths excepting first one are relative */
947 type = (forceRelative && (i > 0)) ? TCL_PATH_RELATIVE :
948 TclGetPathType(elt, &fsPtr, &driveNameLength, &driveName);
949 if (type != TCL_PATH_RELATIVE) {
950 /*
951 * Zero out the current result.
952 */
953
954 if (res != NULL) {
955 TclDecrRefCount(res);
956 }
957
958 if (driveName != NULL) {
959 /*
960 * We've been given a separate drive-name object, because the
961 * prefix in 'elt' is not in a suitable format for us (e.g. it
962 * may contain irrelevant multiple separators, like
963 * C://///foo).
964 */
965
966 res = Tcl_DuplicateObj(driveName);
967 TclDecrRefCount(driveName);
968
969 /*
970 * Do not set driveName to NULL, because we will check its
971 * value below (but we won't access the contents, since those
972 * have been cleaned-up).
973 */
974 } else {
975 res = Tcl_NewStringObj(strElt, driveNameLength);
976 }
977 strElt += driveNameLength;
978 } else if (driveName != NULL) {
979 Tcl_DecrRefCount(driveName);
980 }
981
982 /*
983 * Optimisation block: if this is the last element to be examined, and
984 * it is absolute or the only element, and the drive-prefix was ok (if
985 * there is one), it might be that the path is already in a suitable
986 * form to be returned. Then we can short-cut the rest of this
987 * function.
988 */
989
990 if ((driveName == NULL) && (i == (elements - 1))
991 && (type != TCL_PATH_RELATIVE || res == NULL)) {
992 /*
993 * It's the last path segment. Perform a quick check if the path
994 * is already in a suitable form.
995 */
996
997 if (tclPlatform == TCL_PLATFORM_WINDOWS) {
998 if (strchr(strElt, '\\') != NULL) {
999 goto noQuickReturn;
1000 }
1001 }
1002 ptr = strElt;
1003 /* [Bug f34cf83dd0] */
1004 if (driveNameLength > 0) {
1005 if (ptr[0] == '/' && ptr[-1] == '/') {
1006 goto noQuickReturn;
1007 }
1008 }
1009 while (*ptr != '\0') {
1010 if (*ptr == '/' && (ptr[1] == '/' || ptr[1] == '\0')) {
1011 /*
1012 * We have a repeated file separator, which means the path
1013 * is not in normalized form
1014 */
1015
1016 goto noQuickReturn;
1017 }
1018 ptr++;
1019 }
1020 if (res != NULL) {
1021 TclDecrRefCount(res);
1022 }
1023
1024 /*
1025 * This element is just what we want to return already; no further
1026 * manipulation is requred.
1027 */
1028
1029 return elt;
1030 }
1031
1032 /*
1033 * The path element was not of a suitable form to be returned as is.
1034 * We need to perform a more complex operation here.
1035 */
1036
1037 noQuickReturn:
1038 if (res == NULL) {
1039 TclNewObj(res);
1040 }
1041 ptr = TclGetStringFromObj(res, &length);
1042
1043 /*
1044 * Strip off any './' before a tilde, unless this is the beginning of
1045 * the path.
1046 */
1047
1048 if (length > 0 && strEltLen > 0 && (strElt[0] == '.') &&
1049 (strElt[1] == '/') && (strElt[2] == '~')) {
1050 strElt += 2;
1051 }
1052
1053 /*
1054 * A NULL value for fsPtr at this stage basically means we're trying
1055 * to join a relative path onto something which is also relative (or
1056 * empty). There's nothing particularly wrong with that.
1057 */
1058
1059 if (*strElt == '\0') {
1060 continue;
1061 }
1062
1063 if (fsPtr == &tclNativeFilesystem || fsPtr == NULL) {
1064 TclpNativeJoinPath(res, strElt);
1065 } else {
1066 char separator = '/';
1067 int needsSep = 0;
1068
1069 if (fsPtr->filesystemSeparatorProc != NULL) {
1070 Tcl_Obj *sep = fsPtr->filesystemSeparatorProc(res);
1071
1072 if (sep != NULL) {
1073 separator = TclGetString(sep)[0];
1074 TclDecrRefCount(sep);
1075 }
1076 /* Safety check in case the VFS driver caused sharing */
1077 if (Tcl_IsShared(res)) {
1078 TclDecrRefCount(res);
1079 res = Tcl_DuplicateObj(res);
1080 Tcl_IncrRefCount(res);
1081 }
1082 }
1083
1084 if (length > 0 && ptr[length -1] != '/') {
1085 Tcl_AppendToObj(res, &separator, 1);
1086 TclGetStringFromObj(res, &length);
1087 }
1088 Tcl_SetObjLength(res, length + (int) strlen(strElt));
1089
1090 ptr = TclGetString(res) + length;
1091 for (; *strElt != '\0'; strElt++) {
1092 if (*strElt == separator) {
1093 while (strElt[1] == separator) {
1094 strElt++;
1095 }
1096 if (strElt[1] != '\0') {
1097 if (needsSep) {
1098 *ptr++ = separator;
1099 }
1100 }
1101 } else {
1102 *ptr++ = *strElt;
1103 needsSep = 1;
1104 }
1105 }
1106 length = ptr - TclGetString(res);
1107 Tcl_SetObjLength(res, length);
1108 }
1109 }
1110 assert ( res != NULL );
1111 return res;
1112 }
1113
1114 /*
1115 *---------------------------------------------------------------------------
1116 *
1117 * Tcl_FSConvertToPathType --
1118 *
1119 * This function tries to convert the given Tcl_Obj to a valid Tcl path
1120 * type, taking account of the fact that the cwd may have changed even if
1121 * this object is already supposedly of the correct type.
1122 *
1123 * The filename may begin with "~" (to indicate current user's home
1124 * directory) or "~<user>" (to indicate any user's home directory).
1125 *
1126 * Results:
1127 * Standard Tcl error code.
1128 *
1129 * Side effects:
1130 * The old representation may be freed, and new memory allocated.
1131 *
1132 *---------------------------------------------------------------------------
1133 */
1134
1135 int
Tcl_FSConvertToPathType(Tcl_Interp * interp,Tcl_Obj * pathPtr)1136 Tcl_FSConvertToPathType(
1137 Tcl_Interp *interp, /* Interpreter in which to store error message
1138 * (if necessary). */
1139 Tcl_Obj *pathPtr) /* Object to convert to a valid, current path
1140 * type. */
1141 {
1142 /*
1143 * While it is bad practice to examine an object's type directly, this is
1144 * actually the best thing to do here. The reason is that if we are
1145 * converting this object to FsPath type for the first time, we don't need
1146 * to worry whether the 'cwd' has changed. On the other hand, if this
1147 * object is already of FsPath type, and is a relative path, we do have to
1148 * worry about the cwd. If the cwd has changed, we must recompute the
1149 * path.
1150 */
1151
1152 if (TclHasIntRep(pathPtr, &fsPathType)) {
1153 if (TclFSEpochOk(PATHOBJ(pathPtr)->filesystemEpoch)) {
1154 return TCL_OK;
1155 }
1156
1157 TclGetString(pathPtr);
1158 Tcl_StoreIntRep(pathPtr, &fsPathType, NULL);
1159 }
1160
1161 return SetFsPathFromAny(interp, pathPtr);
1162 }
1163
1164 /*
1165 * Helper function for normalization.
1166 */
1167
1168 static int
IsSeparatorOrNull(int ch)1169 IsSeparatorOrNull(
1170 int ch)
1171 {
1172 if (ch == 0) {
1173 return 1;
1174 }
1175 switch (tclPlatform) {
1176 case TCL_PLATFORM_UNIX:
1177 return (ch == '/' ? 1 : 0);
1178 case TCL_PLATFORM_WINDOWS:
1179 return ((ch == '/' || ch == '\\') ? 1 : 0);
1180 }
1181 return 0;
1182 }
1183
1184 /*
1185 * Helper function for SetFsPathFromAny. Returns position of first directory
1186 * delimiter in the path. If no separator is found, then returns the position
1187 * of the end of the string.
1188 */
1189
1190 static int
FindSplitPos(const char * path,int separator)1191 FindSplitPos(
1192 const char *path,
1193 int separator)
1194 {
1195 int count = 0;
1196 switch (tclPlatform) {
1197 case TCL_PLATFORM_UNIX:
1198 while (path[count] != 0) {
1199 if (path[count] == separator) {
1200 return count;
1201 }
1202 count++;
1203 }
1204 break;
1205
1206 case TCL_PLATFORM_WINDOWS:
1207 while (path[count] != 0) {
1208 if (path[count] == separator || path[count] == '\\') {
1209 return count;
1210 }
1211 count++;
1212 }
1213 break;
1214 }
1215 return count;
1216 }
1217
1218 /*
1219 *---------------------------------------------------------------------------
1220 *
1221 * TclNewFSPathObj --
1222 *
1223 * Creates a path object whose string representation is '[file join
1224 * dirPtr addStrRep]', but does so in a way that allows for more
1225 * efficient creation and caching of normalized paths, and more efficient
1226 * 'file dirname', 'file tail', etc.
1227 *
1228 * Assumptions:
1229 * 'dirPtr' must be an absolute path. 'len' may not be zero.
1230 *
1231 * Results:
1232 * The new Tcl object, with refCount zero.
1233 *
1234 * Side effects:
1235 * Memory is allocated. 'dirPtr' gets an additional refCount.
1236 *
1237 *---------------------------------------------------------------------------
1238 */
1239
1240 Tcl_Obj *
TclNewFSPathObj(Tcl_Obj * dirPtr,const char * addStrRep,int len)1241 TclNewFSPathObj(
1242 Tcl_Obj *dirPtr,
1243 const char *addStrRep,
1244 int len)
1245 {
1246 FsPath *fsPathPtr;
1247 Tcl_Obj *pathPtr;
1248 const char *p;
1249 int state = 0, count = 0;
1250
1251 /* [Bug 2806250] - this is only a partial solution of the problem.
1252 * The PATHFLAGS != 0 representation assumes in many places that
1253 * the "tail" part stored in the normPathPtr field is itself a
1254 * relative path. Strings that begin with "~" are not relative paths,
1255 * so we must prevent their storage in the normPathPtr field.
1256 *
1257 * More generally we ought to be testing "addStrRep" for any value
1258 * that is not a relative path, but in an unconstrained VFS world
1259 * that could be just about anything, and testing could be expensive.
1260 * Since this routine plays a big role in [glob], anything that slows
1261 * it down would be unwelcome. For now, continue the risk of further
1262 * bugs when some Tcl_Filesystem uses otherwise relative path strings
1263 * as absolute path strings. Sensible Tcl_Filesystems will avoid
1264 * that by mounting on path prefixes like foo:// which cannot be the
1265 * name of a file or directory read from a native [glob] operation.
1266 */
1267 if (addStrRep[0] == '~') {
1268 Tcl_Obj *tail = Tcl_NewStringObj(addStrRep, len);
1269
1270 pathPtr = AppendPath(dirPtr, tail);
1271 Tcl_DecrRefCount(tail);
1272 return pathPtr;
1273 }
1274
1275 TclNewObj(pathPtr);
1276 fsPathPtr = (FsPath *)ckalloc(sizeof(FsPath));
1277
1278 /*
1279 * Set up the path.
1280 */
1281
1282 fsPathPtr->translatedPathPtr = NULL;
1283 fsPathPtr->normPathPtr = Tcl_NewStringObj(addStrRep, len);
1284 Tcl_IncrRefCount(fsPathPtr->normPathPtr);
1285 fsPathPtr->cwdPtr = dirPtr;
1286 Tcl_IncrRefCount(dirPtr);
1287 fsPathPtr->nativePathPtr = NULL;
1288 fsPathPtr->fsPtr = NULL;
1289 fsPathPtr->filesystemEpoch = 0;
1290
1291 SETPATHOBJ(pathPtr, fsPathPtr);
1292 PATHFLAGS(pathPtr) = TCLPATH_APPENDED;
1293 TclInvalidateStringRep(pathPtr);
1294
1295 /*
1296 * Look for path components made up of only "."
1297 * This is overly conservative analysis to keep simple. It may mark some
1298 * things as needing more aggressive normalization that don't actually
1299 * need it. No harm done.
1300 */
1301 for (p = addStrRep; len > 0; p++, len--) {
1302 switch (state) {
1303 case 0: /* So far only "." since last dirsep or start */
1304 switch (*p) {
1305 case '.':
1306 count++;
1307 break;
1308 case '/':
1309 case '\\':
1310 case ':':
1311 if (count) {
1312 PATHFLAGS(pathPtr) |= TCLPATH_NEEDNORM;
1313 len = 0;
1314 }
1315 break;
1316 default:
1317 count = 0;
1318 state = 1;
1319 }
1320 break;
1321 case 1: /* Scanning for next dirsep */
1322 switch (*p) {
1323 case '/':
1324 case '\\':
1325 case ':':
1326 state = 0;
1327 break;
1328 }
1329 }
1330 }
1331 if (len == 0 && count) {
1332 PATHFLAGS(pathPtr) |= TCLPATH_NEEDNORM;
1333 }
1334
1335 return pathPtr;
1336 }
1337
1338 static Tcl_Obj *
AppendPath(Tcl_Obj * head,Tcl_Obj * tail)1339 AppendPath(
1340 Tcl_Obj *head,
1341 Tcl_Obj *tail)
1342 {
1343 int numBytes;
1344 const char *bytes;
1345 Tcl_Obj *copy = Tcl_DuplicateObj(head);
1346
1347 /*
1348 * This is likely buggy when dealing with virtual filesystem drivers
1349 * that use some character other than "/" as a path separator. I know
1350 * of no evidence that such a foolish thing exists. This solution was
1351 * chosen so that "JoinPath" operations that pass through either path
1352 * intrep produce the same results; that is, bugward compatibility. If
1353 * we need to fix that bug here, it needs fixing in TclJoinPath() too.
1354 */
1355 bytes = TclGetStringFromObj(tail, &numBytes);
1356 if (numBytes == 0) {
1357 Tcl_AppendToObj(copy, "/", 1);
1358 } else {
1359 TclpNativeJoinPath(copy, bytes);
1360 }
1361 return copy;
1362 }
1363
1364 /*
1365 *---------------------------------------------------------------------------
1366 *
1367 * TclFSMakePathRelative --
1368 *
1369 * Only for internal use.
1370 *
1371 * Takes a path and a directory, where we _assume_ both path and
1372 * directory are absolute, normalized and that the path lies inside the
1373 * directory. Returns a Tcl_Obj representing filename of the path
1374 * relative to the directory.
1375 *
1376 * Results:
1377 * NULL on error, otherwise a valid object, typically with refCount of
1378 * zero, which it is assumed the caller will increment.
1379 *
1380 * Side effects:
1381 * The old representation may be freed, and new memory allocated.
1382 *
1383 *---------------------------------------------------------------------------
1384 */
1385
1386 Tcl_Obj *
TclFSMakePathRelative(TCL_UNUSED (Tcl_Interp *),Tcl_Obj * pathPtr,Tcl_Obj * cwdPtr)1387 TclFSMakePathRelative(
1388 TCL_UNUSED(Tcl_Interp *),
1389 Tcl_Obj *pathPtr, /* The path we have. */
1390 Tcl_Obj *cwdPtr) /* Make it relative to this. */
1391 {
1392 int cwdLen, len;
1393 const char *tempStr;
1394 Tcl_ObjIntRep *irPtr = TclFetchIntRep(pathPtr, &fsPathType);
1395
1396 if (irPtr) {
1397 FsPath *fsPathPtr = PATHOBJ(pathPtr);
1398
1399 if (PATHFLAGS(pathPtr) != 0 && fsPathPtr->cwdPtr == cwdPtr) {
1400 return fsPathPtr->normPathPtr;
1401 }
1402 }
1403
1404 /*
1405 * We know the cwd is a normalised object which does not end in a
1406 * directory delimiter, unless the cwd is the name of a volume, in which
1407 * case it will end in a delimiter! We handle this situation here. A
1408 * better test than the '!= sep' might be to simply check if 'cwd' is a
1409 * root volume.
1410 *
1411 * Note that if we get this wrong, we will strip off either too much or
1412 * too little below, leading to wrong answers returned by glob.
1413 */
1414
1415 tempStr = TclGetStringFromObj(cwdPtr, &cwdLen);
1416
1417 /*
1418 * Should we perhaps use 'Tcl_FSPathSeparator'? But then what about the
1419 * Windows special case? Perhaps we should just check if cwd is a root
1420 * volume.
1421 */
1422
1423 switch (tclPlatform) {
1424 case TCL_PLATFORM_UNIX:
1425 if (tempStr[cwdLen-1] != '/') {
1426 cwdLen++;
1427 }
1428 break;
1429 case TCL_PLATFORM_WINDOWS:
1430 if (tempStr[cwdLen-1] != '/' && tempStr[cwdLen-1] != '\\') {
1431 cwdLen++;
1432 }
1433 break;
1434 }
1435 tempStr = TclGetStringFromObj(pathPtr, &len);
1436
1437 return Tcl_NewStringObj(tempStr + cwdLen, len - cwdLen);
1438 }
1439
1440 /*
1441 *---------------------------------------------------------------------------
1442 *
1443 * MakePathFromNormalized --
1444 *
1445 * Like SetFsPathFromAny, but assumes the given object is an absolute
1446 * normalized path. Only for internal use.
1447 *
1448 * Results:
1449 * Standard Tcl error code.
1450 *
1451 * Side effects:
1452 * The old representation may be freed, and new memory allocated.
1453 *
1454 *---------------------------------------------------------------------------
1455 */
1456
1457 static int
MakePathFromNormalized(TCL_UNUSED (Tcl_Interp *),Tcl_Obj * pathPtr)1458 MakePathFromNormalized(
1459 TCL_UNUSED(Tcl_Interp *),
1460 Tcl_Obj *pathPtr) /* The object to convert. */
1461 {
1462 FsPath *fsPathPtr;
1463
1464 if (TclHasIntRep(pathPtr, &fsPathType)) {
1465 return TCL_OK;
1466 }
1467
1468 fsPathPtr = (FsPath *)ckalloc(sizeof(FsPath));
1469
1470 /*
1471 * It's a pure normalized absolute path.
1472 */
1473
1474 fsPathPtr->translatedPathPtr = NULL;
1475
1476 Tcl_IncrRefCount(fsPathPtr->normPathPtr = Tcl_DuplicateObj(pathPtr));
1477 fsPathPtr->cwdPtr = NULL;
1478 fsPathPtr->nativePathPtr = NULL;
1479 fsPathPtr->fsPtr = NULL;
1480 /* Remember the epoch under which we decided pathPtr was normalized */
1481 fsPathPtr->filesystemEpoch = TclFSEpoch();
1482
1483 SETPATHOBJ(pathPtr, fsPathPtr);
1484 PATHFLAGS(pathPtr) = 0;
1485
1486 return TCL_OK;
1487 }
1488
1489 /*
1490 *---------------------------------------------------------------------------
1491 *
1492 * Tcl_FSNewNativePath --
1493 *
1494 * Performs the something like the reverse of the usual
1495 * obj->path->nativerep conversions. If some code retrieves a path in
1496 * native form (from, e.g. readlink or a native dialog), and that path is
1497 * to be used at the Tcl level, then calling this function is an
1498 * efficient way of creating the appropriate path object type.
1499 *
1500 * Any memory which is allocated for 'clientData' should be retained
1501 * until clientData is passed to the filesystem's freeInternalRepProc
1502 * when it can be freed. The built in platform-specific filesystems use
1503 * 'ckalloc' to allocate clientData, and ckfree to free it.
1504 *
1505 * Results:
1506 * NULL or a valid path object pointer, with refCount zero.
1507 *
1508 * Side effects:
1509 * New memory may be allocated.
1510 *
1511 *---------------------------------------------------------------------------
1512 */
1513
1514 Tcl_Obj *
Tcl_FSNewNativePath(const Tcl_Filesystem * fromFilesystem,ClientData clientData)1515 Tcl_FSNewNativePath(
1516 const Tcl_Filesystem *fromFilesystem,
1517 ClientData clientData)
1518 {
1519 Tcl_Obj *pathPtr = NULL;
1520 FsPath *fsPathPtr;
1521
1522
1523 if (fromFilesystem->internalToNormalizedProc != NULL) {
1524 pathPtr = (*fromFilesystem->internalToNormalizedProc)(clientData);
1525 }
1526 if (pathPtr == NULL) {
1527 return NULL;
1528 }
1529
1530 /*
1531 * Free old representation; shouldn't normally be any, but best to be
1532 * safe.
1533 */
1534
1535 Tcl_StoreIntRep(pathPtr, &fsPathType, NULL);
1536 fsPathPtr = (FsPath *)ckalloc(sizeof(FsPath));
1537
1538 fsPathPtr->translatedPathPtr = NULL;
1539
1540 Tcl_IncrRefCount(fsPathPtr->normPathPtr = Tcl_DuplicateObj(pathPtr));
1541 fsPathPtr->cwdPtr = NULL;
1542 fsPathPtr->nativePathPtr = clientData;
1543 fsPathPtr->fsPtr = fromFilesystem;
1544 fsPathPtr->filesystemEpoch = TclFSEpoch();
1545
1546 SETPATHOBJ(pathPtr, fsPathPtr);
1547 PATHFLAGS(pathPtr) = 0;
1548
1549 return pathPtr;
1550 }
1551
1552 /*
1553 *---------------------------------------------------------------------------
1554 *
1555 * Tcl_FSGetTranslatedPath --
1556 *
1557 * Attempts to extract the translated path from the given
1558 * Tcl_Obj. If the translation succeeds (i.e. the object is a valid
1559 * path), then it is returned. Otherwise NULL is returned and an
1560 * error message may be left in the interpreter if it is not NULL.
1561 *
1562 * Results:
1563 * A Tcl_Obj pointer or NULL.
1564 *
1565 * Side effects:
1566 * pathPtr is converted to fsPathType if necessary.
1567 *
1568 * FsPath members are modified as needed.
1569 *
1570 *---------------------------------------------------------------------------
1571 */
1572
1573 Tcl_Obj *
Tcl_FSGetTranslatedPath(Tcl_Interp * interp,Tcl_Obj * pathPtr)1574 Tcl_FSGetTranslatedPath(
1575 Tcl_Interp *interp,
1576 Tcl_Obj *pathPtr)
1577 {
1578 Tcl_Obj *retObj = NULL;
1579 FsPath *srcFsPathPtr;
1580
1581 if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) {
1582 return NULL;
1583 }
1584 srcFsPathPtr = PATHOBJ(pathPtr);
1585 if (srcFsPathPtr->translatedPathPtr == NULL) {
1586 if (PATHFLAGS(pathPtr) == 0) {
1587 /*
1588 * Path is already normalized
1589 */
1590 retObj = srcFsPathPtr->normPathPtr;
1591 } else {
1592 /*
1593 * We lack a translated path result, but we have a directory
1594 * (cwdPtr) and a tail (normPathPtr), and if we join the
1595 * translated version of cwdPtr to normPathPtr, we'll get the
1596 * translated result we need, and can store it for future use.
1597 */
1598
1599 Tcl_Obj *translatedCwdPtr = Tcl_FSGetTranslatedPath(interp,
1600 srcFsPathPtr->cwdPtr);
1601 Tcl_ObjIntRep *translatedCwdIrPtr;
1602
1603 if (translatedCwdPtr == NULL) {
1604 return NULL;
1605 }
1606
1607 retObj = Tcl_FSJoinToPath(translatedCwdPtr, 1,
1608 &srcFsPathPtr->normPathPtr);
1609 Tcl_IncrRefCount(srcFsPathPtr->translatedPathPtr = retObj);
1610 translatedCwdIrPtr = TclFetchIntRep(translatedCwdPtr, &fsPathType);
1611 if (translatedCwdIrPtr) {
1612 srcFsPathPtr->filesystemEpoch
1613 = PATHOBJ(translatedCwdPtr)->filesystemEpoch;
1614 } else {
1615 srcFsPathPtr->filesystemEpoch = 0;
1616 }
1617 Tcl_DecrRefCount(translatedCwdPtr);
1618 }
1619 } else {
1620 /*
1621 * It is an ordinary path object.
1622 */
1623
1624 retObj = srcFsPathPtr->translatedPathPtr;
1625 }
1626
1627 if (retObj != NULL) {
1628 Tcl_IncrRefCount(retObj);
1629 }
1630 return retObj;
1631 }
1632
1633 /*
1634 *---------------------------------------------------------------------------
1635 *
1636 * Tcl_FSGetTranslatedStringPath --
1637 *
1638 * This function attempts to extract the translated path from the given
1639 * Tcl_Obj. If the translation succeeds (i.e. the object is a valid
1640 * path), then the path is returned. Otherwise NULL will be returned, and
1641 * an error message may be left in the interpreter (if it is non-NULL)
1642 *
1643 * Results:
1644 * NULL or a valid string.
1645 *
1646 * Side effects:
1647 * Only those of 'Tcl_FSConvertToPathType'
1648 *
1649 *---------------------------------------------------------------------------
1650 */
1651
1652 const char *
Tcl_FSGetTranslatedStringPath(Tcl_Interp * interp,Tcl_Obj * pathPtr)1653 Tcl_FSGetTranslatedStringPath(
1654 Tcl_Interp *interp,
1655 Tcl_Obj *pathPtr)
1656 {
1657 Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
1658
1659 if (transPtr != NULL) {
1660 int len;
1661 const char *orig = TclGetStringFromObj(transPtr, &len);
1662 char *result = (char *)ckalloc(len+1);
1663
1664 memcpy(result, orig, len+1);
1665 TclDecrRefCount(transPtr);
1666 return result;
1667 }
1668
1669 return NULL;
1670 }
1671
1672 /*
1673 *---------------------------------------------------------------------------
1674 *
1675 * Tcl_FSGetNormalizedPath --
1676 *
1677 * This important function attempts to extract from the given Tcl_Obj a
1678 * unique normalised path representation, whose string value can be used
1679 * as a unique identifier for the file.
1680 *
1681 * Results:
1682 * NULL or a valid path object pointer.
1683 *
1684 * Side effects:
1685 * New memory may be allocated. The Tcl 'errno' may be modified in the
1686 * process of trying to examine various path possibilities.
1687 *
1688 *---------------------------------------------------------------------------
1689 */
1690
1691 Tcl_Obj *
Tcl_FSGetNormalizedPath(Tcl_Interp * interp,Tcl_Obj * pathPtr)1692 Tcl_FSGetNormalizedPath(
1693 Tcl_Interp *interp,
1694 Tcl_Obj *pathPtr)
1695 {
1696 FsPath *fsPathPtr;
1697
1698 if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) {
1699 return NULL;
1700 }
1701 fsPathPtr = PATHOBJ(pathPtr);
1702
1703 if (PATHFLAGS(pathPtr) != 0) {
1704 /*
1705 * This is a special path object which is the result of something like
1706 * 'file join'
1707 */
1708
1709 Tcl_Obj *dir, *copy;
1710 int tailLen, cwdLen, pathType;
1711
1712 pathType = Tcl_FSGetPathType(fsPathPtr->cwdPtr);
1713 dir = Tcl_FSGetNormalizedPath(interp, fsPathPtr->cwdPtr);
1714 if (dir == NULL) {
1715 return NULL;
1716 }
1717 /* TODO: Figure out why this is needed. */
1718 TclGetString(pathPtr);
1719
1720 TclGetStringFromObj(fsPathPtr->normPathPtr, &tailLen);
1721 if (tailLen) {
1722 copy = AppendPath(dir, fsPathPtr->normPathPtr);
1723 } else {
1724 copy = Tcl_DuplicateObj(dir);
1725 }
1726 Tcl_IncrRefCount(dir);
1727 Tcl_IncrRefCount(copy);
1728
1729 /*
1730 * We now own a reference on both 'dir' and 'copy'
1731 */
1732
1733 (void) TclGetStringFromObj(dir, &cwdLen);
1734
1735 /* Normalize the combined string. */
1736
1737 if (PATHFLAGS(pathPtr) & TCLPATH_NEEDNORM) {
1738 /*
1739 * If the "tail" part has components (like /../) that cause the
1740 * combined path to need more complete normalizing, call on the
1741 * more powerful routine to accomplish that so we avoid [Bug
1742 * 2385549] ...
1743 */
1744
1745 Tcl_Obj *newCopy = TclFSNormalizeAbsolutePath(interp, copy);
1746
1747 Tcl_DecrRefCount(copy);
1748 copy = newCopy;
1749 } else {
1750 /*
1751 * ... but in most cases where we join a trouble free tail to a
1752 * normalized head, we can more efficiently normalize the combined
1753 * path by passing over only the unnormalized tail portion. When
1754 * this is sufficient, prior developers claim this should be much
1755 * faster. We use 'cwdLen' so that we are already pointing at
1756 * the dir-separator that we know about. The normalization code
1757 * will actually start off directly after that separator.
1758 */
1759
1760 TclFSNormalizeToUniquePath(interp, copy, cwdLen);
1761 }
1762
1763 /* Now we need to construct the new path object. */
1764
1765 if (pathType == TCL_PATH_RELATIVE) {
1766 Tcl_Obj *origDir = fsPathPtr->cwdPtr;
1767
1768 /*
1769 * NOTE: here we are (dangerously?) assuming that origDir points
1770 * to a Tcl_Obj with Tcl_ObjType == &fsPathType. The
1771 * pathType = Tcl_FSGetPathType(fsPathPtr->cwdPtr);
1772 * above that set the pathType value should have established that,
1773 * but it's far less clear on what basis we know there's been no
1774 * shimmering since then.
1775 */
1776
1777 FsPath *origDirFsPathPtr = PATHOBJ(origDir);
1778
1779 fsPathPtr->cwdPtr = origDirFsPathPtr->cwdPtr;
1780 Tcl_IncrRefCount(fsPathPtr->cwdPtr);
1781
1782 TclDecrRefCount(fsPathPtr->normPathPtr);
1783 fsPathPtr->normPathPtr = copy;
1784
1785 TclDecrRefCount(dir);
1786 TclDecrRefCount(origDir);
1787 } else {
1788 TclDecrRefCount(fsPathPtr->cwdPtr);
1789 fsPathPtr->cwdPtr = NULL;
1790 TclDecrRefCount(fsPathPtr->normPathPtr);
1791 fsPathPtr->normPathPtr = copy;
1792
1793 TclDecrRefCount(dir);
1794 }
1795 PATHFLAGS(pathPtr) = 0;
1796 }
1797
1798 /*
1799 * Ensure cwd hasn't changed.
1800 */
1801
1802 if (fsPathPtr->cwdPtr != NULL) {
1803 if (!TclFSCwdPointerEquals(&fsPathPtr->cwdPtr)) {
1804 TclGetString(pathPtr);
1805 Tcl_StoreIntRep(pathPtr, &fsPathType, NULL);
1806 if (SetFsPathFromAny(interp, pathPtr) != TCL_OK) {
1807 return NULL;
1808 }
1809 fsPathPtr = PATHOBJ(pathPtr);
1810 } else if (fsPathPtr->normPathPtr == NULL) {
1811 int cwdLen;
1812 Tcl_Obj *copy;
1813
1814 copy = AppendPath(fsPathPtr->cwdPtr, pathPtr);
1815
1816 (void) TclGetStringFromObj(fsPathPtr->cwdPtr, &cwdLen);
1817 cwdLen += (Tcl_GetString(copy)[cwdLen] == '/');
1818
1819 /*
1820 * Normalize the combined string, but only starting after the end
1821 * of the previously normalized 'dir'. This should be much faster!
1822 */
1823
1824 TclFSNormalizeToUniquePath(interp, copy, cwdLen-1);
1825 fsPathPtr->normPathPtr = copy;
1826 Tcl_IncrRefCount(fsPathPtr->normPathPtr);
1827 }
1828 }
1829 if (fsPathPtr->normPathPtr == NULL) {
1830 Tcl_Obj *useThisCwd = NULL;
1831
1832 /*
1833 * Since normPathPtr is NULL but this is a valid path object, we know
1834 * that the translatedPathPtr cannot be NULL.
1835 */
1836
1837 Tcl_Obj *absolutePath = fsPathPtr->translatedPathPtr;
1838 const char *path = TclGetString(absolutePath);
1839
1840 Tcl_IncrRefCount(absolutePath);
1841
1842 /*
1843 * We have to be a little bit careful here to avoid infinite loops
1844 * we're asking Tcl_FSGetPathType to return the path's type, but that
1845 * call can actually result in a lot of other filesystem action, which
1846 * might loop back through here.
1847 */
1848
1849 if (path[0] == '\0') {
1850 /*
1851 * Special handling for the empty string value. This one is very
1852 * weird with [file normalize {}] => {}. (The reasoning supporting
1853 * this is unknown to DGP, but he fears changing it.) Attempt here
1854 * to keep the expectations of other parts of Tcl_Filesystem code
1855 * about state of the FsPath fields satisfied.
1856 *
1857 * In particular, capture the cwd value and save so it can be
1858 * stored in the cwdPtr field below.
1859 */
1860
1861 useThisCwd = Tcl_FSGetCwd(interp);
1862 } else {
1863 /*
1864 * We don't ask for the type of 'pathPtr' here, because that is
1865 * not correct for our purposes when we have a path like '~'. Tcl
1866 * has a bit of a contradiction in that '~' paths are defined as
1867 * 'absolute', but in reality can be just about anything,
1868 * depending on how env(HOME) is set.
1869 */
1870
1871 Tcl_PathType type = Tcl_FSGetPathType(absolutePath);
1872
1873 if (type == TCL_PATH_RELATIVE) {
1874 useThisCwd = Tcl_FSGetCwd(interp);
1875
1876 if (useThisCwd == NULL) {
1877 return NULL;
1878 }
1879
1880 Tcl_DecrRefCount(absolutePath);
1881 absolutePath = Tcl_FSJoinToPath(useThisCwd, 1, &absolutePath);
1882 Tcl_IncrRefCount(absolutePath);
1883
1884 /*
1885 * We have a refCount on the cwd.
1886 */
1887 #ifdef _WIN32
1888 } else if (type == TCL_PATH_VOLUME_RELATIVE) {
1889 /*
1890 * Only Windows has volume-relative paths.
1891 */
1892
1893 Tcl_DecrRefCount(absolutePath);
1894 absolutePath = TclWinVolumeRelativeNormalize(interp,
1895 path, &useThisCwd);
1896 if (absolutePath == NULL) {
1897 return NULL;
1898 }
1899 #endif /* _WIN32 */
1900 }
1901 }
1902
1903 /*
1904 * Already has refCount incremented.
1905 */
1906
1907 if (fsPathPtr->normPathPtr) {
1908 Tcl_DecrRefCount(fsPathPtr->normPathPtr);
1909 }
1910 fsPathPtr->normPathPtr = TclFSNormalizeAbsolutePath(interp,
1911 absolutePath);
1912
1913 if (useThisCwd != NULL) {
1914 /*
1915 * We just need to free an object we allocated above for relative
1916 * paths (this was returned by Tcl_FSJoinToPath above), and then
1917 * of course store the cwd.
1918 */
1919
1920 fsPathPtr->cwdPtr = useThisCwd;
1921 }
1922 TclDecrRefCount(absolutePath);
1923 }
1924
1925 return fsPathPtr->normPathPtr;
1926 }
1927
1928 /*
1929 *---------------------------------------------------------------------------
1930 *
1931 * Tcl_FSGetInternalRep --
1932 *
1933 * Produces a native representation of a given path object in the given
1934 * filesystem.
1935 *
1936 * In the future it might be desirable to have separate versions
1937 * of this function with different signatures, for example
1938 * Tcl_FSGetNativeWinPath, Tcl_FSGetNativeUnixPath etc. Right now, since
1939 * native paths are all string based, we use just one function.
1940 *
1941 * Results:
1942 *
1943 * The native handle for the path, or NULL if the path is not handled by
1944 * the given filesystem
1945 *
1946 * Side effects:
1947 *
1948 * Tcl_FSCreateInternalRepProc if needed to produce the native
1949 * handle, which is then stored in the internal representation of pathPtr.
1950 *
1951 *---------------------------------------------------------------------------
1952 */
1953
1954 ClientData
Tcl_FSGetInternalRep(Tcl_Obj * pathPtr,const Tcl_Filesystem * fsPtr)1955 Tcl_FSGetInternalRep(
1956 Tcl_Obj *pathPtr,
1957 const Tcl_Filesystem *fsPtr)
1958 {
1959 FsPath *srcFsPathPtr;
1960
1961 if (Tcl_FSConvertToPathType(NULL, pathPtr) != TCL_OK) {
1962 return NULL;
1963 }
1964 srcFsPathPtr = PATHOBJ(pathPtr);
1965
1966 /*
1967 * Currently there must be a unique bi-directional mapping between a path
1968 * and a filesystem, and therefore there is no way to "remap" a file, i.e.,
1969 * to map a file in one filesystem into another. Another way of putting
1970 * this is that 'stacked' filesystems are not allowed. It could be useful
1971 * in the future to redesign the system to allow that.
1972 *
1973 * Even something simple like a 'pass through' filesystem which logs all
1974 * activity and passes the calls onto the native system would be nice, but
1975 * not currently easily achievable.
1976 */
1977
1978 if (srcFsPathPtr->fsPtr == NULL) {
1979 Tcl_FSGetFileSystemForPath(pathPtr);
1980
1981 srcFsPathPtr = PATHOBJ(pathPtr);
1982 if (srcFsPathPtr->fsPtr == NULL) {
1983 /*
1984 * The path is probably not a valid path in the filesystsem, and is
1985 * most likely to be a use of the empty path "" via a direct call
1986 * to one of the objectified interfaces (e.g. from the Tcl
1987 * testsuite).
1988 */
1989 return NULL;
1990 }
1991 }
1992
1993 /*
1994 * If the file belongs to a different filesystem, perhaps it is actually
1995 * linked through to a file in the given filesystem. Check this by
1996 * inspecting the filesystem associated with the given path.
1997 */
1998
1999 if (fsPtr != srcFsPathPtr->fsPtr) {
2000 const Tcl_Filesystem *actualFs = Tcl_FSGetFileSystemForPath(pathPtr);
2001
2002 if (actualFs == fsPtr) {
2003 return Tcl_FSGetInternalRep(pathPtr, fsPtr);
2004 }
2005 return NULL;
2006 }
2007
2008 if (srcFsPathPtr->nativePathPtr == NULL) {
2009 Tcl_FSCreateInternalRepProc *proc;
2010 char *nativePathPtr;
2011
2012 proc = srcFsPathPtr->fsPtr->createInternalRepProc;
2013 if (proc == NULL) {
2014 return NULL;
2015 }
2016
2017 nativePathPtr = (char *)proc(pathPtr);
2018 srcFsPathPtr = PATHOBJ(pathPtr);
2019 srcFsPathPtr->nativePathPtr = nativePathPtr;
2020 srcFsPathPtr->filesystemEpoch = TclFSEpoch();
2021 }
2022
2023 return srcFsPathPtr->nativePathPtr;
2024 }
2025
2026 /*
2027 *---------------------------------------------------------------------------
2028 *
2029 * TclFSEnsureEpochOk --
2030 *
2031 * Ensure that the path is a valid path, and that it has a
2032 * fsPathType internal representation that is not stale.
2033 *
2034 * Results:
2035 * A standard Tcl return code.
2036 *
2037 * Side effects:
2038 * The internal representation of fsPtrPtr is converted to fsPathType if
2039 * possible.
2040 *
2041 *---------------------------------------------------------------------------
2042 */
2043
2044 int
TclFSEnsureEpochOk(Tcl_Obj * pathPtr,const Tcl_Filesystem ** fsPtrPtr)2045 TclFSEnsureEpochOk(
2046 Tcl_Obj *pathPtr,
2047 const Tcl_Filesystem **fsPtrPtr)
2048 {
2049 FsPath *srcFsPathPtr;
2050
2051 if (!TclHasIntRep(pathPtr, &fsPathType)) {
2052 return TCL_OK;
2053 }
2054
2055 srcFsPathPtr = PATHOBJ(pathPtr);
2056
2057 if (!TclFSEpochOk(srcFsPathPtr->filesystemEpoch)) {
2058 /*
2059 * The filesystem has changed in some way since the internal
2060 * representation for this object was calculated. Discard the stale
2061 * representation and recalculate it.
2062 */
2063
2064 TclGetString(pathPtr);
2065 Tcl_StoreIntRep(pathPtr, &fsPathType, NULL);
2066 if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) {
2067 return TCL_ERROR;
2068 }
2069 srcFsPathPtr = PATHOBJ(pathPtr);
2070 }
2071
2072 if (srcFsPathPtr->fsPtr != NULL) {
2073 /*
2074 * There is already a filesystem assigned to this path.
2075 */
2076 *fsPtrPtr = srcFsPathPtr->fsPtr;
2077 }
2078 return TCL_OK;
2079 }
2080
2081 /*
2082 *---------------------------------------------------------------------------
2083 *
2084 * TclFSSetPathDetails --
2085 *
2086 * ???
2087 *
2088 * Results:
2089 * None
2090 *
2091 * Side effects:
2092 * ???
2093 *
2094 *---------------------------------------------------------------------------
2095 */
2096
2097 void
TclFSSetPathDetails(Tcl_Obj * pathPtr,const Tcl_Filesystem * fsPtr,ClientData clientData)2098 TclFSSetPathDetails(
2099 Tcl_Obj *pathPtr,
2100 const Tcl_Filesystem *fsPtr,
2101 ClientData clientData)
2102 {
2103 FsPath *srcFsPathPtr;
2104
2105 /*
2106 * Make sure pathPtr is of the correct type.
2107 */
2108
2109 if (!TclHasIntRep(pathPtr, &fsPathType)) {
2110 if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) {
2111 return;
2112 }
2113 }
2114
2115 srcFsPathPtr = PATHOBJ(pathPtr);
2116 srcFsPathPtr->fsPtr = fsPtr;
2117 srcFsPathPtr->nativePathPtr = clientData;
2118 srcFsPathPtr->filesystemEpoch = TclFSEpoch();
2119 }
2120
2121 /*
2122 *---------------------------------------------------------------------------
2123 *
2124 * Tcl_FSEqualPaths --
2125 *
2126 * This function tests whether the two paths given are equal path
2127 * objects. If either or both is NULL, 0 is always returned.
2128 *
2129 * Results:
2130 * 1 or 0.
2131 *
2132 * Side effects:
2133 * None.
2134 *
2135 *---------------------------------------------------------------------------
2136 */
2137
2138 int
Tcl_FSEqualPaths(Tcl_Obj * firstPtr,Tcl_Obj * secondPtr)2139 Tcl_FSEqualPaths(
2140 Tcl_Obj *firstPtr,
2141 Tcl_Obj *secondPtr)
2142 {
2143 const char *firstStr, *secondStr;
2144 int firstLen, secondLen, tempErrno;
2145
2146 if (firstPtr == secondPtr) {
2147 return 1;
2148 }
2149
2150 if (firstPtr == NULL || secondPtr == NULL) {
2151 return 0;
2152 }
2153 firstStr = TclGetStringFromObj(firstPtr, &firstLen);
2154 secondStr = TclGetStringFromObj(secondPtr, &secondLen);
2155 if ((firstLen == secondLen) && !memcmp(firstStr, secondStr, firstLen)) {
2156 return 1;
2157 }
2158
2159 /*
2160 * Try the most thorough, correct method of comparing fully normalized
2161 * paths.
2162 */
2163
2164 tempErrno = Tcl_GetErrno();
2165 firstPtr = Tcl_FSGetNormalizedPath(NULL, firstPtr);
2166 secondPtr = Tcl_FSGetNormalizedPath(NULL, secondPtr);
2167 Tcl_SetErrno(tempErrno);
2168
2169 if (firstPtr == NULL || secondPtr == NULL) {
2170 return 0;
2171 }
2172
2173 firstStr = TclGetStringFromObj(firstPtr, &firstLen);
2174 secondStr = TclGetStringFromObj(secondPtr, &secondLen);
2175 return ((firstLen == secondLen) && !memcmp(firstStr, secondStr, firstLen));
2176 }
2177
2178 /*
2179 *---------------------------------------------------------------------------
2180 *
2181 * SetFsPathFromAny --
2182 *
2183 * Attempt to convert the internal representation of pathPtr to
2184 * fsPathType.
2185 *
2186 * A tilde ("~") character at the beginnig of the filename indicates the
2187 * current user's home directory, and "~<user>" indicates a particular
2188 * user's directory.
2189 *
2190 * Results:
2191 * Standard Tcl error code.
2192 *
2193 * Side effects:
2194 * The old representation may be freed, and new memory allocated.
2195 *
2196 *---------------------------------------------------------------------------
2197 */
2198
2199 static int
SetFsPathFromAny(Tcl_Interp * interp,Tcl_Obj * pathPtr)2200 SetFsPathFromAny(
2201 Tcl_Interp *interp, /* Used for error reporting if not NULL. */
2202 Tcl_Obj *pathPtr) /* The object to convert. */
2203 {
2204 int len;
2205 FsPath *fsPathPtr;
2206 Tcl_Obj *transPtr;
2207 const char *name;
2208
2209 if (TclHasIntRep(pathPtr, &fsPathType)) {
2210 return TCL_OK;
2211 }
2212
2213 /*
2214 * First step is to translate the filename. This is similar to
2215 * Tcl_TranslateFilename, but shouldn't convert everything to windows
2216 * backslashes on that platform. The current implementation of this piece
2217 * is a slightly optimised version of the various Tilde/Split/Join stuff
2218 * to avoid multiple split/join operations.
2219 *
2220 * We remove any trailing directory separator.
2221 *
2222 * However, the split/join routines are quite complex, and one has to make
2223 * sure not to break anything on Unix or Win (fCmd.test, fileName.test and
2224 * cmdAH.test exercise most of the code).
2225 */
2226
2227 name = TclGetStringFromObj(pathPtr, &len);
2228
2229 /*
2230 * Handle tilde substitutions, if needed.
2231 */
2232
2233 if (len && name[0] == '~') {
2234 Tcl_DString temp;
2235 int split;
2236 char separator = '/';
2237
2238 /*
2239 * We have multiple cases '~/foo/bar...', '~user/foo/bar...', etc.
2240 * split becomes value 1 for '~/...' as well as for '~'.
2241 */
2242 split = FindSplitPos(name, separator);
2243
2244 /*
2245 * Do some tilde substitution.
2246 */
2247
2248 if (split == 1) {
2249 /*
2250 * We have just '~' (or '~/...')
2251 */
2252
2253 const char *dir;
2254 Tcl_DString dirString;
2255
2256 dir = TclGetEnv("HOME", &dirString);
2257 if (dir == NULL) {
2258 if (interp) {
2259 Tcl_SetObjResult(interp, Tcl_NewStringObj(
2260 "couldn't find HOME environment variable to"
2261 " expand path", -1));
2262 Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH",
2263 "HOMELESS", NULL);
2264 }
2265 return TCL_ERROR;
2266 }
2267 Tcl_DStringInit(&temp);
2268 Tcl_JoinPath(1, &dir, &temp);
2269 Tcl_DStringFree(&dirString);
2270 } else {
2271 /*
2272 * There is a '~user'
2273 */
2274
2275 const char *expandedUser;
2276 Tcl_DString userName;
2277
2278 Tcl_DStringInit(&userName);
2279 Tcl_DStringAppend(&userName, name+1, split-1);
2280 expandedUser = Tcl_DStringValue(&userName);
2281
2282 Tcl_DStringInit(&temp);
2283 if (TclpGetUserHome(expandedUser, &temp) == NULL) {
2284 if (interp != NULL) {
2285 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
2286 "user \"%s\" doesn't exist", expandedUser));
2287 Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "NOUSER",
2288 NULL);
2289 }
2290 Tcl_DStringFree(&userName);
2291 Tcl_DStringFree(&temp);
2292 return TCL_ERROR;
2293 }
2294 Tcl_DStringFree(&userName);
2295 }
2296
2297 transPtr = TclDStringToObj(&temp);
2298
2299 if (split != len) {
2300 /*
2301 * Join up the tilde substitution with the rest.
2302 */
2303
2304 if (name[split+1] == separator) {
2305 /*
2306 * Somewhat tricky case like ~//foo/bar. Make use of
2307 * Split/Join machinery to get it right. Assumes all paths
2308 * beginning with ~ are part of the native filesystem.
2309 */
2310
2311 int objc;
2312 Tcl_Obj **objv;
2313 Tcl_Obj *parts = TclpNativeSplitPath(pathPtr, NULL);
2314
2315 Tcl_ListObjGetElements(NULL, parts, &objc, &objv);
2316
2317 /*
2318 * Skip '~'. It's replaced by its expansion.
2319 */
2320
2321 objc--; objv++;
2322 while (objc--) {
2323 TclpNativeJoinPath(transPtr, Tcl_GetString(*objv++));
2324 }
2325 TclDecrRefCount(parts);
2326 } else {
2327 Tcl_Obj *pair[2];
2328
2329 pair[0] = transPtr;
2330 pair[1] = Tcl_NewStringObj(name+split+1, -1);
2331 transPtr = TclJoinPath(2, pair, 1);
2332 if (transPtr != pair[0]) {
2333 Tcl_DecrRefCount(pair[0]);
2334 }
2335 if (transPtr != pair[1]) {
2336 Tcl_DecrRefCount(pair[1]);
2337 }
2338 }
2339 }
2340 } else {
2341 transPtr = TclJoinPath(1, &pathPtr, 1);
2342 }
2343
2344 /*
2345 * Now we have a translated filename in 'transPtr'. This will have forward
2346 * slashes on Windows, and will not contain any ~user sequences.
2347 */
2348
2349 fsPathPtr = (FsPath *)ckalloc(sizeof(FsPath));
2350
2351 if (transPtr == pathPtr) {
2352 transPtr = Tcl_DuplicateObj(pathPtr);
2353 fsPathPtr->filesystemEpoch = 0;
2354 } else {
2355 fsPathPtr->filesystemEpoch = TclFSEpoch();
2356 }
2357 Tcl_IncrRefCount(transPtr);
2358 fsPathPtr->translatedPathPtr = transPtr;
2359 fsPathPtr->normPathPtr = NULL;
2360 fsPathPtr->cwdPtr = NULL;
2361 fsPathPtr->nativePathPtr = NULL;
2362 fsPathPtr->fsPtr = NULL;
2363
2364 SETPATHOBJ(pathPtr, fsPathPtr);
2365 PATHFLAGS(pathPtr) = 0;
2366 return TCL_OK;
2367 }
2368
2369 static void
FreeFsPathInternalRep(Tcl_Obj * pathPtr)2370 FreeFsPathInternalRep(
2371 Tcl_Obj *pathPtr) /* Path object with internal rep to free. */
2372 {
2373 FsPath *fsPathPtr = PATHOBJ(pathPtr);
2374
2375 if (fsPathPtr->translatedPathPtr != NULL) {
2376 if (fsPathPtr->translatedPathPtr != pathPtr) {
2377 TclDecrRefCount(fsPathPtr->translatedPathPtr);
2378 }
2379 }
2380 if (fsPathPtr->normPathPtr != NULL) {
2381 if (fsPathPtr->normPathPtr != pathPtr) {
2382 TclDecrRefCount(fsPathPtr->normPathPtr);
2383 }
2384 fsPathPtr->normPathPtr = NULL;
2385 }
2386 if (fsPathPtr->cwdPtr != NULL) {
2387 TclDecrRefCount(fsPathPtr->cwdPtr);
2388 fsPathPtr->cwdPtr = NULL;
2389 }
2390 if (fsPathPtr->nativePathPtr != NULL && fsPathPtr->fsPtr != NULL) {
2391 Tcl_FSFreeInternalRepProc *freeProc =
2392 fsPathPtr->fsPtr->freeInternalRepProc;
2393
2394 if (freeProc != NULL) {
2395 freeProc(fsPathPtr->nativePathPtr);
2396 fsPathPtr->nativePathPtr = NULL;
2397 }
2398 }
2399
2400 ckfree(fsPathPtr);
2401 }
2402
2403 static void
DupFsPathInternalRep(Tcl_Obj * srcPtr,Tcl_Obj * copyPtr)2404 DupFsPathInternalRep(
2405 Tcl_Obj *srcPtr, /* Path obj with internal rep to copy. */
2406 Tcl_Obj *copyPtr) /* Path obj with internal rep to set. */
2407 {
2408 FsPath *srcFsPathPtr = PATHOBJ(srcPtr);
2409 FsPath *copyFsPathPtr = (FsPath *)ckalloc(sizeof(FsPath));
2410
2411 SETPATHOBJ(copyPtr, copyFsPathPtr);
2412
2413 copyFsPathPtr->translatedPathPtr = srcFsPathPtr->translatedPathPtr;
2414 if (copyFsPathPtr->translatedPathPtr != NULL) {
2415 Tcl_IncrRefCount(copyFsPathPtr->translatedPathPtr);
2416 }
2417
2418 copyFsPathPtr->normPathPtr = srcFsPathPtr->normPathPtr;
2419 if (copyFsPathPtr->normPathPtr != NULL) {
2420 Tcl_IncrRefCount(copyFsPathPtr->normPathPtr);
2421 }
2422
2423 copyFsPathPtr->cwdPtr = srcFsPathPtr->cwdPtr;
2424 if (copyFsPathPtr->cwdPtr != NULL) {
2425 Tcl_IncrRefCount(copyFsPathPtr->cwdPtr);
2426 }
2427
2428 copyFsPathPtr->flags = srcFsPathPtr->flags;
2429
2430 if (srcFsPathPtr->fsPtr != NULL
2431 && srcFsPathPtr->nativePathPtr != NULL) {
2432 Tcl_FSDupInternalRepProc *dupProc =
2433 srcFsPathPtr->fsPtr->dupInternalRepProc;
2434
2435 if (dupProc != NULL) {
2436 copyFsPathPtr->nativePathPtr =
2437 dupProc(srcFsPathPtr->nativePathPtr);
2438 } else {
2439 copyFsPathPtr->nativePathPtr = NULL;
2440 }
2441 } else {
2442 copyFsPathPtr->nativePathPtr = NULL;
2443 }
2444 copyFsPathPtr->fsPtr = srcFsPathPtr->fsPtr;
2445 copyFsPathPtr->filesystemEpoch = srcFsPathPtr->filesystemEpoch;
2446 }
2447
2448 /*
2449 *---------------------------------------------------------------------------
2450 *
2451 * UpdateStringOfFsPath --
2452 *
2453 * Gives an object a valid string rep.
2454 *
2455 * Results:
2456 * None.
2457 *
2458 * Side effects:
2459 * Memory may be allocated.
2460 *
2461 *---------------------------------------------------------------------------
2462 */
2463
2464 static void
UpdateStringOfFsPath(Tcl_Obj * pathPtr)2465 UpdateStringOfFsPath(
2466 Tcl_Obj *pathPtr) /* path obj with string rep to update. */
2467 {
2468 FsPath *fsPathPtr = PATHOBJ(pathPtr);
2469 int cwdLen;
2470 Tcl_Obj *copy;
2471
2472 if (PATHFLAGS(pathPtr) == 0 || fsPathPtr->cwdPtr == NULL) {
2473 Tcl_Panic("Called UpdateStringOfFsPath with invalid object");
2474 }
2475
2476 copy = AppendPath(fsPathPtr->cwdPtr, fsPathPtr->normPathPtr);
2477 if (Tcl_IsShared(copy)) {
2478 copy = Tcl_DuplicateObj(copy);
2479 }
2480
2481 Tcl_IncrRefCount(copy);
2482 /* Steal copy's string rep */
2483 pathPtr->bytes = TclGetStringFromObj(copy, &cwdLen);
2484 pathPtr->length = cwdLen;
2485 TclInitStringRep(copy, NULL, 0);
2486 TclDecrRefCount(copy);
2487 }
2488
2489 /*
2490 *---------------------------------------------------------------------------
2491 *
2492 * TclNativePathInFilesystem --
2493 *
2494 * Any path object is acceptable to the native filesystem, by default (we
2495 * will throw errors when illegal paths are actually tried to be used).
2496 *
2497 * However, this behavior means the native filesystem must be the last
2498 * filesystem in the lookup list (otherwise it will claim all files
2499 * belong to it, and other filesystems will never get a look in).
2500 *
2501 * Results:
2502 * TCL_OK, to indicate 'yes', -1 to indicate no.
2503 *
2504 * Side effects:
2505 * None.
2506 *
2507 *---------------------------------------------------------------------------
2508 */
2509
2510 int
TclNativePathInFilesystem(Tcl_Obj * pathPtr,TCL_UNUSED (ClientData *))2511 TclNativePathInFilesystem(
2512 Tcl_Obj *pathPtr,
2513 TCL_UNUSED(ClientData *))
2514 {
2515 /*
2516 * A special case is required to handle the empty path "". This is a valid
2517 * path (i.e. the user should be able to do 'file exists ""' without
2518 * throwing an error), but equally the path doesn't exist. Those are the
2519 * semantics of Tcl (at present anyway), so we have to abide by them here.
2520 */
2521
2522 if (TclHasIntRep(pathPtr, &fsPathType)) {
2523 if (pathPtr->bytes != NULL && pathPtr->bytes[0] == '\0') {
2524 /*
2525 * We reject the empty path "".
2526 */
2527
2528 return -1;
2529 }
2530
2531 /*
2532 * Otherwise there is no way this path can be empty.
2533 */
2534 } else {
2535 /*
2536 * It is somewhat unusual to reach this code path without the object
2537 * being of fsPathType. However, we do our best to deal with the
2538 * situation.
2539 */
2540
2541 int len;
2542
2543 (void) TclGetStringFromObj(pathPtr, &len);
2544 if (len == 0) {
2545 /*
2546 * We reject the empty path "".
2547 */
2548
2549 return -1;
2550 }
2551 }
2552
2553 /*
2554 * Path is of correct type, or is of non-zero length, so we accept it.
2555 */
2556
2557 return TCL_OK;
2558 }
2559
2560 /*
2561 * Local Variables:
2562 * mode: c
2563 * c-basic-offset: 4
2564 * fill-column: 78
2565 * End:
2566 */
2567