Tcl Source Code

Check-in [945ecdbfcd]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:refactoring normalize in case of second path starting with tilde (~/~foo) - force second path as relative by join (provide normalize flag for TclJoinPath); test cases extended
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | bug-7a9dc52b29
Files: files | file ages | folders
SHA3-256: 945ecdbfcdd2e81c291c0f1d25ba9af005337655491fa208280089b0584f672f
User & Date: sebres 2018-11-20 20:11:02
Context
2018-11-20
20:23
win: fixes case sensitivity of glob test cases (winFile-2.*): current directory can be different as ... check-in: 2897840177 user: sebres tags: bug-7a9dc52b29
20:11
refactoring normalize in case of second path starting with tilde (~/~foo) - force second path as rel... check-in: 945ecdbfcd user: sebres tags: bug-7a9dc52b29
18:02
fixes segfault [7a9dc52b29]: unexpected decrement of the ref-count after TclJoinPath check-in: 10e9bd8b12 user: sebres tags: bug-7a9dc52b29
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclPathObj.c.

817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851


852
853
854
855
856
857
858
...
871
872
873
874
875
876
877
878
879
880
881
882
883

884
885
886
887
888
889
890
891
...
949
950
951
952
953
954
955

956
957
958
959
960
961
962
963
....
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425


2426
2427
2428
2429

2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
....
2457
2458
2459
2460
2461
2462
2463






2464
2465
2466
2467
2468
2469
2470

2471
2472
2473
2474
2475
2476
2477
2478
2479

2480
2481
2482
2483
2484
2485
2486
....
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj * TclJoinPath(int elements, Tcl_Obj * const objv[]);

Tcl_Obj *
Tcl_FSJoinPath(
    Tcl_Obj *listObj,		/* Path elements to join, may have a zero
				 * reference count. */
    int elements)		/* Number of elements to use (-1 = all) */
{
    Tcl_Obj *copy, *res;
    int objc;
    Tcl_Obj **objv;

    if (Tcl_ListObjLength(NULL, listObj, &objc) != TCL_OK) {
	return NULL;
    }

    elements = ((elements >= 0) && (elements <= objc)) ? elements : objc;
    copy = TclListObjCopy(NULL, listObj);
    Tcl_ListObjGetElements(NULL, listObj, &objc, &objv);
    res = TclJoinPath(elements, objv);
    Tcl_DecrRefCount(copy);
    return res;
}

Tcl_Obj *
TclJoinPath(
    int elements,
    Tcl_Obj * const objv[])


