Tcl Source Code

Check-in [08a3ce668a]
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:merge 8.5
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | bug-0e4d88b650
Files: files | file ages | folders
SHA1: 08a3ce668a1c7f5d4fad3683cace9911a5dd42fe
User & Date: dgp 2017-09-02 21:36:57
Context
2017-09-02
21:48
[0e4d88b650] Allow command overwrite when deletion callback deletes namespace. check-in: 45f8a407e0 user: dgp tags: core-8-5-branch
21:36
merge 8.5 Closed-Leaf check-in: 08a3ce668a user: dgp tags: bug-0e4d88b650
21:14
Add test check-in: 6ef60d9e40 user: dgp tags: bug-0e4d88b650
2017-08-08
16:45
Cherrypick [527d354828] check-in: b300e0ceb0 user: andy tags: core-8-5-branch
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclIOUtil.c.

1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
    }

    /*
     * The eofchar is \32 (^Z). This is the usual on Windows, but we effect
     * this cross-platform to allow for scripted documents. [Bug: 2040]
     */

    Tcl_SetChannelOption(interp, chan, "-eofchar", "\32");

    /*
     * If the encoding is specified, set it for the channel. Else don't touch
     * it (and use the system encoding) Report error on unknown encoding.
     */

    if (encodingName != NULL) {






|







1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
    }

    /*
     * The eofchar is \32 (^Z). This is the usual on Windows, but we effect
     * this cross-platform to allow for scripted documents. [Bug: 2040]
     */

    Tcl_SetChannelOption(interp, chan, "-eofchar", "\32 {}");

    /*
     * If the encoding is specified, set it for the channel. Else don't touch
     * it (and use the system encoding) Report error on unknown encoding.
     */

    if (encodingName != NULL) {

Changes to generic/tclInt.h.

3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
 *
 * MODULE_SCOPE int	TclUtfToUniChar(const char *string, Tcl_UniChar *ch);
 *----------------------------------------------------------------
 */

#define TclUtfToUniChar(str, chPtr) \
	((((unsigned char) *(str)) < 0xC0) ?		\
	    ((*(chPtr) = (Tcl_UniChar) *(str)), 1)	\
	    : Tcl_UtfToUniChar(str, chPtr))

/*
 *----------------------------------------------------------------
 * Macro that encapsulates the logic that determines when it is safe to
 * interpret a string as a byte array directly. In summary, the object must be
 * a byte array and must not have a string representation (as the operations






|







3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
 *
 * MODULE_SCOPE int	TclUtfToUniChar(const char *string, Tcl_UniChar *ch);
 *----------------------------------------------------------------
 */

#define TclUtfToUniChar(str, chPtr) \
	((((unsigned char) *(str)) < 0xC0) ?		\
	    ((*(chPtr) = (unsigned char) *(str)), 1)	\
	    : Tcl_UtfToUniChar(str, chPtr))

/*
 *----------------------------------------------------------------
 * Macro that encapsulates the logic that determines when it is safe to
 * interpret a string as a byte array directly. In summary, the object must be
 * a byte array and must not have a string representation (as the operations

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
859




860
861
862
863
864
865

866
867

868
869
870
871
872
873
874
875



876
877
878
879



880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
...
913
914
915
916
917
918
919
920
921
922
923
924
925
926

927
928
929

930
931
932
933

934
935
936
937
938
939
940
941
942
943
944
945
946

947
948
949
950
951
952
953
954
955

956
957
958
959
960
961
962
....
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057

1058
1059
1060
1061
1062
1063
1064
....
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089

1090
1091
1092
1093
1094
1095
1096
....
1122
1123
1124
1125
1126
1127
1128






1129
1130
1131
1132
1133
1134
1135
....
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525

2526
2527

2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */



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 i;
    Tcl_Filesystem *fsPtr = NULL;

    if (elements < 0) {
	if (Tcl_ListObjLength(NULL, listObj, &elements) != TCL_OK) {
	    return NULL;
	}
    } else {
	/*
	 * Just make sure it is a valid list.
	 */

	int listTest;

	if (Tcl_ListObjLength(NULL, listObj, &listTest) != TCL_OK) {





	    return NULL;
	}

	/*
	 * Correct this if it is too large, otherwise we will waste our time
	 * joining null elements to the path.
	 */

	if (elements > listTest) {


	    elements = listTest;
	}
    }


    res = NULL;





    for (i = 0; i < elements; i++) {
	Tcl_Obj *elt, *driveName = NULL;
	int driveNameLength, strEltLen, length;
	Tcl_PathType type;
	char *strElt, *ptr;


	Tcl_ListObjIndex(NULL, listObj, i, &elt);


	/*
	 * This is a special case where we can be much more efficient, where
	 * we are joining a single relative path onto an object that is
	 * already of path type. The 'TclNewFSPathObj' call below creates an
	 * object which can be normalized more efficiently. Currently we only
	 * use the special case when we have exactly two elements, but we
	 * could expand that in the future.



	 */

	if ((i == (elements-2)) && (i == 0) && (elt->typePtr == &tclFsPathType)
		&& !(elt->bytes != NULL && (elt->bytes[0] == '\0'))) {



	    Tcl_Obj *tail;

	    Tcl_ListObjIndex(NULL, listObj, i+1, &tail);
	    type = TclGetPathType(tail, NULL, NULL, NULL);
	    if (type == TCL_PATH_RELATIVE) {
		const char *str;
		int len;

		str = Tcl_GetStringFromObj(tail, &len);
		if (len == 0) {
		    /*
		     * This happens if we try to handle the root volume '/'.
		     * There's no need to return a special path object, when
		     * the base itself is just fine!
		     */

		    if (res != NULL) {
			TclDecrRefCount(res);
		    }
		    return elt;
		}

		/*
		 * If it doesn't begin with '.' and is a unix path or it a
		 * windows path without backslashes, then we can be very
		 * efficient here. (In fact even a windows path with
		 * backslashes can be joined efficiently, but the path object
................................................................................
		    /*
		     * Finally, on Windows, 'file join' is defined to convert
		     * all backslashes to forward slashes, so the base part
		     * cannot have backslashes either.
		     */

		    if ((tclPlatform != TCL_PLATFORM_WINDOWS)
			    || (strchr(Tcl_GetString(elt), '\\') == NULL)) {
			if (res != NULL) {
			    TclDecrRefCount(res);
			}

			if (PATHFLAGS(elt)) {
			    return TclNewFSPathObj(elt, str, len);

			}
			if (TCL_PATH_ABSOLUTE != Tcl_FSGetPathType(elt)) {
			    return TclNewFSPathObj(elt, str, len);

			}
			(void) Tcl_FSGetNormalizedPath(NULL, elt);
			if (elt == PATHOBJ(elt)->normPathPtr) {
			    return TclNewFSPathObj(elt, str, len);

			}
		    }
		}

		/*
		 * Otherwise we don't have an easy join, and we must let the
		 * more general code below handle things.
		 */
	    } else if (tclPlatform == TCL_PLATFORM_UNIX) {
		if (res != NULL) {
		    TclDecrRefCount(res);
		}
		return tail;

	    } else {
		const char *str = TclGetString(tail);

		if (tclPlatform == TCL_PLATFORM_WINDOWS) {
		    if (strchr(str, '\\') == NULL) {
			if (res != NULL) {
			    TclDecrRefCount(res);
			}
			return tail;

		    }
		}
	    }
	}
	strElt = Tcl_GetStringFromObj(elt, &strEltLen);
	driveNameLength = 0;
	type = TclGetPathType(elt, &fsPtr, &driveNameLength, &driveName);
................................................................................
		     * is not in normalized form
		     */

		    goto noQuickReturn;
		}
		ptr++;
	    }
	    if (res != NULL) {
		TclDecrRefCount(res);
	    }

	    /*
	     * This element is just what we want to return already - no
	     * further manipulation is requred.
	     */

	    return elt;
	}

	/*
	 * The path element was not of a suitable form to be returned as is.
	 * We need to perform a more complex operation here.
	 */

    noQuickReturn:
	if (res == NULL) {
	    res = Tcl_NewObj();
	    ptr = Tcl_GetStringFromObj(res, &length);
	} else {
	    ptr = Tcl_GetStringFromObj(res, &length);
	}


	/*
	 * Strip off any './' before a tilde, unless this is the beginning of
	 * the path.
	 */

	if (length > 0 && strEltLen > 0 && (strElt[0] == '.') &&
................................................................................
	if (fsPtr == &tclNativeFilesystem || fsPtr == NULL) {
	    TclpNativeJoinPath(res, strElt);
	} else {
	    char separator = '/';
	    int needsSep = 0;

	    if (fsPtr->filesystemSeparatorProc != NULL) {
		Tcl_Obj *sep = (*fsPtr->filesystemSeparatorProc)(res);

		if (sep != NULL) {
		    separator = TclGetString(sep)[0];

		}
		/* Safety check in case the VFS driver caused sharing */
		if (Tcl_IsShared(res)) {
		    TclDecrRefCount(res);
		    res = Tcl_DuplicateObj(res);
		    Tcl_IncrRefCount(res);
		}
................................................................................
	    Tcl_SetObjLength(res, length);
	}
    }
    if (res == NULL) {
	res = Tcl_NewObj();
    }
    return res;






}
 
