##+##########################################################################
#
# datefield.tcl
#
# Implements a datefield entry widget ala Iwidget::datefield
# by Keith Vetter (keith@ebook.gemstar.com)
#
# Datefield creates an entry widget but with a special binding to KeyPress
# (based on Iwidget::datefield) to ensure that the current value is always
# a valid date. All normal entry commands and configurations still work.
#
# Usage:
#  ::datefield::datefield .df -background yellow -textvariable myDate \
#   -format "%Y-%m-%d"
#  pack .df
#
# Bugs:
#   o won't work if you programmatically put in an invalid date
#     e.g. .df insert end "abc"	  will cause it to behave erratically
#
# Revisions:
# KPV	Feb 07, 2002	- initial revision
# TW	Mar 26, 2017	- support more keys and the mouse wheel
#			- add option -format to support 3 date-styles:
#				"%d.%m.%Y" (for German)
#				"%m/%d/%Y" (for English, standard)
#				"%Y-%m-%d" (for ISO)
#
##+##########################################################################
#############################################################################

package require Tk 8.0
package provide datefield 0.3

namespace eval ::datefield {
    namespace export datefield

    # Have the widget use tile/ttk should it be available.

    variable entry entry
    if {![catch {
	package require tile
    }]} {
	set entry ttk::entry
    }

    proc datefield {w args} {
	variable entry
	variable Format
	variable Separator

	set i [lsearch $args "-form*"]
	if {$i == -1} {		# Default English
	    set Format($w) "%m/%d/%Y"
	} else {
	    set Format($w) [lindex [lreplace $args $i $i] $i]
	    switch -- $Format($w) {
		"%d.%m.%Y" {	# German
		}
		"%m/%d/%Y" {	# English
		}
		"%Y-%m-%d" {	# ISO
		}
		default {	# Error
		    error "ERROR: Unknown value for option -format on datefield $w $args"
		}
	    }
	    set args [lreplace $args $i $i]
	    set args [lreplace $args $i $i]
	}
	set Separator($w) [string range $Format($w) 2 2]
	eval $entry $w -width 10 -justify center $args
	if {([$w get] eq "") \
	 || [catch {clock scan [$w get] -format $Format($w)} base]} {
	    $w delete 0 end
	    $w insert end [clock format [clock seconds] -format $Format($w)]

	}
	$w icursor 0
	bind $w <KeyPress>	 [list ::datefield::KeyPress $w %A %K %s]
	bind $w <MouseWheel>	 [list ::datefield::MouseWheel $w %D]
	bind $w <Button1-Motion> break
	bind $w <Button2-Motion> break
	bind $w <Double-Button>	 break
	bind $w <Triple-Button>	 break
	bind $w <2>		 break
	return $w
    }

    proc Spin {w dir unit code} {
	variable Format

	set base [clock scan [$w get] -format $Format($w)]
	set new [clock add $base $dir $unit]
	set date [clock format $new -format $Format($w)]
	set icursor [$w index insert]
	$w delete 0 end
	$w insert end $date
	$w icursor $icursor
	return $code
    }

    proc MouseWheel {w dir} {
	$w selection clear
	set Dir [expr {$dir / 120}]
	return -code [Spin $w $Dir "day" continue]
    }

