Check-in [0d00b0ddea]
Not logged in

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:merge with trunk
Timelines: family | ancestors | descendants | both | wtf-8-experiment
Files: files | file ages | folders
SHA1: 0d00b0ddeafd559f6a733233cd66b266012b6022
User & Date: chw 2019-09-09 07:18:33
Context
2019-09-11
16:15
merge with trunk check-in: 8c494d215a user: chw tags: wtf-8-experiment
2019-09-09
07:18
merge with trunk check-in: 0d00b0ddea user: chw tags: wtf-8-experiment
07:14
add selected tcl upstream changes check-in: be205a221e user: chw tags: trunk
2019-09-08
16:04
merge with trunk check-in: 643ca4b9c0 user: chw tags: wtf-8-experiment
Changes

Changes to assets/tklib0.6/datefield/datefield.tcl.

6
7
8
9
10
11
12
13

14
15
16
17
18
19
20
21





22
23
24
25
26
27
28
29
30
31
32
33
34
..
36
37
38
39
40
41
42


43




















44



45
46
47

48

49
50
51
52
53
54
55
56
57

58
59




60




61
62
63
64
65
66
67
68
69
70
71

72
73
74
75

76
77


78
79
80
81
82
83
84
85
86
87

88
89


90
91




92







93
94
95







96
97




98
99

100
101
102
103
104







105
106




107


108




109



110
111
112
113
114
115
116
117




118
119
120



121
122




















123
124
125
126
127





128























































129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166


167
168
169
170
171
172
173
174
175
176

177
178
179
180
181
182
183
184
185





186




















187
188

189
190

191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209




210
211

















212
213







































214
215
216
217
218
219
# 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

#  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





#
##+##########################################################################
#############################################################################

package require Tk 8.0
package provide datefield 0.2

namespace eval ::datefield {
    namespace export datefield

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

