Tcl Source Code

2012-02-01  Donal K. Fellows  <[email protected]>

	* doc/AddErrInfo.3: [Bug 3482614]: Documentation nit.

2012-01-26  Don Porter  <[email protected]>

	* generic/tclPathObj.c:	[Bug 3475569]: Add checks for unshared values
	before calls demanding them.  [Bug 3479689]: Stop memory corruption
	when shimmering 0-refCount value to "path" type.

2012-01-22  Jan Nijtmans  <[email protected]>

	* tools/uniClass.tcl:    [Frq 3473670]: Various Unicode-related 
	* tools/uniParse.tcl:    speedups/robustness. Enhanced tools to
	* generic/tclUniData.c:  be able to handle characters > 0xffff
	* generic/tclUtf.c:      Done in all branches in order to simplify
	* generic/regc_locale.c: merges for new Unicode versions (such as 6.1)

\fB\-errorcode\fR, and \fB\-errorline\fR will appear in the
dictionary.  Also, the entries for the keys \fB\-code\fR
and \fB\-level\fR will be adjusted if necessary to agree
with the value of \fIcode\fR.  The \fB(Tcl_Obj *)\fR returned
by \fBTcl_GetReturnOptions\fR points to an unshared
\fBTcl_Obj\fR with reference count of zero.  The dictionary
may be written to, either adding, removing, or overwriting
any entries in it, without the need to check for a shared object.
.PP
A typical usage for \fBTcl_GetReturnOptions\fR is to
retrieve the stack trace when script evaluation returns
\fBTCL_ERROR\fR, like so:
.CS
int code = Tcl_Eval(interp, script);
if (code == TCL_ERROR) {

		}
		(void) Tcl_GetStringFromObj(retVal, &curLen);
		if (curLen == 0) {
		    Tcl_AppendToObj(retVal, dirSep, 1);
		}
		if (!first || (tclPlatform == TCL_PLATFORM_UNIX)) {
		    link = Tcl_FSLink(retVal, NULL, 0);

		    /* Safety check in case driver caused sharing */
		    if (Tcl_IsShared(retVal)) {
			TclDecrRefCount(retVal);
			retVal = Tcl_DuplicateObj(retVal);
			Tcl_IncrRefCount(retVal);
		    }

		    if (link != NULL) {
			/*
			 * Got a link. Need to check if the link is relative
			 * or absolute, for those platforms where relative
			 * links exist.
			 */

				    Tcl_GetStringFromObj(retVal, &curLen);

			    while (--curLen >= 0) {
				if (IsSeparatorOrNull(path[curLen])) {
				    break;
				}
			    }






			    /*
			     * We want the trailing slash.
			     */

			    Tcl_SetObjLength(retVal, curLen+1);
			    Tcl_AppendObjToObj(retVal, link);
			    TclDecrRefCount(link);
			    linkStr = Tcl_GetStringFromObj(retVal, &curLen);
			} else {
			    /*
			     * Absolute link.
			     */

			    TclDecrRefCount(retVal);
			    if (Tcl_IsShared(link)) {
				retVal = Tcl_DuplicateObj(link);
				TclDecrRefCount(link);
			    } else {
				retVal = link;
			    }
			    linkStr = Tcl_GetStringFromObj(retVal, &curLen);

			    /*
			     * Convert to forward-slashes on windows.
			     */

			    if (tclPlatform == TCL_PLATFORM_WINDOWS) {

	    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);
		}
	    }

	    if (length > 0 && ptr[length -1] != '/') {
		Tcl_AppendToObj(res, &separator, 1);
		length++;
	    }

		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--;
    }