/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSConvertToPathType --
 *
................................................................................

		objc--; objv++;
		while (objc--) {
		    TclpNativeJoinPath(transPtr, Tcl_GetString(*objv++));
		}
		TclDecrRefCount(parts);
	    } else {
		/*
		 * Simple case. "rest" is relative path. Just join it. The
		 * "rest" object will be freed when Tcl_FSJoinToPath returns
		 * (unless something else claims a refCount on it).
		 */

		Tcl_Obj *joined;

		Tcl_Obj *rest = Tcl_NewStringObj(name+split+1, -1);


		Tcl_IncrRefCount(transPtr);
		joined = Tcl_FSJoinToPath(transPtr, 1, &rest);
		TclDecrRefCount(transPtr);
		transPtr = joined;
	    }
	}
	Tcl_DStringFree(&temp);
    } else {
	/* Bug 3479689: protect 0-refcount pathPth from getting freed */
	pathPtr->refCount++;
	transPtr = Tcl_FSJoinToPath(pathPtr, 0, NULL);
	pathPtr->refCount--;
    }

    /*
     * 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

859
860
861
862
863

864
865
866
867
868
869
870
871
872
873
874
875
876
877
878

879
880
881
882
883

884
885
886
887
888
889
890
891
892
893
894
895
896



897
898
899
900
901
902
903
904
...
911
912
913
914
915
916
917
918
919



920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940



941
942
943
944
945
946
947



948
949
950
951
952
953
954
955
956
....
1021
1022
1023
1024
1025
1026
1027




1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043



1044
1045
1046
1047
1048
1049
1050
1051
1052
....
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
....
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
....
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[]);

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++) {

	int driveNameLength, strEltLen, length;
	Tcl_PathType type;
	char *strElt, *ptr;
	Tcl_Obj *driveName = NULL;
	

	elt = objv[i];

	/*
	 * This is a special case where we can be much more efficient, where
	 * we are joining a single relative path onto an object that is
	 * already of path type. The 'TclNewFSPathObj' call below creates an
	 * object which can be normalized more efficiently. Currently we only
	 * 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) {
		    /*
		     * This happens if we try to handle the root volume '/'.
		     * There's no need to return a special path object, when
		     * the base itself is just fine!
		     */




		    goto partReturn; /* return elt; */
		}

		/*
		 * If it doesn't begin with '.' and is a unix path or it a
		 * windows path without backslashes, then we can be very
		 * efficient here. (In fact even a windows path with
		 * backslashes can be joined efficiently, but the path object
................................................................................
		    /*
		     * Finally, on Windows, 'file join' is defined to convert
		     * all backslashes to forward slashes, so the base part
		     * cannot have backslashes either.
		     */

		    if ((tclPlatform != TCL_PLATFORM_WINDOWS)
			    || (strchr(Tcl_GetString(elt), '\\') == NULL)
		    ) {



			if (PATHFLAGS(elt)) {
			    elt = TclNewFSPathObj(elt, str, len);
			    goto partReturn; /* return elt; */
			}
			if (TCL_PATH_ABSOLUTE != Tcl_FSGetPathType(elt)) {
			    elt = TclNewFSPathObj(elt, str, len);
			    goto partReturn; /* return elt; */
			}
			(void) Tcl_FSGetNormalizedPath(NULL, elt);
			if (elt == PATHOBJ(elt)->normPathPtr) {
			    elt = TclNewFSPathObj(elt, str, len);
			    goto partReturn; /* return elt; */
			}
		    }
		}

		/*
		 * Otherwise we don't have an easy join, and we must let the
		 * more general code below handle things.
		 */
	    } else if (tclPlatform == TCL_PLATFORM_UNIX) {



		elt = tailObj;
		goto partReturn; /* return elt; */
	    } else {
		const char *str = TclGetString(tailObj);

		if (tclPlatform == TCL_PLATFORM_WINDOWS) {
		    if (strchr(str, '\\') == NULL) {



			elt = tailObj;
			goto partReturn; /* return elt; */
		    }
		}
	    }
	}
	strElt = Tcl_GetStringFromObj(elt, &strEltLen);
	driveNameLength = 0;
	type = TclGetPathType(elt, &fsPtr, &driveNameLength, &driveName);
