Tcl Source Code

*/config.log
*/config.status
*/tclConfig.sh
*/tclsh*
*/tcltest*
*/versions.vc
unix/dltest.marker
unix/tcl.pc
unix/pkgs/*
win/pkgs/*
win/tcl.hpj

2013-06-01  Don Porter  <[email protected]>

	*** 8.4.20 TAGGED FOR RELEASE ***

	* README:		Bump version number to 8.4.20
	* generic/tcl.h:
	* tools/tcl.wse.in:
	* unix/configure.in:
	* unix/tcl.spec:
	* win/README.binary:
	* win/configure.in:

	* unix/configure:	autoconf-2.13
	* win/configure:

	* changes:		updates for 8.4.20 release.

2013-04-09  Reinhard Max  <[email protected]>

	* library/http/http.tcl (http::geturl): Allow URLs that don't have
	a path, but a query query, e.g. http://example.com?foo=bar .
	* Bump the http package to 2.5.8.

2013-04-08  Don Porter  <[email protected]>

	* generic/regc_color.c:	[Bug 3610026] Stop crash when the number of
	* generic/regerrs.h:	"colors" in a regular expression overflows
	* generic/regex.h:	a short int.  Thanks to Heikki Linnakangas
	* generic/regguts.h:	for the report and the patch.
	* tests/regexp.test:

2013-03-19  Don Porter  <[email protected]>

	* generic/tclFCmd.c: [Bug 3597000] Consistent [file copy] result.

2013-03-19  Jan Nijtmans  <[email protected]>

2012-02-06 (bug fix)[3484621] bump bytecode epoch on exec traces (kuhn,sofer)

2012-02-09 (bug fix)[3484402] mem corrupt OBOE in unicode append (porter)

2012-02-29 (bug fix)[3466099] BOM in Unicode (nijtmans)

2012-03-07 (bug fix)[3498327] RFC 3986 compliance (kupries)


2012-05-10 (bug fix)[473946] correct send of special characters (nijtmans)
=> dde 1.2.5

2012-06-29 (enhancement) Add tn, ro_MO, ru_MO to msgcat (nijtmans)
=> msgcat 1.3.5

2013-03-06 (bug fix)[3606683] [regexp (((((a)*)*)*)*)* {}] hangs
(grathwohl,lane,porter)

2013-03-12 (enhancement) better build support for Debian arch (shadura)

2013-03-19 (bug fix)[2893771] [file stat] on locked files (thoyts,nijtmans)

2013-04-08 (bug fix)[3610026] regexp surplus colors crash (linnakangas)

2013-04-09 (bug fix) Allow http://example.com?foo=bar (max)
=> http 2.5.8

New package: platform 1.0.11

--- Released 8.4.20, June 1, 2013 --- See ChangeLog for details ---

 ^ static color newcolor(struct colormap *);
 */
static color			/* COLORLESS for error */
newcolor(cm)
struct colormap *cm;
{
	struct colordesc *cd;

	size_t n;

	if (CISERR())
		return COLORLESS;

	if (cm->free != 0) {
		assert(cm->free > 0);
		assert((size_t)cm->free < cm->ncds);
		cd = &cm->cd[cm->free];
		assert(UNUSEDCOLOR(cd));
		assert(cd->arcs == NULL);
		cm->free = cd->sub;
	} else if (cm->max < cm->ncds - 1) {
		cm->max++;
		cd = &cm->cd[cm->max];
	} else {
		/* oops, must allocate more */
		struct colordesc *newCd;

		if (cm->max == MAX_COLOR) {
			CERR(REG_ECOLORS);
			return COLORLESS;	/* too many colors */
		}
		n = cm->ncds * 2;
		if (n < MAX_COLOR + 1)
			n = MAX_COLOR + 1;
		if (cm->cd == cm->cdspace) {
			newCd = (struct colordesc *)MALLOC(n *
						sizeof(struct colordesc));
			if (newCd != NULL)
				memcpy(VS(newCd), VS(cm->cdspace), cm->ncds *
						sizeof(struct colordesc));
		} else
			newCd = (struct colordesc *)REALLOC(cm->cd,
						n * sizeof(struct colordesc));
		if (newCd == NULL) {
			CERR(REG_ESPACE);
			return COLORLESS;
		}
		cm->cd = newCd;
		cm->ncds = n;
		assert(cm->max < cm->ncds - 1);
		cm->max++;
		cd = &cm->cd[cm->max];
	}