    # internal routine for all key presses in the datefield entry widget
    proc KeyPress {w char sym state} {
	variable Format
	variable Separator

	proc Move {w dir} {
	    variable Format

	    set icursor [$w index insert]
	    set icursor [expr {($icursor + 10 + $dir) % 10}]
	    if {$Format($w) ne "%Y-%m-%d"} {			# English or German
		if {($icursor == 2) || ($icursor == 5)} {		# Don't land on a / or .
		    set icursor [expr {($icursor + 10 + $dir) % 10}]
		}
	    } \
	    elseif {($icursor == 4) || ($icursor == 7)} {	# ISO	# Don't land on a -
		set icursor [expr {($icursor + 10 + $dir) % 10}]
	    }
	    $w icursor $icursor
	}

	set icursor [$w index insert]
	$w selection clear
	# Handle some non-number characters first
	switch -exact -- $sym {
	    "Down"	{return -code [Spin $w -1 "day"		continue]}
	    "End"	{$w icursor 9;		return -code	break}
	    "minus"	{return -code [Spin $w -1 "day"		break]}
	    "Next"	{return -code [Spin $w -1 "month"	continue]}
	    "plus"	{return -code [Spin $w 1 "day"		break]}
	    "Prior"	{return -code [Spin $w 1 "month"	continue]}
	    "Up"	{return -code [Spin $w 1 "day"		continue]}
	    "BackSpace"	-
	    "Delete"	-
	    "Left"	{Move $w -1;		return -code	break}
	    "Right"	{Move $w 1;		return -code	break}
	    "Tab"		{
		if {$Format($w) ne "%Y-%m-%d"} {	# English or German
		    if {($state & 5) == 0} {		# ->|
			if {$icursor < 3} {	# from 1st to 2nd
			    $w icursor 3
			} \
			elseif {$icursor < 6} {	# from 2nd to 10th-year
			    $w icursor 8

			} else {		# next widget
			    return -code continue
			}
		    } \
		    elseif {$icursor > 4} {		# |<-
			$w icursor 3		;# from year to 2nd
		    } \
		    elseif {$icursor > 1} {	# from 2nd to 1st
			$w icursor 0
		    } else {			# previous widget
			return -code continue
		    }
		} \
		elseif {($state & 5) == 0} {		# ->|	ISO
		    if {$icursor < 5} {		# from year to month
			$w icursor 5
		    } \
		    elseif {$icursor < 8} {	# from month to day
			$w icursor 8
		    } else {			# next widget
			return -code continue
		    }
		} \
		elseif {$icursor > 6} {			# |<-
		    $w icursor 5		;# from day to month
		} \
		elseif {$icursor > 2} {		# from month to 10th-year
		    $w icursor 2
		} else {			# previous widget
		    return -code continue
		}
		return -code break

	    }
	}
	if {$char eq ""} {			# remaining special keys
	    return -code continue
	}
	if {! [regexp -- {[0-9]} $char]} {	# Unknown character
	    bell
	    return -code break
	}
	if {$icursor >= 10} {			# Can't add beyond end
	    bell
	    return -code break
	}
	switch -- $Separator($w) {
	    "." {	# German
		foreach {day month year} [split [$w get] $Separator($w)] break
		if {$icursor < 2} {			# DAY SECTION
		    set endday [lastDay $month $year]
		    foreach {d1 d2} [split $day ""] break
		    set cursor 3		;# Where to leave the cursor
		    if {$icursor == 0} {	# 1st digit of day
			if {($char < 3) \
			 || (($char == 3) && ($month ne "02"))} {
			    set day "$char$d2"
			    if {$day eq "00"} {set day "01"}
			    if {$day > $endday} {set day $endday}
			    set cursor 1
			} else {
			    set day "0$char"
			}
		    } else {			# 2nd digit of day
			set day "$d1$char"
			if {($day > $endday) || ($day eq "00")} {
			    bell
			    return -code break
			}
		    }
		    $w delete 0 2
		    $w insert 0 $day
		    $w icursor $cursor
		    return -code break

		}
		if {$icursor < 5} {			# MONTH SECTION
		    foreach {m1 m2} [split $month ""] break
		    set cursor 6		;# Where to leave the cursor
		    if {$icursor == 3} {	# 1st digit of month
			if {$char < 2} {
			    set month "$char$m2"
			    set cursor 4
			} else {
			    set month "0$char"
			}
			if {$month > 12} {set month "10"}
			if {$month eq "00"} {set month "01"}
		    } else {			# 2nd digit of month
			set month "$m1$char"

			if {$month > 12} {set month "0$char"}
			if {$month eq "00"} {
			    bell
			    return -code break
			}
		    }
		    $w delete 3 5
		    $w insert 3 $month
		    # Validate the day of the month
		    if {$day > [set endday [lastDay $month $year]]} {
			$w delete 0 2
			$w insert 0 $endday
		    }
		    $w icursor $cursor
		    return -code break
		}
		set y1 [string range $year 0 0];	# YEAR SECTION
		if {$icursor < 7} {		# 1st digit of year
		    if {($char ne "1") && ($char ne "2")} {
			bell
			return -code break
		    }
		    if {$char != $y1} {		# Different century
			set y 1999
			if {$char eq "2"} {set y 2000}
			$w delete 6 end
			$w insert end $y
		    }
		    $w icursor 7
		    return -code break
		}
		$w delete $icursor
		$w insert $icursor $char
		if {[catch {clock scan [$w get] -format $Format($w)}] != 0} {	# Validate the year
		    $w delete 6 end
		    $w insert end $year		;# Put back in the old year
		    $w icursor $icursor
		    bell
		}
	    }
	    "/" {	# English
		foreach {month day year} [split [$w get] $Separator($w)] break
		if {$icursor < 2} {			# MONTH SECTION
		    foreach {m1 m2} [split $month ""] break
		    set cursor 3		;# Where to leave the cursor
		    if {$icursor == 0} {	# 1st digit of month
			if {$char < 2} {
			    set month "$char$m2"
			    set cursor 1
			} else {
			    set month "0$char"
			}
			if {$month > 12} {set month "10"}
			if {$month eq "00"} {set month "01"}
		    } else {			# 2nd digit of month
			set month "$m1$char"
			if {$month > 12} {set month "0$char"}
			if {$month eq "00"} {
			    bell
			    return -code break
			}
		    }
		    $w delete 0 2
		    $w insert 0 $month
		    # Validate the day of the month
		    if {$day > [set endday [lastDay $month $year]]} {
			$w delete 3 5
			$w insert 3 $endday
		    }
		    $w icursor $cursor

		    return -code break
		}

		if {$icursor < 5} {			# DAY SECTION
		    set endday [lastDay $month $year]
		    foreach {d1 d2} [split $day ""] break
		    set cursor 6		;# Where to leave the cursor
		    if {$icursor == 3} {	# 1st digit of day
			if {($char < 3) \
			 || (($char == 3) && ($month ne "02"))} {
			    set day "$char$d2"
			    if {$day eq "00"} {set day "01"}
			    if {$day > $endday} {set day $endday}
			    set cursor 4
			} else {
			    set day "0$char"
			}
		    } else {			# 2nd digit of day
			set day "$d1$char"
			if {($day > $endday) || ($day eq "00")} {
			    bell
			    return -code break
			}
		    }
		    $w delete 3 5
		    $w insert 3 $day
		    $w icursor $cursor
		    return -code break
		}

		set y1 [string range $year 0 0];	# YEAR SECTION

		if {$icursor < 7} {		# 1st digit of year
		    if {($char ne "1") && ($char ne "2")} {
			bell
			return -code break
		    }
		    if {$char != $y1} {		# Different century
			set y 1999
			if {$char eq "2"} {set y 2000}
			$w delete 6 end
			$w insert end $y
		    }
		    $w icursor 7
		    return -code break
		}
		$w delete $icursor
		$w insert $icursor $char
		if {[catch {clock scan [$w get] -format $Format($w)}] != 0} {	# Validate the year
		    $w delete 6 end
		    $w insert end $year		;# Put back in the old year
		    $w icursor $icursor
		    bell
		}
	    }
	    default {	# ISO
		foreach {year month day} [split [$w get] $Separator($w)] break
		if {$icursor < 4} {			# YEAR SECTION
		    set y1 [string range $year 0 0];
		    if {$icursor == 0} {	# 1st digit of year
			if {($char ne "1") && ($char ne "2")} {
			    bell
			    return -code break
			}
			if {$char != $y1} {	# Different century
			    set y 1999
			    if {$char eq "2"} {set y 2000}
			    $w delete 0 4
			    $w insert 0 $y
			}
			$w icursor 1
			return -code break
		    }
		    $w delete $icursor
		    $w insert $icursor $char
		    if {[catch {clock scan [$w get] -format $Format($w)}] != 0} {	# Validate the year
			$w delete 0 4
			$w insert 0 $year	;# Put back in the old year
			$w icursor $icursor
			bell
		    }
		    if {$icursor == 3} {	# last digit of year
			$w icursor 5	;# Don't land on a -
		    }
		    return -code break
		}
		if {$icursor < 7} {			# MONTH SECTION
		    foreach {m1 m2} [split $month ""] break
		    set cursor 8		;# Where to leave the cursor
		    if {$icursor == 5} {	# 1st digit of month
			if {$char < 2} {
			    set month "$char$m2"
			    set cursor 6
			} else {
			    set month "0$char"
			}
			if {$month > 12} {set month "10"}
			if {$month eq "00"} {set month "01"}
		    } else {			# 2nd digit of month
			set month "$m1$char"
			if {$month > 12} {set month "0$char"}
			if {$month eq "00"} {
			    bell
			    return -code break
			}
		    }
		    $w delete 5 7
		    $w insert 5 $month
		    # Validate the day of the month
		    if {$day > [set endday [lastDay $month $year]]} {
			$w delete 8 end
			$w insert end $endday
		    }
		    $w icursor $cursor
		    return -code break
		}
		set endday [lastDay $month $year]	;# DAY SECTION
		foreach {d1 d2} [split $day ""] break
		set cursor 10			;# Where to leave the cursor
		if {$icursor == 8} {		# 1st digit of day
		    if {($char < 3) \
		     || (($char == 3) && ($month ne "02"))} {
			set day "$char$d2"
			if {$day eq "00"} {set day "01"}
			if {$day > $endday} {set day $endday}
			set cursor 9
		    } else {
			set day "0$char"
		    }
		} else {			# 2nd digit of day
		    set day "$d1$char"
		    if {($day > $endday) || ($day eq "00")} {
			bell
			return -code break
		    }
		}
		$w delete 8 end
		$w insert end $day
		$w icursor $cursor
	    }
	}
	return -code break
    }

