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-14  Harald Oehlmann  <[email protected]>

	* library/msgcat/msgcat.tcl: [Bug 3604576]: Catch missing registry entry
	"HCU\Control Panel\International".
	Bumped msgcat version to 1.5.1

2013-02-11  Donal K. Fellows  <[email protected]>

	* generic/tclZlib.c (ZlibTransformOutput): [Bug 3603553]: Ensure that
	data gets written to the underlying stream by compressing transforms
	when the amount of data to be written is one buffer's-worth; problem
	was particularly likely to occur when compressing large quantities of
	not-very-compressible data. Many thanks to Piera Poggio (vampiera) for

.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
msgcat \- Tcl message catalog
.SH SYNOPSIS
\fBpackage require Tcl 8.5\fR
.sp
\fBpackage require msgcat 1.5\fR
.sp
\fB::msgcat::mc \fIsrc-string\fR ?\fIarg arg ...\fR?
.sp
\fB::msgcat::mcmax ?\fIsrc-string src-string ...\fR?
.sp
\fB::msgcat::mclocale \fR?\fInewLocale\fR?
.sp

static void
fixempties(
    struct nfa *nfa,
    FILE *f)			/* for debug output; NULL none */
{
    struct state *s;
    struct state *nexts;
    struct state *to;
    struct arc *a;
    struct arc *nexta;
    int progress;

    /*
     * Find and eliminate empties until there are no more.
     */

    do {
	progress = 0;
	for (s = nfa->states; s != NULL && !NISERR(); s = nexts) {

	    nexts = s->next;
	    for (a = s->outs; a != NULL && !NISERR(); a = a->outchain) {
		if (a->type == EMPTY) {

		    /*
		     *  Mark a for deletion; copy arcs to preserve graph
		     * connectivity after it is gone.
		     */

		    unempty(nfa, a);
		}
	    }

	    /*
	     * Now pass through and delete the marked arcs.  Doing all the
	     * deletion after all the marking prevents arc copying from
	     * resurrecting deleted arcs which can cause failure to converge.
	     * [Tcl Bug 3604074]
	     */

	    for (a = s->outs; a != NULL; a = nexta) {
		nexta = a->outchain;
		if (a->from == NULL) {
		    progress = 1;
		    to = a->to;
		    a->from = s;
		    freearc(nfa, a);
		    if (to->nins == 0) {
			while ((a = to->outs)) {
			    freearc(nfa, a);
			}
			if (nexts == to) {
			    nexts = to->next;
			}
			freestate(nfa, to);
		    }
		    if (s->nouts == 0) {
			while ((a = s->ins)) {
			    freearc(nfa, a);
			}
			freestate(nfa, s);
		    }
		}
	    }
	}
	if (progress && f != NULL) {
	    dumpnfa(nfa, f);
	}
    } while (progress && !NISERR());
}

static int			/* 0 couldn't, 1 could */
unempty(
    struct nfa *nfa,
    struct arc *a)
{
    struct state *from = a->from;
    struct state *to = a->to;


    assert(a->type == EMPTY);
    assert(from != nfa->pre && to != nfa->post);

    if (from == to) {		/* vacuous loop */
	freearc(nfa, a);
	return 1;
    }

    /*
     *  Mark arc for deletion.
     */



    a->from = NULL;





    if (from->nouts > to->nins) {
	copyouts(nfa, to, from);
	return 1;
    }




    if (from->nouts < to->nins) {







	copyins(nfa, from, to);
	return 1;
    }


    /*

     * from->nouts == to->nins . decide on secondary issue:  copy fewest arcs
     */

    if (from->nins > to->nouts) {


	copyouts(nfa, to, from);
	return 1;
    }

    copyins(nfa, from, to);
    return 1;
}

/*
 - cleanup - clean up NFA after optimizations
 ^ static void cleanup(struct nfa *);
 */

    for (; objc>0 ; objc--) {
        Tcl_Obj *objPtr;

        objPtr = tosPtr[1 - objc + off];
        if (!objPtr) {
            Tcl_Panic("InnerContext: bad tos -- appending null object");
        }
        if ((objPtr->refCount<=0)
#ifdef TCL_MEM_DEBUG
                || (objPtr->refCount==0x61616161)
#endif
        ) {
            Tcl_Panic("InnerContext: bad tos -- appending freed object %p",
                    objPtr);
        }
        Tcl_ListObjAppendElement(NULL, result, objPtr);
    }

    return result;

    void *buffer,		/* Dummy: unused by this implementation */
    int size,			/* Dummy: unused by this implementation */
    int codeSize,		/* Dummy: unused by this implementation */
    Tcl_LoadHandle *loadHandle,	/* Dummy: unused by this implementation */
    Tcl_FSUnloadFileProc **unloadProcPtr)
				/* Dummy: unused by this implementation */
{
    Tcl_SetObjResult(interp, Tcl_NewStringObj("dynamic loading from memory "
	    "is not available on this system", -1));
    return TCL_ERROR;
}