................................................................................
		     * is not in normalized form
		     */

		    goto noQuickReturn;
		}
		ptr++;
	    }




	    /*
	     * This element is just what we want to return already; no further
	     * manipulation is requred.
	     */

	    goto partReturn; /* return elt; */
	}

	/*
	 * The path element was not of a suitable form to be returned as is.
	 * We need to perform a more complex operation here.
	 */

    noQuickReturn:
	if (res == NULL) {
	    res = Tcl_NewObj();



	}
	ptr = Tcl_GetStringFromObj(res, &length);

	/*
	 * Strip off any './' before a tilde, unless this is the beginning of
	 * the path.
	 */

	if (length > 0 && strEltLen > 0 && (strElt[0] == '.') &&
................................................................................
	if (fsPtr == &tclNativeFilesystem || fsPtr == NULL) {
	    TclpNativeJoinPath(res, strElt);
	} else {
	    char separator = '/';
	    int needsSep = 0;

	    if (fsPtr->filesystemSeparatorProc != NULL) {
		Tcl_Obj *sep = fsPtr->filesystemSeparatorProc(res);

		if (sep != NULL) {
		    separator = TclGetString(sep)[0];
		    TclDecrRefCount(sep);
		}
		/* Safety check in case the VFS driver caused sharing */
		if (Tcl_IsShared(res)) {
		    TclDecrRefCount(res);
		    res = Tcl_DuplicateObj(res);
		    Tcl_IncrRefCount(res);
		}
................................................................................
	    Tcl_SetObjLength(res, length);
	}
    }
    if (res == NULL) {
	res = Tcl_NewObj();
    }
    return res;

partReturn:
    if (res != NULL) {
	TclDecrRefCount(res);
    }
    return elt;
}
 