{
    Tcl_Obj *res = NULL;	/* Resulting path object (container of join) */
    Tcl_Obj *elt;		/* Path part (result if returns part of path) */
    int i;
    Tcl_Filesystem *fsPtr = NULL;

    for (i = 0; i < elements; i++) {
................................................................................
	 * use the special case when we have exactly two elements, but we
	 * could expand that in the future.
         *
         * Bugfix [a47641a0]. TclNewFSPathObj requires first argument
         * to be an absolute path. Added a check for that elt is absolute.
	 */

	if ((i == (elements-2)) && (i == 0)
                && (elt->typePtr == &tclFsPathType)
		&& !((elt->bytes != NULL) && (elt->bytes[0] == '\0'))
                && TclGetPathType(elt, NULL, NULL, NULL) == TCL_PATH_ABSOLUTE) {
            Tcl_Obj *tailObj = objv[i+1];


	    type = TclGetPathType(tailObj, NULL, NULL, NULL);
	    if (type == TCL_PATH_RELATIVE) {
		const char *str;
		int len;

		str = Tcl_GetStringFromObj(tailObj, &len);
		if (len == 0) {
		    /*
................................................................................
			goto partReturn; /* return elt; */
		    }
		}
	    }
	}
	strElt = Tcl_GetStringFromObj(elt, &strEltLen);
	driveNameLength = 0;

	type = TclGetPathType(elt, &fsPtr, &driveNameLength, &driveName);
	if (type != TCL_PATH_RELATIVE) {
	    /*
	     * Zero out the current result.
	     */

	    if (res != NULL) {
		TclDecrRefCount(res);
................................................................................

    name = Tcl_GetStringFromObj(pathPtr, &len);

    /*
     * Handle tilde substitutions, if needed.
     */

    if (name[0] == '~') {
	char *expandedUser;
	Tcl_DString temp;
	int split;
	char separator = '/';

	split = FindSplitPos(name, separator);
	if (split != len) {
	    /*
	     * We have multiple pieces '~user/foo/bar...'


	     */

	    name[split] = '\0';
	}


	/*
	 * Do some tilde substitution.
	 */

	if (name[1] == '\0') {
	    /*
	     * We have just '~'
	     */

	    const char *dir;
	    Tcl_DString dirString;

	    if (split != len) {
		name[split] = separator;
	    }

	    dir = TclGetEnv("HOME", &dirString);
	    if (dir == NULL) {
		if (interp) {
		    Tcl_ResetResult(interp);
		    Tcl_AppendResult(interp, "couldn't find HOME environment "
			    "variable to expand path", NULL);
		}
................................................................................
	    Tcl_JoinPath(1, &dir, &temp);
	    Tcl_DStringFree(&dirString);
	} else {
	    /*
	     * We have a user name '~user'
	     */







	    Tcl_DStringInit(&temp);
	    if (TclpGetUserHome(name+1, &temp) == NULL) {
		if (interp != NULL) {
		    Tcl_ResetResult(interp);
		    Tcl_AppendResult(interp, "user \"", name+1,
			    "\" doesn't exist", NULL);
		}

		Tcl_DStringFree(&temp);
		if (split != len) {
		    name[split] = separator;
		}
		return TCL_ERROR;
	    }
	    if (split != len) {
		name[split] = separator;
	    }

	}

	expandedUser = Tcl_DStringValue(&temp);
	transPtr = Tcl_NewStringObj(expandedUser, Tcl_DStringLength(&temp));

	if (split != len) {
	    /*
................................................................................
		}
		TclDecrRefCount(parts);
	    } else {
		Tcl_Obj *pair[2];

		pair[0] = transPtr;
		pair[1] = Tcl_NewStringObj(name+split+1, -1);
		transPtr = TclJoinPath(2, pair);
		if (transPtr != pair[0]) {
		    TclDecrRefCount(pair[0]);
		}
		if (transPtr != pair[1]) {
		    TclDecrRefCount(pair[1]);
		}
	    }
	}
	Tcl_DStringFree(&temp);
    } else {
	transPtr = TclJoinPath(1, &pathPtr);
    }

    /*
     * Now we have a translated filename in 'transPtr'. This will have forward
     * slashes on Windows, and will not contain any ~user sequences.
     */







|







|








<

|
<





|
|
>
>







 







|





>
|







 







>
|







 







|





<
<
|
<
>
>
|
<
<
<
>





|

|





<
<
<
<







 







>
>
>
>
>
>

|


|


>

<
<
<


<
<
<
>







 







|










|







817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840

841
842

843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
...
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
...
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
....
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423


2424

2425
2426
2427



2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441




2442
2443
2444
2445
2446
2447
2448
....
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473



2474
2475



2476
2477
2478
2479
2480
2481
2482
2483
....
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj * TclJoinPath(int elements, Tcl_Obj * const objv[], int normalize);

Tcl_Obj *
Tcl_FSJoinPath(
    Tcl_Obj *listObj,		/* Path elements to join, may have a zero
				 * reference count. */
    int elements)		/* Number of elements to use (-1 = all) */
{
    Tcl_Obj *res;
    int objc;
    Tcl_Obj **objv;

    if (Tcl_ListObjLength(NULL, listObj, &objc) != TCL_OK) {
	return NULL;
    }

    elements = ((elements >= 0) && (elements <= objc)) ? elements : objc;

    Tcl_ListObjGetElements(NULL, listObj, &objc, &objv);
    res = TclJoinPath(elements, objv, 0);

    return res;
}

Tcl_Obj *
TclJoinPath(
    int elements,		/* Number of elements to use (-1 = all) */
    Tcl_Obj * const objv[],	/* Path elements to join */
    int normalize)		/* 1 if special normalization case (force second
				 * path relative) */
{
    Tcl_Obj *res = NULL;	/* Resulting path object (container of join) */
    Tcl_Obj *elt;		/* Path part (result if returns part of path) */
    int i;
    Tcl_Filesystem *fsPtr = NULL;

    for (i = 0; i < elements; i++) {
................................................................................
	 * use the special case when we have exactly two elements, but we
	 * could expand that in the future.
         *
         * Bugfix [a47641a0]. TclNewFSPathObj requires first argument
         * to be an absolute path. Added a check for that elt is absolute.
	 */

	if ((i == 0) && (elements == 2)
                && (elt->typePtr == &tclFsPathType)
		&& !((elt->bytes != NULL) && (elt->bytes[0] == '\0'))
                && TclGetPathType(elt, NULL, NULL, NULL) == TCL_PATH_ABSOLUTE) {
            Tcl_Obj *tailObj = objv[i+1];

	    type = normalize ? TCL_PATH_RELATIVE :
		    TclGetPathType(tailObj, NULL, NULL, NULL);
	    if (type == TCL_PATH_RELATIVE) {
		const char *str;
		int len;

		str = Tcl_GetStringFromObj(tailObj, &len);
		if (len == 0) {
		    /*
................................................................................
			goto partReturn; /* return elt; */
		    }
		}
	    }
	}
	strElt = Tcl_GetStringFromObj(elt, &strEltLen);
	driveNameLength = 0;
	type = (normalize && (i > 0)) ? TCL_PATH_RELATIVE :
		TclGetPathType(elt, &fsPtr, &driveNameLength, &driveName);
	if (type != TCL_PATH_RELATIVE) {
	    /*
	     * Zero out the current result.
	     */

	    if (res != NULL) {
		TclDecrRefCount(res);
................................................................................

    name = Tcl_GetStringFromObj(pathPtr, &len);

    /*
     * Handle tilde substitutions, if needed.
     */

    if (len && name[0] == '~') {
	char *expandedUser;
	Tcl_DString temp;
	int split;
	char separator = '/';



	/*

	 * We have multiple cases '~/foo/bar...', '~user/foo/bar...', etc.
	 * split becomes value 1 for '~/...' as well as for '~'.
	 */



	split = FindSplitPos(name, separator);

	/*
	 * Do some tilde substitution.
	 */

	if (split == 1) {
	    /*
	     * We have just '~' (or '~/...')
	     */

	    const char *dir;
	    Tcl_DString dirString;





	    dir = TclGetEnv("HOME", &dirString);
	    if (dir == NULL) {
		if (interp) {
		    Tcl_ResetResult(interp);
		    Tcl_AppendResult(interp, "couldn't find HOME environment "
			    "variable to expand path", NULL);
		}
................................................................................
	    Tcl_JoinPath(1, &dir, &temp);
	    Tcl_DStringFree(&dirString);
	} else {
	    /*
	     * We have a user name '~user'
	     */

	    Tcl_DString userName;

	    Tcl_DStringInit(&userName);
	    Tcl_DStringAppend(&userName, name+1, split-1);
	    expandedUser = Tcl_DStringValue(&userName);

	    Tcl_DStringInit(&temp);
	    if (TclpGetUserHome(expandedUser, &temp) == NULL) {
		if (interp != NULL) {
		    Tcl_ResetResult(interp);
		    Tcl_AppendResult(interp, "user \"", expandedUser,
			    "\" doesn't exist", NULL);
		}
		Tcl_DStringFree(&userName);
		Tcl_DStringFree(&temp);



		return TCL_ERROR;
	    }



	    Tcl_DStringFree(&userName);
	}

	expandedUser = Tcl_DStringValue(&temp);
	transPtr = Tcl_NewStringObj(expandedUser, Tcl_DStringLength(&temp));

	if (split != len) {
	    /*
................................................................................
		}
		TclDecrRefCount(parts);
	    } else {
		Tcl_Obj *pair[2];

		pair[0] = transPtr;
		pair[1] = Tcl_NewStringObj(name+split+1, -1);
		transPtr = TclJoinPath(2, pair, 1);
		if (transPtr != pair[0]) {
		    TclDecrRefCount(pair[0]);
		}
		if (transPtr != pair[1]) {
		    TclDecrRefCount(pair[1]);
		}
	    }
	}
	Tcl_DStringFree(&temp);
    } else {
	transPtr = TclJoinPath(1, &pathPtr, 1);
    }

    /*
     * Now we have a translated filename in 'transPtr'. This will have forward
     * slashes on Windows, and will not contain any ~user sequences.
     */

Changes to tests/cmdAH.test.

537
538
539
540
541
542
543







544
545
546
547
548
549
550
    testsetplatform windows
    file tail {c:/foo\bar}
} bar
test cmdAH-9.51 {Tcl_FileObjCmd: tail} testsetplatform {
    testsetplatform windows
    file tail {foo\bar}
} bar








# rootname

test cmdAH-10.1 {Tcl_FileObjCmd: rootname} testsetplatform {
    testsetplatform unix
    list [catch {file rootname a b} msg] $msg
} {1 {wrong # args: should be "file rootname name"}}






>
>
>
>
>
>
>







537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
    testsetplatform windows
    file tail {c:/foo\bar}
} bar
test cmdAH-9.51 {Tcl_FileObjCmd: tail} testsetplatform {
    testsetplatform windows
    file tail {foo\bar}
} bar
test cmdAH-9.52 {Tcl_FileObjCmd: tail / normalize, bug 7a9dc52b29} {
    list \
	[file tail {~/~foo}] \
	[file tail {~/test/~foo}] \
	[file tail [file normalize {~/~foo}]] \
	[file tail [file normalize {~/test/~foo}]]
} [lrepeat 4 ./~foo]

# rootname

test cmdAH-10.1 {Tcl_FileObjCmd: rootname} testsetplatform {
    testsetplatform unix
    list [catch {file rootname a b} msg] $msg
} {1 {wrong # args: should be "file rootname name"}}