    # internal routine that returns the last valid day of a given month and year
    proc lastDay {month year} {
	return [clock format [clock scan "+1 month -1 day" \
	 -base [clock scan "$month/01/$year"]] -format %d]
    }
}

package ifneeded datefield 0.3 [list source [file join $dir datefield.tcl]]

imgjp2
======

Tk photo image format handler for the JPEG2000 (.jp2) format using
libopenjp2 from http://www.openjpeg.org

The image format name is "jp2", i.e.

  package require imgjp2
  image create photo MyImage
  MyImage read filename -format jp2
  MyImage filename -format jp2[<compress-options>]

Supported <compress-options> are "/r:<num>,...", "/q:<num>,...",
and "/I". For further information consult the description of the
"opj_compress" command in http://www.openjpeg.org

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

#include <tcl.h>
#include <tk.h>
#include <string.h>
#include <stdlib.h>
#include <openjpeg.h>

static void
LogHandler(const char *msg, void *udata)
{
#ifndef NDEBUG
    fprintf(stderr, "%s", msg);

{
    int match = 0;
    opj_codec_t *codec;
    opj_dparameters_t par;
    opj_image_t *img = NULL;

    codec = opj_create_decompress(OPJ_CODEC_JP2);
    if (codec == NULL) {
	goto done;
    }
    opj_set_info_handler(codec, LogHandler, 0);
    opj_set_warning_handler(codec, LogHandler, 0);
    opj_set_error_handler(codec, LogHandler, 0);
    memset(&par, 0, sizeof(par));
    opj_set_default_decoder_parameters(&par);
    opj_setup_decoder(codec, &par);
    if (opj_read_header(stream, codec, &img)) {

	    *widthPtr = w;
	}
	if (heightPtr != NULL) {
	    *heightPtr = h;
	}
	match = 1;
    }
done:
    if (codec != NULL) {
	opj_destroy_codec(codec);
    }
    if (img != NULL) {
	opj_image_destroy(img);
    }
    return match;
}

