Tcl Source Code

    /*
     * When entering here, result == 1 and failat == 0.
     */

    switch (index) {
    case STR_IS_ALNUM:
	int Tcl_Utf8procIsAlnum(int ch);
	chcomp = Tcl_Utf8procIsAlnum;
	break;
    case STR_IS_ALPHA:
	int Tcl_Utf8procIsAlpha(int ch);
	chcomp = Tcl_Utf8procIsAlpha;
	break;
    case STR_IS_ASCII:
	chcomp = UniCharIsAscii;
	break;
    case STR_IS_BOOL:
    case STR_IS_TRUE:
    case STR_IS_FALSE:

	    }
	} else if ((objPtr->internalRep.wideValue != 0)
		? (index == STR_IS_FALSE) : (index == STR_IS_TRUE)) {
	    result = 0;
	}
	break;
    case STR_IS_CONTROL:
	int Tcl_Utf8procIsControl(int ch);
	chcomp = Tcl_Utf8procIsControl;
	break;
    case STR_IS_DICT: {
	int dresult;
	Tcl_Size dsize;

	dresult = Tcl_DictObjSize(interp, objPtr, &dsize);
	Tcl_ResetResult(interp);

		    break;
		}
	    }
	}
	break;
    }
    case STR_IS_DIGIT:
	int Tcl_Utf8procIsDigit(int ch);
	chcomp = Tcl_Utf8procIsDigit;
	break;

    case STR_IS_DOUBLE: {
	if (TclHasInternalRep(objPtr, &tclDoubleType) ||
		TclHasInternalRep(objPtr, &tclIntType) ||
		TclHasInternalRep(objPtr, &tclBignumType)) {
	    break;
	}
	string1 = TclGetStringFromObj(objPtr, &length1);

		result = 0;
		TclFreeInternalRep(objPtr);
	    }
	}
	break;
    }
    case STR_IS_GRAPH:
	int Tcl_Utf8procIsGraph(int ch);
	chcomp = Tcl_Utf8procIsGraph;
	break;
    case STR_IS_INT:
    case STR_IS_ENTIER:
	if (TclHasInternalRep(objPtr, &tclIntType) ||
		TclHasInternalRep(objPtr, &tclBignumType)) {
	    break;
	}

		    break;
		}
	    }
	}
	result = 0;
	break;
    case STR_IS_LOWER:
	int Tcl_Utf8procIsLower(int ch);
	chcomp = Tcl_Utf8procIsLower;
	break;
    case STR_IS_PRINT:
	int Tcl_Utf8procIsPrint(int ch);
	chcomp = Tcl_Utf8procIsPrint;
	break;
    case STR_IS_PUNCT:
	int Tcl_Utf8procIsPunct(int ch);
	chcomp = Tcl_Utf8procIsPunct;
	break;
    case STR_IS_SPACE:
	int Tcl_Utf8procIsSpace(int ch);
	chcomp = Tcl_Utf8procIsSpace;
	break;
    case STR_IS_UPPER:
	int Tcl_Utf8procIsUpper(int ch);
	chcomp = Tcl_Utf8procIsUpper;
	break;
    case STR_IS_WORD:
	int Tcl_Utf8procIsWordChar(int ch);
	chcomp = Tcl_Utf8procIsWordChar;
	break;
    case STR_IS_XDIGIT:
	chcomp = UniCharIsHexDigit;
	break;
    default:
	TCL_UNREACHABLE();
    }

	if (Tcl_ObjSetVar2(interp, failVarObj, NULL, objPtr, TCL_LEAVE_ERR_MSG) == NULL) {
	    return TCL_ERROR;
	}
    }
    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
    return TCL_OK;
}

/*
 * TclUnicodeNormalizeCmd --
 *
 *	This procedure implements the "unicode tonfc|tonfd|tonfkc|tonfkd"
 *	commands. See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Stores the normalized string in the interpreter result.
 */