	cd->nchrs = 0;

{ REG_ESPACE,	"REG_ESPACE",	"out of memory" },
{ REG_BADRPT,	"REG_BADRPT",	"quantifier operand invalid" },
{ REG_ASSERT,	"REG_ASSERT",	"\"can't happen\" -- you found a bug" },
{ REG_INVARG,	"REG_INVARG",	"invalid argument to regex function" },
{ REG_MIXED,	"REG_MIXED",	"character widths of regex and string differ" },
{ REG_BADOPT,	"REG_BADOPT",	"invalid embedded option" },
{ REG_ETOOBIG,	"REG_ETOOBIG",	"nfa has too many states" },
{ REG_ECOLORS,	"REG_ECOLORS",	"too many colors" },

#define	REG_ESPACE	12	/* out of memory */
#define	REG_BADRPT	13	/* quantifier operand invalid */
#define	REG_ASSERT	15	/* "can't happen" -- you found a bug */
#define	REG_INVARG	16	/* invalid argument to regex function */
#define	REG_MIXED	17	/* character widths of regex and string differ */
#define	REG_BADOPT	18	/* invalid embedded option */
#define	REG_ETOOBIG	19	/* nfa has too many states */
#define	REG_ECOLORS	20	/* too many colors */
/* two specials for debugging and testing */
#define	REG_ATOI	101	/* convert error-code name to number */
#define	REG_ITOA	102	/* convert error-code number to name */



/*

/*
 * As soon as possible, we map chrs into equivalence classes -- "colors" --
 * which are of much more manageable number.
 */
typedef short color;		/* colors of characters */
typedef int pcolor;		/* what color promotes to */
#define MAX_COLOR	SHRT_MAX /* max color value */
#define	COLORLESS	(-1)	/* impossible color */
#define	WHITE		0	/* default color, parent of all others */



/*
 * A colormap is a tree -- more precisely, a DAG -- indexed at each level

 *
 * Side effects:
 *	See the functions they call.
 *
 *----------------------------------------------------------------------
 */

#undef Tcl_EvalObj
int
Tcl_EvalObj(interp, objPtr)
    Tcl_Interp * interp;
    Tcl_Obj * objPtr;
{
    return Tcl_EvalObjEx(interp, objPtr, 0);
}

#undef Tcl_GlobalEvalObj
int
Tcl_GlobalEvalObj(interp, objPtr)
    Tcl_Interp * interp;
    Tcl_Obj * objPtr;
{
    return Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL);
}

#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */

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

#undef TclUnusedStubEntry

#undef Tcl_PkgPresent
#define Tcl_PkgPresent(interp, name, version, exact) \
	Tcl_PkgPresentEx(interp, name, version, exact, NULL)
#undef Tcl_PkgProvide
#define Tcl_PkgProvide(interp, name, version) \
	Tcl_PkgProvideEx(interp, name, version, NULL)
#undef Tcl_PkgRequire
#define Tcl_PkgRequire(interp, name, version, exact) \
	Tcl_PkgRequireEx(interp, name, version, exact, NULL)

/*
 * Deprecated Tcl procedures:
 */

#undef Tcl_EvalObj
#define Tcl_EvalObj(interp,objPtr) \
    Tcl_EvalObjEx((interp),(objPtr),0)
#undef Tcl_GlobalEvalObj
#define Tcl_GlobalEvalObj(interp,objPtr) \
    Tcl_EvalObjEx((interp),(objPtr),TCL_EVAL_GLOBAL)


#endif /* _TCLDECLS */

 *	The interpreter remembers that this package is available,
 *	so that no other version of the package may be provided for
 *	the interpreter.
 *
 *----------------------------------------------------------------------
 */

