Tcl Source Code

declare 694 {
    int Tcl_ListObjRange(Tcl_Interp *interp, Tcl_Obj *objPtr,
	    Tcl_Size start, Tcl_Size end, Tcl_Obj **resultPtrPtr)
}

# TIP 726
declare 695 {
    int Tcl_UtfToNormalizedDString(Tcl_Interp *interp,
	    const char *bytes, Tcl_Size length,
	    Tcl_UnicodeNormalizationForm normForm, int profile,
	    Tcl_DString *dsPtr)
}
declare 696 {
    int Tcl_UtfToNormalized(Tcl_Interp *interp,
	    const char *bytes, Tcl_Size length,
	    Tcl_UnicodeNormalizationForm normForm, int profile,
	    char *bufPtr, Tcl_Size bufLen, Tcl_Size *lengthPtr)
}

# ----- BASELINE -- FOR -- 9.1.0 ----- #

declare 697 {
    void TclUnusedStubEntry(void)
}

##############################################################################

# Define the platform specific public Tcl interface. These functions are only
# available on the designated platform.

	Tcl_WrongNumArgs(interp, 1, objv, "?-profile PROFILE? STRING");
	return TCL_ERROR;
    }

    Tcl_DString ds;
    if (Tcl_UtfToNormalizedDString(interp, Tcl_GetString(objv[objc - 1]),
	    TCL_INDEX_NONE, (Tcl_UnicodeNormalizationForm)clientData, profile,
	    &ds) != TCL_OK) {
	return TCL_ERROR;
    }

    Tcl_DStringResult(interp, &ds);
    return TCL_OK;
}


				Tcl_Obj *const objv[],
				Tcl_Obj **resultPtrPtr);
/* 694 */
EXTERN int		Tcl_ListObjRange(Tcl_Interp *interp, Tcl_Obj *objPtr,
				Tcl_Size start, Tcl_Size end,
				Tcl_Obj **resultPtrPtr);
/* 695 */
EXTERN int		Tcl_UtfToNormalizedDString(Tcl_Interp *interp,
				const char *bytes, Tcl_Size length,
				Tcl_UnicodeNormalizationForm normForm,
				int profile, Tcl_DString *dsPtr);
/* 696 */
EXTERN int		Tcl_UtfToNormalized(Tcl_Interp *interp,
				const char *bytes, Tcl_Size length,
				Tcl_UnicodeNormalizationForm normForm,
				int profile, char *bufPtr, Tcl_Size bufLen,
				Tcl_Size *lengthPtr);
/* 697 */
EXTERN void		TclUnusedStubEntry(void);

typedef struct {
    const struct TclPlatStubs *tclPlatStubs;
    const struct TclIntStubs *tclIntStubs;
    const struct TclIntPlatStubs *tclIntPlatStubs;
} TclStubHooks;

    Tcl_Obj * (*tcl_NewWideUIntObj) (Tcl_WideUInt wideValue); /* 688 */
    void (*tcl_SetWideUIntObj) (Tcl_Obj *objPtr, Tcl_WideUInt uwideValue); /* 689 */
    int (*tcl_IsEmpty) (Tcl_Obj *obj); /* 690 */
    const char * (*tcl_GetEncodingNameForUser) (Tcl_DString *bufPtr); /* 691 */
    int (*tcl_ListObjReverse) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj **resultPtrPtr); /* 692 */
    int (*tcl_ListObjRepeat) (Tcl_Interp *interp, Tcl_Size repeatCount, Tcl_Size objc, Tcl_Obj *const objv[], Tcl_Obj **resultPtrPtr); /* 693 */
    int (*tcl_ListObjRange) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Size start, Tcl_Size end, Tcl_Obj **resultPtrPtr); /* 694 */
    int (*tcl_UtfToNormalizedDString) (Tcl_Interp *interp, const char *bytes, Tcl_Size length, Tcl_UnicodeNormalizationForm normForm, int profile, Tcl_DString *dsPtr); /* 695 */
    int (*tcl_UtfToNormalized) (Tcl_Interp *interp, const char *bytes, Tcl_Size length, Tcl_UnicodeNormalizationForm normForm, int profile, char *bufPtr, Tcl_Size bufLen, Tcl_Size *lengthPtr); /* 696 */
    void (*tclUnusedStubEntry) (void); /* 697 */
} TclStubs;

