Merge trunk

1 files changed, 233 insertions, 153 deletions

diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 11f8ea2..8d0f43e 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -12,6 +12,8 @@
  */
 
 #include "tclInt.h"
+#include "tclIO.h"
+#include "tclTomMath.h"
 #ifdef _WIN32
 #   include "tclWinInt.h"
 #endif
@@ -49,6 +51,7 @@ static Tcl_ObjCmdProc	EncodingConvertfromObjCmd;
 static Tcl_ObjCmdProc	EncodingConverttoObjCmd;
 static Tcl_ObjCmdProc	EncodingDirsObjCmd;
 static Tcl_ObjCmdProc	EncodingNamesObjCmd;
+static Tcl_ObjCmdProc	EncodingProfilesObjCmd;
 static Tcl_ObjCmdProc	EncodingSystemObjCmd;
 static inline int	ForeachAssignments(Tcl_Interp *interp,
 			    struct ForeachState *statePtr);
@@ -384,6 +387,7 @@ TclInitEncodingCmd(
 	{"convertto",   EncodingConverttoObjCmd,   TclCompileBasic1To3ArgCmd, NULL, NULL, 0},
 	{"dirs",        EncodingDirsObjCmd,        TclCompileBasic0Or1ArgCmd, NULL, NULL, 1},
 	{"names",       EncodingNamesObjCmd,       TclCompileBasic0ArgCmd,    NULL, NULL, 0},
+	{"profiles",    EncodingProfilesObjCmd,    TclCompileBasic0ArgCmd,    NULL, NULL, 0},
 	{"system",      EncodingSystemObjCmd,      TclCompileBasic0Or1ArgCmd, NULL, NULL, 1},
 	{NULL,          NULL,                      NULL,                      NULL, NULL, 0}
     };
@@ -392,6 +396,116 @@ TclInitEncodingCmd(
 }
 
 /*
+ *------------------------------------------------------------------------
+ *
+ * EncodingConvertParseOptions --
+ *
+ *    Common routine for parsing arguments passed to encoding convertfrom
+ *    and encoding convertto.
+ *
+ * Results:
+ *    TCL_OK or TCL_ERROR.
+ *
+ * Side effects:
+ *    On success,
+ *    - *encPtr is set to the encoding. Must be freed with Tcl_FreeEncoding
+ *      if non-NULL
+ *    - *dataObjPtr is set to the Tcl_Obj containing the data to encode or
+ *      decode
+ *    - *profilePtr is set to encoding error handling profile
+ *    - *failVarPtr is set to -failindex option value or NULL
+ *    On error, all of the above are uninitialized.
+ *
+ *------------------------------------------------------------------------
+ */
+static int
+EncodingConvertParseOptions (
+    Tcl_Interp *interp,    /* For error messages. May be NULL */
+    int objc,		   /* Number of arguments */
+    Tcl_Obj *const objv[], /* Argument objects as passed to command. */
+    Tcl_Encoding *encPtr,  /* Where to store the encoding */
+    Tcl_Obj **dataObjPtr,  /* Where to store ptr to Tcl_Obj containing data */
+    int *profilePtr,         /* Bit mask of encoding option profile */
+    Tcl_Obj **failVarPtr   /* Where to store -failindex option value */
+)
+{
+    static const char *const options[] = {"-profile", "-failindex", NULL};
+    enum convertfromOptions { PROFILE, FAILINDEX } optIndex;
+    Tcl_Encoding encoding;
+    Tcl_Obj *dataObj;
+    Tcl_Obj *failVarObj;
+#if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED)
+    int profile = TCL_ENCODING_PROFILE_TCL8; /* TODO - default for Tcl9? */
+#else
+    int profile = TCL_ENCODING_PROFILE_TCL8;
+#endif
+
+    /*
+     * Possible combinations:
+     * 1) data						-> objc = 2
+     * 2) ?options? encoding data			-> objc >= 3
+     * It is intentional that specifying option forces encoding to be
+     * specified. Less prone to user error. This should have always been
+     * the case even in 8.6 imho where there were no options (ie (1)
+     * should never have been allowed)
+     */
+
+    if (objc == 1) {
+numArgsError: /* ONLY jump here if nothing needs to be freed!!! */
+	Tcl_WrongNumArgs(interp,
+			 1,
+			 objv,
+			 "?-profile profile? ?-failindex var? encoding data");
+	((Interp *)interp)->flags |= INTERP_ALTERNATE_WRONG_ARGS;
+	Tcl_WrongNumArgs(interp, 1, objv, "data");
+	return TCL_ERROR;
+    }
+
+    failVarObj = NULL;
+    if (objc == 2) {
+	encoding = Tcl_GetEncoding(interp, NULL);
+	dataObj = objv[1];
+    } else {
+	int argIndex;
+	for (argIndex = 1; argIndex < (objc-2); ++argIndex) {
+	    if (Tcl_GetIndexFromObj(
+		    interp, objv[argIndex], options, "option", 0, &optIndex)
+		!= TCL_OK) {
+		return TCL_ERROR;
+	    }
+	    if (++argIndex == (objc - 2)) {
+		goto numArgsError;
+	    }
+	    switch (optIndex) {
+	    case PROFILE:
+		if (TclEncodingProfileNameToId(interp,
+					       Tcl_GetString(objv[argIndex]),
+					       &profile) != TCL_OK) {
+		    return TCL_ERROR;
+		}
+		break;
+	    case FAILINDEX:
+		failVarObj = objv[argIndex];
+		break;
+	    }
+	}
+	/* Get encoding after opts so no need to free it on option error */
+	if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding)
+	    != TCL_OK) {
+	    return TCL_ERROR;
+	}
+	dataObj = objv[objc - 1];
+    }
+
+    *encPtr = encoding;
+    *dataObjPtr = dataObj;
+    *profilePtr = profile;
+    *failVarPtr = failVarObj;
+
+    return TCL_OK;
+}
+
+/*
  *----------------------------------------------------------------------
  *
  * EncodingConvertfromObjCmd --
@@ -417,94 +531,66 @@ EncodingConvertfromObjCmd(
     Tcl_Encoding encoding;	/* Encoding to use */
     size_t length = 0;			/* Length of the byte array being converted */
     const char *bytesPtr;	/* Pointer to the first byte of the array */
-    int flags = 0;
-    size_t result;
-    Tcl_Obj *failVarObj = NULL;
-    /*
-     * Decode parameters:
-     * Possible combinations:
-     * 1) data						-> objc = 2
-     * 2) encoding data					-> objc = 3
-     * 3) -nocomplain data				-> objc = 3
-     * 4) -nocomplain encoding data			-> objc = 4
-     * 5) -strict data				-> objc = 3
-     * 6) -strict encoding data			-> objc = 4
-     * 7) -failindex val data				-> objc = 4
-     * 8) -failindex val encoding data			-> objc = 5
-     */
+    int flags;
+    int result;
+    Tcl_Obj *failVarObj;
+    Tcl_Size errorLocation;
 
-    if (objc == 2) {
-	encoding = Tcl_GetEncoding(interp, NULL);
-	data = objv[1];
-    } else if (objc > 2 && objc < 6) {
-	int objcUnprocessed = objc;
-	data = objv[objc - 1];
-	bytesPtr = Tcl_GetString(objv[1]);
-	if (bytesPtr[0] == '-' && bytesPtr[1] == 'n'
-		&& !strncmp(bytesPtr, "-nocomplain", strlen(bytesPtr))) {
-	    flags = TCL_ENCODING_NOCOMPLAIN;
-	    objcUnprocessed--;
-	} else if (bytesPtr[0] == '-' && bytesPtr[1] == 's'
-		&& !strncmp(bytesPtr, "-strict", strlen(bytesPtr))) {
-	    flags = TCL_ENCODING_STRICT;
-	    objcUnprocessed--;
-	} else if (bytesPtr[0] == '-' && bytesPtr[1] == 'f'
-		&& !strncmp(bytesPtr, "-failindex", strlen(bytesPtr))) {
-	    /* at least two additional arguments needed */
-	    if (objc < 4) {
-		goto encConvFromError;
-	    }
-	    failVarObj = objv[2];
-	    objcUnprocessed -= 2;
-	}
-	switch (objcUnprocessed) {
-	    case 3:
-		if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) {
-		    return TCL_ERROR;
-		}
-		break;
-	    case 2:
-		encoding = Tcl_GetEncoding(interp, NULL);
-		break;
-	    default:
-		goto encConvFromError;
-	}
-    } else {
-    encConvFromError:
-	Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain? ?-strict? ?-failindex var? ?encoding? data");
+    if (EncodingConvertParseOptions(
+	    interp, objc, objv, &encoding, &data, &flags, &failVarObj)
+	!= TCL_OK) {
 	return TCL_ERROR;
     }
 
     /*
-     * Convert the string into a byte array in 'ds'
+     * Convert the string into a byte array in 'ds'.
      */
     bytesPtr = (char *) Tcl_GetBytesFromObj(interp, data, &length);
+
     if (bytesPtr == NULL) {
 	return TCL_ERROR;
     }
-    result = Tcl_ExternalToUtfDStringEx(encoding, bytesPtr, length,
-	    flags, &ds);
-    if ((!(flags & TCL_ENCODING_NOCOMPLAIN) || ((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT)) && (result != TCL_INDEX_NONE)) {
-	if (failVarObj != NULL) {
-	    if (Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewWideIntObj(result), TCL_LEAVE_ERR_MSG) == NULL) {
-		return TCL_ERROR;
-	    }
-	} else {
-	    char buf[TCL_INTEGER_SPACE];
-	    sprintf(buf, "%" TCL_Z_MODIFIER "u", result);
-	    Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected byte sequence starting at index %"
-		    TCL_Z_MODIFIER "u: '\\x%X'", result, UCHAR(bytesPtr[result])));
-	    Tcl_SetErrorCode(interp, "TCL", "ENCODING", "ILLEGALSEQUENCE",
-		    buf, NULL);
-	    Tcl_DStringFree(&ds);
+    result = Tcl_ExternalToUtfDStringEx(interp, encoding, bytesPtr, length, flags,
+                                        &ds, failVarObj ? &errorLocation : NULL);
+    /* NOTE: ds must be freed beyond this point even on error */
+    switch (result) {
+    case TCL_OK:
+        errorLocation = TCL_INDEX_NONE;
+        break;
+    case TCL_ERROR:
+	/* Error in parameters. Should not happen. interp will have error */
+        Tcl_DStringFree(&ds);
+	return TCL_ERROR;
+    default:
+	/*
+	 * One of the TCL_CONVERT_* errors. If we were not interested in the
+	 * error location, interp result would already have been filled in
+	 * and we can just return the error. Otherwise, we have to return
+	 * what could be decoded and the returned error location.
+	 */
+	if (failVarObj == NULL) {
+            Tcl_DStringFree(&ds);
 	    return TCL_ERROR;
 	}
-    } else if (failVarObj != NULL) {
-	if (Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(-1), TCL_LEAVE_ERR_MSG) == NULL) {
+        break;
+    }
+
+    /*
+     * TCL_OK or a TCL_CONVERT_* error where the caller wants back as much
+     * data as was converted.
+     */
+    if (failVarObj) {
+	Tcl_Obj *failIndex;
+	TclNewIndexObj(failIndex, errorLocation);
+	if (Tcl_ObjSetVar2(interp,
+			   failVarObj,
+			   NULL,
+			   failIndex,
+			   TCL_LEAVE_ERR_MSG) == NULL) {
+	    Tcl_DStringFree(&ds);
 	    return TCL_ERROR;
 	}
     }
-
     /*
      * Note that we cannot use Tcl_DStringResult here because it will
      * truncate the string at the first null byte.
@@ -512,9 +598,7 @@ EncodingConvertfromObjCmd(
 
     Tcl_SetObjResult(interp, Tcl_DStringToObj(&ds));
 
-    /*
-     * We're done with the encoding
-     */
+    /* We're done with the encoding */
 
     Tcl_FreeEncoding(encoding);
     return TCL_OK;
@@ -547,60 +631,14 @@ EncodingConverttoObjCmd(
     Tcl_Encoding encoding;	/* Encoding to use */
     size_t length;			/* Length of the string being converted */
     const char *stringPtr;	/* Pointer to the first byte of the string */
-    size_t result;
-    int flags = 0;
-    Tcl_Obj *failVarObj = NULL;
-
-    /*
-     * Decode parameters:
-     * Possible combinations:
-     * 1) data						-> objc = 2
-     * 2) encoding data					-> objc = 3
-     * 3) -nocomplain data				-> objc = 3
-     * 4) -nocomplain encoding data			-> objc = 4
-     * 5) -failindex val data				-> objc = 4
-     * 6) -failindex val encoding data			-> objc = 5
-     */
+    int result;
+    int flags;
+    Tcl_Obj *failVarObj;
+    Tcl_Size errorLocation;
 
-    if (objc == 2) {
-	encoding = Tcl_GetEncoding(interp, NULL);
-	data = objv[1];
-    } else if (objc > 2 && objc < 6) {
-	int objcUnprocessed = objc;
-	data = objv[objc - 1];
-	stringPtr = Tcl_GetString(objv[1]);
-	if (stringPtr[0] == '-' && stringPtr[1] == 'n'
-		&& !strncmp(stringPtr, "-nocomplain", strlen(stringPtr))) {
-	    flags = TCL_ENCODING_NOCOMPLAIN;
-	    objcUnprocessed--;
-	} else if (stringPtr[0] == '-' && stringPtr[1] == 's'
-		&& !strncmp(stringPtr, "-strict", strlen(stringPtr))) {
-	    flags = TCL_ENCODING_STRICT;
-	    objcUnprocessed--;
-	} else if (stringPtr[0] == '-' && stringPtr[1] == 'f'
-		&& !strncmp(stringPtr, "-failindex", strlen(stringPtr))) {
-	    /* at least two additional arguments needed */
-	    if (objc < 4) {
-		goto encConvToError;
-	    }
-	    failVarObj = objv[2];
-	    objcUnprocessed -= 2;
-	}
-	switch (objcUnprocessed) {
-	    case 3:
-		if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) {
-		    return TCL_ERROR;
-		}
-		break;
-	    case 2:
-		encoding = Tcl_GetEncoding(interp, NULL);
-		break;
-	    default:
-		goto encConvToError;
-	}
-    } else {
-    encConvToError:
-	Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain? ?-strict? ?-failindex var? ?encoding? data");
+    if (EncodingConvertParseOptions(
+	    interp, objc, objv, &encoding, &data, &flags, &failVarObj)
+	!= TCL_OK) {
 	return TCL_ERROR;
     }
 
@@ -609,40 +647,54 @@ EncodingConverttoObjCmd(
      */
 
     stringPtr = Tcl_GetStringFromObj(data, &length);
-    result = Tcl_UtfToExternalDStringEx(encoding, stringPtr, length,
-	    flags, &ds);
-    if ((!(flags & TCL_ENCODING_NOCOMPLAIN) || ((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT)) && (result != TCL_INDEX_NONE)) {
-	if (failVarObj != NULL) {
-	    /* I hope, wide int will cover size_t data type */
-	    if (Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewWideIntObj(result), TCL_LEAVE_ERR_MSG) == NULL) {
-		return TCL_ERROR;
-	    }
-	} else {
-	    size_t pos = Tcl_NumUtfChars(stringPtr, result);
-	    int ucs4;
-	    char buf[TCL_INTEGER_SPACE];
-	    TclUtfToUCS4(&stringPtr[result], &ucs4);
-	    sprintf(buf, "%" TCL_Z_MODIFIER "u", result);
-	    Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected character at index %"
-		    TCL_Z_MODIFIER "u: 'U+%06X'", pos, ucs4));
-	    Tcl_SetErrorCode(interp, "TCL", "ENCODING", "ILLEGALSEQUENCE",
-		    buf, NULL);
-	    Tcl_DStringFree(&ds);
+    result = Tcl_UtfToExternalDStringEx(interp, encoding, stringPtr, length, flags,
+                                        &ds, failVarObj ? &errorLocation : NULL);
+    /* NOTE: ds must be freed beyond this point even on error */
+
+    switch (result) {
+    case TCL_OK:
+	errorLocation = TCL_INDEX_NONE;
+	break;
+    case TCL_ERROR:
+	/* Error in parameters. Should not happen. interp will have error */
+        Tcl_DStringFree(&ds);
+	return TCL_ERROR;
+    default:
+	/*
+	 * One of the TCL_CONVERT_* errors. If we were not interested in the
+	 * error location, interp result would already have been filled in
+	 * and we can just return the error. Otherwise, we have to return
+	 * what could be decoded and the returned error location.
+	 */
+	if (failVarObj == NULL) {
+            Tcl_DStringFree(&ds);
 	    return TCL_ERROR;
 	}
-    } else if (failVarObj != NULL) {
-	if (Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(-1), TCL_LEAVE_ERR_MSG) == NULL) {
+        break;
+    }
+    /*
+     * TCL_OK or a TCL_CONVERT_* error where the caller wants back as much
+     * data as was converted.
+     */
+    if (failVarObj) {
+	Tcl_Obj *failIndex;
+	TclNewIndexObj(failIndex, errorLocation);
+	if (Tcl_ObjSetVar2(interp,
+			   failVarObj,
+			   NULL,
+			   failIndex,
+			   TCL_LEAVE_ERR_MSG) == NULL) {
+	    Tcl_DStringFree(&ds);
 	    return TCL_ERROR;
 	}
     }
+
     Tcl_SetObjResult(interp,
 		     Tcl_NewByteArrayObj((unsigned char*) Tcl_DStringValue(&ds),
 					 Tcl_DStringLength(&ds)));
     Tcl_DStringFree(&ds);
 
-    /*
-     * We're done with the encoding
-     */
+    /* We're done with the encoding */
 
     Tcl_FreeEncoding(encoding);
     return TCL_OK;
@@ -727,6 +779,34 @@ EncodingNamesObjCmd(
 /*
  *-----------------------------------------------------------------------------
  *
+ * EncodingProfilesObjCmd --
+ *
+ *	This command returns a list of the available encoding profiles
+ *
+ * Results:
+ *	Returns a standard Tcl result
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+int
+EncodingProfilesObjCmd(
+    TCL_UNUSED(void *),
+    Tcl_Interp* interp,	    /* Tcl interpreter */
+    int objc,		    /* Number of command line args */
+    Tcl_Obj* const objv[])  /* Vector of command line args */
+{
+    if (objc > 1) {
+	Tcl_WrongNumArgs(interp, 1, objv, NULL);
+	return TCL_ERROR;
+    }
+    TclGetEncodingProfiles(interp);
+    return TCL_OK;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
  * EncodingSystemObjCmd --
  *
  *	This command retrieves or changes the system encoding