#undef Tcl_PkgProvide
int
Tcl_PkgProvide(interp, name, version)
     Tcl_Interp *interp;	/* Interpreter in which package is now
				 * available. */
     CONST char *name;		/* Name of package. */
     CONST char *version;	/* Version string for package. */
{

     Tcl_Obj *CONST reqv[];     /* 0 means to use the latest version available. */
     ClientData *clientDataPtr;
{
    return TCL_ERROR;
}
#endif

#undef Tcl_PkgRequire
CONST char *
Tcl_PkgRequire(interp, name, version, exact)
    Tcl_Interp *interp;	        /* Interpreter in which package is now
				 * available. */
     CONST char *name;		/* Name of desired package. */
     CONST char *version;	/* Version string for desired version; NULL
				 * means use the latest version available. */

 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

#undef Tcl_PkgPresent
CONST char *
Tcl_PkgPresent(interp, name, version, exact)
     Tcl_Interp *interp;	/* Interpreter in which package is now
				 * available. */
     CONST char *name;		/* Name of desired package. */
     CONST char *version;	/* Version string for desired version;
				 * NULL means use the latest version

	    } 
	    if ((objc > 3) && (CheckVersionAndConvert(interp,
		    TclGetString(objv[3]), NULL, NULL) == TCL_OK)) {
		version = TclGetString(objv[3]);
	    }
	}
#endif
	Tcl_PkgPresentEx(interp, name, version, exact, NULL);
	return TCL_ERROR;
	break;
    }
    case PKG_PROVIDE: {
	if ((objc != 3) && (objc != 4)) {
	    Tcl_WrongNumArgs(interp, 2, objv, "package ?version?");
	    return TCL_ERROR;

#ifndef TCL_TIP268
	if (CheckVersion(interp, argv3) != TCL_OK) {
#else
	if (CheckVersionAndConvert(interp, argv3, NULL, NULL) != TCL_OK) {
#endif
	    return TCL_ERROR;
	}
	return Tcl_PkgProvideEx(interp, argv2, argv3, NULL);
    }
    case PKG_REQUIRE: {
    require:
	if (objc < 3) {
	requireSyntax:
#ifndef TCL_TIP268
	    Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?");

		return TCL_ERROR;
	    }
	} else if ((objc != 3) || exact) {
	    goto requireSyntax;
	}
	if (exact) {
	    argv3 =  Tcl_GetString(objv[3]);
	    version = Tcl_PkgRequireEx(interp, argv3, version, exact, NULL);
	} else {
	    version = Tcl_PkgRequireEx(interp, argv2, version, exact, NULL);
	}
	if (version == NULL) {
	    return TCL_ERROR;
	}
	Tcl_SetObjResult( interp, Tcl_NewStringObj( version, -1 ) );
#else
	version = NULL;

#	favor of raising an error
# 2.4	Added -binary option to http::geturl and charset element to the state
#	array.

package require Tcl 8.4
# Keep this in sync with pkgIndex.tcl and with the install directories
# in Makefiles
package provide http 2.5.8

namespace eval http {
    variable http
    array set http {
	-accept */*
	-proxyhost {}
	-proxyport {}

		(
		    [^@/\#?]+		# <userinfo part of authority>
		) @
	    )?
	    ( [^/:\#?]+ )		# <host part of authority>
	    (?: : (\d+) )?		# <port part of authority>
	)?
	( [/\?] [^\#]*)?		# <path> (including query)
	(?: \# (.*) )?			# <fragment>
	$
    }

    # Phase one: parse
    if {![regexp -- $URLmatcher $url -> proto user host port srvurl]} {
	unset $token

		return -code error \
			"Illegal encoding character usage \"$bad\" in URL user"
	    }
	    return -code error "Illegal characters in URL user"
	}
    }
    if {$srvurl ne ""} {
	# RFC 3986 allows empty paths (not even a /), but servers
	# return 400 if the path in the HTTP request doesn't start
	# with / , so add it here if needed.
	if {[string index $srvurl 0] ne "/"} {
	    set srvurl /$srvurl
	}
	# Check for validity according to RFC 3986, Appendix A
	set validityRE {(?xi)
	    ^
	    # Path part (already must start with / character)
	    (?:	      [-\w.~!$&'()*+,;=:@/]  | %[0-9a-f][0-9a-f] )*
	    # Query part (optional, permits ? characters)
	    (?: \? (?: [-\w.~!$&'()*+,;=:@/?] | %[0-9a-f][0-9a-f] )* )?

# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

if {![package vsatisfies [package provide Tcl] 8.4]} {return}
package ifneeded http 2.5.8 [list tclPkgSetup $dir http 2.5.8 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}]

set tail /a/b/c
set url //[info hostname]:$port/a/b/c
set fullurl http://user:pass@[info hostname]:$port/a/b/c
set binurl //[info hostname]:$port/binary
set posturl //[info hostname]:$port/post
set badposturl //[info hostname]:$port/droppost
set badcharurl //%user@[info hostname]:$port/a/^b/c
set authorityurl //[info hostname]:$port

test http-3.4 {http::geturl} {
    set token [http::geturl $url]
    http::data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET $tail</h2>

    http::geturl http://somewhere/path?%query
} -returnCodes error -result {Illegal encoding character usage "%qu" in URL path}
test http-3.25 {http::geturl parse failures} -body {
    set ::http::strict 0
    set token [http::geturl $badcharurl]
    http::cleanup $token
} -returnCodes ok -result {}
test http-3.30 {http::geturl query without path} -body {
    set token [http::geturl $authorityurl?var=val]
    http::ncode $token
} -cleanup {
    catch { http::cleanup $token }
} -result 200
test http-3.31 {http::geturl fragment without path} -body {
    set token [http::geturl "$authorityurl#fragment42"]
    http::ncode $token
} -cleanup {
    catch { http::cleanup $token }
} -result 200


test http-4.1 {http::Event} {
    set token [http::geturl $url]
    upvar #0 $token data
    array set meta $data(meta)
    expr ($data(totalsize) == $meta(Content-Length))
} 1

	[a 671]([a 55])[a 669]([a 55])[a 668]([a 55])[a 669]([a 55]) \
	[a 669]([a 55])[a 669]([a 55])[a 668]([a 55])[a 669]([a 55]) \
	[a 668]([a 55])[a 710]([a 55])[a 668]([a 55])[a 668]([a 55]) \
	[a 668]([a 55])[a 668]([a 55])[a 668]([a 55])[a 511]] {}] a
} -cleanup {
    rename a {}
} -returnCodes 1 -result {couldn't compile regular expression pattern: nfa has too many states}
test regexp-22.5 {Bug 3610026} -setup {
    set e {}
    set cp 99
    while {$cp < 32864} {
	append e [format %c [incr cp]]
    }
} -body {
    regexp -about $e
} -cleanup {
    unset -nocomplain e cp
} -returnCodes error  -match glob -result {*too many colors*}

# cleanup
::tcltest::cleanupTests
return

    if (Tcl_InitStubs(interp, "8.4", 0) == NULL) {
	if (Tcl_InitStubs(interp, "8.4-", 0) == NULL) {
	    return TCL_ERROR;
	}
	Tcl_ResetResult(interp);
    }
    code = Tcl_PkgProvide(interp, "Pkgb", "2.3");
    if (code != TCL_OK) {
	return code;
    }
    Tcl_CreateObjCommand(interp, "pkgb_sub", Pkgb_SubObjCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateObjCommand(interp, "pkgb_unsafe", Pkgb_UnsafeObjCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);

    if (Tcl_InitStubs(interp, "8.4", 0) == NULL) {
	if (Tcl_InitStubs(interp, "8.4-", 0) == NULL) {
	    return TCL_ERROR;
	}
	Tcl_ResetResult(interp);
    }
    code = Tcl_PkgProvide(interp, "Pkgb", "2.3");
    if (code != TCL_OK) {
	return code;
    }
    Tcl_CreateObjCommand(interp, "pkgb_sub", Pkgb_SubObjCmd, (ClientData) 0,
	    (Tcl_CmdDeleteProc *) NULL);
    return TCL_OK;
}