Checkpoint of work in progress.

doc/copy.n

@@ -14,7 +14,7 @@ oo::copy \- create copies of objects and classes
 .nf
 package require TclOO
 
-\fBoo::copy\fI sourceObject \fR?\fItargetObject\fR?
+\fBoo::copy\fI sourceObject \fR?\fItargetObject\fR? ?\fItargetNamespace\fR?
 .fi
 .BE
 .SH DESCRIPTION
@@ -22,11 +22,21 @@ package require TclOO
 The \fBoo::copy\fR command creates a copy of an object or class. It takes the
 name of the object or class to be copied, \fIsourceObject\fR, and optionally
 the name of the object or class to create, \fItargetObject\fR, which will be
-resolved relative to the current namespace if not an absolute qualified name.
-If \fItargetObject\fR is omitted, a new name is chosen. The copied object will
-be of the same class as the source object, and will have all its per-object
-methods copied. If it is a class, it will also have all the class methods in
-the class copied, but it will not have any of its instances copied.
+resolved relative to the current namespace if not an absolute qualified name
+and
+.VS TIP473
+\fItargetNamespace\fR which is the name of the namespace that will hold the
+internal state of the object (\fBmy\fR command, etc.); it \fImust not\fR
+refer to an existing namespace.
+If either \fItargetObject\fR or \fItargetNamespace\fR is omitted or is given
+as the empty string, a new name is chosen. Names, unless specified, are
+chosen with the same algorithm used by the \fBnew\fR method of
+\fBoo::class\fR.
+.VE TIP473
+The copied object will be of the same class as the source object, and will have 
+all its per-object methods copied. If it is a class, it will also have all the 
+class methods in the class copied, but it will not have any of its instances 
+copied.
 .PP
 .VS
 After the \fItargetObject\fR has been created and all definitions of its

doc/define.n

@@ -142,6 +142,8 @@ be afterwards.
 \fBself\fI subcommand arg ...\fR
 .TP
 \fBself\fI script\fR
+.TP
+\fBself\fR
 .
 This command is equivalent to calling \fBoo::objdefine\fR on the class being
 defined (see \fBCONFIGURING OBJECTS\fR below for a description of the
@@ -151,6 +153,13 @@ and
 .QW "\fBoo::define \fIcls \fBself \fIsubcommand ...\fR"
 operates identically to
 .QW "\fBoo::objdefine \fIcls subcommand ...\fR" .
+.RS
+.PP
+.VS TIP470
+If no arguments at all are used, this gives the name of the class currently
+being configured.
+.VE TIP470
+.RE
 .TP
 \fBsuperclass\fR ?\fI\-slotOperation\fR? ?\fIclassName ...\fR?
 .VS
@@ -265,6 +274,12 @@ not previously refer to a method in that object. Does not affect the classes
 that the object is an instance of. Does not change the export status of the
 method; if it was exported before, it will be afterwards.
 .TP
+\fBself \fR
+.
+.VS TIP470
+This gives the name of the object currently being configured.
+.VE TIP470
+.TP
 \fBunexport\fI name \fR?\fIname ...\fR?
 .
 This arranges for each of the named methods, \fIname\fR, to be not exported

doc/dict.n

@@ -437,7 +437,7 @@ puts $foo
 #    prints: \fIa b foo {a b} bar 2 baz 3\fR
 .CE
 .SH "SEE ALSO"
-append(n), array(n), foreach(n), mapeach(n), incr(n), list(n), lappend(n), set(n)
+append(n), array(n), foreach(n), incr(n), list(n), lappend(n), lmap(n), set(n)
 .SH KEYWORDS
 dictionary, create, update, lookup, iterate, filter, map
 '\" Local Variables:

doc/regsub.n

@@ -68,6 +68,31 @@ and
 sequences are handled for each substitution using the information
 from the corresponding match.
 .TP
+\fB\-command\fR
+.VS 8.7
+Changes the handling of the substitution string so that it no longer treats
+.QW &
+and
+.QW \e
+as special characters, but instead uses them as a non-empty list of words.
+Each time a substitution is processed, another complete Tcl word is appended
+to that list for each substitution value (the first such argument represents
+the overall matched substring, the subsequent arguments will be one per
+capturing sub-RE, much as are returned from \fBregexp\fR \fB\-inline\fR) and
+the overall list is then evaluated as a Tcl command call. If the command
+finishes successfully, the result of command call is substituted into the
+resulting string.
+.RS
+.PP
+If \fB\-all\fR is not also given, the command callback will be invoked at most
+once (exactly when the regular expression matches). If \fB\-all\fR is given,
+the command callback will be invoked for each matched location, in sequence.
+The exact location indices that matched are not made available to the script.
+.PP
+See \fBEXAMPLES\fR below for illustrative cases.
+.RE
+.VE 8.7
+.TP
 \fB\-expanded\fR
 .
 Enables use of the expanded regular expression syntax where
@@ -183,6 +208,53 @@ set substitution {[format \e\e\e\eu%04x [scan "\e\e&" %c]]}
 set quoted [subst [string map {\en {\e\eu000a}} \e
         [\fBregsub\fR -all $RE $string $substitution]]]
 .CE
+.PP
+.VS 8.7
+The above operation can be done using \fBregsub \-command\fR instead, which is
+often faster. (A full pre-computed \fBstring map\fR would be faster still, but
+the cost of computing the map for a transformation as complex as this can be
+quite large.)
+.PP
+.CS
+# This RE is just a character class for everything "bad"
+set RE {[][{};#\e\e\e$\es\eu0080-\euffff]}
+
+# This encodes what the RE described above matches
+proc encodeChar {ch} {
+    # newline is handled specially since backslash-newline is a
+    # special sequence.
+    if {$ch eq "\en"} {
+        return "\e\eu000a"
+    }
+    # No point in writing this as a one-liner
+    scan $ch %c charNumber
+    format "\e\eu%04x" $charNumber
+}
+
+set quoted [\fBregsub\fR -all -command $RE $string encodeChar]
+.CE
+.PP
+Decoding a URL-encoded string using \fBregsub \-command\fR, a lambda term and
+the \fBapply\fR command.
+.PP
+.CS
+# Match one of the sequences in a URL-encoded string that needs
+# fixing, converting + to space and %XX to the right character
+# (e.g., %7e becomes ~)
+set RE {(\e+)|%([0-9A-Fa-f]{2})}
+
+# Note that -command uses a command prefix, not a command name
+set decoded [\fBregsub\fR -all -command $RE $string {apply {{- p h} {
+    # + is a special case; handle directly
+    if {$p eq "+"} {
+        return " "
+    }
+    # convert hex to a char
+    scan $h %x charNumber
+    format %c $charNumber
+}}}]
+.CE
+.VE 8.7
 .SH "SEE ALSO"
 regexp(n), re_syntax(n), subst(n), string(n)
 .SH KEYWORDS

generic/tclCmdMZ.c

@@ -487,26 +487,28 @@ Tcl_RegsubObjCmd(
     Tcl_Obj *const objv[])	/* Argument objects. */
 {
     int idx, result, cflags, all, wlen, wsublen, numMatches, offset;
-    int start, end, subStart, subEnd, match;
+    int start, end, subStart, subEnd, match, command, numParts, numArgs;
     Tcl_RegExp regExpr;
     Tcl_RegExpInfo info;
     Tcl_Obj *resultPtr, *subPtr, *objPtr, *startIndex = NULL;
+    Tcl_Obj **args = NULL, **parts;
     Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec, *wend;
 
     static const char *const options[] = {
-	"-all",		"-nocase",	"-expanded",
-	"-line",	"-linestop",	"-lineanchor",	"-start",
+	"-all",		"-command",	"-expanded",	"-line",
+	"-linestop",	"-lineanchor",	"-nocase",	"-start",
 	"--",		NULL
     };
     enum options {
-	REGSUB_ALL,	REGSUB_NOCASE,	REGSUB_EXPANDED,
-	REGSUB_LINE,	REGSUB_LINESTOP, REGSUB_LINEANCHOR,	REGSUB_START,
+	REGSUB_ALL,	 REGSUB_COMMAND,    REGSUB_EXPANDED, REGSUB_LINE,
+	REGSUB_LINESTOP, REGSUB_LINEANCHOR, REGSUB_NOCASE,   REGSUB_START,
 	REGSUB_LAST
     };
 
     cflags = TCL_REG_ADVANCED;
     all = 0;
     offset = 0;
+    command = 0;
     resultPtr = NULL;
 
     for (idx = 1; idx < objc; idx++) {
@@ -528,6 +530,9 @@ Tcl_RegsubObjCmd(
 	case REGSUB_NOCASE:
 	    cflags |= TCL_REG_NOCASE;
 	    break;
+	case REGSUB_COMMAND:
+	    command = 1;
+	    break;
 	case REGSUB_EXPANDED:
 	    cflags |= TCL_REG_EXPANDED;
 	    break;
@@ -585,7 +590,7 @@ Tcl_RegsubObjCmd(
 	}
     }
 
-    if (all && (offset == 0)
+    if (all && (offset == 0) && (command == 0)
 	    && (strpbrk(TclGetString(objv[2]), "&\\") == NULL)
 	    && (strpbrk(TclGetString(objv[0]), "*+?{}()[].\\|^$") == NULL)) {
 	/*
@@ -661,6 +666,28 @@ Tcl_RegsubObjCmd(
 	return TCL_ERROR;
     }
 
+    if (command) {
+	/*
+	 * In command-prefix mode, we require that the third non-option
+	 * argument be a list, so we enforce that here. Afterwards, we fetch
+	 * the RE compilation again in case objv[0] and objv[2] are the same
+	 * object. (If they aren't, that's cheap to do.)
+	 */
+
+	if (Tcl_ListObjLength(interp, objv[2], &numParts) != TCL_OK) {
+	    return TCL_ERROR;
+	}
+	if (numParts < 1) {
+	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
+		    "command prefix must be a list of at least one element",
+		    -1));
+	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "REGSUB",
+		    "CMDEMPTY", NULL);
+	    return TCL_ERROR;
+	}
+	regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
+    }
+
     /*
      * Make sure to avoid problems where the objects are shared. This can
      * cause RegExpObj <> UnicodeObj shimmering that causes data corruption.
@@ -678,7 +705,9 @@ Tcl_RegsubObjCmd(
     } else {
 	subPtr = objv[2];
     }
-    wsubspec = Tcl_GetUnicodeFromObj(subPtr, &wsublen);
+    if (!command) {
+	wsubspec = Tcl_GetUnicodeFromObj(subPtr, &wsublen);
+    }
 
     result = TCL_OK;
 
@@ -736,6 +765,88 @@ Tcl_RegsubObjCmd(
 	end = info.matches[0].end;
 	Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, start);
 
+	/*
+	 * In command-prefix mode, the substitutions are added as quoted
+	 * arguments to the subSpec to form a command, that is then executed
+	 * and the result used as the string to substitute in. Actually,
+	 * everything is passed through Tcl_EvalObjv, as that's much faster.
+	 */
+
+	if (command) {
+	    if (args == NULL) {
+		Tcl_ListObjGetElements(interp, subPtr, &numParts, &parts);
+		numArgs = numParts + info.nsubs + 1;
+		args = ckalloc(sizeof(Tcl_Obj*) * numArgs);
+		memcpy(args, parts, sizeof(Tcl_Obj*) * numParts);
+	    }
+
+	    for (idx = 0 ; idx <= info.nsubs ; idx++) {
+		subStart = info.matches[idx].start;
+		subEnd = info.matches[idx].end;
+		if ((subStart >= 0) && (subEnd >= 0)) {
+		    args[idx + numParts] = Tcl_NewUnicodeObj(
+			    wstring + offset + subStart, subEnd - subStart);
+		} else {
+		    args[idx + numParts] = Tcl_NewObj();
+		}
+		Tcl_IncrRefCount(args[idx + numParts]);
+	    }
+
+	    /*
+	     * At this point, we're locally holding the references to the
+	     * argument words we added for this time round the loop, and the
+	     * subPtr is holding the references to the words that the user
+	     * supplied directly. None are zero-refcount, which is important
+	     * because Tcl_EvalObjv is "hairy monster" in terms of refcount
+	     * handling, being able to optionally add references to any of its
+	     * argument words. We'll drop the local refs immediately
+	     * afterwarsds; subPtr is handled in the main exit stanza.
+	     */
+
+	    result = Tcl_EvalObjv(interp, numArgs, args, 0);
+	    for (idx = 0 ; idx <= info.nsubs ; idx++) {
+		TclDecrRefCount(args[idx + numParts]);
+	    }
+	    if (result != TCL_OK) {
+		if (result == TCL_ERROR) {
+		    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+			    "\n    (%s substitution computation script)",
+			    options[REGSUB_COMMAND]));
+		}
+		goto done;
+	    }
+
+	    Tcl_AppendObjToObj(resultPtr, Tcl_GetObjResult(interp));
+	    Tcl_ResetResult(interp);
+
+	    /*
+	     * Refetch the unicode, in case the representation was smashed by
+	     * the user code.
+	     */
+
+	    wstring = Tcl_GetUnicodeFromObj(objPtr, &wlen);
+
+	    offset += end;
+	    if (end == 0 || start == end) {
+		/*
+		 * Always consume at least one character of the input string
+		 * in order to prevent infinite loops, even when we
+		 * technically matched the empty string; we must not match
+		 * again at the same spot.
+		 */
+
+		if (offset < wlen) {
+		    Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1);
+		}
+		offset++;
+	    }
+	    if (all) {
+		continue;
+	    } else {
+		break;
+	    }
+	}
+
 	/*
 	 * Append the subSpec argument to the variable, making appropriate
 	 * substitutions. This code is a bit hairy because of the backslash
@@ -864,6 +975,9 @@ Tcl_RegsubObjCmd(
     if (subPtr && (objv[2] == objv[0])) {
 	Tcl_DecrRefCount(subPtr);
     }
+    if (args) {
+	ckfree(args);
+    }
     if (resultPtr) {
 	Tcl_DecrRefCount(resultPtr);
     }

generic/tclOO.c

@@ -41,6 +41,7 @@ static const struct {
     {"forward", TclOODefineForwardObjCmd, 1},
     {"method", TclOODefineMethodObjCmd, 1},
     {"renamemethod", TclOODefineRenameMethodObjCmd, 1},
+    {"self", TclOODefineObjSelfObjCmd, 0},
     {"unexport", TclOODefineUnexportObjCmd, 1},
     {NULL, NULL, 0}
 };

generic/tclOOBasic.c

@@ -1183,8 +1183,9 @@ TclOOCopyObjectCmd(
 {
     Tcl_Object oPtr, o2Ptr;
 
-    if (objc < 2 || objc > 3) {
-	Tcl_WrongNumArgs(interp, 1, objv, "sourceName ?targetName?");
+    if (objc < 2 || objc > 4) {
+	Tcl_WrongNumArgs(interp, 1, objv,
+			 "sourceName ?targetName? ?targetNamespace?");
 	return TCL_ERROR;
     }
 
@@ -1204,12 +1205,14 @@ TclOOCopyObjectCmd(
     if (objc == 2) {
 	o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, NULL, NULL);
     } else {
-	const char *name;
+	const char *name, *namespaceName;
 	Tcl_DString buffer;
 
 	name = TclGetString(objv[2]);
 	Tcl_DStringInit(&buffer);
-	if (name[0]!=':' || name[1]!=':') {
+	if (name[0] == '\0') {
+	    name = NULL;
+	} else if (name[0]!=':' || name[1]!=':') {
 	    Interp *iPtr = (Interp *) interp;
 
 	    if (iPtr->varFramePtr != NULL) {
@@ -1220,7 +1223,26 @@ TclOOCopyObjectCmd(
 	    Tcl_DStringAppend(&buffer, name, -1);
 	    name = Tcl_DStringValue(&buffer);
 	}
-	o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, name, NULL);
+
+	/*
+	 * Choose a unique namespace name if the user didn't supply one.
+	 */
+
+	namespaceName = NULL;
+	if (objc == 4) {
+	    namespaceName = TclGetString(objv[3]);
+
+	    if (namespaceName[0] == '\0') {
+		namespaceName = NULL;
+	    } else if (Tcl_FindNamespace(interp, namespaceName, NULL,
+		    0) != NULL) {
+		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+			"%s refers to an existing namespace", namespaceName));
+		return TCL_ERROR;
+	    }
+	}
+
+	o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, name, namespaceName);
 	Tcl_DStringFree(&buffer);
     }
 

generic/tclOODefineCmds.c