#endif /* TCL_LOAD_FROM_MEMORY */

/*
 * Local Variables:

#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

package require Tcl 8.5-
# When the version number changes, be sure to update the pkgIndex.tcl file,
# and the installation directory in the Makefiles.
package provide msgcat 1.5.1

namespace eval msgcat {
    namespace export mc mcload mclocale mcmax mcmset mcpreferences mcset \
	    mcunknown mcflset mcflmset

    # Records the current locale as passed to mclocale
    variable Locale ""

    variable FileLocale
    # Save the file locale if we are recursively called
    if {[info exists FileLocale]} {
	set nestedFileLocale $FileLocale
    }
    set x 0
    foreach p [mcpreferences] {
	if {$p eq {}} {
	    set p ROOT
	}
	set langfile [file join $langdir $p.msg]
	if {[file exists $langfile]} {
	    incr x
	    set FileLocale [string tolower [file tail [file rootname $langfile]]]
	    if {"root" eq $FileLocale} {

# Arguments:
#	locale		The locale to use.
#	pairs		One or more src/dest pairs (must be even length)
#
# Results:
#	Returns the number of pairs processed

proc msgcat::mcmset {locale pairs} {
    variable Msgs

    set length [llength $pairs]
    if {$length % 2} {
	return -code error "bad translation list:\
		 should be \"[lindex [info level 0] 0] locale {src dest ...}\""
    }

    # -[a-z]{4}  : script (optional, translated by table Latn->latin)
    # -[a-z]{2}|[0-9]{3} : territory (optional, numerical region codes not used)
    # (-.*)* : variant, extension, private use (optional, not used)
    # Those are translated to local strings.
    # Examples: de-CH -> de_ch, sr-Latn-CS -> sr_cs@latin, es-419 -> es
    #
    set key {HKEY_CURRENT_USER\Control Panel\International}
    if {![catch {registry get $key LocaleName} localeName]
	    && [regexp {^([a-z]{2,3})(?:-([a-z]{4}))?(?:-([a-z]{2}))?(?:-.+)?$}\

	    [string tolower $localeName] match locale script territory]} {
	if {"" ne $territory} {
	    append locale _ $territory
	}
	set modifierDict [dict create latn latin cyrl cyrillic]
	if {[dict exists $modifierDict $script]} {
	    append locale @ [dict get $modifierDict $script]
	}

	if {![catch {mclocale [ConvertLocale $locale]}]} {

	    return
	}
    }

    # then check key locale which contains a numerical language ID
    if {[catch {
	set locale [registry get $key "locale"]

if {![package vsatisfies [package provide Tcl] 8.5-]} {return}
package ifneeded msgcat 1.5.1 [list source [file join $dir msgcat.tcl]]

# message catalogs for locales foo, foo_BAR, and foo_BAR_baz.

package require Tcl 8.5-
if {[catch {package require tcltest 2}]} {
    puts stderr "Skipping tests in [info script].  tcltest 2 required."
    return
}
if {[catch {package require msgcat 1.5}]} {
    puts stderr "Skipping tests in [info script].  No msgcat 1.5 found to test."
    return
}

namespace eval ::msgcat::test {
    namespace import ::msgcat::*
    namespace import ::tcltest::test
    namespace import ::tcltest::cleanupTests

test regexp-22.1 {Bug 1810038} {
    regexp ($|^X)* {}
} 1
test regexp-22.2 {regexp compile and backrefs, Bug 1857126} {
    regexp -- {([bc])\1} bb
} 1
test regexp-22.3 {Bug 3604074} {
    # This will hang in interps where the bug is not fixed
    regexp ((((((((a)*)*)*)*)*)*)*)* a
} 1

test regexp-23.1 {regexp -all and -line} {
    set string ""
    list \
	[regexp -all -inline -indices -line -- {^} $string] \
	[regexp -all -inline -indices -line -- {^$} $string] \
	[regexp -all -inline -indices -line -- {$} $string]

	@echo "Installing package http 2.8.6 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.6/http-2.8.6.tm;
	@echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/";
	@for i in $(TOP_DIR)/library/opt/*.tcl ; \
	    do \
	    $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \
	    done;
	@echo "Installing package msgcat 1.5.1 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.5.1.tm;
	@echo "Installing package tcltest 2.3.5 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.5.tm;

	@echo "Installing package platform 1.0.11 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.11.tm;
	@echo "Installing package platform::shell 1.1.4 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform/shell-1.1.4.tm;

	@echo "Installing package http 2.8.6 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.6/http-2.8.6.tm;
	@echo "Installing library opt0.4 directory";
	@for j in $(ROOT_DIR)/library/opt/*.tcl; \
	    do \
	    $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \
	    done;
	@echo "Installing package msgcat 1.5.1 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.5.1.tm;
	@echo "Installing package tcltest 2.3.5 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.5.tm;
	@echo "Installing package platform 1.0.11 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform-1.0.11.tm;
	@echo "Installing package platform::shell 1.1.4 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/platform/shell.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform/shell-1.1.4.tm;
	@echo "Installing encodings";

	echo "$as_me:$LINENO: result: shared" >&5
echo "${ECHO_T}shared" >&6
	SHARED_BUILD=1
    else
	echo "$as_me:$LINENO: result: static" >&5
echo "${ECHO_T}static" >&6
	SHARED_BUILD=0

cat >>confdefs.h <<\_ACEOF
#define STATIC_BUILD 1
_ACEOF

    fi


#--------------------------------------------------------------------

#		TCL_BIN_DIR
#		TCL_SRC_DIR
#		TCL_LIB_FILE
#
#------------------------------------------------------------------------

AC_DEFUN([SC_LOAD_TCLCONFIG], [
    AC_MSG_CHECKING([for existence of ${TCL_BIN_DIR}/tclConfig.sh])

    if test -f "${TCL_BIN_DIR}/tclConfig.sh" ; then
        AC_MSG_RESULT([loading])
	. "${TCL_BIN_DIR}/tclConfig.sh"
    else
        AC_MSG_RESULT([could not find ${TCL_BIN_DIR}/tclConfig.sh])
    fi

    #
    # If the TCL_BIN_DIR is the build directory (not the install directory),
    # then set the common variable name to the value of the build variables.
    # For example, the variable TCL_LIB_SPEC will be set to the value
    # of TCL_BUILD_LIB_SPEC. An extension should make use of TCL_LIB_SPEC

    AC_SUBST(TCL_DEFS)
])

#------------------------------------------------------------------------
# SC_LOAD_TKCONFIG --
#
#	Load the tkConfig.sh file

#
# Arguments:
#
#	Requires the following vars to be set:
#		TK_BIN_DIR
#
# Results:
#
#	Sets the following vars that should be in tkConfig.sh:
#		TK_BIN_DIR
#------------------------------------------------------------------------

AC_DEFUN([SC_LOAD_TKCONFIG], [
    AC_MSG_CHECKING([for existence of ${TK_BIN_DIR}/tkConfig.sh])

    if test -f "${TK_BIN_DIR}/tkConfig.sh" ; then
        AC_MSG_RESULT([loading])
	. "${TK_BIN_DIR}/tkConfig.sh"
    else
        AC_MSG_RESULT([could not find ${TK_BIN_DIR}/tkConfig.sh])
    fi


    AC_SUBST(TK_BIN_DIR)
    AC_SUBST(TK_SRC_DIR)
    AC_SUBST(TK_LIB_FILE)
])

#		SHARED_BUILD	Value of 1 or 0
#------------------------------------------------------------------------

AC_DEFUN([SC_ENABLE_SHARED], [
    AC_MSG_CHECKING([how to build libraries])
    AC_ARG_ENABLE(shared,
	[  --enable-shared         build and link with shared libraries (default: on)],
	[tcl_ok=$enableval], [tcl_ok=yes])

    if test "${enable_shared+set}" = set; then
	enableval="$enable_shared"
	tcl_ok=$enableval
    else
	tcl_ok=yes
    fi

    if test "$tcl_ok" = "yes" ; then
	AC_MSG_RESULT([shared])
	SHARED_BUILD=1
    else
	AC_MSG_RESULT([static])
	SHARED_BUILD=0
	AC_DEFINE(STATIC_BUILD, 1, [Is this a static build?])
    fi
])

#------------------------------------------------------------------------
# SC_ENABLE_THREADS --
#
#	Specify if thread support should be enabled

    fi
    AC_SUBST(TCL_THREADS)
])

#------------------------------------------------------------------------
# SC_ENABLE_SYMBOLS --
#
#	Specify if debugging symbols should be used.
#	Memory (TCL_MEM_DEBUG) and compile (TCL_COMPILE_DEBUG) debugging
#	can also be enabled.
#
# Arguments:
#	none
#
#	Requires the following vars to be set in the Makefile: