summaryrefslogtreecommitdiffstats
path: root/generic/tclCmdAH.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclCmdAH.c')
-rw-r--r--generic/tclCmdAH.c185
1 files changed, 162 insertions, 23 deletions
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index c09ad95..28fc210 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -188,7 +188,7 @@ Tcl_CaseObjCmd(
if (caseObjc == 1) {
Tcl_Obj **newObjv;
- TclListObjGetElements(interp, caseObjv[0], &caseObjc, &newObjv);
+ TclListObjGetElementsM(interp, caseObjv[0], &caseObjc, &newObjv);
caseObjv = newObjv;
}
@@ -513,8 +513,8 @@ TclInitEncodingCmd(
Tcl_Interp* interp) /* Tcl interpreter */
{
static const EnsembleImplMap encodingImplMap[] = {
- {"convertfrom", EncodingConvertfromObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
- {"convertto", EncodingConverttoObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
+ {"convertfrom", EncodingConvertfromObjCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0},
+ {"convertto", EncodingConverttoObjCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0},
{"dirs", EncodingDirsObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1},
{"names", EncodingNamesObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
{"system", EncodingSystemObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1},
@@ -550,25 +550,97 @@ EncodingConvertfromObjCmd(
Tcl_Encoding encoding; /* Encoding to use */
int length; /* Length of the byte array being converted */
const char *bytesPtr; /* Pointer to the first byte of the array */
+#if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED)
+ int flags = TCL_ENCODING_STOPONERROR;
+#else
+ int flags = TCL_ENCODING_NOCOMPLAIN;
+#endif
+ int 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) -failindex val data -> objc = 4
+ * 6) -failindex val encoding data -> objc = 5
+ */
if (objc == 2) {
encoding = Tcl_GetEncoding(interp, NULL);
data = objv[1];
- } else if (objc == 3) {
- if (Tcl_GetEncodingFromObj(interp, objv[1], &encoding) != TCL_OK) {
- return TCL_ERROR;
+ } 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] == 'f'
+ && !strncmp(bytesPtr, "-failindex", strlen(bytesPtr))) {
+ /* at least two additional arguments needed */
+ if (objc < 4) {
+ goto encConvFromError;
+ }
+ failVarObj = objv[2];
+ flags = TCL_ENCODING_STOPONERROR;
+ 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;
}
- data = objv[2];
} else {
- Tcl_WrongNumArgs(interp, 1, objv, "?encoding? data");
+ encConvFromError:
+ Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain? ?-failindex var? ?encoding? data");
return TCL_ERROR;
}
/*
* Convert the string into a byte array in 'ds'
*/
- bytesPtr = (char *) Tcl_GetByteArrayFromObj(data, &length);
- Tcl_ExternalToUtfDString(encoding, bytesPtr, length, &ds);
+#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9)
+ if (!(flags & TCL_ENCODING_STOPONERROR)) {
+ bytesPtr = (char *) Tcl_GetByteArrayFromObj(data, &length);
+ } else
+#endif
+ bytesPtr = (char *) TclGetBytesFromObj(interp, data, &length);
+ if (bytesPtr == NULL) {
+ return TCL_ERROR;
+ }
+ result = Tcl_ExternalToUtfDStringEx(encoding, bytesPtr, length,
+ flags, &ds);
+ if (!(flags & TCL_ENCODING_NOCOMPLAIN) && (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, "%u", result);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected byte sequence starting at index %"
+ "u: '\\x%X'", result, UCHAR(bytesPtr[result])));
+ Tcl_SetErrorCode(interp, "TCL", "ENCODING", "ILLEGALSEQUENCE",
+ buf, 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) {
+ return TCL_ERROR;
+ }
+ }
/*
* Note that we cannot use Tcl_DStringResult here because it will
@@ -612,19 +684,61 @@ EncodingConverttoObjCmd(
Tcl_Encoding encoding; /* Encoding to use */
int length; /* Length of the string being converted */
const char *stringPtr; /* Pointer to the first byte of the string */
+ int result;
+#if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED)
+ int flags = TCL_ENCODING_STOPONERROR;
+#else
+ int flags = TCL_ENCODING_NOCOMPLAIN;
+#endif
+ Tcl_Obj *failVarObj = NULL;
- /* TODO - ADJUST OBJ INDICES WHEN ENSEMBLIFYING THIS */
+ /*
+ * 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
+ */
if (objc == 2) {
encoding = Tcl_GetEncoding(interp, NULL);
data = objv[1];
- } else if (objc == 3) {
- if (Tcl_GetEncodingFromObj(interp, objv[1], &encoding) != TCL_OK) {
- return TCL_ERROR;
+ } 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] == 'f'
+ && !strncmp(stringPtr, "-failindex", strlen(stringPtr))) {
+ /* at least two additional arguments needed */
+ if (objc < 4) {
+ goto encConvToError;
+ }
+ failVarObj = objv[2];
+ flags = TCL_ENCODING_STOPONERROR;
+ 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;
}
- data = objv[2];
} else {
- Tcl_WrongNumArgs(interp, 1, objv, "?encoding? data");
+ encConvToError:
+ Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain? ?-failindex var? ?encoding? data");
return TCL_ERROR;
}
@@ -633,7 +747,32 @@ EncodingConverttoObjCmd(
*/
stringPtr = TclGetStringFromObj(data, &length);
- Tcl_UtfToExternalDString(encoding, stringPtr, length, &ds);
+ result = Tcl_UtfToExternalDStringEx(encoding, stringPtr, length,
+ flags, &ds);
+ if (!(flags & TCL_ENCODING_NOCOMPLAIN) && (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, "%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);
+ return TCL_ERROR;
+ }
+ } else if (failVarObj != NULL) {
+ if (Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(-1), TCL_LEAVE_ERR_MSG) == NULL) {
+ return TCL_ERROR;
+ }
+ }
Tcl_SetObjResult(interp,
Tcl_NewByteArrayObj((unsigned char*) Tcl_DStringValue(&ds),
Tcl_DStringLength(&ds)));
@@ -1972,7 +2111,7 @@ PathSplitCmd(
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
- res = Tcl_FSSplitPath(objv[1], NULL);
+ res = Tcl_FSSplitPath(objv[1], (int *)NULL);
if (res == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not read \"%s\": no such file or directory",
@@ -2260,13 +2399,13 @@ StoreStatData(
*/
STORE_ARY("dev", Tcl_NewWideIntObj((long)statPtr->st_dev));
- STORE_ARY("ino", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_ino));
+ STORE_ARY("ino", Tcl_NewWideIntObj(statPtr->st_ino));
STORE_ARY("nlink", Tcl_NewWideIntObj((long)statPtr->st_nlink));
STORE_ARY("uid", Tcl_NewWideIntObj((long)statPtr->st_uid));
STORE_ARY("gid", Tcl_NewWideIntObj((long)statPtr->st_gid));
- STORE_ARY("size", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_size));
+ STORE_ARY("size", Tcl_NewWideIntObj(statPtr->st_size));
#ifdef HAVE_STRUCT_STAT_ST_BLOCKS
- STORE_ARY("blocks", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_blocks));
+ STORE_ARY("blocks", Tcl_NewWideIntObj(statPtr->st_blocks));
#endif
#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
STORE_ARY("blksize", Tcl_NewWideIntObj((long)statPtr->st_blksize));
@@ -2667,7 +2806,7 @@ EachloopCmd(
result = TCL_ERROR;
goto done;
}
- TclListObjGetElements(NULL, statePtr->vCopyList[i],
+ TclListObjGetElementsM(NULL, statePtr->vCopyList[i],
&statePtr->varcList[i], &statePtr->varvList[i]);
if (statePtr->varcList[i] < 1) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
@@ -2685,7 +2824,7 @@ EachloopCmd(
result = TCL_ERROR;
goto done;
}
- TclListObjGetElements(NULL, statePtr->aCopyList[i],
+ TclListObjGetElementsM(NULL, statePtr->aCopyList[i],
&statePtr->argcList[i], &statePtr->argvList[i]);
j = statePtr->argcList[i] / statePtr->varcList[i];
generated by cgit v0.12 at 2025-12-09 12:47:00 (GMT)