@@ -47,8 +47,11 @@ struct DeclaredSlot {
 static inline void	BumpGlobalEpoch(Tcl_Interp *interp, Class *classPtr);
 static Tcl_Command	FindCommand(Tcl_Interp *interp, Tcl_Obj *stringObj,
 			    Tcl_Namespace *const namespacePtr);
-static void		GenerateErrorInfo(Tcl_Interp *interp, Object *oPtr,
+static inline void	GenerateErrorInfo(Tcl_Interp *interp, Object *oPtr,
 			    Tcl_Obj *savedNameObj, const char *typeOfSubject);
+static inline int	MagicDefinitionInvoke(Tcl_Interp *interp,
+			    Tcl_Namespace *nsPtr, int cmdIndex,
+			    int objc, Tcl_Obj *const *objv);
 static inline Class *	GetClassInOuterContext(Tcl_Interp *interp,
 			    Tcl_Obj *className, const char *errMsg);
 static inline int	InitDefineContext(Tcl_Interp *interp,
@@ -755,7 +758,7 @@ GetClassInOuterContext(
  * ----------------------------------------------------------------------
  */
 
-static void
+static inline void
 GenerateErrorInfo(
     Tcl_Interp *interp,		/* Where to store the error info trace. */
     Object *oPtr,		/* What object (or class) was being configured
@@ -784,6 +787,69 @@ GenerateErrorInfo(
 	    (overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
 }
 
+/*
+ * ----------------------------------------------------------------------
+ *
+ * MagicDefinitionInvoke --
+ *	Part of the implementation of the "oo::define" and "oo::objdefine"
+ *	commands that is used to implement the more-than-one-argument case,
+ *	applying ensemble-like tricks with dispatch so that error messages are
+ *	clearer. Doesn't handle the management of the stack frame.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline int
+MagicDefinitionInvoke(
+    Tcl_Interp *interp,
+    Tcl_Namespace *nsPtr,
+    int cmdIndex,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Tcl_Obj *objPtr, *obj2Ptr, **objs;
+    Tcl_Command cmd;
+    int isRoot, dummy, result, offset = cmdIndex + 1;
+
+    /*
+     * More than one argument: fire them through the ensemble processing
+     * engine so that everything appears to be good and proper in error
+     * messages. Note that we cannot just concatenate and send through
+     * Tcl_EvalObjEx, as that doesn't do ensemble processing, and we cannot go
+     * through Tcl_EvalObjv without the extra work to pre-find the command, as
+     * that finds command names in the wrong namespace at the moment. Ugly!
+     */
+
+    isRoot = TclInitRewriteEnsemble(interp, offset, 1, objv);
+
+    /*
+     * Build the list of arguments using a Tcl_Obj as a workspace. See
+     * comments above for why these contortions are necessary.
+     */
+
+    objPtr = Tcl_NewObj();
+    obj2Ptr = Tcl_NewObj();
+    cmd = FindCommand(interp, objv[cmdIndex], nsPtr);
+    if (cmd == NULL) {
+	/* punt this case! */
+	Tcl_AppendObjToObj(obj2Ptr, objv[cmdIndex]);
+    } else {
+	Tcl_GetCommandFullName(interp, cmd, obj2Ptr);
+    }
+    Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);
+    /* TODO: overflow? */
+    Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-offset, objv+offset);
+    Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs);
+
+    result = Tcl_EvalObjv(interp, objc-cmdIndex, objs, TCL_EVAL_INVOKE);
+    if (isRoot) {
+	TclResetRewriteEnsemble(interp, 1);
+    }
+    Tcl_DecrRefCount(objPtr);
+
+    return result;
+}
+
 /*
  * ----------------------------------------------------------------------
  *
@@ -805,8 +871,8 @@ TclOODefineObjCmd(
     Tcl_Obj *const *objv)
 {
     Foundation *fPtr = TclOOGetFoundation(interp);
-    int result;
     Object *oPtr;
+    int result;
 
     if (objc < 3) {
 	Tcl_WrongNumArgs(interp, 1, objv, "className arg ?arg ...?");
@@ -846,46 +912,7 @@ TclOODefineObjCmd(
 	}
 	TclDecrRefCount(objNameObj);
     } else {
-	Tcl_Obj *objPtr, *obj2Ptr, **objs;
-	Tcl_Command cmd;
-	int isRoot, dummy;
-
-	/*
-	 * More than one argument: fire them through the ensemble processing
-	 * engine so that everything appears to be good and proper in error
-	 * messages. Note that we cannot just concatenate and send through
-	 * Tcl_EvalObjEx, as that doesn't do ensemble processing, and we
-	 * cannot go through Tcl_EvalObjv without the extra work to pre-find
-	 * the command, as that finds command names in the wrong namespace at
-	 * the moment. Ugly!
-	 */
-
-	isRoot = TclInitRewriteEnsemble(interp, 3, 1, objv);
-
-	/*
-	 * Build the list of arguments using a Tcl_Obj as a workspace. See
-	 * comments above for why these contortions are necessary.
-	 */
-
-	objPtr = Tcl_NewObj();
-	obj2Ptr = Tcl_NewObj();
-	cmd = FindCommand(interp, objv[2], fPtr->defineNs);
-	if (cmd == NULL) {
-	    /* punt this case! */
-	    Tcl_AppendObjToObj(obj2Ptr, objv[2]);
-	} else {
-	    Tcl_GetCommandFullName(interp, cmd, obj2Ptr);
-	}
-	Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);
-	/* TODO: overflow? */
-	Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-3, objv+3);
-	Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs);
-
-	result = Tcl_EvalObjv(interp, objc-2, objs, TCL_EVAL_INVOKE);
-	if (isRoot) {
-	    TclResetRewriteEnsemble(interp, 1);
-	}
-	Tcl_DecrRefCount(objPtr);
+	result = MagicDefinitionInvoke(interp, fPtr->defineNs, 2, objc, objv);
     }
     DelRef(oPtr);
 
@@ -918,8 +945,8 @@ TclOOObjDefObjCmd(
     Tcl_Obj *const *objv)
 {
     Foundation *fPtr = TclOOGetFoundation(interp);
-    int isRoot, result;
     Object *oPtr;
+    int result;
 
     if (objc < 3) {
 	Tcl_WrongNumArgs(interp, 1, objv, "objectName arg ?arg ...?");
@@ -952,47 +979,7 @@ TclOOObjDefObjCmd(
 	}
 	TclDecrRefCount(objNameObj);
     } else {
-	Tcl_Obj *objPtr, *obj2Ptr, **objs;
-	Tcl_Command cmd;
-	int dummy;
-
-	/*
-	 * More than one argument: fire them through the ensemble processing
-	 * engine so that everything appears to be good and proper in error
-	 * messages. Note that we cannot just concatenate and send through
-	 * Tcl_EvalObjEx, as that doesn't do ensemble processing, and we
-	 * cannot go through Tcl_EvalObjv without the extra work to pre-find
-	 * the command, as that finds command names in the wrong namespace at
-	 * the moment. Ugly!
-	 */
-
-	isRoot = TclInitRewriteEnsemble(interp, 3, 1, objv);
-
-	/*
-	 * Build the list of arguments using a Tcl_Obj as a workspace. See
-	 * comments above for why these contortions are necessary.
-	 */
-
-	objPtr = Tcl_NewObj();
-	obj2Ptr = Tcl_NewObj();
-	cmd = FindCommand(interp, objv[2], fPtr->objdefNs);
-	if (cmd == NULL) {
-	    /* punt this case! */
-	    Tcl_AppendObjToObj(obj2Ptr, objv[2]);
-	} else {
-	    Tcl_GetCommandFullName(interp, cmd, obj2Ptr);
-	}
-	Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);
-	/* TODO: overflow? */
-	Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-3, objv+3);
-	Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs);
-
-	result = Tcl_EvalObjv(interp, objc-2, objs, TCL_EVAL_INVOKE);
-
-	if (isRoot) {
-	    TclResetRewriteEnsemble(interp, 1);
-	}
-	Tcl_DecrRefCount(objPtr);
+	result = MagicDefinitionInvoke(interp, fPtr->objdefNs, 2, objc, objv);
     }
     DelRef(oPtr);
 
@@ -1025,19 +1012,19 @@ TclOODefineSelfObjCmd(
     Tcl_Obj *const *objv)
 {
     Foundation *fPtr = TclOOGetFoundation(interp);
-    int result;
     Object *oPtr;
-
-    if (objc < 2) {
-	Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?");
-	return TCL_ERROR;
-    }
+    int result;
 
     oPtr = (Object *) TclOOGetDefineCmdContext(interp);
     if (oPtr == NULL) {
 	return TCL_ERROR;
     }
 
+    if (objc < 2) {
+	Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr));
+	return TCL_OK;
+    }
+
     /*
      * Make the oo::objdefine namespace the current namespace and evaluate the
      * command(s).
@@ -1059,46 +1046,7 @@ TclOODefineSelfObjCmd(
 	}
 	TclDecrRefCount(objNameObj);
     } else {
-	Tcl_Obj *objPtr, *obj2Ptr, **objs;
-	Tcl_Command cmd;
-	int isRoot, dummy;
-
-	/*
-	 * More than one argument: fire them through the ensemble processing
-	 * engine so that everything appears to be good and proper in error
-	 * messages. Note that we cannot just concatenate and send through
-	 * Tcl_EvalObjEx, as that doesn't do ensemble processing, and we
-	 * cannot go through Tcl_EvalObjv without the extra work to pre-find
-	 * the command, as that finds command names in the wrong namespace at
-	 * the moment. Ugly!
-	 */
-
-	isRoot = TclInitRewriteEnsemble(interp, 2, 1, objv);
-
-	/*
-	 * Build the list of arguments using a Tcl_Obj as a workspace. See
-	 * comments above for why these contortions are necessary.
-	 */
-
-	objPtr = Tcl_NewObj();
-	obj2Ptr = Tcl_NewObj();
-	cmd = FindCommand(interp, objv[1], fPtr->objdefNs);
-	if (cmd == NULL) {
-	    /* punt this case! */
-	    Tcl_AppendObjToObj(obj2Ptr, objv[1]);
-	} else {
-	    Tcl_GetCommandFullName(interp, cmd, obj2Ptr);
-	}
-	Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);
-	/* TODO: overflow? */
-	Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-2, objv+2);
-	Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs);
-
-	result = Tcl_EvalObjv(interp, objc-1, objs, TCL_EVAL_INVOKE);
-	if (isRoot) {
-	    TclResetRewriteEnsemble(interp, 1);
-	}
-	Tcl_DecrRefCount(objPtr);
+	result = MagicDefinitionInvoke(interp, fPtr->objdefNs, 1, objc, objv);
     }
     DelRef(oPtr);
 