#if defined(__CYGWIN__) && defined(__WIN32__)
    {
	char winbuf[MAX_PATH+1];

	/*

    foreach pkg [lsort [array names files]] {
	set cmd {}
	foreach {name version} $pkg {
	    break
	}
	lappend cmd ::tcl::Pkg::Create -name $name -version $version
	foreach spec [lsort -index 0 $files($pkg)] {
	    foreach {file type procs} $spec {
		if { $direct } {
		    set procs {}
		}
		lappend cmd "-$type" [list $file $procs]
	    }
	}

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

testConstraint testobj [llength [info commands testobj]]
testConstraint testdstring [llength [info commands testdstring]]

test stringObj-1.1 {string type registration} testobj {
    set t [testobj types]
    set first [string first "string" $t]
    set result [expr {$first != -1}]
} {1}

    set x abcdefghi
    set y $x
    string length $x
    list [testobj objtype $x] [testobj objtype $y] [append x jkl] \
	    [set y] [testobj objtype $x] [testobj objtype $y]
} {string string abcdefghijkl abcdefghi string string}

test stringObj-9.1 {TclAppendObjToObj, mixed src & dest} {testobj testdstring} {
    set x abc\u00ef\u00bf\u00aeghi
    testdstring free
    testdstring append \u00ae\u00bf\u00ef -1
    set y [testdstring get]
    string length $x
    list [testobj objtype $x] [testobj objtype $y] [append x $y] \
            [set y] [testobj objtype $x] [testobj objtype $y]
} "string none abc\u00ef\u00bf\u00aeghi\u00ae\u00bf\u00ef \u00ae\u00bf\u00ef string none"
test stringObj-9.2 {TclAppendObjToObj, mixed src & dest} testobj {
    set x abc￮ghi
    string length $x
    list [testobj objtype $x] [append x $x] [testobj objtype $x] \
	    [append x $x] [testobj objtype $x]
} {string abc￮ghiabc￮ghi string\
abc￮ghiabc￮ghiabc￮ghiabc￮ghi\
string}
test stringObj-9.3 {TclAppendObjToObj, mixed src & 1-byte dest} {testobj testdstring} {
    set x abcdefghi
    testdstring free
    testdstring append \u00ae\u00bf\u00ef -1
    set y [testdstring get]
    string length $x
    list [testobj objtype $x] [testobj objtype $y] [append x $y] \
            [set y] [testobj objtype $x] [testobj objtype $y]
} "string none abcdefghi\u00ae\u00bf\u00ef \u00ae\u00bf\u00ef string none"
test stringObj-9.4 {TclAppendObjToObj, 1-byte src & dest} {testobj testdstring} {
    set x abcdefghi
    testdstring free
    testdstring append jkl -1
    set y [testdstring get]
    string length $x
    list [testobj objtype $x] [testobj objtype $y] [append x $y] \
            [set y] [testobj objtype $x] [testobj objtype $y]
} {string none abcdefghijkl jkl string none}
test stringObj-9.5 {TclAppendObjToObj, 1-byte src & dest} testobj {
    set x abcdefghi
    string length $x
    list [testobj objtype $x] [append x $x] [testobj objtype $x] \
	    [append x $x] [testobj objtype $x]
} {string abcdefghiabcdefghi string abcdefghiabcdefghiabcdefghiabcdefghi\
string}
test stringObj-9.6 {TclAppendObjToObj, 1-byte src & mixed dest} {testobj testdstring} {
    set x abc\u00ef\u00bf\u00aeghi
    testdstring free
    testdstring append jkl -1
    set y [testdstring get]
    string length $x
    list [testobj objtype $x] [testobj objtype $y] [append x $y] \
            [set y] [testobj objtype $x] [testobj objtype $y]
} "string none abc\u00ef\u00bf\u00aeghijkl jkl string none"
test stringObj-9.7 {TclAppendObjToObj, integer src & dest} testobj {
    set x [expr {4 * 5}]
    set y [expr {4 + 5}]
    list [testobj objtype $x] [testobj objtype $y] [append x $y] \
	    [testobj objtype $x] [append x $y] [testobj objtype $x] \
	    [testobj objtype $y]
} {int int 209 string 2099 string int}

    set q {}
    for {set i 0} {$i < 12} {incr i} {
	lappend q [string index $x $i]
    }
    set q
} {a b c d e f a � b � c �}

test stringObj-10.1 {Tcl_GetRange with all byte-size chars} {testobj testdstring} {
    testdstring free
    testdstring append abcdef -1
    set x [testdstring get]
    list [testobj objtype $x] [set y [string range $x 1 end-1]] \
            [testobj objtype $x] [testobj objtype $y]
} [list none bcde string string]
test stringObj-10.2 {Tcl_GetRange with some mixed width chars} {testobj testdstring} {
    # Because this test does not use \uXXXX notation below instead of
    # hardcoding the values, it may fail in multibyte locales. However, we
    # need to test that the parser produces untyped objects even when there
    # are high-ASCII characters in the input (like "�"). I don't know what
    # else to do but inline those characters here.
    testdstring free
    testdstring append "abc\u00ef\u00efdef" -1
    set x [testdstring get]
    list [testobj objtype $x] [set y [string range $x 1 end-1]] \
            [testobj objtype $x] [testobj objtype $y]
} [list none "bc\u00EF\u00EFde" string string]
test stringObj-10.3 {Tcl_GetRange with some mixed width chars} testobj {
    # set x "abc��def"
    # Use \uXXXX notation below instead of hardcoding the values, otherwise
    # the test will fail in multibyte locales.
    set x "abc\u00EF\u00EFdef"
    string length $x