static void
DownShift(
    opj_image_comp_t *comp)
{

    opj_codec_t *codec;
    opj_dparameters_t par;
    opj_image_t *img = NULL;

    memset(&par, 0, sizeof(par));
    opj_set_default_decoder_parameters(&par);
    codec = opj_create_decompress(OPJ_CODEC_JP2);
    if (codec == NULL) {
	Tcl_SetResult(interp, "error creating codec", TCL_STATIC);
	goto done;
    }
    opj_set_info_handler(codec, LogHandler, 0);
    opj_set_warning_handler(codec, LogHandler, 0);
    opj_set_error_handler(codec, LogHandler, 0);
    opj_setup_decoder(codec, &par);
    if (opj_read_header(stream, codec, &img) &&
	opj_set_decode_area(codec, img, srcX, srcY,
			    srcX + width, srcY + height)) {

	    }
	    Tk_PhotoExpand(interp, imgHandle,
			   destX + blk.width, destY + blk.height);
	    Tk_PhotoPutBlock_NoComposite(imgHandle, &blk, destX, destY,
					 blk.width, blk.height);
	}
    }
done:
    if (codec != NULL) {
	opj_destroy_codec(codec);
    }
    if (img != NULL) {
	opj_image_destroy(img);
    }
    return result;
}