@@ -1110,6 +1058,39 @@ TclOODefineSelfObjCmd(
     return result;
 }
 
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineObjSelfObjCmd --
+ *	Implementation of the "self" subcommand of the "oo::objdefine"
+ *	command.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineObjSelfObjCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Object *oPtr;
+
+    if (objc != 1) {
+	Tcl_WrongNumArgs(interp, 1, objv, NULL);
+	return TCL_ERROR;
+    }
+
+    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+
+    Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr));
+    return TCL_OK;
+}
+
 /*
  * ----------------------------------------------------------------------
  *

generic/tclOOInt.h

@@ -431,6 +431,9 @@ MODULE_SCOPE int	TclOODefineClassObjCmd(ClientData clientData,
 MODULE_SCOPE int	TclOODefineSelfObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const *objv);
+MODULE_SCOPE int	TclOODefineObjSelfObjCmd(ClientData clientData,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const *objv);
 MODULE_SCOPE int	TclOOUnknownDefinition(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const *objv);

generic/tclStrToD.c

@@ -1190,9 +1190,9 @@ TclParseNumber(
 	case sNA:
 	case sNANPAREN:
 	case sNANHEX:
+#endif
 	    Tcl_Panic("TclParseNumber: bad acceptState %d parsing '%s'",
 		    acceptState, bytes);
-#endif
 	case BINARY:
 	    shift = numTrailZeros;
 	    if (!significandOverflow && significandWide != 0 &&

generic/tclStringObj.c

@@ -2847,9 +2847,11 @@ TclStringCatObjv(
     Tcl_Obj * const objv[],
     Tcl_Obj **objPtrPtr)
 {
-    Tcl_Obj *objPtr, *objResultPtr, * const *ov;
-    int oc, length = 0, binary = 1, first = 0, last = 0;
+    Tcl_Obj *objResultPtr, * const *ov;
+    int oc, length = 0, binary = 1;
     int allowUniChar = 1, requestUniChar = 0;
+    int first = objc - 1;	/* Index of first value possibly not empty */
+    int last = 0;		/* Index of last value possibly not empty */
 
     /* assert ( objc >= 0 ) */
 