    variable entry entry
................................................................................
	package require tile
    }]} {
	set entry ttk::entry
    }

    proc datefield {w args} {
	variable entry























	eval $entry $w -width 10 -justify center $args



	$w insert end [clock format [clock seconds] -format "%m/%d/%Y"]
	$w icursor 0


	bind $w <KeyPress> [list ::datefield::KeyPress $w %A %K %s]

	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
    }


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




	set icursor [$w index insert]





	# Handle some non-number characters first
	if {$sym == "plus" || $sym == "Up" || \
		$sym == "minus" || $sym == "Down"} {
	    set dir "1 day"
	    if {$sym == "minus" || $sym == "Down"} {
		set dir "-1 day"
	    }
	    set base [clock scan [$w get]]
	    if {[catch {set new [clock scan $dir -base $base]}] != 0} {
		bell

		return -code break
	    }
	    set date [clock format $new -format "%m/%d/%Y"]
	    if {[catch {clock scan $date}]} {

		bell
		return -code break


	    }
	    $w delete 0 end
	    $w insert end $date
	    $w icursor $icursor
	    return -code break
	} elseif {$sym == "Right" || $sym == "Left" || $sym == "BackSpace" || \
		$sym == "Delete"} {
	    set dir -1
	    if {$sym == "Right"} {set dir 1}


	    set icursor [expr {($icursor + 10 + $dir) % 10}]
	    if {$icursor == 2 || $icursor == 5} {;# Don't land on a slash


		set icursor [expr {($icursor + 10 + $dir) % 10}]
	    }




	    $w icursor $icursor







	    return -code break
	} elseif {($sym == "Control_L") || ($sym == "Shift_L") || \
		($sym == "Control_R") || ($sym == "Shift_R")} {







	    return -code break
	} elseif {$sym == "Tab" && $state == 0} {;# Tab key




	    if {$icursor < 3} {
		$w icursor 3

	    } elseif {$icursor < 6} {
		$w icursor 8
	    } else {
		return -code continue
	    }







	    return -code break
	} elseif {$sym == "Tab" && ($state == 1 || $state == 4)} {




	    if {$icursor > 4} {


		$w icursor 3




	    } elseif {$icursor > 1} {



		$w icursor 0
	    } else {
		return -code continue
	    }
	    return -code break
	}

	if {! [regexp {[0-9]} $char]} {		;# Unknown character




	    bell
	    return -code break
	}




	if {$icursor >= 10} {			;# Can't add beyond end




















	    bell
	    return -code break
	}
	foreach {month day year} [split [$w get] "/"] break






	# MONTH SECTION























































	if {$icursor < 2} {
	    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 == "00"} {set month "01"}
	    } else {				;# 2nd digit of month
		set month "$m1$char"
		if {$month > 12} {set month "0$char"}
		if {$month == "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
	}
	# DAY SECTION
	if {$icursor < 5} {			;# DAY
	    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 != "02")} {


		    set day "$char$d2"
		    if {$day == "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 == "00"} {

		    bell
		    return -code break
		}
	    }
	    $w delete 3 5
	    $w insert 3 $day
	    $w icursor $cursor
	    return -code break
	}


























	# YEAR SECTION
	set y1 [lindex [split $year ""] 0]

	if {$icursor < 7} {			;# 1st digit of year
	    if {$char != "1" && $char != "2"} {

		bell
		return -code break
	    }
	    if {$char != $y1} {			;# Different century
		set y 1999
		if {$char == "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]}] != 0} {;# Validate the year
	    $w delete 6 end
	    $w insert end $year			;# Put back in the old year
	    $w icursor $icursor
	    bell




	    return -code break
	}

















	return -code break
    }







































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







|
>







|
>
>
>
>
>





|







 







>
>

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

>
>
>
|
<
|
>
|
>





<



>
|
<
>
>
>
>

>
>
>
>
|
<
<
<
<
<
<
|
<
|
|
>
|
|
<
<
>
|
|
>
>
|
<
<
|
|
<
<
<
<

>

<
>
>
|
|
>
>
>
>

>
>
>
>
>
>
>
|
<
<
>
>
>
>
>
>
>
|
<
>
>
>
>
|
|
>
|
|
|
|
|
>
>
>
>
>
>
>
|
<
>
>
>
>
|
>
>
|
>
>
>
>
|
>
>
>
|
|
|
|
|
|
|
<
>
>
>
>



>
>
>
|
<
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
<
|
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
<
|
|
|
|
|
<
>
>
|
|
|
|
|
|
|
|
|
<
>
|
|
|
|
|
|
|
|
|
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
<
>
|
<
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
>
>
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>


|
|


6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
..
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76

77
78
79
80
81
82
83
84
85

86
87
88
89
90

91
92
93
94
95
96
97
98
99
100






101

102
103
104
105
106


107
108
109
110
111
112


113
114




115
116
117

118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134


135
136
137
138
139
140
141
142

143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162

163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185

186
187
188
189
190
191
192
193
194
195
196

197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219

220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309

310
311

312
313
314
315
316

317
318
319
320
321
322
323
324
325
326
327

328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364

365
366

367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
# 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
................................................................................
	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]
    }
}

Changes to assets/tklib0.6/datefield/pkgIndex.tcl.

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

Added jni/imgjp2/README.txt.

































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
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

Changes to jni/imgjp2/imgjp2.c.

9
10
11
12
13
14
15

16
17
18
19
20
21
22
..
32
33
34
35
36
37
38



39
40
41
42
43
44
45
..
53
54
55
56
57
58
59


60


61

62
63
64
65
66
67
68
..
89
90
91
92
93
94
95




96
97
98
99
100
101
102
...
152
153
154
155
156
157
158


159


160

161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179

















































180




181




182
183
184
185
186
187
188
...
223
224
225
226
227
228
229

230


231

232
233
234
235
236
237
238
 * 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 <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);



    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;
    }


    opj_destroy_codec(codec);


    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);




    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);
	}
    }


    opj_destroy_codec(codec);


    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 = NULL;
    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;

















































    par.irreversible = 1;




    codec = opj_create_compress(OPJ_CODEC_JP2);




    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:

    opj_destroy_codec(codec);


    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;







>







 







>
>
>







 







>
>
|
>
>
|
>







 







>
>
>
>







 







>
>
|
>
>
|
>












|






>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>

>
>
>
>







 







>
|
>
>
|
>







9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
..
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
..
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
...
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
...
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
 * 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;

Changes to jni/sdl2tk/macosx/tkMacOSXWm.c.

5520
5521
5522
5523
5524
5525
5526
5527
5528
5529
5530
5531
5532
5533
5534
....
5589
5590
5591
5592
5593
5594
5595
5596
5597
5598
5599
5600
5601
5602
5603
....
5614
5615
5616
5617
5618
5619
5620
5621
5622
5623
5624
5625
5626
5627
5628
....
5828
5829
5830
5831
5832
5833
5834
5835
5836
5837
5838
5839
5840
5841
5842
5843
....
5850
5851
5852
5853
5854
5855
5856
5857