static int
TclUnicodeCategoryCmd(
    void *clientData,		/* TCL_{NFC,NFD,NFKC,NFKD} */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"str");
	return TCL_ERROR;
    }
    Tcl_Obj *categoriesObj = Tcl_NewListObj(0, NULL);
    Tcl_Size length1, length2;
    const char *string = TclGetStringFromObj(objv[1], &length1);
    const char *end = string + length1;
    for (; string < end; string += length2) {
	int ucs4;

	length2 = TclUtfToUniChar(string, &ucs4);
	Tcl_ListObjAppendElement(interp, categoriesObj,
	    Tcl_NewStringObj(utf8proc_category_string(ucs4), -1));
    }
    Tcl_SetObjResult(interp, categoriesObj);
    return TCL_OK;
}

/*
 * TclUnicodeNormalizeCmd --
 *
 *	This procedure implements the "unicode tonfc|tonfd|tonfkc|tonfkd"
 *	commands. See the user documentation for details on what it does.
 *

{
    static const EnsembleImplMap unicodeImplMap[] = {
	{"tonfc", TclUnicodeNormalizeCmd, NULL, NULL, (void *)TCL_NFC, 0},
	{"tonfd", TclUnicodeNormalizeCmd, NULL, NULL, (void *)TCL_NFD, 0},
	{"tonfkc", TclUnicodeNormalizeCmd, NULL, NULL, (void *)TCL_NFKC, 0},
	{"tonfkd", TclUnicodeNormalizeCmd, NULL, NULL, (void *)TCL_NFKD, 0},
	{"is", TclUnicodeIsCmd, NULL, NULL, NULL, 0},
	{"category", TclUnicodeCategoryCmd, NULL, NULL, NULL, 0},
	{NULL, NULL, NULL, NULL, NULL, 0}
    };
    return TclMakeEnsemble(interp, "unicode", unicodeImplMap);
}

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

/*
 * tclUtf.c --
 *
 *	Routines for manipulating UTF-8 strings.
 *
 * Copyright © 1997-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include "tclInt.h"
#include "../utf8proc/utf8proc.h"

/*
 * Include the static character classification tables and macros.
 */

#include "tclUniData.c"

    GRAPH_BITS = WORD_BITS | PUNCT_BITS |
	(1 << NON_SPACING_MARK) | (1 << ENCLOSING_MARK) |
	(1 << COMBINING_SPACING_MARK) | (1 << LETTER_NUMBER) |
	(1 << OTHER_NUMBER) |
	(1 << MATH_SYMBOL) | (1 << CURRENCY_SYMBOL) |
	(1 << MODIFIER_SYMBOL) | (1 << OTHER_SYMBOL)
};

enum Utf8ProcCharacterCategoryMasks {
    UTF8PROC_ALPHA_BITS =
	(1 << UTF8PROC_CATEGORY_LU) | (1 << UTF8PROC_CATEGORY_LL) |
	(1 << UTF8PROC_CATEGORY_LT) | (1 << UTF8PROC_CATEGORY_LM) |
	(1 << UTF8PROC_CATEGORY_LO),

    UTF8PROC_CONTROL_BITS =
	(1 << UTF8PROC_CATEGORY_CC) | (1 << UTF8PROC_CATEGORY_CF),

    UTF8PROC_DIGIT_BITS = (1 << UTF8PROC_CATEGORY_ND),

    UTF8PROC_SPACE_BITS = (1 << UTF8PROC_CATEGORY_ZS) |
			  (1 << UTF8PROC_CATEGORY_ZL) |
			  (1 << UTF8PROC_CATEGORY_ZP),

    UTF8PROC_WORD_BITS =
	UTF8PROC_ALPHA_BITS | UTF8PROC_DIGIT_BITS | (1 << UTF8PROC_CATEGORY_PC),

    UTF8PROC_PUNCT_BITS =
	(1 << UTF8PROC_CATEGORY_PC) | (1 << UTF8PROC_CATEGORY_PD) |
	(1 << UTF8PROC_CATEGORY_PS) | (1 << UTF8PROC_CATEGORY_PE) |
	(1 << UTF8PROC_CATEGORY_PI) | (1 << UTF8PROC_CATEGORY_PF) |
	(1 << UTF8PROC_CATEGORY_PO),