extern const TclStubs *tclStubsPtr;

#ifdef __cplusplus
}
#endif

	(tclStubsPtr->tcl_ListObjReverse) /* 692 */
#define Tcl_ListObjRepeat \
	(tclStubsPtr->tcl_ListObjRepeat) /* 693 */
#define Tcl_ListObjRange \
	(tclStubsPtr->tcl_ListObjRange) /* 694 */
#define Tcl_UtfToNormalizedDString \
	(tclStubsPtr->tcl_UtfToNormalizedDString) /* 695 */
#define Tcl_UtfToNormalized \
	(tclStubsPtr->tcl_UtfToNormalized) /* 696 */
#define TclUnusedStubEntry \
	(tclStubsPtr->tclUnusedStubEntry) /* 697 */

#endif /* defined(USE_TCL_STUBS) */

/* !END!: Do not edit above this line. */

#undef TclUnusedStubEntry

    objPtr = Tcl_NewListObj(n, NULL);
    for (i = 0; i < n; ++i) {
	Tcl_ListObjAppendElement(interp, objPtr,
		Tcl_NewStringObj(encodingProfiles[i].name, TCL_INDEX_NONE));
    }
    Tcl_SetObjResult(interp, objPtr);
}











static utf8proc_ssize_t
TclUtfNormalize(
    Tcl_Interp *interp,	/* Error messages. May be NULL */
    const char *bytes,  /* Operand encoded in Tcl internal UTF8 */
    Tcl_Size numBytes, /* Length bytes[], or -1 if NUL terminated */
    Tcl_Encoding encoding, /* Encoding - must be UTF-8. Caller passed for reuse */
    Tcl_UnicodeNormalizationForm normForm, /* TCL_{NFC,NFD,NFKC,NFKC} */
    int profile,                  /* TCL_ENCODING_PROFILE_{STRICT,REPLACE} */


    utf8proc_uint8_t **bufPtrPtr) /* On success, output length excluding nul */
{


    if (profile != TCL_ENCODING_PROFILE_REPLACE &&
	profile != TCL_ENCODING_PROFILE_STRICT) {
	if (interp) {
	    Tcl_SetObjResult(interp,
		Tcl_ObjPrintf("Invalid value %d passed for encoding profile.",
		    profile));
	}
	return -1;
    }

    utf8proc_option_t options = UTF8PROC_STABLE;
    switch (normForm) {
    case TCL_NFC:
	options |= UTF8PROC_COMPOSE;
	break;
    case TCL_NFD:
	options |= UTF8PROC_DECOMPOSE;
	break;
    case TCL_NFKC:
	options |= UTF8PROC_COMPOSE | UTF8PROC_COMPAT;
	break;
    case TCL_NFKD:
	options |= UTF8PROC_DECOMPOSE | UTF8PROC_COMPAT;
	break;
    default:
	if (interp) {
	    Tcl_SetObjResult(interp,
		Tcl_ObjPrintf("Invalid value %d passed for normalization form.",
		    normForm));

	}
	return -1;
    }




    if (numBytes < 0) {
	numBytes = -1;
    }
    int result;
    Tcl_DString dsExt;
    result = Tcl_UtfToExternalDStringEx(interp, encoding, bytes, numBytes,
	profile, &dsExt, NULL);
    /* !!! dsExt needs to be freed even in case of error returns */

    utf8proc_ssize_t normLength = -1;
    if (result == TCL_OK) {

	normLength =


	    utf8proc_map_custom((utf8proc_uint8_t *)Tcl_DStringValue(&dsExt),

		Tcl_DStringLength(&dsExt), bufPtrPtr, options, NULL, NULL);

	if (normLength < 0) {
	    if (interp) {
		const char *errorMsg = utf8proc_errmsg(normLength);
		Tcl_SetObjResult(interp,
		    Tcl_NewStringObj(
			errorMsg ? errorMsg : "Unicode normalization failed.",






			-1));
	    }
	}
    }

    Tcl_DStringFree(&dsExt);
    return normLength;
}