/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSConvertToPathType --
 *
................................................................................

		objc--; objv++;
		while (objc--) {
		    TclpNativeJoinPath(transPtr, Tcl_GetString(*objv++));
		}
		TclDecrRefCount(parts);
	    } else {
		Tcl_Obj *pair[2];






		pair[0] = transPtr;
		pair[1] = Tcl_NewStringObj(name+split+1, -1);

		transPtr = TclJoinPath(2, pair);
		TclDecrRefCount(pair[0]);

		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.
     */

Changes to library/auto.tcl.

207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
...
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
    append index "# element name is the name of a command and the value is\n"
    append index "# a script that loads the command.\n\n"
    if {[llength $args] == 0} {
	set args *.tcl
    }

    auto_mkindex_parser::init
    foreach file [glob -- {*}$args] {
        if {[catch {auto_mkindex_parser::mkindex $file} msg opts] == 0} {
            append index $msg
        } else {
            cd $oldDir
	    return -options $opts $msg
        }
    }
................................................................................
    append index "# more commands.  Typically each line is a command that\n"
    append index "# sets an element in the auto_index array, where the\n"
    append index "# element name is the name of a command and the value is\n"
    append index "# a script that loads the command.\n\n"
    if {[llength $args] == 0} {
	set args *.tcl
    }
    foreach file [glob -- {*}$args] {
	set f ""
	set error [catch {
	    set f [open $file]
	    while {[gets $f line] >= 0} {
		if {[regexp {^proc[ 	]+([^ 	]*)} $line match procName]} {
		    set procName [lindex [auto_qualify $procName "::"] 0]
		    append index "set [list auto_index($procName)]"






|







 







|







207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
...
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
    append index "# element name is the name of a command and the value is\n"
    append index "# a script that loads the command.\n\n"
    if {[llength $args] == 0} {
	set args *.tcl
    }

    auto_mkindex_parser::init
    foreach file [lsort [glob -- {*}$args]] {
        if {[catch {auto_mkindex_parser::mkindex $file} msg opts] == 0} {
            append index $msg
        } else {
            cd $oldDir
	    return -options $opts $msg
        }
    }
................................................................................
    append index "# more commands.  Typically each line is a command that\n"
    append index "# sets an element in the auto_index array, where the\n"
    append index "# element name is the name of a command and the value is\n"
    append index "# a script that loads the command.\n\n"
    if {[llength $args] == 0} {
	set args *.tcl
    }
    foreach file [lsort [glob -- {*}$args]] {
	set f ""
	set error [catch {
	    set f [open $file]
	    while {[gets $f line] >= 0} {
		if {[regexp {^proc[ 	]+([^ 	]*)} $line match procName]} {
		    set procName [lindex [auto_qualify $procName "::"] 0]
		    append index "set [list auto_index($procName)]"