5858
5859
5860
5861
5862
5863
5864
....
5950
5951
5952
5953
5954
5955
5956
5957
5958
5959
5960
5961
5962
5963
5964
	(zoomPart == inZoomIn ? NormalState : ZoomState);
    return true;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TkUnsupported1Cmd --
 *
 *	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, "tabbingid 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, "isdark 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.  Note, however, that changing the tabbingIdentifier of a window
 *      which is already a tab does not cause it to become a separate window.
 *
 *----------------------------------------------------------------------
 */

static int
WmWinTabbingId(
    Tcl_Interp *interp,		/* Current interpreter. */
................................................................................
    NSString *idString;
    NSWindow *win = TkMacOSXDrawableWindow(winPtr->window);
    if (win) {
	idString = win.tabbingIdentifier;
	result = Tcl_NewStringObj(idString.UTF8String, [idString length]);
    }
    if (result == NULL) {
	Tcl_Panic("Failed to read tabbing identifier.");

    }
    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 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;







|







 







|







 







|







 







|
|







 







|
>







 







|







5520
5521
5522
5523
5524
5525
5526
5527
5528
5529
5530
5531
5532
5533
5534
....
5589
5590
5591
5592
5593
5594
5595
5596
5597
5598
5599
5600
5601
5602
5603
....
5614
5615
5616
5617
5618
5619
5620
5621
5622
5623
5624
5625
5626
5627
5628
....
5828
5829
5830
5831
5832
5833
5834
5835
5836
5837
5838
5839
5840
5841
5842
5843
....
5850
5851
5852
5853
5854
5855
5856
5857
5858
5859
5860
5861
5862
5863
5864
5865
....
5951
5952
5953
5954
5955
5956
5957
5958
5959
5960
5961
5962
5963
5964
5965
	(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. */
................................................................................
    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;

Changes to jni/tcl/generic/tclProc.c.

691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706




707
708

709
710
711
712
713
714
715
    /*
     * Parse string to figure out which level number to go to.
     */

    result = 1;
    curLevel = iPtr->varFramePtr->level;
    if (*name== '#') {
	if (Tcl_GetInt(interp, name+1, &level) != TCL_OK || level < 0) {
	    goto levelError;
	}
    } else if (isdigit(UCHAR(*name))) { /* INTL: digit */
	if (Tcl_GetInt(interp, name, &level) != TCL_OK) {
	    goto levelError;
	}
	level = curLevel - level;
    } else {




	level = curLevel - 1;
	result = 0;

    }

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

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







|



|




>
>
>
>


>







691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
    /*
     * 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;

Changes to jni/tcl/tests/cmdAH.test.

17
18
19
20
21
22
23




24
25
26
27
28
29
30
....
1285
1286
1287
1288
1289
1290
1291
















1292
1293
1294
1295
1296
1297
1298

::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 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

















# 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







>
>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
....
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318

::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

Changes to jni/tcl/tests/uplevel.test.

79
80
81
82
83
84
85










86
87
88
89
90
91
92
} 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.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 {{} {







>
>
>
>
>
>
>
>
>
>







79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
} 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 {{} {

Changes to jni/tcl/tests/upvar.test.

300
301
302
303
304
305
306











307
308
309
310
311
312
313
...
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
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.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 "xyz"}}
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}







>
>
>
>
>
>
>
>
>
>
>







 







|







300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
...
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
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}

Changes to jni/tcl/tools/tcltk-man2html-utils.tcl.

865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
...
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
		    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 {







|







 







|







865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
...
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
		    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 {

Changes to jni/tcl/win/tclWinTest.c.

37
38
39
40
41
42
43


44
45
46
47
48
49
50
..
74
75
76
77
78
79
80

81
82
83
84
85
86
87
...
305
306
307
308
309
310
311

























312
313
314
315
316
317
318
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 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);

    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TesteventloopCmd --
................................................................................
    }
    if (Tcl_GetIntFromObj(interp, objv[1], &ms) != TCL_OK) {
	return TCL_ERROR;
    }
    Sleep((DWORD) ms);
    return TCL_OK;
}

























 
/*
 *----------------------------------------------------------------------
 *
 * TestExceptionCmd --
 *
 *	Causes this process to end with the named exception. Used for testing







>
>







 







>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
..
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
...
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
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