/*
 * Tcl_UtfToNormalizedDString --
 *
 *	Converts the passed string to a Unicode normalization form storing
 *	it in dsPtr.
 *
 * Results:
 *	A standard Tcl error code.
 *
 * Side effects:
 *      The output string is stored in dsPtr, which is initialized.
 */
int
Tcl_UtfToNormalizedDString(
    Tcl_Interp *interp, /* Used for error messages. May be NULL */
    const char *bytes,  /* Operand encoded in Tcl internal UTF8 */
    Tcl_Size numBytes,	/* Length of bytes[], or -1 if NUL terminated */
    Tcl_UnicodeNormalizationForm normForm, /* TCL_{NFC,NFD,NFKC,NFKC} */
    int profile,        /* TCL_ENCODING_PROFILE_{STRICT,REPLACE} */
    Tcl_DString *dsPtr) /* Converted output string in Tcl internal
			   UTF8 encoding. Init'ed by function */
{
    Tcl_DStringInit(dsPtr);
    Tcl_Encoding encoding = Tcl_GetEncoding(interp, "utf-8");
    if (encoding == NULL) {
	return TCL_ERROR;
    }

    utf8proc_uint8_t *normUtf8;
    utf8proc_ssize_t normLength;

    normLength = TclUtfNormalize(interp, bytes, numBytes, encoding, normForm,
	profile, &normUtf8);
    if (normLength >= 0) {
	assert(normUtf8);
	/* Convert standard UTF8 to internal UTF8 */
	int result = Tcl_ExternalToUtfDStringEx(interp, encoding,
	    (const char *)normUtf8, normLength, profile, dsPtr, NULL);
	if (result != TCL_OK) {
	    normLength = -1;
	}
	free(normUtf8); /* NOT Tcl_Free! */
    }
    Tcl_FreeEncoding(encoding);
    return normLength >= 0 ? TCL_OK : TCL_ERROR;
}

/*
 * Tcl_UtfToNormalized --
 *
 *	Converts the passed string to a Unicode normalization form storing
 *	it in the caller provided buffer.
 *
 * Results:
 *	A standard Tcl error code.
 *
 * Side effects:
 *      The output string is stored in bufPtr.
 */