static int
CommonWriteJP2(
    Tcl_Interp *interp,
    opj_stream_t *stream,
    Tcl_Obj *fmtObj,
    Tk_PhotoImageBlock *blkPtr)
{
    int x, y, result = TCL_ERROR;
    opj_cparameters_t par;
    opj_codec_t *codec;
    opj_image_t *img = NULL;
    opj_image_cmptparm_t comps[3];

    memset(&par, 0, sizeof(par));
    opj_set_default_encoder_parameters(&par);
    par.tcp_mct = 255;
    if (fmtObj != NULL) {
	char *fmtStr, *p, *q;
	int len, n;

	fmtStr = Tcl_GetString(fmtObj);
	p = strchr(fmtStr, '/');
	while (p != NULL) {
	    len = strlen(p);
	    if (len > 3 && strncmp(p, "/r:", 3) == 0) {
		n = 0;
		q = p + 3;
		while (n < sizeof(par.tcp_rates) / sizeof(par.tcp_rates[0])) {
		    char *end = q;
		    double d;

		    d = strtod(q, &end);
		    if (end == NULL || end == q) {
			break;
		    }
		    if (d < 1) {
			d = 1;
		    }
		    par.tcp_rates[n++] = d;
		    q = end + 1;
		}
		par.tcp_numlayers = n;
		par.cp_disto_alloc = 1;
		par.cp_fixed_quality = 0;
		memset(par.tcp_distoratio, 0, sizeof(par.tcp_distoratio));
	    } else if (len > 3 && strncmp(p, "/q:", 3) == 0) {
		n = 0;
		q = p + 3;
		while (n < sizeof(par.tcp_distoratio) /
		       sizeof(par.tcp_distoratio[0])) {
		    char *end = q;
		    double d;

		    d = strtod(q, &end);
		    if (end == NULL || end == q) {
			break;
		    }
		    par.tcp_distoratio[n++] = d;
		    q = end + 1;
		}
		par.tcp_numlayers = n;
		par.cp_fixed_quality = 1;
		par.cp_disto_alloc = 0;
		memset(par.tcp_rates, 0, sizeof(par.tcp_rates));
	    } else if (len > 1 && strncmp(p, "/I", 2) == 0) {
		par.irreversible = 1;
	    }
	    p = strchr(p + 1, '/');
	}
    }
    codec = opj_create_compress(OPJ_CODEC_JP2);
    if (codec == NULL) {
	Tcl_SetResult(interp, "error creating codec", TCL_STATIC);
	goto done;
    }
    opj_set_info_handler(codec, LogHandler, 0);
    opj_set_warning_handler(codec, LogHandler, 0);
    opj_set_error_handler(codec, LogHandler, 0);
    memset(comps, 0, sizeof(comps));
    comps[0].prec = comps[0].bpp = 8;
    comps[0].sgnd = 0;
    comps[0].dx = comps[0].dy = 1;

	Tcl_SetResult(interp, "encoding failed", TCL_STATIC);
    } else if (!opj_end_compress(codec, stream)) {
	Tcl_SetResult(interp, "end compress failed", TCL_STATIC);
    } else {
	result = TCL_OK;
    }
done:
    if (codec != NULL) {
	opj_destroy_codec(codec);
    }
    if (img != NULL) {
	opj_image_destroy(img);
    }
    return result;
}

static OPJ_SIZE_T
ChanRead(void *buffer, OPJ_SIZE_T nbytes, void *udata)
{
    Tcl_Channel chan = (Tcl_Channel) udata;

	(zoomPart == inZoomIn ? NormalState : ZoomState);
    return true;
}