@@ -2870,7 +2872,7 @@ TclStringCatObjv(
 
     ov = objv, oc = objc;
     do {
-	objPtr = *ov++;
+	Tcl_Obj *objPtr = *ov++;
 
 	if (objPtr->bytes) {
 	    /* Value has a string rep. */
@@ -2906,7 +2908,7 @@ TclStringCatObjv(
 	/* Result will be pure byte array. Pre-size it */
 	ov = objv; oc = objc;
 	do {
-	    objPtr = *ov++;
+	    Tcl_Obj *objPtr = *ov++;
 
 	    if (objPtr->bytes == NULL) {
 		int numBytes;
@@ -2927,7 +2929,7 @@ TclStringCatObjv(
 	/* Result will be pure Tcl_UniChar array. Pre-size it. */
 	ov = objv; oc = objc;
 	do {
-	    objPtr = *ov++;
+	    Tcl_Obj *objPtr = *ov++;
 
 	    if ((objPtr->bytes == NULL) || (objPtr->length)) {
 		int numChars;
@@ -2945,45 +2947,94 @@ TclStringCatObjv(
 	    }
 	} while (--oc);
     } else {
-	Tcl_Obj *pendingPtr = NULL;
-
 	/* Result will be concat of string reps. Pre-size it. */
 	ov = objv; oc = objc;
 	do {
-	    int numBytes;
+	    Tcl_Obj *pendingPtr = NULL;
 
-	    objPtr = *ov++;
+	    /*
+	     * Loop until a possibly non-empty value is reached.
+	     * Keep string rep generation pending when possible.
+	     */
 
-	    if ((length == 0) && (objPtr->bytes == NULL) && !pendingPtr) {
-		/* No string rep; Take the chance we can avoid making it */
+	    do {
+		/* assert ( pendingPtr == NULL ) */
+		/* assert ( length == 0 ) */
 
-		last = objc - oc;
-		first = last;
-		pendingPtr = objPtr;
-	    } else {
+		Tcl_Obj *objPtr = *ov++;
 
-		Tcl_GetStringFromObj(objPtr, &numBytes); /* PANIC? */
-		if (numBytes == 0) {
-		    continue;
+		if (objPtr->bytes == NULL) {
+		    /* No string rep; Take the chance we can avoid making it */
+		    pendingPtr = objPtr;
+		} else {
+		    Tcl_GetStringFromObj(objPtr, &length); /* PANIC? */
 		}
-		last = objc - oc;
-		if (pendingPtr) {
-		    Tcl_GetStringFromObj(pendingPtr, &length); /* PANIC? */
-		    pendingPtr = NULL;
+	    } while (--oc && (length == 0) && (pendingPtr == NULL));
+
+	    /*
+ 	     * Either we found a possibly non-empty value, and we
+ 	     * remember this index as the first and last such value so
+ 	     * far seen, or (oc == 0) and all values are known empty,
+ 	     * so first = last = objc - 1 signals the right quick return.
+ 	     */
+
+	    first = last = objc - oc - 1;
+
+	    if (oc && (length == 0)) {
+		int numBytes;
+
+		/* assert ( pendingPtr != NULL ) */
+
+		/*
+		 * There's a pending value followed by more values.
+		 * Loop over remaining values generating strings until
+		 * a non-empty value is found, or the pending value gets
+		 * its string generated.
+		 */
+
+		do {
+		    Tcl_Obj *objPtr = *ov++;
+		    Tcl_GetStringFromObj(objPtr, &numBytes); /* PANIC? */
+		} while (--oc && numBytes == 0 && pendingPtr->bytes == NULL);
+
+		if (numBytes) {
+		    last = objc -oc -1;
+		}
+		if (oc || numBytes) {
+		    Tcl_GetStringFromObj(pendingPtr, &length);
 		}
 		if (length == 0) {
-		    first = last;
+		    if (numBytes) {
+			first = last;
+		    }
 		} else if (numBytes > INT_MAX - length) {
 		    goto overflow;
 		}
 		length += numBytes;
 	    }
-	} while (--oc);
+	} while (oc && (length == 0));
+
+	while (oc) {
+	    int numBytes;
+	    Tcl_Obj *objPtr = *ov++;
+
+	    /* assert ( length > 0 && pendingPtr == NULL )  */
+
+	    Tcl_GetStringFromObj(objPtr, &numBytes); /* PANIC? */
+	    if (numBytes) {
+		last = objc - oc;
+		if (numBytes > INT_MAX - length) {
+		    goto overflow;
+		}
+		length += numBytes;
+	    }
+	    --oc;
+	}
     }
 
-    if (last == first /*|| length == 0 */) {
+    if (last <= first /*|| length == 0 */) {
 	/* Only one non-empty value or zero length; return first */
-	/* NOTE: (length == 0) implies (last == first) */
+	/* NOTE: (length == 0) implies (last <= first) */
 	*objPtrPtr = objv[first];
 	return TCL_OK;
     }

library/http3/http.tcl

@@ -0,0 +1,700 @@
+package require Tcl 8.7-
+package provided http 3
+
+namespace eval ::http {
+    if {[info command ::http::Log] eq {}} {proc ::http::Log {args} {}}
+
+    variable ContextConfig {
+	-accept {string {^[^\s/]+/+[^\s/+]$} "MIME type"}
+	-charset string
+	-connectionclass class
+	-keepalive boolean
+	-proxyfilter callback
+	-proxyhost string
+	-proxyport integer
+	-strict boolean
+	-urlencoding encoding
+	-useragent string
+    }
+
+    variable ConnectionConfig {
+	-binary boolean
+	-blocksize integer
+	-channel channel
+	-command callback
+	-handler callback
+	-headers dict
+	-keepalive boolean
+	-method {string ^[A-Z0-9]+$ "uppercase string"}
+	-myaddr string
+	-progress callback
+	-protocol string
+	-query string
+	-queryblocksize integer
+	-querychannel channel
+	-queryprogress callback
+	-timeout integer
+	-type {string {^[^\s/]+/+[^\s/+]$} "MIME type"}
+	-validate boolean
+    }
+    variable ConnectionDefaults {
+	-binary false
+	-blocksize 8192
+	-queryblocksize 8192
+	-validate false
+	-headers {}
+	-timeout 0
+	-type application/x-www-form-urlencoded
+	-queryprogress {}
+	-protocol 1.1
+    }
+
+    oo::class create Context {
+	variable config
+	variable socketmap urltypes encodings charset keepalive
+	variable connectionclass counter
+
+	constructor {} {
+	    array set config {
+		-accept */*
+		-charset iso8859-1
+		-keepalive 0
+		-proxyhost {}
+		-proxyport {}
+		-urlencoding utf-8
+	    }
+	    set config(-proxyfilter) [namespace code {my ProxyRequired}]
+	    set connectionclass ::http::Connection
+
+	    # We need a useragent string of this style or various servers will
+	    # refuse to send us compressed content even when we ask for it.
+	    # This follows the de-facto layout of user-agent strings in
+	    # current browsers.  Safe interpreters do not have
+	    # ::tcl_platform(os) or ::tcl_platform(osVersion).
+
+	    if {[interp issafe]} {
+		set platform "Windows; U; Windows NT 10.0"
+	    } else {
+		global tcl_platform
+		set platform "[string totitle $tcl_platform(platform)]; U;\
+			$tcl_platform(os) $tcl_platform(osVersion)"
+	    }
+	    set config(-useragent) "Mozilla/5.0 ($platform)\
+		    http/[package provide http] Tcl/[package provide Tcl]"
+
+	    # Create a map for HTTP/1.1 open sockets
+	    if {[info exists socketmap]} {
+		# Close but don't remove open sockets on re-init
+		foreach {url sock} [array get socketmap] {
+		    catch {close $sock}
+		}
+	    }
+	    array set socketmap {}
+
+	    set urltypes(http) [list 80 ::socket]
+
+	    set encodings [string tolower [encoding names]]
+	    set charset "iso8859-1"
+	    set keepalive 0
+	    set counter 0
+	}
+
+	method register {proto port command} {
+	    set lower [string tolower $proto]
+	    try {
+		return $urltypes($lower)
+	    } on error {} {
+		return {}
+	    } finally {
+		set urltypes($lower) [list $port $command]
+	    }
+	}
+
+	method unregister {proto} {
+	    set lower [string tolower $proto]
+	    if {![info exists urlTypes($lower)]} {
+		return -code error "unsupported url type \"$proto\""
+	    }
+	    try {
+		return $urlTypes($lower)
+	    } finally {
+		unset -nocomplain urlTypes($lower)
+	    }
+	}
+
+	method configure {args} {
+	    variable ::http::ContextConfig
+
+	    set options [dict keys $ContextConfig]
+	    if {[llength $args] == 0} {
+		set result {}
+		dict for {option typeinfo} $ContextConfig {
+		    lappend result $option $config($option)
+		}
+		return $result
+	    }
+	    if {[llength $args] == 1} {
+		set opt [::tcl::prefix match $options [lindex $args 0]]
+		return $config($opt)
+	    }
+	    foreach {option value} $args {
+		set opt [::tcl::prefix match $options $option]
+		set typeinfo [lassign [dict get $ContextConfig $opt] type]
+		::http::Validate($type) $opt $value {*}$typeinfo
+		set config($opt) $value
+	    }
+	}
+
+	method formatQuery args {
+	    set result ""
+	    set sep ""
+	    foreach i $args {
+		append result $sep [my mapReply $i]
+		if {$sep eq "="} {
+		    set sep &
+		} else {
+		    set sep =
+		}
+	    }
+	    return $result
+	}
+
+	method mapReply {string} {
+	    # The spec says: "non-alphanumeric characters are replaced by
+	    # '%HH'". [Bug 1020491] [regsub -command] is *designed* for this.
+
+	    if {$urlencoding ne ""} {
+		set string [encoding convertto $urlencoding $string]
+	    }
+
+	    set RE "(\r?\n)|(\[^._~a-zA-Z0-9\])"
+	    return [regsub -all -command -- $RE $string {apply {{- nl ch} {
+		# RFC3986 Section 2.3 say percent encode all except:
+		# "... percent-encoded octets in the ranges of ALPHA (%41-%5A
+		# and %61-%7A), DIGIT (%30-%39), hyphen (%2D), period (%2E),
+		# underscore (%5F), or tilde (%7E) should not be created by
+		# URI producers ..."
+		#
+		# Note that newline is a special case
+		if {$nl ne ""} {return %0D%0A}
+		scan $ch %c c
+		return [format %%%.2X $c]
+	    }}}]
+	}
+
+	method geturl {url args} {
+	    variable ::http::ConnectionConfig
+	    variable ::http::ConnectionDefaults
+	    if {[llength $args] & 1} {
+		return -code error "missing configuration option"
+	    }
+	    set names [dict keys $ConnectionConfig]
+	    set options [dict map {opt value} $args {
+		set opt [::tcl::prefix match $names $opt]
+		set typeinfo [lassign [dict get $ConnectionConfig $opt] type]
+		::http::Validate($type) $opt $value {*}$typeinfo
+		set value
+	    }]
+	    $connectionclass create [incr counter] \
+		[self] $url $ConnectionDefaults $options
+	}
+
+	method ProxyRequred {host} {
+	    if {[info exists proxyhost] && [string length $proxyhost]} {
+		if {![info exists proxyport] || ![string length $proxyport]} {
+		    set proxyport 8080
+		}
+		return [list $proxyhost $proxyport]
+	    }
+	}
+
+	method parseURL {url} {
+	    # Validate URL, determine the server host and port, and check
+	    # proxy case Recognize user:pass@host URLs also, although we do
+	    # not do anything with that info yet.
+
+	    # URLs have basically four parts.
+	    #
+	    # First, before the colon, is the protocol scheme (e.g. http).
+	    #
+	    # Second, for HTTP-like protocols, is the authority. The authority
+	    #	is preceded by // and lasts up to (but not including) the
+	    #	following / or ? and it identifies up to four parts, of which
+	    #	only one, the host, is required (if an authority is present at
+	    #	all). All other parts of the authority (user name, password,
+	    #	port number) are optional.
+	    #
+	    # Third is the resource name, which is split into two parts at a ?
+	    #	The first part (from the single "/" up to "?") is the path,
+	    #	and the second part (from that "?" up to "#") is the
+	    #	query. *HOWEVER*, we do not need to separate them; we send the
+	    #	whole lot to the server.  Both, path and query are allowed to
+	    #	be missing, including their delimiting character.
+	    #
+	    # Fourth is the fragment identifier, which is everything after the
+	    #	firsts "#" in the URL. The fragment identifier MUST NOT be
+	    #	sent to the server and indeed, we don't bother to validate it
+	    #	(it could be an error to pass it in here, but it's cheap to
+	    #	strip).
+	    #
+	    # An example of a URL that has all the parts:
+	    #
+	    #   http://joe:xyzzy@www.bogus.net:8000/foo/bar.tml?q=foo#changes
+	    #
+	    # The "http" is the protocol, the user is "joe", the password is
+	    # "xyzzy", the host is "www.bogus.net", the port is "8000", the
+	    # path is "/foo/bar.tml", the query is "q=foo", and the fragment
+	    # is "changes".
+	    #
+	    # Note that the RE actually combines the user and password parts,
+	    # as recommended in RFC 3986. Indeed, that RFC states that putting
+	    # passwords in URLs is a Really Bad Idea, something with which I
+	    # would agree utterly.
+	    #
+	    # From a validation perspective, we need to ensure that the parts
+	    # of the URL that are going to the server are correctly encoded.
+	    # This is only done if $config(-strict) is true.
+
+	    set URLmatcher {(?x)	# this is _expanded_ syntax
+		^
+		(?: (\w+) : ) ?		# <protocol scheme>
+		(?: //
+		    (?:
+			(
+			    [^@/\#?]+	# <userinfo part of authority>
+			) @
+		    )?
+		    (			# <host part of authority>
+			[^/:\#?]+ |	# host name or IPv4 address
+			\[ [^/\#?]+ \]	# IPv6 address in square brackets
+		    )
+		    (?: : (\d+) )?	# <port part of authority>
+		)?
+		( [/\?] [^\#]*)?	# <path> (including query)
+		(?: \# (.*) )?		# <fragment>
+		$
+	    }
+
+	    # Phase one: parse
+	    if {![regexp -- $URLmatcher $url -> \
+		    proto user host port srvurl fragment]} {
+		return -code error "unsupported URL: $url"
+	    }
+	    # Phase two: validate
+	    set host [string trim $host {[]}]; # strip square brackets from IPv6 address
+	    if {$host eq ""} {
+		# Caller has to provide a host name; we do not have a "default
+		# host" that would enable us to handle relative URLs.
+		return -code error "Missing host part: $url"
+		# Note that we don't check the hostname for validity here; if
+		# it's invalid, we'll simply fail to resolve it later on.
+	    }
+	    if {$port ne "" && $port > 65535} {
+		return -code error "invalid port number: $port"
+	    }
+	    # The user identification and resource identification parts of the
+	    # URL can have encoded characters in them; take care!
+	    if {$user ne ""} {
+		# Check for validity according to RFC 3986, Appendix A
+		set validityRE {(?xi)
+		    ^
+		    (?: [-\w.~!$&'()*+,;=:] | %[0-9a-f][0-9a-f] )+
+		    $
+		}
+		if {$config(-strict) && ![regexp -- $validityRE $user]} {
+		    # Provide a better error message in this error case
+		    if {[regexp {(?i)%(?![0-9a-f][0-9a-f]).?.?} $user bad]} {
+			return -code error \
+			    "illegal encoding character usage \"$bad\" in URL user"
+		    }
+		    return -code error "illegal characters in URL user"
+		}
+	    }
+	    if {$srvurl ne ""} {
+		# RFC 3986 allows empty paths (not even a /), but servers
+		# return 400 if the path in the HTTP request doesn't start
+		# with / , so add it here if needed.
+		if {[string index $srvurl 0] ne "/"} {
+		    set srvurl /$srvurl
+		}
+		# Check for validity according to RFC 3986, Appendix A
+		set validityRE {(?xi)
+		    ^
+		    # Path part (already must start with / character)
+		    (?:	      [-\w.~!$&'()*+,;=:@/]  | %[0-9a-f][0-9a-f] )*
+		    # Query part (optional, permits ? characters)
+		    (?: \? (?: [-\w.~!$&'()*+,;=:@/?] | %[0-9a-f][0-9a-f] )* )?
+		    $
+		}
+		if {$config(-strict) && ![regexp -- $validityRE $srvurl]} {
+		    # Provide a better error message in this error case
+		    if {[regexp {(?i)%(?![0-9a-f][0-9a-f])..} $srvurl bad]} {
+			return -code error \
+			    "illegal encoding character usage \"$bad\" in URL path"
+		    }
+		    return -code error "illegal characters in URL path"
+		}
+	    }
+
+	    return [list $proto $user $host $port $srvurl \
+		    [string trimleft $fragment "#"]]
+	}
+    }
+
+    oo::class create Connection {
+	variable cfg urlTypes http
+	variable binary state meta coding currentsize totalsize querylength
+	variable queryoffset type body status httpline connection charset
+	variable theURL after socketinfo sock acceptTypes
+
+	constructor {context url defaults options} {
+	    interp alias {} [namespace current]::Context {} $context
+	    set ns [info object namespace $context]
+	    my eval namespace upvar $ns \
+		config http urlTypes urlTypes socketmap socketmap
+	    foreach {opt value} $defaults {
+		set cfg($opt) $value
+	    }
+	    set cfg(-keepalive) $http(-keepalive)
+	    foreach {opt value} $options {
+		set cfg($opt) $value
+	    }
+
+	    my reset
+
+	    set binary 0
+	    set state connecting
+	    set meta {}
+	    set coding {}
+	    set currentsize 0
+	    set totalsize 0
+	    set querylength 0
+	    set queryoffset 0
+	    set type text/html
+	    set body {}
+	    set status ""
+	    set httpline ""
+	    set connection close
+	    set charset $http(-charset)
+
+	    if {[info exists cfg(-querychannel)]&&[info exists cfg(-query)]} {
+		return -code error \
+		    "can't use -query and -querychannel options together"
+	    }
+
+	    lassign [Context parseURL $url] proto user host port srvurl
+	    if {$srvurl eq ""} {
+		set srvurl "/"
+	    }
+	    if {$proto eq ""} {
+		set proto "http"
+	    }
+	    set lower [string tolower $proto]
+	    if {![info exists urlTypes($lower)]} {
+		return -code error "unsupported URL type \"$proto\""
+	    }
+	    lassign $urlTypes($lower) defport defcmd
+	    if {$port eq ""} {
+		set port $defport
+	    }
+
+	    # Check for the proxy's opinion
+	    catch {
+		if {[llength $http(-proxyfilter)]} {
+		    lassign [{*}$http(-proxyfilter) $host] phost pport
+		}
+	    }
+
+	    # OK, now reassemble into a full URL
+	    set url ${proto}://
+	    if {$user ne ""} {
+		append url $user
+		append url @
+	    }
+	    append url $host
+	    if {$port != $defport} {
+		append url : $port
+	    }
+	    append url $srvurl
+	    # Don't append the fragment!
+	    set theURL $url
+
+	    # If a timeout is specified we set up the after event and arrange
+	    # for an asynchronous socket connection.
+
+	    set sockopts [list -async]
+	    if {$cfg(-timeout) > 0} {
+		set after [after $cfg(-timeout) [namespace code {
+		    my reset timeout
+		}]]
+	    }
+
+	    # If we are using the proxy, we must pass in the full URL that
+	    # includes the server name.
+
+	    if {[info exists phost] && ($phost ne "")} {
+		set srvurl $url
+		set targetAddr [list $phost $pport]
+	    } else {
+		set targetAddr [list $host $port]
+	    }
+	    # Proxy connections aren't shared among different hosts.
+	    set socketinfo $host:$port
+
+	    # Save the accept types at this point to prevent a race condition.
+	    # [Bug c11a51c482]
+	    set acceptTypes $http(-accept)
+
+	    # See if we are supposed to use a previously opened channel.
+	    if {$cfg(-keepalive)} {
+		if {[info exists socketmap($socketinfo)]} {
+		    if {[catch {fconfigure $socketmap($socketinfo)}]} {
+			Log "WARNING: socket for $socketinfo was closed"
+			unset socketmap($socketinfo)
+		    } else {
+			set sock $socketmap($socketinfo)
+			Log "reusing socket $sock for $socketinfo"
+			catch {fileevent $sock writable {}}
+			catch {fileevent $sock readable {}}
+		    }
+		}
+		# don't automatically close this connection socket
+		set connection {}
+	    }
+	    if {![info exists sock]} {
+		# Pass -myaddr directly to the socket command
+		if {[info exists cfg(-myaddr)]} {
+		    lappend sockopts -myaddr $cfg(-myaddr)
+		}
+		try {
+		    set sock [{*}$defcmd {*}$sockopts {*}$targetAddr]
+		} on error {msg} {
+		    # Something went wrong while trying to establish the
+		    # connection.  Clean up after events and such, but DON'T
+		    # call the command callback (if available) because we're
+		    # going to throw an exception from here instead.
+		    my Finish "" 1
+		    return -code error $msg
+		}
+	    }
+	    Log "Using $sock for $socketinfo" \
+		[expr {$cfg(-keepalive) ? "keepalive" : ""}]
+	    if {$cfg(-keepalive)} {
+		set socketmap($socketinfo) $sock
+	    }
+
+	    if {![info exists phost]} {
+		set phost ""
+	    }
+	    fileevent $sock writable [namespace code [list \
+		my Connect $proto $phost $srvurl]]
+
+	    # Wait for the connection to complete.
+	    if {![info exists cfg(-command)]} {
+		# geturl does EVERYTHING asynchronously, so if the user calls
+		# it synchronously, we just do a wait here.
+		my wait
+
+		if {![info exists status]} {
+		    # If we timed out then Finish has been called and the
+		    # users command callback may have cleaned up the token. If
+		    # so we end up here with nothing left to do.
+		    return
+		} elseif {$status eq "error"} {
+		    # Something went wrong while trying to establish the
+		    # connection.  Clean up after events and such, but DON'T
+		    # call the command callback (if available) because we're
+		    # going to throw an exception from here instead.
+		    return -code error [lindex $error 0]
+		}
+	    }
+	}
+
+	method Connect {proto phost srvurl} {
+	    
+	}
+
+	destructor {
+	}
+
+	method reset {{why ""}} {
+	}
+
+	method wait {} {
+	    if {![info exists status] || $status eq ""} {
+		# We must wait on the true variable name, not the local
+		# unqualified version.
+		vwait [my varname status]
+	    }
+
+	    return [my status]
+	}
+
+	method data {} {
+	    return $body
+	}
+
+	method error {} {
+	    if {[info exists error]} {
+		return $error
+	    }
+	    return ""
+	}
+
+	method status {} {
+	    if {![info exists status]} {
+		return "error"
+	    }
+	    return $status
+	}
+
+	method code {} {
+	    return $httpline
+	}
+
+	method ncode {} {
+	    set thecode [my code]
+	    if {[regexp {[0-9]{3}} $thecode numeric_code]} {
+		return $numeric_code
+	    } else {
+		return $thecode
+	    }
+	}
+
+	method size {} {
+	    return $currentsize
+	}
+
+	method meta {} {
+	    return $meta
+	}
+
+	# Return the list of content-encoding transformations we need to do in
+	# order.
+	method ContentEncoding {} {
+	    set r {}
+	    if {[info exists coding]} {
+		foreach c [split $coding ,] {
+		    switch -exact -- $c {
+			deflate { lappend r inflate }
+			gzip - x-gzip { lappend r gunzip }
+			compress - x-compress { lappend r decompress }
+			identity {}
+			default {
+			    return -code error \
+				"unsupported content-encoding \"$c\""
+			}
+		    }
+		}
+	    }
+	    return $r
+	}
+    }
+
+    # ----------------------------------------------------------------------
+    # General type validators
+
+    proc Validate(boolean) {option value} {
+	if {![string is boolean -strict $value]} {
+	    return -code error \
+		"bad value for $option ($value), must be boolean"
+	}
+    }
+
+    proc Validate(integer) {option value} {
+	if {![string is integer -strict $value] || $value < 0} {
+	    return -code error \
+		"bad value for $option ($value), must be non-negative integer"
+	}
+    }
+
+    proc Validate(channel) {option value} {
+	if {$value ni [channel names]} {
+	    return -code error \
+		"bad value for $option ($value), must be open channel"
+	}
+    }
+
+    proc Validate(encoding) {option value} {
+	if {$value ni [encoding names]} {
+	    return -code error \
+		"bad value for $option ($value), must be encoding"
+	}
+    }
+
+    proc Validate(string) {option value {regexp ""} {typedesc ""}} {
+	if {$regexp ne "" && ![regexp -- $regexp $value]} {
+	    if {$typedesc eq ""} {
+		set typedesc "match for $regexp"
+	    }
+	    return -code error \
+		"bad value for $option ($value), must be $typedesc"
+	}
+    }
+
+    proc Validate(callback) {option value} {
+	if {![string is list $value]} {
+	    return -code error \
+		"bad value for $option ($value), must be command prefix"
+	}
+    }
+
+    proc Validate(dict) {option value} {
+	if {![string is list $value] || [llength $value] & 1} {
+	    return -code error \
+		"bad value for $opt ($value), must be dict"
+	}
+    }
+
+    proc Validate(class) {option value} {
+	if {![info object isa class $value]} {
+	    return -code error \
+		"bad value for $opt ($value), must be class"
+	}
+    }
+
+    # http::CharsetToEncoding --
+    #
+    #	Tries to map a given IANA charset to a tcl encoding.  If no encoding
+    #	can be found, returns binary.
+    #
+
+    proc CharsetToEncoding {charset} {
+	variable encodings
+
+	set charset [string tolower $charset]
+	if {[regexp {iso-?8859-([0-9]+)} $charset -> num]} {
+	    set encoding "iso8859-$num"
+	} elseif {[regexp {iso-?2022-(jp|kr)} $charset -> ext]} {
+	    set encoding "iso2022-$ext"
+	} elseif {[regexp {shift[-_]?js} $charset]} {
+	    set encoding "shiftjis"
+	} elseif {[regexp {(?:windows|cp)-?([0-9]+)} $charset -> num]} {
+	    set encoding "cp$num"
+	} elseif {$charset eq "us-ascii"} {
+	    set encoding "ascii"
+	} elseif {[regexp {(?:iso-?)?lat(?:in)?-?([0-9]+)} $charset -> num]} {
+	    switch -- $num {
+		5 {set encoding "iso8859-9"}
+		1 - 2 - 3 {
+		    set encoding "iso8859-$num"
+		}
+	    }
+	} else {
+	    # other charset, like euc-xx, utf-8,... may directly map to
+	    # encoding
+	    set encoding $charset
+	}
+	set idx [lsearch -exact $encodings $encoding]
+	if {$idx >= 0} {
+	    return $encoding
+	} else {
+	    return "binary"
+	}
+    }
+}
+
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: t
+# End:

tests/format.test

@@ -79,6 +79,25 @@ test format-1.11.1 {integer formatting} longIs64bit {
 test format-1.12 {integer formatting} {
     format "%b %#b %#b %llb" 5 0 5 [expr {2**100}]
 } {101 0b0 0b101 10000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000}
+test format-1.13 {integer formatting} longIs32bit {
+    format "%#d %#d %#d %#d %#d" 0 6 34 16923 -12 -1
+} {0 6 34 16923 -12}
+test format-1.13.1 {integer formatting} longIs64bit {
+    format "%#d %#d %#d %#d %#d" 0 6 34 16923 -12 -1
+} {0 6 34 16923 -12}
+test format-1.14 {integer formatting} longIs32bit {
+    format "%#5d %#20d %#20d %#20d %#20d" 0 6 34 16923 -12 -1
+} {    0                    6                   34                16923                  -12}
+test format-1.14.1 {integer formatting} longIs64bit {
+    format "%#5d %#20d %#20d %#20d %#20d" 0 6 34 16923 -12 -1
+} {    0                    6                   34                16923                  -12}
+test format-1.15 {integer formatting} longIs32bit {
+    format "%-#5d %-#20d %-#20d %-#20d %-#20d" 0 6 34 16923 -12 -1
+} {0     6                    34                   16923                -12                 }
+test format-1.15.1 {integer formatting} longIs64bit {
+    format "%-#5d %-#20d %-#20d %-#20d %-#20d" 0 6 34 16923 -12 -1
+} {0     6                    34                   16923                -12                 }
+
 
 test format-2.1 {string formatting} {
     format "%s %s %c %s" abcd {This is a very long test string.} 120 x

tests/oo.test

@@ -2013,6 +2013,41 @@ test oo-15.10 {variable binding must not bleed through oo::copy} -setup {
 } -cleanup {
     FooClass destroy
 } -result {foo bar grill bar}
+test oo-15.11 {OO: object cloning} -returnCodes error -body {
+    oo::copy
+} -result {wrong # args: should be "oo::copy sourceName ?targetName? ?targetNamespace?"}
+test oo-15.12 {OO: object cloning with target NS} -setup {
+    oo::class create Super
+    oo::class create Cls {superclass Super}
+} -body {
+    namespace eval ::existing {}
+    oo::copy Cls {} ::existing
+} -returnCodes error -cleanup {
+    Super destroy
+    catch {namespace delete ::existing}
+} -result {::existing refers to an existing namespace}
+test oo-15.13 {OO: object cloning with target NS} -setup {
+    oo::class create Super
+    oo::class create Cls {superclass Super}
+} -body {
+    list [namespace exist ::dupens] [oo::copy Cls Cls2 ::dupens] [namespace exist ::dupens]
+} -cleanup {
+    Super destroy
+} -result {0 ::Cls2 1}
+test oo-15.14 {OO: object cloning with target NS} -setup {
+    oo::class create Cls {export eval}
+    set result {}
+} -body {
+    Cls create obj
+    obj eval {
+	proc test-15.14 {} {}
+    }
+    lappend result [info commands ::dupens::t*]
+    oo::copy obj obj2 ::dupens
+    lappend result [info commands ::dupens::t*]
+} -cleanup {
+    Cls destroy
+} -result {{} ::dupens::test-15.14}
 
 test oo-16.1 {OO: object introspection} -body {
     info object
@@ -3766,6 +3801,113 @@ test oo-35.4 {Bug 593baa032c: mixins list teardown} {
     namespace eval [info object namespace D] [list [namespace which B] destroy]
 } {}
 
+test oo-36.1 {TIP #470: introspection within oo::define} {
+    oo::define oo::object self
+} ::oo::object
+test oo-36.2 {TIP #470: introspection within oo::define} -setup {
+    oo::class create Cls
+} -body {
+    oo::define Cls self
+} -cleanup {
+    Cls destroy
+} -result ::Cls
+test oo-36.3 {TIP #470: introspection within oo::define} -setup {
+    oo::class create Super
+    set result uncalled
+} -body {
+    oo::class create Sub {
+	superclass Super
+	::set ::result [self]
+    }
+    return $result
+} -cleanup {
+    Super destroy
+} -result ::Sub
+test oo-36.4 {TIP #470: introspection within oo::define} -setup {
+    oo::class create Super
+    set result uncalled
+} -body {
+    oo::class create Sub {
+	superclass Super
+	::set ::result [self {}]
+    }
+    return $result
+} -cleanup {
+    Super destroy
+} -result {}
+test oo-36.5 {TIP #470: introspection within oo::define} -setup {
+    oo::class create Super
+    set result uncalled
+} -body {
+    oo::class create Sub {
+	superclass Super
+	::set ::result [self self]
+    }
+} -cleanup {
+    Super destroy
+} -result ::Sub
+test oo-36.6 {TIP #470: introspection within oo::objdefine} -setup {
+    oo::class create Cls
+    set result uncalled
+} -body {
+    Cls create obj
+    oo::objdefine obj {
+	::set ::result [self]
+    }
+} -cleanup {
+    Cls destroy
+} -result ::obj
+test oo-36.7 {TIP #470: introspection within oo::objdefine} -setup {
+    oo::class create Cls
+} -body {
+    Cls create obj
+    oo::objdefine obj {
+	self
+    }
+} -cleanup {
+    Cls destroy
+} -result ::obj
+test oo-36.8 {TIP #470: introspection within oo::objdefine} -setup {
+    oo::class create Cls
+} -body {
+    Cls create obj
+    oo::objdefine obj {
+	self anything
+    }
+} -returnCodes error -cleanup {
+    Cls destroy
+} -result {wrong # args: should be "self"}
+test oo-36.9 {TIP #470: introspection within oo::define} -setup {
+    oo::class create Cls
+    set result uncalled
+} -body {
+    proc oo::define::testself {} {
+	global result
+	set result [list [catch {self} msg] $msg \
+			[catch {uplevel 1 self} msg] $msg]
+	return
+    }
+    list [oo::define Cls testself] $result
+} -cleanup {
+    Cls destroy
+    catch {rename oo::define::testself {}}
+} -result {{} {1 {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command} 0 ::Cls}}
+test oo-36.10 {TIP #470: introspection within oo::define} -setup {
+    oo::class create Cls
+    set result uncalled
+} -body {
+    proc oo::objdefine::testself {} {
+	global result
+	set result [list [catch {self} msg] $msg \
+			[catch {uplevel 1 self} msg] $msg]
+	return
+    }
+    Cls create obj
+    list [oo::objdefine obj testself] $result
+} -cleanup {
+    Cls destroy
+    catch {rename oo::objdefine::testself {}}
+} -result {{} {1 {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command} 0 ::obj}}
 
 cleanupTests
 return

tests/regexp.test

@@ -19,6 +19,20 @@ if {"::tcltest" ni [namespace children]} {
 unset -nocomplain foo
 
 testConstraint exec [llength [info commands exec]]
+
+# Used for constraining memory leak tests
+testConstraint memory [llength [info commands memory]]
+if {[testConstraint memory]} {
+    proc memtest script {
+	set end [lindex [split [memory info] \n] 3 3]
+	for {set i 0} {$i < 5} {incr i} {
+	    uplevel 1 $script
+	    set tmp $end
+	    set end [lindex [split [memory info] \n] 3 3]
+	}
+	expr {$end - $tmp}
+    }
+}
 
 test regexp-1.1 {basic regexp operation} {
     regexp ab*c abbbc
@@ -453,7 +467,7 @@ test regexp-11.4 {regsub errors} {
 } {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}}
 test regexp-11.5 {regsub errors} {
     list [catch {regsub -gorp a b c} msg] $msg
-} {1 {bad option "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}}
+} {1 {bad option "-gorp": must be -all, -command, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}}
 test regexp-11.6 {regsub errors} {
     list [catch {regsub -nocase a( b c d} msg] $msg
 } {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
@@ -1123,6 +1137,57 @@ test regexp-26.12 {regexp with -line option} {
 test regexp-26.13 {regexp without -line option} {
     regexp -all -inline -- {a*} "b\n"
 } {{} {}}
+
+test regexp-27.1 {regsub -command} {
+    regsub -command {.x.} {abcxdef} {string length}
+} ab3ef
+test regexp-27.2 {regsub -command} {
+    regsub -command {.x.} {abcxdefxghi} {string length}
+} ab3efxghi
+test regexp-27.3 {regsub -command} {
+    set x 0
+    regsub -all -command {(?=.)} abcde {apply {args {incr ::x}}}
+} 1a2b3c4d5e
+test regexp-27.4 {regsub -command} -body {
+    regsub -command {.x.} {abcxdef} error
+} -returnCodes error -result cxd
+test regexp-27.5 {regsub -command} {
+    regsub -command {(.)(.)} {abcdef} {list ,}
+} {, ab a bcdef}
+test regexp-27.6 {regsub -command} {
+    regsub -command -all {(.)(.)} {abcdef} {list ,}
+} {, ab a b, cd c d, ef e f}
+test regexp-27.7 {regsub -command representation smash} {
+    set ::s {123=456 789}
+    regsub -command -all {\d+} $::s {apply {n {
+	expr {[llength $::s] + $n}
+    }}}
+} {125=458 791}
+test regexp-27.8 {regsub -command representation smash} {
+    set ::t {apply {n {
+	expr {[llength [lindex $::t 1 1 1]] + $n}
+    }}}
+    regsub -command -all {\d+} "123=456 789" $::t
+} {131=464 797}
+test regexp-27.9 {regsub -command memory leak testing} memory {
+    set ::s "123=456 789"
+    set ::t {apply {n {
+	expr {[llength [lindex $::t 1 1 1]] + [llength $::s] + $n}
+    }}}
+    memtest {
+	regsub -command -all {\d+} $::s $::t
+    }
+} 0
+test regexp-27.10 {regsub -command error cases} -returnCodes error -body {
+    regsub -command . abc "def \{ghi"
+} -result {unmatched open brace in list}
+test regexp-27.11 {regsub -command error cases} -returnCodes error -body {
+    regsub -command . abc {}
+} -result {command prefix must be a list of at least one element}
+test regexp-27.12 {regsub -command representation smash} {
+    set s {list (.+)}
+    regsub -command $s {list list} $s
+} {(.+) {list list} list}
 
 # cleanup
 ::tcltest::cleanupTests

tests/regexpComp.test

@@ -587,7 +587,7 @@ test regexpComp-11.5 {regsub errors} {
     evalInProc {
 	list [catch {regsub -gorp a b c} msg] $msg
     }
-} {1 {bad option "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}}
+} {1 {bad option "-gorp": must be -all, -command, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}}
 test regexpComp-11.6 {regsub errors} {
     evalInProc {
 	list [catch {regsub -nocase a( b c d} msg] $msg

tests/string.test

@@ -2024,6 +2024,21 @@ test string-29.13 {string cat, efficiency} -body {
     tcl::unsupported::representation [string cat \
 	[encoding convertto utf-8 {}] [encoding convertto utf-8 {}] [list x]]
 } -match glob -result {*, string representation "x"}
+test string-29.14 {string cat, efficiency} -setup {
+    set e [encoding convertto utf-8 {}]
+} -cleanup {
+    unset e
+} -body {
+    tcl::unsupported::representation [string cat $e $e [list x]]
+} -match glob -result {*no string representation}
+test string-29.15 {string cat, efficiency} -setup {
+    set e [encoding convertto utf-8 {}]
+    set f [encoding convertto utf-8 {}]
+} -cleanup {
+    unset e f
+} -body {
+    tcl::unsupported::representation [string cat $e $f $e $f [list x]]
+} -match glob -result {*no string representation}
 
 
 

unix/tclUnixSock.c

@@ -730,6 +730,8 @@ TcpClose2Proc(
  */
 
 #ifndef NEED_FAKE_RFC2553
+#pragma GCC diagnostic push
+#pragma GCC diagnostic ignored "-Wstrict-aliasing"
 static inline int
 IPv6AddressNeedsNumericRendering(
     struct in6_addr addr)
@@ -743,16 +745,14 @@ IPv6AddressNeedsNumericRendering(
      * at least some versions of OSX.
      */
 
-#pragma GCC diagnostic push
-#pragma GCC diagnostic ignored "-Wstrict-aliasing"
     if (!IN6_IS_ADDR_V4MAPPED(&addr)) {
-#pragma GCC diagnostic pop
         return 0;
     }
 
     return (addr.s6_addr[12] == 0 && addr.s6_addr[13] == 0
             && addr.s6_addr[14] == 0 && addr.s6_addr[15] == 0);
 }
+#pragma GCC diagnostic pop
 #endif /* NEED_FAKE_RFC2553 */
 
 static void