int
Tcl_UtfToNormalized(
    Tcl_Interp *interp, /* Used for error messages. May be NULL */
    const char *bytes,  /* Operand encoded in Tcl internal UTF8 */
    Tcl_Size numBytes,  /* Length of bytes[], or -1 if NUL terminated */
    Tcl_UnicodeNormalizationForm normForm, /* TCL_{NFC,NFD,NFKC,NFKC} */
    int profile,        /* TCL_ENCODING_PROFILE_{STRICT,REPLACE} */
    char *bufPtr,       /* Pointer to output buffer. Must not be NULL.  */
    Tcl_Size bufLen,    /* Size of bufPtr storage. */
    Tcl_Size *lengthPtr) /* Length of the output string in bytes excluding
			   the trailing NUL byte. May be NULL */
{
    Tcl_Encoding encoding = Tcl_GetEncoding(interp, "utf-8");
    if (encoding == NULL) {
	return TCL_ERROR;
    }

    utf8proc_uint8_t *normUtf8;
    utf8proc_ssize_t normLength;
    normLength = TclUtfNormalize(interp, bytes, numBytes, encoding, normForm,
	profile, &normUtf8);
    Tcl_FreeEncoding(encoding);
    if (normLength < 0) {
	return TCL_ERROR;
    }
    assert(normUtf8);

    /* Convert standard UTF8 to internal UTF8 */
    int result;
    utf8proc_uint8_t *from = normUtf8;
    utf8proc_uint8_t *fromEnd = from + normLength;
    char *to = (utf8proc_uint8_t *)bufPtr;
    char *toEnd = to + bufLen - 1; /* -1 for trailing NUL */
    while (from < fromEnd && to < toEnd) {
	/*
	 * The only difference between UTF-8 and internal UTF-8 is that
	 * internal UTF-8 does not allow NUL bytes in the middle of the string.
	 */
	if (*from) {
	    *to++ = *from++;
	} else {
	    *to++ = 0xC0; /* NUL byte in internal UTF-8 is encoded as C080 */
	    if (to == toEnd) {
		break;
	    }
	    *to++ = 0x80;
	    from++;
	}
    }
    if (from < fromEnd) {
	Tcl_SetObjResult(interp,
	    Tcl_NewStringObj("Output buffer too small", -1));
	result = TCL_CONVERT_NOSPACE;
    } else {
	assert(to < (bufPtr + bufLen - 1));
	*to = '\0'; /* NUL terminate the output */
	if (lengthPtr) {
	    *lengthPtr = to-bufPtr;
	}
	result = TCL_OK;
    }

    free(normUtf8); /* NOT Tcl_Free! */
    return result;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

    Tcl_SetWideUIntObj, /* 689 */
    Tcl_IsEmpty, /* 690 */
    Tcl_GetEncodingNameForUser, /* 691 */
    Tcl_ListObjReverse, /* 692 */
    Tcl_ListObjRepeat, /* 693 */
    Tcl_ListObjRange, /* 694 */
    Tcl_UtfToNormalizedDString, /* 695 */
    Tcl_UtfToNormalized, /* 696 */
    TclUnusedStubEntry, /* 697 */
};

/* !END!: Do not edit above this line. */

static Tcl_FSOpenFileChannelProc SimpleOpenFileChannel;
static Tcl_FSListVolumesProc SimpleListVolumes;
static Tcl_FSPathInFilesystemProc SimplePathInFilesystem;
static Tcl_Obj *	SimpleRedirect(Tcl_Obj *pathPtr);
static Tcl_FSMatchInDirectoryProc SimpleMatchInDirectory;
static Tcl_ObjCmdProc	TestUtfNextCmd;
static Tcl_ObjCmdProc	TestUtfPrevCmd;
static Tcl_ObjCmdProc	TestUtfToNormalizedDStringCmd;
static Tcl_ObjCmdProc	TestUtfToNormalizedCmd;
static Tcl_ObjCmdProc	TestNumUtfCharsCmd;
static Tcl_ObjCmdProc	TestGetUniCharCmd;
static Tcl_ObjCmdProc	TestFindFirstCmd;
static Tcl_ObjCmdProc	TestFindLastCmd;
static Tcl_ObjCmdProc	TestHashSystemHashCmd;
static Tcl_ObjCmdProc	TestGetIntForIndexCmd;
static Tcl_ObjCmdProc	TestLutilCmd;

	    NULL, NULL);
    Tcl_CreateObjCommand(interp, "testinterpresolver", TestInterpResolverCmd,
	    NULL, NULL);
    Tcl_CreateObjCommand(interp, "testapplylambda", TestApplyLambdaCmd,
	    NULL, NULL);
    Tcl_CreateObjCommand(interp, "testlutil", TestLutilCmd,
	    NULL, NULL);
    Tcl_CreateObjCommand(interp, "testutftonormalized",
	TestUtfToNormalizedCmd, NULL, NULL);
    Tcl_CreateObjCommand(interp, "testutftonormalizeddstring",
	TestUtfToNormalizedDStringCmd, NULL, NULL);
#if defined(_WIN32)
    Tcl_CreateObjCommand(interp, "testhandlecount", TestHandleCountCmd,
	    NULL, NULL);
    Tcl_CreateObjCommand(interp, "testappverifierpresent",
	    TestAppVerifierPresentCmd, NULL, NULL);
