Tcl Source Code

2013-02-15  Don Porter  <[email protected]>

	* generic/regc_nfa.c:	[Bug 3604074] Fix regexp optimization to
	* tests/regexp.test:	stop hanging on the expression
	((((((((a)*)*)*)*)*)*)*)* .  Thanks to Bjørn Grathwohl for discovery.

2013-02-05  Don Porter  <[email protected]>

		"can't create namespace \"\": only global namespace can have empty name", (char *) NULL);
	return NULL;
    } else {
	/*
	 * Find the parent for the new namespace.
	 */

	TclGetNamespaceForQualName(interp, name, (Namespace *) NULL,
		/*flags*/ (CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG),
		&parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName);

	/*
	 * If the unqualified name at the end is empty, there were trailing
	 * "::"s after the namespace's name which we ignore. The new
	 * namespace was already (recursively) created and is pointed to
	 * by parentPtr.

	}
    }

    /*
     * Check that the pattern doesn't have namespace qualifiers.
     */

    TclGetNamespaceForQualName(interp, pattern, nsPtr,
	    /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY),
	    &exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern);

    if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) {
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
	        "invalid export pattern \"", pattern,
		"\": pattern can't specify a namespace",
		(char *) NULL);

    int i, result;

    /*
     * If the specified namespace is NULL, use the current namespace.
     */

    if (namespacePtr == NULL) {
        nsPtr = (Namespace *) (Namespace *) Tcl_GetCurrentNamespace(interp);
    } else {
        nsPtr = (Namespace *) namespacePtr;
    }

    /*
     * Append the export pattern list onto objPtr.
     */

     */

    if (strlen(pattern) == 0) {
	Tcl_SetStringObj(Tcl_GetObjResult(interp),
	        "empty import pattern", -1);
        return TCL_ERROR;
    }
    TclGetNamespaceForQualName(interp, pattern, nsPtr,
	    /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY),
	    &importNsPtr, &dummyPtr, &dummyPtr, &simplePattern);

    if (importNsPtr == NULL) {
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		"unknown namespace in import pattern \"",
		pattern, "\"", (char *) NULL);
        return TCL_ERROR;

    }

    /*
     * Parse the pattern into its namespace-qualification (if any)
     * and the simple pattern.
     */

    TclGetNamespaceForQualName(interp, pattern, nsPtr,
	    /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY),
	    &sourceNsPtr, &dummyPtr, &dummyPtr, &simplePattern);

    if (sourceNsPtr == NULL) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		"unknown namespace in namespace forget pattern \"",
		pattern, "\"", (char *) NULL);
        return TCL_ERROR;

static int
NamespaceExportCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Namespace *currNsPtr = (Namespace*) Tcl_GetCurrentNamespace(interp);
    char *pattern, *string;
    int resetListFirst = 0;
    int firstArg, patternCt, i, result;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 2, objv,
	        "?-clear? ?pattern pattern...?");
        return TCL_ERROR;
    }

    /*
     * Process the optional "-clear" argument.

     */

    firstArg = 2;
    if (firstArg < objc) {
	string = Tcl_GetString(objv[firstArg]);
	if (strcmp(string, "-clear") == 0) {
	    resetListFirst = 1;
	    firstArg++;
	}



    }

    /*
     * If no pattern arguments are given, and "-clear" isn't specified,
     * return the namespace's current export pattern list.
     */

    patternCt = (objc - firstArg);
    if (patternCt == 0) {
	if (firstArg > 2) {
	    return TCL_OK;
	} else {		/* create list with export patterns */
	    Tcl_Obj *listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);

	    result = Tcl_AppendExportList(interp,
		    (Tcl_Namespace *) currNsPtr, listPtr);
	    if (result != TCL_OK) {
		return result;
	    }
	    Tcl_SetObjResult(interp, listPtr);
	    return TCL_OK;
	}

    }

    /*
     * Add each pattern to the namespace's export pattern list.
     */
    
    for (i = firstArg;  i < objc;  i++) {
	pattern = Tcl_GetString(objv[i]);
	result = Tcl_Export(interp, (Tcl_Namespace *) currNsPtr, pattern,
		((i == firstArg)? resetListFirst : 0));
        if (result != TCL_OK) {
            return result;
        }
    }
    return TCL_OK;
}


        namespace export -clear cmd4
    }
    namespace eval test_ns_2 {
        namespace import ::test_ns_1::*
    }
    list [lsort [info commands test_ns_2::*]] [test_ns_2::cmd4 hello]
} [list [lsort {::test_ns_2::cmd4 ::test_ns_2::cmd1 ::test_ns_2::cmd3}] {cmd4: hello}]









test namespace-27.1 {NamespaceForgetCmd, no args} {
    catch {eval namespace delete [namespace children :: test_ns_*]}
    namespace forget
} {}
test namespace-27.2 {NamespaceForgetCmd, args must be valid namespaces} {
    list [catch {namespace forget ::test_ns_1::xxx} msg] $msg