/*
 *----------------------------------------------------------------------
 *
 * TkUnsupported1ObjCmd --
 *
 *	This procedure is invoked to process the
 *	"::tk::unsupported::MacWindowStyle" Tcl command. This command allows
 *	you to set the style of decoration for a Macintosh window.
 *
 * Results:
 *	A standard Tcl result.

	if ([NSApp macMinorVersion] < 12) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
                "Tabbing identifiers did not exist until OSX 10.12.", -1));
	    Tcl_SetErrorCode(interp, "TK", "WINDOWSTYLE", "TABBINGID", NULL);
	    return TCL_ERROR;
	}
	if ((objc < 3) || (objc > 4)) {
	    Tcl_WrongNumArgs(interp, 2, objv, "window ?newid?");
	    return TCL_ERROR;
	}
	return WmWinTabbingId(interp, winPtr, objc, objv);
    case TKMWS_APPEARANCE:
	if ([NSApp macMinorVersion] < 9) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
                "Window appearances did not exist until OSX 10.9.", -1));

		    -1));
	    Tcl_SetErrorCode(interp, "TK", "WINDOWSTYLE", "APPEARANCE", NULL);
	    return TCL_ERROR;
	}
	return WmWinAppearance(interp, winPtr, objc, objv);
    case TKMWS_ISDARK:
	if ((objc != 3)) {
	    Tcl_WrongNumArgs(interp, 2, objv, "window");
	    return TCL_ERROR;
	}
	Tcl_SetObjResult(interp, Tcl_NewBooleanObj(TkMacOSXInDarkMode(tkwin)));
	return TCL_OK;
    default:
	return TCL_ERROR;
    }

 *      function.  If the optional newId argument is omitted, the window's
 *      tabbingIdentifier is not changed.
 *
 * Side effects:
 *	Windows may only be grouped together as tabs if they all have the same
 *      tabbingIdentifier.  In particular, by giving a window a unique
 *      tabbingIdentifier one can prevent it from becoming a tab in any other
 *      window.  Changing the tabbingIdentifier of a window which is already
 *      a tab causes it to become a separate window.
 *
 *----------------------------------------------------------------------
 */