#endif

    if (l2Obj) {
	Tcl_DecrRefCount(l2Obj);
    }
    return ret;
}

/*
 * TestUtfToNormalizedCmd --
 *
 *	This procedure implements the "testutftonormalized" command which
 *	provides a raw interface to the Tcl_UtfToNormalized API.
 *      objv[1] - input byte array encoded in Tcl internal UTF-8. Use
 *		  teststringbytes to construct.
 *	objv[2] - normForm value to pass to Tcl_UtfToNormalized
 *	objv[3] - profile value to pass to Tcl_UtfToNormalized
 *	objv[4] - buffer length to pass to Tcl_UtfToNormalized.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	The interpreter result is set to the raw bytes output of the
 *	Tcl_UtfToNormalized call.
 *
 *----------------------------------------------------------------------
 */
static int
TestUtfToNormalizedCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Arguments. */
{
    if (objc != 5 && objc != 6) {
	Tcl_WrongNumArgs(interp, 1, objv, "BYTES NORMALFORM PROFILE ?LENGTH? BUFLENGTH");
	return TCL_ERROR;
    }
    Tcl_Size bufLen, len, slen;
    unsigned char *s = Tcl_GetBytesFromObj(interp, objv[1], &slen);
    if (s == NULL) {
	return TCL_ERROR;
    }
    int normForm, profile;
    if (Tcl_GetIntFromObj(interp, objv[2], &normForm) != TCL_OK ||
	Tcl_GetIntFromObj(interp, objv[3], &profile) != TCL_OK) {
	return TCL_ERROR;
    }
    if (Tcl_GetSizeIntFromObj(interp, objv[objc-1], &bufLen) != TCL_OK) {
	return TCL_ERROR;
    }
    if (objc == 5) {
	len = slen;
    } else {
	if (Tcl_GetSizeIntFromObj(interp, objv[4], &len) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (len > slen) {
	    Tcl_SetObjResult(interp,
		Tcl_ObjPrintf(
		    "Passed length %" TCL_SIZE_MODIFIER
		    "d is greater than string length %" TCL_SIZE_MODIFIER
		    "d.", len, slen));
	    return TCL_ERROR;
	}
    }
    int result;
    char buffer[20] = {0x80};
    char *bufPtr;
    Tcl_Size bufStored = 0;
    if (bufLen > sizeof(buffer)) {
	bufPtr = (char *)Tcl_Alloc(bufLen);
    } else {
	bufPtr = buffer;
    }
    result = Tcl_UtfToNormalized(interp, (char *) s, len,
	(Tcl_UnicodeNormalizationForm)normForm, profile, bufPtr, bufLen, &bufStored);
    if (result == TCL_OK) {
	/* Return as raw bytes, not string */
	Tcl_SetObjResult(interp,
	    Tcl_NewByteArrayObj(bufPtr, bufStored));
    }
    if (bufPtr != buffer) {
	Tcl_Free(bufPtr);
    }
    return result;
}

/*
 * TestUtfToNormalizedDStringCmd --
 *
 *	This procedure implements the "testutftonormalizedstring" command which
 *	provides a raw interface to the Tcl_UtfToNormalizedDString API.
 *      objv[1] - input byte array encoded in Tcl internal UTF-8. Use
 *		  teststringbytes to construct.
 *	objv[2] - normForm value to pass to Tcl_UtfToNormalizedDString
 *	objv[3] - profile value to pass to Tcl_UtfToNormalizedDString
 *	objv[4] - (optional) length to pass to Tcl_UtfToNormalizedDString. If
 *		  not present, length of objv[1] is used.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	The interpreter result is set to the raw bytes output of the
 *	Tcl_UtfToNormalizedDString call.
 *
 *----------------------------------------------------------------------
 */
static int
TestUtfToNormalizedDStringCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Arguments. */
{
    if (objc != 4 && objc != 5) {
	Tcl_WrongNumArgs(interp, 1, objv, "BYTES NORMALFORM PROFILE ?LENGTH?");

    if (Tcl_GetIntFromObj(interp, objv[2], &normForm) != TCL_OK ||
	Tcl_GetIntFromObj(interp, objv[3], &profile) != TCL_OK) {
	return TCL_ERROR;
    }
    if (objc == 4) {
	len = slen;
    } else {
	if (Tcl_GetSizeIntFromObj(interp, objv[5], &len) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (len > slen) {
	    Tcl_SetObjResult(interp,
		Tcl_ObjPrintf(
		    "Passed length %" TCL_SIZE_MODIFIER
		    "d is greater than string length %" TCL_SIZE_MODIFIER
		    "d.", len, slen));
	    return TCL_ERROR;
	}
    }

    Tcl_DString ds;
    int result;
    result = Tcl_UtfToNormalizedDString(interp, (char *) s, len,
	(Tcl_UnicodeNormalizationForm)normForm, profile, &ds);
    if (result == TCL_OK) {


	/* Return as raw bytes, not string */
	Tcl_SetObjResult(interp,
	    Tcl_NewByteArrayObj((unsigned char *)Tcl_DStringValue(&ds),
		Tcl_DStringLength(&ds)));
	Tcl_DStringFree(&ds);
    }
    return result;
}

#ifdef _WIN32
/*
 *----------------------------------------------------------------------
 *
 * TestHandleCountCmd --

        lassign $testCase lineno chars nfc nfd nfkc nfkd
        set bytes [teststringbytes $chars]
        foreach profile {strict replace} {
            foreach normForm {nfc nfd nfkc nfkd} {
                test Tcl_UtfToNormalizedDString-$normForm-line-$lineno-$profile \
                    "Tcl_UtfToNormalizedDString for $normForm at line $lineno of $::tcltests::ucd::normalizationDataFile" \
                    -body {
                        testutftonormalizeddstring $bytes $normEnums($normForm) \
					        $profileFlags($profile)
                    } -result [teststringbytes [set $normForm]]
            }
        }
    }

    foreach normForm {nfc nfd nfkc nfkd} {
        test Tcl_UtfToNormalizedDString-$normForm-nulchar-$profile \
            "Tcl_UtfToNormalizedDString for $normForm passed nul character" \
            -body {
                testutftonormalizeddstring [teststringbytes \0] \
				$normEnums($normForm) $profileFlags($profile)
            } -result \xC0\x80
    }

    # Tcl_UtfToNormalizedDString error cases

    foreach normForm {nfc nfd nfkc nfkd} {
        test Tcl_UtfToNormalizedDString-$normForm-tcl8 \
            "Tcl_UtfToNormalizedDString for $normForm profile tcl8" \
            -body {
                testutftonormalizeddstring abc $normEnums($normForm) $profileFlags(tcl8)
            } -result {Invalid value 16777216 passed for encoding profile.} -returnCodes error

        if {0} {
            # TODO - currently, Tcl "fixes up" any internal invalid UTF-8 so
            # no way to test normalization of invalid UTF-8. Enable this test
            # once this "fixing up" by Tcl is corrected (see Bug [b69e00ecf6])
            test Tcl_UtfToNormalizedDString-$normForm-invalid-utf8 \
                "Tcl_UtfToNormalizedDString for $normForm invalid utf8 profile strict" \
                -body {
                    testutftonormalizeddstring [testbytestring [binary decode hex EFBF7F]] $normEnums($normForm) $profileFlags(strict)
                } -result {} -returnCodes error
        }
    }

    test Tcl_UtfToNormalizedDString-invalid-normalization-form \
            "Tcl_UtfToNormalizedDString invalid value for normalization form" \
            -body {
                testutftonormalizeddstring abc 4 $profileFlags(strict)
            } -result {Invalid value 4 passed for normalization form.} -returnCodes error

}

::tcltest::cleanupTests
namespace delete unicode::test
return