    UTF8PROC_GRAPH_BITS = UTF8PROC_WORD_BITS | UTF8PROC_PUNCT_BITS |
			  (1 << UTF8PROC_CATEGORY_MN) |
			  (1 << UTF8PROC_CATEGORY_MC) |
			  (1 << UTF8PROC_CATEGORY_ME) |
			  (1 << UTF8PROC_CATEGORY_NL) |
			  (1 << UTF8PROC_CATEGORY_NO) |
			  (1 << UTF8PROC_CATEGORY_SM) |
			  (1 << UTF8PROC_CATEGORY_SC) |
			  (1 << UTF8PROC_CATEGORY_SK) |
			  (1 << UTF8PROC_CATEGORY_SO)
};

/*
 * Unicode characters less than this value are represented by themselves in
 * UTF-8 strings.
 */

#define UNICODE_SELF	0x80

    int ch)			/* Unicode character to test. */
{
    if (UNICODE_OUT_OF_RANGE(ch)) {
	return 0;
    }
    return (((ALPHA_BITS | DIGIT_BITS) >> GetCategory(ch)) & 1);
}
int
Tcl_Utf8procIsAlnum(
    int ch)			/* Unicode character to test. */
{
    return ((1 << utf8proc_category(ch)) & (UTF8PROC_ALPHA_BITS|UTF8PROC_DIGIT_BITS)) != 0;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharIsAlpha --
 *
 *	Test if a character is an alphabetic Unicode character.

    int ch)			/* Unicode character to test. */
{
    if (UNICODE_OUT_OF_RANGE(ch)) {
	return 0;
    }
    return ((ALPHA_BITS >> GetCategory(ch)) & 1);
}
int
Tcl_Utf8procIsAlpha(
    int ch)			/* Unicode character to test. */
{
    return ((1 << utf8proc_category(ch)) & UTF8PROC_ALPHA_BITS) != 0;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharIsControl --
 *
 *	Test if a character is a Unicode control character.

    if (UNICODE_OUT_OF_RANGE(ch)) {
	/* Clear away extension bits, if any */
	ch &= 0x1FFFFF;
	return ((ch == 0xE0001) || ((unsigned)(ch - 0xE0020) <= 0x5F));
    }
    return ((CONTROL_BITS >> GetCategory(ch)) & 1);
}
int
Tcl_Utf8procIsControl(
    int ch)			/* Unicode character to test. */
{
    return ((1 << utf8proc_category(ch)) & UTF8PROC_CONTROL_BITS) != 0;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharIsDigit --
 *
 *	Test if a character is a numeric Unicode character.

    int ch)			/* Unicode character to test. */
{
    if (UNICODE_OUT_OF_RANGE(ch)) {
	return 0;
    }
    return (GetCategory(ch) == DECIMAL_DIGIT_NUMBER);
}
int
Tcl_Utf8procIsDigit(
    int ch)			/* Unicode character to test. */
{
    return (utf8proc_category(ch) == UTF8PROC_CATEGORY_ND);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharIsGraph --
 *
 *	Test if a character is any Unicode print character except space.

    int ch)			/* Unicode character to test. */
{
    if (UNICODE_OUT_OF_RANGE(ch)) {
	return ((unsigned)((ch & 0x1FFFFF) - 0xE0100) <= 0xEF);
    }
    return ((GRAPH_BITS >> GetCategory(ch)) & 1);
}
int
Tcl_Utf8procIsGraph(
    int ch)			/* Unicode character to test. */
{
    return ((1 << utf8proc_category(ch)) & UTF8PROC_GRAPH_BITS) != 0;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharIsLower --
 *
 *	Test if a character is a lowercase Unicode character.

    int ch)			/* Unicode character to test. */
{
    if (UNICODE_OUT_OF_RANGE(ch)) {
	return 0;
    }
    return (GetCategory(ch) == LOWERCASE_LETTER);
}
int
Tcl_Utf8procIsLower(
    int ch)			/* Unicode character to test. */
{
    return (utf8proc_category(ch) == UTF8PROC_CATEGORY_LL);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharIsPrint --
 *
 *	Test if a character is a Unicode print character.

    int ch)			/* Unicode character to test. */
{
    if (UNICODE_OUT_OF_RANGE(ch)) {
	return ((unsigned)((ch & 0x1FFFFF) - 0xE0100) <= 0xEF);
    }
    return (((GRAPH_BITS|SPACE_BITS) >> GetCategory(ch)) & 1);
}
int
Tcl_Utf8procIsPrint(
    int ch)			/* Unicode character to test. */
{
    return ((1 << utf8proc_category(ch)) & (UTF8PROC_SPACE_BITS|UTF8PROC_GRAPH_BITS)) != 0;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharIsPunct --
 *
 *	Test if a character is a Unicode punctuation character.

    int ch)			/* Unicode character to test. */
{
    if (UNICODE_OUT_OF_RANGE(ch)) {
	return 0;
    }
    return ((PUNCT_BITS >> GetCategory(ch)) & 1);
}
int
Tcl_Utf8procIsPunct(
    int ch)			/* Unicode character to test. */
{
    return ((1 << utf8proc_category(ch)) & UTF8PROC_PUNCT_BITS) != 0;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharIsSpace --
 *
 *	Test if a character is a whitespace Unicode character.

    } else if (ch == 0x0085 || ch == 0x180E || ch == 0x200B
	    || ch == 0x202F || ch == 0x2060 || ch == 0xFEFF) {
	return 1;
    } else {
	return ((SPACE_BITS >> GetCategory(ch)) & 1);
    }
}
int
Tcl_Utf8procIsSpace(
    int ch)			/* Unicode character to test. */
{
    /* Ignore upper 11 bits. */
    ch &= 0x1FFFFF;

    /*
     * If the character is within the first 127 characters, just use the
     * standard C function, otherwise consult the Unicode table.
     */

    if (ch < 0x80) {
	return TclIsSpaceProcM((char) ch);
    } else if (UNICODE_OUT_OF_RANGE(ch)) {
	return 0;
    } else if (ch == 0x0085 || ch == 0x180E || ch == 0x200B
	    || ch == 0x202F || ch == 0x2060 || ch == 0xFEFF) {
	return 1;
    } else {
	return ((1 << utf8proc_category(ch)) & UTF8PROC_SPACE_BITS) != 0;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharIsUpper --
 *
 *	Test if a character is a uppercase Unicode character.

    int ch)			/* Unicode character to test. */
{
    if (UNICODE_OUT_OF_RANGE(ch)) {
	return 0;
    }
    return (GetCategory(ch) == UPPERCASE_LETTER);
}
int
Tcl_Utf8procIsUpper(
    int ch)			/* Unicode character to test. */
{
    return (utf8proc_category(ch) == UTF8PROC_CATEGORY_LU);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharIsWordChar --
 *
 *	Test if a character is alphanumeric or a connector punctuation mark.

    int ch)			/* Unicode character to test. */
{
    if (UNICODE_OUT_OF_RANGE(ch)) {
	return 0;
    }
    return ((WORD_BITS >> GetCategory(ch)) & 1);
}
int
Tcl_Utf8procIsWordChar(
    int ch)			/* Unicode character to test. */
{
    return ((1 << utf8proc_category(ch)) & UTF8PROC_WORD_BITS) != 0;
}

/*
 *----------------------------------------------------------------------
 *
 * TclUniCharCaseMatch --
 *
 *	See if a particular Unicode string matches a particular pattern.

    } -constraints ucdproperties -result {Upper case mismatches:}

    test unicode-is-upper-outofrange "unicode is upper out of range" -cleanup {
        testobj freeallvars
    } -body {
    	unicode is upper [teststringobj newunicode 1 0x110000]
    } -constraints teststringobj -result 0

	###
    # Compatibility tests between the string and unicode commands.
	proc testStringUnicodeCompatibility {class} {
        set mismatches "is $class mismatches:"
        foreach codePoint [lseq 0 $::tcltests::ucd::maxCodepoint] {
            set ch [format %c $codePoint]
            if {[string is $class $ch] != [unicode is $class $ch]} {
                append mismatches " " U+[format %x $codePoint]
                break
            }
        }
        return $mismatches
    }

    foreach class {alpha alnum control digit graph lower print space upper wordchar} {
    	test string-vs-unicode-is-$class "string is $class vs unicode" -body {
            testStringUnicodeCompatibility $class
		} -result "is $class mismatches:"
    }
}

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