static int
WmWinTabbingId(
    Tcl_Interp *interp,		/* Current interpreter. */
    TkWindow *winPtr,		/* Window to be manipulated. */
    int objc,			/* Number of arguments. */
    Tcl_Obj * const objv[])	/* Argument objects. */
{
#if !(MAC_OS_X_VERSION_MAX_ALLOWED < 101200)
    Tcl_Obj *result = NULL;
    NSString *idString;
    NSWindow *win = TkMacOSXDrawableWindow(winPtr->window);
    if (win) {
	idString = win.tabbingIdentifier;
	result = Tcl_NewStringObj(idString.UTF8String, [idString length]);
    }
    if (result == NULL) {
	NSLog(@"Failed to read tabbing identifier; try calling update before getting/setting the tabbing identifier of the window.");
	return TCL_OK;
    }
    Tcl_SetObjResult(interp, result);
    if (objc == 3) {
	return TCL_OK;
    } else if (objc == 4) {
	int len;
	char *newId = Tcl_GetStringFromObj(objv[3], &len);

		resultString = appearanceStrings[APPEARANCE_DARKAQUA];
	    }
#endif // MAC_OS_X_VERSION_MAX_ALLOWED >= 101400
	}
	result = Tcl_NewStringObj(resultString, strlen(resultString));
    }
    if (result == NULL) {
	NSLog(@"Failed to read appearance name; try calling update before getting/setting the appearance of the window.");
	return TCL_OK;
    }
    if (objc == 4) {
	int index;
	if (Tcl_GetIndexFromObjStruct(interp, objv[3], appearanceStrings,
                sizeof(char *), "appearancename", 0, &index) != TCL_OK) {
            return TCL_ERROR;

    /*
     * Parse string to figure out which level number to go to.
     */

    result = 1;
    curLevel = iPtr->varFramePtr->level;
    if (*name== '#') {
	if (Tcl_GetInt(NULL, name+1, &level) != TCL_OK || level < 0) {
	    goto levelError;
	}
    } else if (isdigit(UCHAR(*name))) { /* INTL: digit */
	if (Tcl_GetInt(NULL, name, &level) != TCL_OK) {
	    goto levelError;
	}
	level = curLevel - level;
    } else {
	/* 
	 * (historical, TODO) If name does not contain a level (#0 or 1),
	 * TclGetFrame and Tcl_UpVar2 uses current level - 1
	 */
	level = curLevel - 1;
	result = 0;
	name = "1"; /* be more consistent with TclObjGetFrame (error at top - 1) */
    }

    /*
     * Figure out which frame to use, and return it to the caller.
     */

    for (framePtr = iPtr->varFramePtr; framePtr != NULL;

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint testchmod       [llength [info commands testchmod]]
testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testvolumetype  [llength [info commands testvolumetype]]
testConstraint time64bit [expr {
    $::tcl_platform(pointerSize) >= 8 ||
    [llength [info command testsize]] && [testsize st_mtime] >= 8
}]
testConstraint linkDirectory [expr {
    ![testConstraint win] ||
    ($::tcl_platform(osVersion) >= 5.0
     && [lindex [file system [temporaryDirectory]] 1] eq "NTFS")
}]

global env

    file mtime con
} -result "could not get modification time for file \"con\"" -returnCodes error
test cmdAH-24.14.1 {
    Tcl_FileObjCmd: mtime (built-in Windows names with dir path and extension)
} -constraints {win} -body {
    file mtime [file join [temporaryDirectory] CON.txt]
} -match regexp -result {could not (?:get modification time|read)} -returnCodes error

# 3155760000 is 64-bit unix time, Wed Jan 01 00:00:00 GMT 2070:
test cmdAH-24.20.1 {Tcl_FileObjCmd: atime 64-bit time_t, bug [4718b41c56]} -constraints {time64bit} -setup {
    set filename [makeFile "" foo.text]
} -body {
    list [file atime $filename 3155760000] [file atime $filename]
} -cleanup {
    removeFile $filename
} -result {3155760000 3155760000}
test cmdAH-24.20.2 {Tcl_FileObjCmd: mtime 64-bit time_t, bug [4718b41c56]} -constraints {time64bit} -setup {
    set filename [makeFile "" foo.text]
} -body {
    list [file mtime $filename 3155760000] [file mtime $filename]
} -cleanup {
    file delete -force $filename
} -result {3155760000 3155760000}

# owned
test cmdAH-25.1 {Tcl_FileObjCmd: owned} -returnCodes error -body {
    file owned a b
} -result {wrong # args: should be "file owned name"}
test cmdAH-25.2 {Tcl_FileObjCmd: owned} -constraints win -body {
    file owned $gorpfile

} 66
test uplevel-3.4 {uplevel to same level} {
    set y zzz
    proc a1 {} {set y 55; uplevel #1 set y}
    a1
} 55

test uplevel-4.0.1 {error: non-existent level} -body {
    uplevel #0 { uplevel { set y 222 } }
} -returnCodes error -result {bad level "1"}
test uplevel-4.0.2 {error: non-existent level} -setup {
    interp create i
} -body {
    i eval { uplevel { set y 222 } }
} -returnCodes error -result {bad level "1"} -cleanup {
    interp delete i
}
test uplevel-4.1 {error: non-existent level} -returnCodes error -body {
    apply {{} {
	uplevel #2 {set y 222}
    }}
} -result {bad level "#2"}
test uplevel-4.2 {error: non-existent level} -returnCodes error -body {
    apply {{} {

test upvar-8.2.1 {upvar with numeric first argument} {
    apply {{} {set 0 ok; apply {{} {upvar 0 x; return $x}}}}
} ok
test upvar-8.3 {errors in upvar command} -returnCodes error -body {
    proc p1 {} {upvar a b c}
    p1
} -result {bad level "a"}
test upvar-8.3.1 {bad level for upvar (upvar at top-level, bug [775ee88560])} -body {
    proc p1 {} { uplevel { upvar b b; lappend b UNEXPECTED } }
    uplevel #0 { p1 }
} -returnCodes error -result {bad level "1"}
test upvar-8.3.2 {bad level for upvar (upvar at top-level, bug [775ee88560])} -setup {
    interp create i
} -body {
    i eval { upvar b b; lappend b UNEXPECTED }
} -returnCodes error -result {bad level "1"} -cleanup {
    interp delete i
}
test upvar-8.4 {errors in upvar command} -returnCodes error -body {
    proc p1 {} {upvar 0 b b}
    p1
} -result {can't upvar from variable to itself}
test upvar-8.5 {errors in upvar command} -returnCodes error -body {
    proc p1 {} {upvar 0 a b; upvar 0 b a}
    p1

} -body {
    array set upvarArray {}
    upvar 0 upvarArray(elem) upvarArrayElemAlias(elem)
} -returnCodes 1 -match glob -result *

test upvar-9.1 {Tcl_UpVar2 procedure} testupvar {
    list [catch {testupvar xyz a {} x global} msg] $msg
} {1 {bad level "1"}}
test upvar-9.1.1 {TclGetFrame, via Tcl_UpVar2} testupvar {
    apply {{} {testupvar xyz a {} x local; set x foo}}
    set a
} foo
test upvar-9.2 {Tcl_UpVar2 procedure} testupvar {
    catch {unset a}
    catch {unset x}

		    url - end-bold {
			append result \
			    [string range $text 0 [expr {$offset(bold)-1}]]
			set body [string range $text [expr {$offset(bold)+3}] \
				      [expr {$offset(end-bold)-1}]]
			set text [string range $text[set text ""] \
				      [expr {$offset(end-bold)+4}] end]
			regsub {http://[\w/.-]+} $body {<A HREF="&">&</A>} body
			append result <B> [cross-reference $body] </B>
			continue
		    }
		    anchor {
			append result \
			    [string range $text 0 [expr {$offset(end-bold)+3}]]
			set text [string range $text[set text ""] \

		set text [string range $text[set text ""] [expr {$off+3}] end]
		append result [cross-reference Tcl]
		continue
	    }
	    url {
		set off [lindex $offsets 0]
		append result [string range $text 0 [expr {$off-1}]]
		regexp -indices -start $off {http://[\w/.-]+} $text range
		set url [string range $text {*}$range]
		append result "<A HREF=\"[string trimright $url .]\">$url</A>"
		set text [string range $text[set text ""] \
			      [expr {[lindex $range 1]+1}] end]
		continue
	    }
	    end-anchor - end-bold - end-quote {

static int		TestvolumetypeCmd(ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
static int		TestwinclockCmd(ClientData dummy, Tcl_Interp* interp,
			    int objc, Tcl_Obj *const objv[]);
static int		TestwinsleepCmd(ClientData dummy, Tcl_Interp* interp,
			    int objc, Tcl_Obj *const objv[]);
static int		TestSizeCmd(ClientData dummy, Tcl_Interp* interp,
			    int objc, Tcl_Obj *const objv[]);
static Tcl_ObjCmdProc	TestExceptionCmd;
static int		TestplatformChmod(const char *nativePath, int pmode);
static int		TestchmodCmd(ClientData dummy, Tcl_Interp* interp,
			    int objc, Tcl_Obj *const objv[]);

/*
 *----------------------------------------------------------------------

    Tcl_CreateObjCommand(interp, "testchmod", TestchmodCmd, NULL, NULL);
    Tcl_CreateObjCommand(interp, "testeventloop", TesteventloopCmd, NULL, NULL);
    Tcl_CreateObjCommand(interp, "testvolumetype", TestvolumetypeCmd,
	    NULL, NULL);
    Tcl_CreateObjCommand(interp, "testwinclock", TestwinclockCmd, NULL, NULL);
    Tcl_CreateObjCommand(interp, "testwinsleep", TestwinsleepCmd, NULL, NULL);
    Tcl_CreateObjCommand(interp, "testexcept", TestExceptionCmd, NULL, NULL);
    Tcl_CreateObjCommand(interp, "testsize", TestSizeCmd, NULL, NULL);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TesteventloopCmd --

    }
    if (Tcl_GetIntFromObj(interp, objv[1], &ms) != TCL_OK) {
	return TCL_ERROR;
    }
    Sleep((DWORD) ms);
    return TCL_OK;
}

static int
TestSizeCmd(
    ClientData clientData,	/* Unused */
    Tcl_Interp* interp,		/* Tcl interpreter */
    int objc,			/* Parameter count */
    Tcl_Obj *const * objv)	/* Parameter vector */
{
    if (objc != 2) {
	goto syntax;
    }
    if (strcmp(Tcl_GetString(objv[1]), "time_t") == 0) {
	Tcl_SetObjResult(interp, Tcl_NewWideIntObj(sizeof(time_t)));
	return TCL_OK;
    }
    if (strcmp(Tcl_GetString(objv[1]), "st_mtime") == 0) {
        Tcl_StatBuf *statPtr;
        Tcl_SetObjResult(interp, Tcl_NewWideIntObj(sizeof(statPtr->st_mtime)));
        return TCL_OK;
    }

syntax:
    Tcl_WrongNumArgs(interp, 1, objv, "time_t|st_mtime");
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * TestExceptionCmd --
 *
 *	Causes this process to end with the named exception. Used for testing