Planet

navi

home

PPS

about

screenshots

download

development

forum

Context Navigation

source: data/trunk/Media/tcl8.5/clock.tcl @ 5180

Last change on this file since 5180 was 5180, checked in by dafrick, 16 years ago

File size: 125.9 KB

Rev	Line
[5180]	1	#----------------------------------------------------------------------
	2	#
	3	# clock.tcl --
	4	#
	5	# This file implements the portions of the [clock] ensemble that
	6	# are coded in Tcl. Refer to the users' manual to see the description
	7	# of the [clock] command and its subcommands.
	8	#
	9	#
	10	#----------------------------------------------------------------------
	11	#
	12	# Copyright (c) 2004,2005,2006,2007 by Kevin B. Kenny
	13	# See the file "license.terms" for information on usage and redistribution
	14	# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
	15	#
	16	# RCS: @(#) $Id: clock.tcl,v 1.47 2008/02/27 02:08:27 kennykb Exp $
	17	#
	18	#----------------------------------------------------------------------
	19
	20	# We must have message catalogs that support the root locale, and
	21	# we need access to the Registry on Windows systems.
	22
	23	uplevel \#0 {
	24	package require msgcat 1.4
	25	if { $::tcl_platform(platform) eq {windows} } {
	26	if { [catch { package require registry 1.1 }] } {
	27	namespace eval ::tcl::clock [list variable NoRegistry {}]
	28	}
	29	}
	30	}
	31
	32	# Put the library directory into the namespace for the ensemble
	33	# so that the library code can find message catalogs and time zone
	34	# definition files.
	35
	36	namespace eval ::tcl::clock \
	37	[list variable LibDir [file dirname [info script]]]
	38
	39	#----------------------------------------------------------------------
	40	#
	41	# clock --
	42	#
	43	# Manipulate times.
	44	#
	45	# The 'clock' command manipulates time. Refer to the user documentation
	46	# for the available subcommands and what they do.
	47	#
	48	#----------------------------------------------------------------------
	49
	50	namespace eval ::tcl::clock {
	51
	52	# Export the subcommands
	53
	54	namespace export format
	55	namespace export clicks
	56	namespace export microseconds
	57	namespace export milliseconds
	58	namespace export scan
	59	namespace export seconds
	60	namespace export add
	61
	62	# Import the message catalog commands that we use.
	63
	64	namespace import ::msgcat::mcload
	65	namespace import ::msgcat::mclocale
	66
	67	}
	68
	69	#----------------------------------------------------------------------
	70	#
	71	# ::tcl::clock::Initialize --
	72	#
	73	# Finish initializing the 'clock' subsystem
	74	#
	75	# Results:
	76	# None.
	77	#
	78	# Side effects:
	79	# Namespace variable in the 'clock' subsystem are initialized.
	80	#
	81	# The '::tcl::clock::Initialize' procedure initializes the namespace
	82	# variables and root locale message catalog for the 'clock' subsystem.
	83	# It is broken into a procedure rather than simply evaluated as a script
	84	# so that it will be able to use local variables, avoiding the dangers
	85	# of 'creative writing' as in Bug 1185933.
	86	#
	87	#----------------------------------------------------------------------
	88
	89	proc ::tcl::clock::Initialize {} {
	90
	91	rename ::tcl::clock::Initialize {}
	92
	93	variable LibDir
	94
	95	# Define the Greenwich time zone
	96
	97	proc InitTZData {} {
	98	variable TZData
	99	array unset TZData
	100	set TZData(:Etc/GMT) {
	101	{-9223372036854775808 0 0 GMT}
	102	}
	103	set TZData(:GMT) $TZData(:Etc/GMT)
	104	set TZData(:Etc/UTC) {
	105	{-9223372036854775808 0 0 UTC}
	106	}
	107	set TZData(:UTC) $TZData(:Etc/UTC)
	108	set TZData(:localtime) {}
	109	}
	110	InitTZData
	111
	112	# Define the message catalog for the root locale.
	113
	114	::msgcat::mcmset {} {
	115	AM {am}
	116	BCE {B.C.E.}
	117	CE {C.E.}
	118	DATE_FORMAT {%m/%d/%Y}
	119	DATE_TIME_FORMAT {%a %b %e %H:%M:%S %Y}
	120	DAYS_OF_WEEK_ABBREV {
	121	Sun Mon Tue Wed Thu Fri Sat
	122	}
	123	DAYS_OF_WEEK_FULL {
	124	Sunday Monday Tuesday Wednesday Thursday Friday Saturday
	125	}
	126	GREGORIAN_CHANGE_DATE 2299161
	127	LOCALE_DATE_FORMAT {%m/%d/%Y}
	128	LOCALE_DATE_TIME_FORMAT {%a %b %e %H:%M:%S %Y}
	129	LOCALE_ERAS {}
	130	LOCALE_NUMERALS {
	131	00 01 02 03 04 05 06 07 08 09
	132	10 11 12 13 14 15 16 17 18 19
	133	20 21 22 23 24 25 26 27 28 29
	134	30 31 32 33 34 35 36 37 38 39
	135	40 41 42 43 44 45 46 47 48 49
	136	50 51 52 53 54 55 56 57 58 59
	137	60 61 62 63 64 65 66 67 68 69
	138	70 71 72 73 74 75 76 77 78 79
	139	80 81 82 83 84 85 86 87 88 89
	140	90 91 92 93 94 95 96 97 98 99
	141	}
	142	LOCALE_TIME_FORMAT {%H:%M:%S}
	143	LOCALE_YEAR_FORMAT {%EC%Ey}
	144	MONTHS_ABBREV {
	145	Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec
	146	}
	147	MONTHS_FULL {
	148	January February March
	149	April May June
	150	July August September
	151	October November December
	152	}
	153	PM {pm}
	154	TIME_FORMAT {%H:%M:%S}
	155	TIME_FORMAT_12 {%I:%M:%S %P}
	156	TIME_FORMAT_24 {%H:%M}
	157	TIME_FORMAT_24_SECS {%H:%M:%S}
	158	}
	159
	160	# Define a few Gregorian change dates for other locales. In most cases
	161	# the change date follows a language, because a nation's colonies changed
	162	# at the same time as the nation itself. In many cases, different
	163	# national boundaries existed; the dominating rule is to follow the
	164	# nation's capital.
	165
	166	# Italy, Spain, Portugal, Poland
	167
	168	::msgcat::mcset it GREGORIAN_CHANGE_DATE 2299161
	169	::msgcat::mcset es GREGORIAN_CHANGE_DATE 2299161
	170	::msgcat::mcset pt GREGORIAN_CHANGE_DATE 2299161
	171	::msgcat::mcset pl GREGORIAN_CHANGE_DATE 2299161
	172
	173	# France, Austria
	174
	175	::msgcat::mcset fr GREGORIAN_CHANGE_DATE 2299227
	176
	177	# For Belgium, we follow Southern Netherlands; Liege Diocese
	178	# changed several weeks later.
	179
	180	::msgcat::mcset fr_BE GREGORIAN_CHANGE_DATE 2299238
	181	::msgcat::mcset nl_BE GREGORIAN_CHANGE_DATE 2299238
	182
	183	# Austria
	184
	185	::msgcat::mcset de_AT GREGORIAN_CHANGE_DATE 2299527
	186
	187	# Hungary
	188
	189	::msgcat::mcset hu GREGORIAN_CHANGE_DATE 2301004
	190
	191	# Germany, Norway, Denmark (Catholic Germany changed earlier)
	192
	193	::msgcat::mcset de_DE GREGORIAN_CHANGE_DATE 2342032
	194	::msgcat::mcset nb GREGORIAN_CHANGE_DATE 2342032
	195	::msgcat::mcset nn GREGORIAN_CHANGE_DATE 2342032
	196	::msgcat::mcset no GREGORIAN_CHANGE_DATE 2342032
	197	::msgcat::mcset da GREGORIAN_CHANGE_DATE 2342032
	198
	199	# Holland (Brabant, Gelderland, Flanders, Friesland, etc. changed
	200	# at various times)
	201
	202	::msgcat::mcset nl GREGORIAN_CHANGE_DATE 2342165
	203
	204	# Protestant Switzerland (Catholic cantons changed earlier)
	205
	206	::msgcat::mcset fr_CH GREGORIAN_CHANGE_DATE 2361342
	207	::msgcat::mcset it_CH GREGORIAN_CHANGE_DATE 2361342
	208	::msgcat::mcset de_CH GREGORIAN_CHANGE_DATE 2361342
	209
	210	# English speaking countries
	211
	212	::msgcat::mcset en GREGORIAN_CHANGE_DATE 2361222
	213
	214	# Sweden (had several changes onto and off of the Gregorian calendar)
	215
	216	::msgcat::mcset sv GREGORIAN_CHANGE_DATE 2361390
	217
	218	# Russia
	219
	220	::msgcat::mcset ru GREGORIAN_CHANGE_DATE 2421639
	221
	222	# Romania (Transylvania changed earler - perhaps de_RO should show
	223	# the earlier date?)
	224
	225	::msgcat::mcset ro GREGORIAN_CHANGE_DATE 2422063
	226
	227	# Greece
	228
	229	::msgcat::mcset el GREGORIAN_CHANGE_DATE 2423480
	230
	231	#------------------------------------------------------------------
	232	#
	233	# CONSTANTS
	234	#
	235	#------------------------------------------------------------------
	236
	237	# Paths at which binary time zone data for the Olson libraries
	238	# are known to reside on various operating systems
	239
	240	variable ZoneinfoPaths {}
	241	foreach path {
	242	/usr/share/zoneinfo
	243	/usr/share/lib/zoneinfo
	244	/usr/lib/zoneinfo
	245	/usr/local/etc/zoneinfo
	246	} {
	247	if { [file isdirectory $path] } {
	248	lappend ZoneinfoPaths $path
	249	}
	250	}
	251
	252	# Define the directories for time zone data and message catalogs.
	253
	254	variable DataDir [file join $LibDir tzdata]
	255	variable MsgDir [file join $LibDir msgs]
	256
	257	# Number of days in the months, in common years and leap years.
	258
	259	variable DaysInRomanMonthInCommonYear \
	260	{ 31 28 31 30 31 30 31 31 30 31 30 31 }
	261	variable DaysInRomanMonthInLeapYear \
	262	{ 31 29 31 30 31 30 31 31 30 31 30 31 }
	263	variable DaysInPriorMonthsInCommonYear [list 0]
	264	variable DaysInPriorMonthsInLeapYear [list 0]
	265	set i 0
	266	foreach j $DaysInRomanMonthInCommonYear {
	267	lappend DaysInPriorMonthsInCommonYear [incr i $j]
	268	}
	269	set i 0
	270	foreach j $DaysInRomanMonthInLeapYear {
	271	lappend DaysInPriorMonthsInLeapYear [incr i $j]
	272	}
	273
	274	# Another epoch (Hi, Jeff!)
	275
	276	variable Roddenberry 1946
	277
	278	# Integer ranges
	279
	280	variable MINWIDE -9223372036854775808
	281	variable MAXWIDE 9223372036854775807
	282
	283	# Day before Leap Day
	284
	285	variable FEB_28 58
	286
	287	# Translation table to map Windows TZI onto cities, so that
	288	# the Olson rules can apply. In some cases the mapping is ambiguous,
	289	# so it's wise to specify $::env(TCL_TZ) rather than simply depending
	290	# on the system time zone.
	291
	292	# The keys are long lists of values obtained from the time zone
	293	# information in the Registry. In order, the list elements are:
	294	# Bias StandardBias DaylightBias
	295	# StandardDate.wYear StandardDate.wMonth StandardDate.wDayOfWeek
	296	# StandardDate.wDay StandardDate.wHour StandardDate.wMinute
	297	# StandardDate.wSecond StandardDate.wMilliseconds
	298	# DaylightDate.wYear DaylightDate.wMonth DaylightDate.wDayOfWeek
	299	# DaylightDate.wDay DaylightDate.wHour DaylightDate.wMinute
	300	# DaylightDate.wSecond DaylightDate.wMilliseconds
	301	# The values are the names of time zones where those rules apply.
	302	# There is considerable ambiguity in certain zones; an attempt has
	303	# been made to make a reasonable guess, but this table needs to be
	304	# taken with a grain of salt.
	305
	306	variable WinZoneInfo [dict create {*}{
	307	{-43200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Kwajalein
	308	{-39600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Midway
	309	{-36000 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Honolulu
	310	{-32400 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Anchorage
	311	{-28800 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Los_Angeles
	312	{-28800 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Tijuana
	313	{-25200 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Denver
	314	{-25200 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Chihuahua
	315	{-25200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Phoenix
	316	{-21600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Regina
	317	{-21600 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Chicago
	318	{-21600 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Mexico_City
	319	{-18000 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/New_York
	320	{-18000 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Indianapolis
	321	{-14400 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Caracas
	322	{-14400 0 3600 0 3 6 2 23 59 59 999 0 10 6 2 23 59 59 999}
	323	:America/Santiago
	324	{-14400 0 3600 0 2 0 5 2 0 0 0 0 11 0 1 2 0 0 0} :America/Manaus
	325	{-14400 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Halifax
	326	{-12600 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/St_Johns
	327	{-10800 0 3600 0 2 0 2 2 0 0 0 0 10 0 3 2 0 0 0} :America/Sao_Paulo
	328	{-10800 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Godthab
	329	{-10800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Buenos_Aires
	330	{-10800 0 3600 0 2 0 5 2 0 0 0 0 11 0 1 2 0 0 0} :America/Brasilia
	331	{-10800 0 3600 0 3 0 2 2 0 0 0 0 10 0 1 2 0 0 0} :America/Montevideo
	332	{-7200 0 3600 0 9 0 5 2 0 0 0 0 3 0 5 2 0 0 0} :America/Noronha
	333	{-3600 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Atlantic/Azores
	334	{-3600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Atlantic/Cape_Verde
	335	{0 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :UTC
	336	{0 0 3600 0 10 0 5 2 0 0 0 0 3 0 5 1 0 0 0} :Europe/London
	337	{3600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Africa/Kinshasa
	338	{3600 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :CET
	339	{7200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Africa/Harare
	340	{7200 0 3600 0 9 4 5 23 59 59 0 0 4 4 5 23 59 59 0}
	341	:Africa/Cairo
	342	{7200 0 3600 0 10 0 5 4 0 0 0 0 3 0 5 3 0 0 0} :Europe/Helsinki
	343	{7200 0 3600 0 9 0 3 2 0 0 0 0 3 5 5 2 0 0 0} :Asia/Jerusalem
	344	{7200 0 3600 0 9 0 5 1 0 0 0 0 3 0 5 0 0 0 0} :Europe/Bucharest
	345	{7200 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Europe/Athens
	346	{7200 0 3600 0 9 5 5 1 0 0 0 0 3 4 5 0 0 0 0} :Asia/Amman
	347	{7200 0 3600 0 10 6 5 23 59 59 999 0 3 0 5 0 0 0 0}
	348	:Asia/Beirut
	349	{7200 0 -3600 0 4 0 1 2 0 0 0 0 9 0 1 2 0 0 0} :Africa/Windhoek
	350	{10800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Riyadh
	351	{10800 0 3600 0 10 0 1 4 0 0 0 0 4 0 1 3 0 0 0} :Asia/Baghdad
	352	{10800 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Europe/Moscow
	353	{12600 0 3600 0 9 2 4 2 0 0 0 0 3 0 1 2 0 0 0} :Asia/Tehran
	354	{14400 0 3600 0 10 0 5 5 0 0 0 0 3 0 5 4 0 0 0} :Asia/Baku
	355	{14400 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Muscat
	356	{14400 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Tbilisi
	357	{16200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Kabul
	358	{18000 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Karachi
	359	{18000 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Yekaterinburg
	360	{19800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Calcutta
	361	{20700 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Katmandu
	362	{21600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Dhaka
	363	{21600 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Novosibirsk
	364	{23400 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Rangoon
	365	{25200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Bangkok
	366	{25200 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Krasnoyarsk
	367	{28800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Chongqing
	368	{28800 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Irkutsk
	369	{32400 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Tokyo
	370	{32400 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Yakutsk
	371	{34200 0 3600 0 3 0 5 3 0 0 0 0 10 0 5 2 0 0 0} :Australia/Adelaide
	372	{34200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Australia/Darwin
	373	{36000 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Australia/Brisbane
	374	{36000 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Vladivostok
	375	{36000 0 3600 0 3 0 5 3 0 0 0 0 10 0 1 2 0 0 0} :Australia/Hobart
	376	{36000 0 3600 0 3 0 5 3 0 0 0 0 10 0 5 2 0 0 0} :Australia/Sydney
	377	{39600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Noumea
	378	{43200 0 3600 0 3 0 3 3 0 0 0 0 10 0 1 2 0 0 0} :Pacific/Auckland
	379	{43200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Fiji
	380	{46800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Tongatapu
	381	}]
	382
	383	# Groups of fields that specify the date, priorities, and
	384	# code bursts that determine Julian Day Number given those groups.
	385	# The code in [clock scan] will choose the highest priority
	386	# (lowest numbered) set of fields that determines the date.
	387
	388	variable DateParseActions {
	389
	390	{ seconds } 0 {}
	391
	392	{ julianDay } 1 {}
	393
	394	{ era century yearOfCentury month dayOfMonth } 2 {
	395	dict set date year [expr { 100 * [dict get $date century]
	396	+ [dict get $date yearOfCentury] }]
	397	set date [GetJulianDayFromEraYearMonthDay $date[set date {}] \
	398	$changeover]
	399	}
	400	{ era century yearOfCentury dayOfYear } 2 {
	401	dict set date year [expr { 100 * [dict get $date century]
	402	+ [dict get $date yearOfCentury] }]
	403	set date [GetJulianDayFromEraYearDay $date[set date {}] \
	404	$changeover]
	405	}
	406
	407	{ century yearOfCentury month dayOfMonth } 3 {
	408	dict set date era CE
	409	dict set date year [expr { 100 * [dict get $date century]
	410	+ [dict get $date yearOfCentury] }]
	411	set date [GetJulianDayFromEraYearMonthDay $date[set date {}] \
	412	$changeover]
	413	}
	414	{ century yearOfCentury dayOfYear } 3 {
	415	dict set date era CE
	416	dict set date year [expr { 100 * [dict get $date century]
	417	+ [dict get $date yearOfCentury] }]
	418	set date [GetJulianDayFromEraYearDay $date[set date {}] \
	419	$changeover]
	420	}
	421	{ iso8601Century iso8601YearOfCentury iso8601Week dayOfWeek } 3 {
	422	dict set date era CE
	423	dict set date iso8601Year \
	424	[expr { 100 * [dict get $date iso8601Century]
	425	+ [dict get $date iso8601YearOfCentury] }]
	426	set date [GetJulianDayFromEraYearWeekDay $date[set date {}] \
	427	$changeover]
	428	}
	429
	430	{ yearOfCentury month dayOfMonth } 4 {
	431	set date [InterpretTwoDigitYear $date[set date {}] $baseTime]
	432	dict set date era CE
	433	set date [GetJulianDayFromEraYearMonthDay $date[set date {}] \
	434	$changeover]
	435	}
	436	{ yearOfCentury dayOfYear } 4 {
	437	set date [InterpretTwoDigitYear $date[set date {}] $baseTime]
	438	dict set date era CE
	439	set date [GetJulianDayFromEraYearDay $date[set date {}] \
	440	$changeover]
	441	}
	442	{ iso8601YearOfCentury iso8601Week dayOfWeek } 4 {
	443	set date [InterpretTwoDigitYear \
	444	$date[set date {}] $baseTime \
	445	iso8601YearOfCentury iso8601Year]
	446	dict set date era CE
	447	set date [GetJulianDayFromEraYearWeekDay $date[set date {}] \
	448	$changeover]
	449	}
	450
	451	{ month dayOfMonth } 5 {
	452	set date [AssignBaseYear $date[set date {}] \
	453	$baseTime $timeZone $changeover]
	454	set date [GetJulianDayFromEraYearMonthDay $date[set date {}] \
	455	$changeover]
	456	}
	457	{ dayOfYear } 5 {
	458	set date [AssignBaseYear $date[set date {}] \
	459	$baseTime $timeZone $changeover]
	460	set date [GetJulianDayFromEraYearDay $date[set date {}] \
	461	$changeover]
	462	}
	463	{ iso8601Week dayOfWeek } 5 {
	464	set date [AssignBaseIso8601Year $date[set date {}] \
	465	$baseTime $timeZone $changeover]
	466	set date [GetJulianDayFromEraYearWeekDay $date[set date {}] \
	467	$changeover]
	468	}
	469
	470	{ dayOfMonth } 6 {
	471	set date [AssignBaseMonth $date[set date {}] \
	472	$baseTime $timeZone $changeover]
	473	set date [GetJulianDayFromEraYearMonthDay $date[set date {}] \
	474	$changeover]
	475	}
	476
	477	{ dayOfWeek } 7 {
	478	set date [AssignBaseWeek $date[set date {}] \
	479	$baseTime $timeZone $changeover]
	480	set date [GetJulianDayFromEraYearWeekDay $date[set date {}] \
	481	$changeover]
	482	}
	483
	484	{} 8 {
	485	set date [AssignBaseJulianDay $date[set date {}] \
	486	$baseTime $timeZone $changeover]
	487	}
	488	}
	489
	490	# Groups of fields that specify time of day, priorities,
	491	# and code that processes them
	492
	493	variable TimeParseActions {
	494
	495	seconds 1 {}
	496
	497	{ hourAMPM minute second amPmIndicator } 2 {
	498	dict set date secondOfDay [InterpretHMSP $date]
	499	}
	500	{ hour minute second } 2 {
	501	dict set date secondOfDay [InterpretHMS $date]
	502	}
	503
	504	{ hourAMPM minute amPmIndicator } 3 {
	505	dict set date second 0
	506	dict set date secondOfDay [InterpretHMSP $date]
	507	}
	508	{ hour minute } 3 {
	509	dict set date second 0
	510	dict set date secondOfDay [InterpretHMS $date]
	511	}
	512
	513	{ hourAMPM amPmIndicator } 4 {
	514	dict set date minute 0
	515	dict set date second 0
	516	dict set date secondOfDay [InterpretHMSP $date]
	517	}
	518	{ hour } 4 {
	519	dict set date minute 0
	520	dict set date second 0
	521	dict set date secondOfDay [InterpretHMS $date]
	522	}
	523
	524	{ } 5 {
	525	dict set date secondOfDay 0
	526	}
	527	}
	528
	529	# Legacy time zones, used primarily for parsing RFC822 dates.
	530
	531	variable LegacyTimeZone [dict create \
	532	gmt +0000 \
	533	ut +0000 \
	534	utc +0000 \
	535	bst +0100 \
	536	wet +0000 \
	537	wat -0100 \
	538	at -0200 \
	539	nft -0330 \
	540	nst -0330 \
	541	ndt -0230 \
	542	ast -0400 \
	543	adt -0300 \
	544	est -0500 \
	545	edt -0400 \
	546	cst -0600 \
	547	cdt -0500 \
	548	mst -0700 \
	549	mdt -0600 \
	550	pst -0800 \
	551	pdt -0700 \
	552	yst -0900 \
	553	ydt -0800 \
	554	hst -1000 \
	555	hdt -0900 \
	556	cat -1000 \
	557	ahst -1000 \
	558	nt -1100 \
	559	idlw -1200 \
	560	cet +0100 \
	561	cest +0200 \
	562	met +0100 \
	563	mewt +0100 \
	564	mest +0200 \
	565	swt +0100 \
	566	sst +0200 \
	567	fwt +0100 \
	568	fst +0200 \
	569	eet +0200 \
	570	eest +0300 \
	571	bt +0300 \
	572	it +0330 \
	573	zp4 +0400 \
	574	zp5 +0500 \
	575	ist +0530 \
	576	zp6 +0600 \
	577	wast +0700 \
	578	wadt +0800 \
	579	jt +0730 \
	580	cct +0800 \
	581	jst +0900 \
	582	kst +0900 \
	583	cast +0930 \
	584	jdt +1000 \
	585	kdt +1000 \
	586	cadt +1030 \
	587	east +1000 \
	588	eadt +1030 \
	589	gst +1000 \
	590	nzt +1200 \
	591	nzst +1200 \
	592	nzdt +1300 \
	593	idle +1200 \
	594	a +0100 \
	595	b +0200 \
	596	c +0300 \
	597	d +0400 \
	598	e +0500 \
	599	f +0600 \
	600	g +0700 \
	601	h +0800 \
	602	i +0900 \
	603	k +1000 \
	604	l +1100 \
	605	m +1200 \
	606	n -0100 \
	607	o -0200 \
	608	p -0300 \
	609	q -0400 \
	610	r -0500 \
	611	s -0600 \
	612	t -0700 \
	613	u -0800 \
	614	v -0900 \
	615	w -1000 \
	616	x -1100 \
	617	y -1200 \
	618	z +0000 \
	619	]
	620
	621	# Caches
	622
	623	variable LocaleNumeralCache {}; # Dictionary whose keys are locale
	624	# names and whose values are pairs
	625	# comprising regexes matching numerals
	626	# in the given locales and dictionaries
	627	# mapping the numerals to their numeric
	628	# values.
	629	variable McLoaded {}; # Dictionary whose keys are locales
	630	# in which [mcload] has been executed
	631	# and whose values are second-level
	632	# dictionaries indexed by message
	633	# name and giving message text.
	634	# variable CachedSystemTimeZone; # If 'CachedSystemTimeZone' exists,
	635	# it contains the value of the
	636	# system time zone, as determined from
	637	# the environment.
	638	variable TimeZoneBad {}; # Dictionary whose keys are time zone
	639	# names and whose values are 1 if
	640	# the time zone is unknown and 0
	641	# if it is known.
	642	variable TZData; # Array whose keys are time zone names
	643	# and whose values are lists of quads
	644	# comprising start time, UTC offset,
	645	# Daylight Saving Time indicator, and
	646	# time zone abbreviation.
	647	variable FormatProc; # Array mapping format group
	648	# and locale to the name of a procedure
	649	# that renders the given format
	650	}
	651	::tcl::clock::Initialize
	652
	653	#----------------------------------------------------------------------
	654	#
	655	# clock format --
	656	#
	657	# Formats a count of seconds since the Posix Epoch as a time
	658	# of day.
	659	#
	660	# The 'clock format' command formats times of day for output.
	661	# Refer to the user documentation to see what it does.
	662	#
	663	#----------------------------------------------------------------------
	664
	665	proc ::tcl::clock::format { args } {
	666
	667	variable FormatProc
	668	variable TZData
	669
	670	lassign [ParseFormatArgs {*}$args] format locale timezone
	671	set locale [string tolower $locale]
	672	set clockval [lindex $args 0]
	673
	674	# Get the data for time changes in the given zone
	675
	676	if {$timezone eq ""} {
	677	set timezone [GetSystemTimeZone]
	678	}
	679	if {![info exists TZData($timezone)]} {
	680	if {[catch {SetupTimeZone $timezone} retval opts]} {
	681	dict unset opts -errorinfo
	682	return -options $opts $retval
	683	}
	684	}
	685
	686	# Build a procedure to format the result. Cache the built procedure's
	687	# name in the 'FormatProc' array to avoid losing its internal
	688	# representation, which contains the name resolution.
	689
	690	set procName ::tcl::clock::formatproc'$format'$locale
	691	if {[info exists FormatProc($procName)]} {
	692	set procName $FormatProc($procName)
	693	} else {
	694	set FormatProc($procName) \
	695	[ParseClockFormatFormat $procName $format $locale]
	696	}
	697
	698	return [$procName $clockval $timezone]
	699
	700	}
	701
	702	#----------------------------------------------------------------------
	703	#
	704	# ParseClockFormatFormat --
	705	#
	706	# Builds and caches a procedure that formats a time value.
	707	#
	708	# Parameters:
	709	# format -- Format string to use
	710	# locale -- Locale in which the format string is to be interpreted
	711	#
	712	# Results:
	713	# Returns the name of the newly-built procedure.
	714	#
	715	#----------------------------------------------------------------------
	716
	717	proc ::tcl::clock::ParseClockFormatFormat {procName format locale} {
	718
	719	if {[namespace which $procName] ne {}} {
	720	return $procName
	721	}
	722
	723	# Map away the locale-dependent composite format groups
	724
	725	EnterLocale $locale oldLocale
	726
	727	# Change locale if a fresh locale has been given on the command line.
	728
	729	set status [catch {
	730
	731	ParseClockFormatFormat2 $format $locale $procName
	732
	733	} result opts]
	734
	735	# Restore the locale
	736
	737	if { [info exists oldLocale] } {
	738	mclocale $oldLocale
	739	}
	740
	741	# Return either the error or the proc name
	742
	743	if { $status == 1 } {
	744	if { [lindex [dict get $opts -errorcode] 0] eq {clock} } {
	745	return -code error $result
	746	} else {
	747	return -options $opts $result
	748	}
	749	} else {
	750	return $result
	751	}
	752
	753	}
	754
	755	proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} {
	756
	757	set didLocaleEra 0
	758	set didLocaleNumerals 0
	759	set preFormatCode \
	760	[string map [list @GREGORIAN_CHANGE_DATE@ \
	761	[mc GREGORIAN_CHANGE_DATE]] \
	762	{
	763	variable TZData
	764	set date [GetDateFields $clockval \
	765	$TZData($timezone) \
	766	@GREGORIAN_CHANGE_DATE@]
	767	}]
	768	set formatString {}
	769	set substituents {}
	770	set state {}
	771
	772	set format [LocalizeFormat $locale $format]
	773
	774	foreach char [split $format {}] {
	775	switch -exact -- $state {
	776	{} {
	777	if { [string equal % $char] } {
	778	set state percent
	779	} else {
	780	append formatString $char
	781	}
	782	}
	783	percent { # Character following a '%' character
	784	set state {}
	785	switch -exact -- $char {
	786	% { # A literal character, '%'
	787	append formatString %%
	788	}
	789	a { # Day of week, abbreviated
	790	append formatString %s
	791	append substituents \
	792	[string map \
	793	[list @DAYS_OF_WEEK_ABBREV@ \
	794	[list [mc DAYS_OF_WEEK_ABBREV]]] \
	795	{ [lindex @DAYS_OF_WEEK_ABBREV@ \
	796	[expr {[dict get $date dayOfWeek] \
	797	% 7}]]}]
	798	}
	799	A { # Day of week, spelt out.
	800	append formatString %s
	801	append substituents \
	802	[string map \
	803	[list @DAYS_OF_WEEK_FULL@ \
	804	[list [mc DAYS_OF_WEEK_FULL]]] \
	805	{ [lindex @DAYS_OF_WEEK_FULL@ \
	806	[expr {[dict get $date dayOfWeek] \
	807	% 7}]]}]
	808	}
	809	b - h { # Name of month, abbreviated.
	810	append formatString %s
	811	append substituents \
	812	[string map \
	813	[list @MONTHS_ABBREV@ \
	814	[list [mc MONTHS_ABBREV]]] \
	815	{ [lindex @MONTHS_ABBREV@ \
	816	[expr {[dict get $date month]-1}]]}]
	817	}
	818	B { # Name of month, spelt out
	819	append formatString %s
	820	append substituents \
	821	[string map \
	822	[list @MONTHS_FULL@ \
	823	[list [mc MONTHS_FULL]]] \
	824	{ [lindex @MONTHS_FULL@ \
	825	[expr {[dict get $date month]-1}]]}]
	826	}
	827	C { # Century number
	828	append formatString %02d
	829	append substituents \
	830	{ [expr {[dict get $date year] / 100}]}
	831	}
	832	d { # Day of month, with leading zero
	833	append formatString %02d
	834	append substituents { [dict get $date dayOfMonth]}
	835	}
	836	e { # Day of month, without leading zero
	837	append formatString %2d
	838	append substituents { [dict get $date dayOfMonth]}
	839	}
	840	E { # Format group in a locale-dependent
	841	# alternative era
	842	set state percentE
	843	if {!$didLocaleEra} {
	844	append preFormatCode \
	845	[string map \
	846	[list @LOCALE_ERAS@ \
	847	[list [mc LOCALE_ERAS]]] \
	848	{
	849	set date [GetLocaleEra \
	850	$date[set date {}] \
	851	@LOCALE_ERAS@]}] \n
	852	set didLocaleEra 1
	853	}
	854	if {!$didLocaleNumerals} {
	855	append preFormatCode \
	856	[list set localeNumerals \
	857	[mc LOCALE_NUMERALS]] \n
	858	set didLocaleNumerals 1
	859	}
	860	}
	861	g { # Two-digit year relative to ISO8601
	862	# week number
	863	append formatString %02d
	864	append substituents \
	865	{ [expr { [dict get $date iso8601Year] % 100 }]}
	866	}
	867	G { # Four-digit year relative to ISO8601
	868	# week number
	869	append formatString %02d
	870	append substituents { [dict get $date iso8601Year]}
	871	}
	872	H { # Hour in the 24-hour day, leading zero
	873	append formatString %02d
	874	append substituents \
	875	{ [expr { [dict get $date localSeconds] \
	876	/ 3600 % 24}]}
	877	}
	878	I { # Hour AM/PM, with leading zero
	879	append formatString %02d
	880	append substituents \
	881	{ [expr { ( ( ( [dict get $date localSeconds] \
	882	% 86400 ) \
	883	+ 86400 \
	884	- 3600 ) \
	885	/ 3600 ) \
	886	% 12 + 1 }] }
	887	}
	888	j { # Day of year (001-366)
	889	append formatString %03d
	890	append substituents { [dict get $date dayOfYear]}
	891	}
	892	J { # Julian Day Number
	893	append formatString %07ld
	894	append substituents { [dict get $date julianDay]}
	895	}
	896	k { # Hour (0-23), no leading zero
	897	append formatString %2d
	898	append substituents \
	899	{ [expr { [dict get $date localSeconds]
	900	/ 3600
	901	% 24 }]}
	902	}
	903	l { # Hour (12-11), no leading zero
	904	append formatString %2d
	905	append substituents \
	906	{ [expr { ( ( ( [dict get $date localSeconds]
	907	% 86400 )
	908	+ 86400
	909	- 3600 )
	910	/ 3600 )
	911	% 12 + 1 }]}
	912	}
	913	m { # Month number, leading zero
	914	append formatString %02d
	915	append substituents { [dict get $date month]}
	916	}
	917	M { # Minute of the hour, leading zero
	918	append formatString %02d
	919	append substituents \
	920	{ [expr { [dict get $date localSeconds]
	921	/ 60
	922	% 60 }]}
	923	}
	924	n { # A literal newline
	925	append formatString \n
	926	}
	927	N { # Month number, no leading zero
	928	append formatString %2d
	929	append substituents { [dict get $date month]}
	930	}
	931	O { # A format group in the locale's
	932	# alternative numerals
	933	set state percentO
	934	if {!$didLocaleNumerals} {
	935	append preFormatCode \
	936	[list set localeNumerals \
	937	[mc LOCALE_NUMERALS]] \n
	938	set didLocaleNumerals 1
	939	}
	940	}
	941	p { # Localized 'AM' or 'PM' indicator
	942	# converted to uppercase
	943	append formatString %s
	944	append preFormatCode \
	945	[list set AM [string toupper [mc AM]]] \n \
	946	[list set PM [string toupper [mc PM]]] \n
	947	append substituents \
	948	{ [expr {(([dict get $date localSeconds]
	949	% 86400) < 43200) ?
	950	$AM : $PM}]}
	951	}
	952	P { # Localized 'AM' or 'PM' indicator
	953	append formatString %s
	954	append preFormatCode \
	955	[list set am [mc AM]] \n \
	956	[list set pm [mc PM]] \n
	957	append substituents \
	958	{ [expr {(([dict get $date localSeconds]
	959	% 86400) < 43200) ?
	960	$am : $pm}]}
	961
	962	}
	963	Q { # Hi, Jeff!
	964	append formatString %s
	965	append substituents { [FormatStarDate $date]}
	966	}
	967	s { # Seconds from the Posix Epoch
	968	append formatString %s
	969	append substituents { [dict get $date seconds]}
	970	}
	971	S { # Second of the minute, with
	972	# leading zero
	973	append formatString %02d
	974	append substituents \
	975	{ [expr { [dict get $date localSeconds]
	976	% 60 }]}
	977	}
	978	t { # A literal tab character
	979	append formatString \t
	980	}
	981	u { # Day of the week (1-Monday, 7-Sunday)
	982	append formatString %1d
	983	append substituents { [dict get $date dayOfWeek]}
	984	}
	985	U { # Week of the year (00-53). The
	986	# first Sunday of the year is the
	987	# first day of week 01
	988	append formatString %02d
	989	append preFormatCode {
	990	set dow [dict get $date dayOfWeek]
	991	if { $dow == 7 } {
	992	set dow 0
	993	}
	994	incr dow
	995	set UweekNumber \
	996	[expr { ( [dict get $date dayOfYear]
	997	- $dow + 7 )
	998	/ 7 }]
	999	}
	1000	append substituents { $UweekNumber}
	1001	}
	1002	V { # The ISO8601 week number
	1003	append formatString %02d
	1004	append substituents { [dict get $date iso8601Week]}
	1005	}
	1006	w { # Day of the week (0-Sunday,
	1007	# 6-Saturday)
	1008	append formatString %1d
	1009	append substituents \
	1010	{ [expr { [dict get $date dayOfWeek] % 7 }]}
	1011	}
	1012	W { # Week of the year (00-53). The first
	1013	# Monday of the year is the first day
	1014	# of week 01.
	1015	append preFormatCode {
	1016	set WweekNumber \
	1017	[expr { ( [dict get $date dayOfYear]
	1018	- [dict get $date dayOfWeek]
	1019	+ 7 )
	1020	/ 7 }]
	1021	}
	1022	append formatString %02d
	1023	append substituents { $WweekNumber}
	1024	}
	1025	y { # The two-digit year of the century
	1026	append formatString %02d
	1027	append substituents \
	1028	{ [expr { [dict get $date year] % 100 }]}
	1029	}
	1030	Y { # The four-digit year
	1031	append formatString %04d
	1032	append substituents { [dict get $date year]}
	1033	}
	1034	z { # The time zone as hours and minutes
	1035	# east (+) or west (-) of Greenwich
	1036	append formatString %s
	1037	append substituents { [FormatNumericTimeZone \
	1038	[dict get $date tzOffset]]}
	1039	}
	1040	Z { # The name of the time zone
	1041	append formatString %s
	1042	append substituents { [dict get $date tzName]}
	1043	}
	1044	% { # A literal percent character
	1045	append formatString %%
	1046	}
	1047	default { # An unknown escape sequence
	1048	append formatString %% $char
	1049	}
	1050	}
	1051	}
	1052	percentE { # Character following %E
	1053	set state {}
	1054	switch -exact -- $char {
	1055	E {
	1056	append formatString %s
	1057	append substituents { } \
	1058	[string map \
	1059	[list @BCE@ [list [mc BCE]] \
	1060	@CE@ [list [mc CE]]] \
	1061	{[dict get {BCE @BCE@ CE @CE@} \
	1062	[dict get $date era]]}]
	1063	}
	1064	C { # Locale-dependent era
	1065	append formatString %s
	1066	append substituents { [dict get $date localeEra]}
	1067	}
	1068	y { # Locale-dependent year of the era
	1069	append preFormatCode {
	1070	set y [dict get $date localeYear]
	1071	if { $y >= 0 && $y < 100 } {
	1072	set Eyear [lindex $localeNumerals $y]
	1073	} else {
	1074	set Eyear $y
	1075	}
	1076	}
	1077	append formatString %s
	1078	append substituents { $Eyear}
	1079	}
	1080	default { # Unknown %E format group
	1081	append formatString %%E $char
	1082	}
	1083	}
	1084	}
	1085	percentO { # Character following %O
	1086	set state {}
	1087	switch -exact -- $char {
	1088	d - e { # Day of the month in alternative
	1089	# numerals
	1090	append formatString %s
	1091	append substituents \
	1092	{ [lindex $localeNumerals \
	1093	[dict get $date dayOfMonth]]}
	1094	}
	1095	H - k { # Hour of the day in alternative
	1096	# numerals
	1097	append formatString %s
	1098	append substituents \
	1099	{ [lindex $localeNumerals \
	1100	[expr { [dict get $date localSeconds]
	1101	/ 3600
	1102	% 24 }]]}
	1103	}
	1104	I - l { # Hour (12-11) AM/PM in alternative
	1105	# numerals
	1106	append formatString %s
	1107	append substituents \
	1108	{ [lindex $localeNumerals \
	1109	[expr { ( ( ( [dict get $date localSeconds]
	1110	% 86400 )
	1111	+ 86400
	1112	- 3600 )
	1113	/ 3600 )
	1114	% 12 + 1 }]]}
	1115	}
	1116	m { # Month number in alternative numerals
	1117	append formatString %s
	1118	append substituents \
	1119	{ [lindex $localeNumerals [dict get $date month]]}
	1120	}
	1121	M { # Minute of the hour in alternative
	1122	# numerals
	1123	append formatString %s
	1124	append substituents \
	1125	{ [lindex $localeNumerals \
	1126	[expr { [dict get $date localSeconds]
	1127	/ 60
	1128	% 60 }]]}
	1129	}
	1130	S { # Second of the minute in alternative
	1131	# numerals
	1132	append formatString %s
	1133	append substituents \
	1134	{ [lindex $localeNumerals \
	1135	[expr { [dict get $date localSeconds]
	1136	% 60 }]]}
	1137	}
	1138	u { # Day of the week (Monday=1,Sunday=7)
	1139	# in alternative numerals
	1140	append formatString %s
	1141	append substituents \
	1142	{ [lindex $localeNumerals \
	1143	[dict get $date dayOfWeek]]}
	1144	}
	1145	w { # Day of the week (Sunday=0,Saturday=6)
	1146	# in alternative numerals
	1147	append formatString %s
	1148	append substituents \
	1149	{ [lindex $localeNumerals \
	1150	[expr { [dict get $date dayOfWeek] % 7 }]]}
	1151	}
	1152	y { # Year of the century in alternative
	1153	# numerals
	1154	append formatString %s
	1155	append substituents \
	1156	{ [lindex $localeNumerals \
	1157	[expr { [dict get $date year] % 100 }]]}
	1158	}
	1159	default { # Unknown format group
	1160	append formatString %%O $char
	1161	}
	1162	}
	1163	}
	1164	}
	1165	}
	1166
	1167	# Clean up any improperly terminated groups
	1168
	1169	switch -exact -- $state {
	1170	percent {
	1171	append formatString %%
	1172	}
	1173	percentE {
	1174	append retval %%E
	1175	}
	1176	percentO {
	1177	append retval %%O
	1178	}
	1179	}
	1180
	1181	proc $procName {clockval timezone} "
	1182	$preFormatCode
	1183	return \[::format [list $formatString] $substituents\]
	1184	"
	1185
	1186	# puts [list $procName [info args $procName] [info body $procName]]
	1187
	1188	return $procName
	1189	}
	1190
	1191	#----------------------------------------------------------------------
	1192	#
	1193	# clock scan --
	1194	#
	1195	# Inputs a count of seconds since the Posix Epoch as a time
	1196	# of day.
	1197	#
	1198	# The 'clock format' command scans times of day on input.
	1199	# Refer to the user documentation to see what it does.
	1200	#
	1201	#----------------------------------------------------------------------
	1202
	1203	proc ::tcl::clock::scan { args } {
	1204
	1205	set format {}
	1206
	1207	# Check the count of args
	1208
	1209	if { [llength $args] < 1 \|\| [llength $args] % 2 != 1 } {
	1210	set cmdName "clock scan"
	1211	return -code error \
	1212	-errorcode [list CLOCK wrongNumArgs] \
	1213	"wrong \# args: should be\
	1214	\"$cmdName string\
	1215	?-base seconds?\
	1216	?-format string? ?-gmt boolean?\
	1217	?-locale LOCALE? ?-timezone ZONE?\""
	1218	}
	1219
	1220	# Set defaults
	1221
	1222	set base [clock seconds]
	1223	set string [lindex $args 0]
	1224	set format {}
	1225	set gmt 0
	1226	set locale c
	1227	set timezone [GetSystemTimeZone]
	1228
	1229	# Pick up command line options.
	1230
	1231	foreach { flag value } [lreplace $args 0 0] {
	1232	set saw($flag) {}
	1233	switch -exact -- $flag {
	1234	-b - -ba - -bas - -base {
	1235	set base $value
	1236	}
	1237	-f - -fo - -for - -form - -forma - -format {
	1238	set format $value
	1239	}
	1240	-g - -gm - -gmt {
	1241	set gmt $value
	1242	}
	1243	-l - -lo - -loc - -loca - -local - -locale {
	1244	set locale [string tolower $value]
	1245	}
	1246	-t - -ti - -tim - -time - -timez - -timezo - -timezon - -timezone {
	1247	set timezone $value
	1248	}
	1249	default {
	1250	return -code error \
	1251	-errorcode [list CLOCK badSwitch $flag] \
	1252	"bad switch \"$flag\",\
	1253	must be -base, -format, -gmt, -locale or -timezone"
	1254	}
	1255	}
	1256	}
	1257
	1258	# Check options for validity
	1259
	1260	if { [info exists saw(-gmt)] && [info exists saw(-timezone)] } {
	1261	return -code error \
	1262	-errorcode [list CLOCK gmtWithTimezone] \
	1263	"cannot use -gmt and -timezone in same call"
	1264	}
	1265	if { [catch { expr { wide($base) } } result] } {
	1266	return -code error \
	1267	"expected integer but got \"$base\""
	1268	}
	1269	if { ![string is boolean $gmt] } {
	1270	return -code error \
	1271	"expected boolean value but got \"$gmt\""
	1272	} else {
	1273	if { $gmt } {
	1274	set timezone :GMT
	1275	}
	1276	}
	1277
	1278	if { ![info exists saw(-format)] } {
	1279	# Perhaps someday we'll localize the legacy code. Right now,
	1280	# it's not localized.
	1281	if { [info exists saw(-locale)] } {
	1282	return -code error \
	1283	-errorcode [list CLOCK flagWithLegacyFormat] \
	1284	"legacy \[clock scan\] does not support -locale"
	1285
	1286	}
	1287	return [FreeScan $string $base $timezone $locale]
	1288	}
	1289
	1290	# Change locale if a fresh locale has been given on the command line.
	1291
	1292	EnterLocale $locale oldLocale
	1293
	1294	set status [catch {
	1295
	1296	# Map away the locale-dependent composite format groups
	1297
	1298	set scanner [ParseClockScanFormat $format $locale]
	1299	$scanner $string $base $timezone
	1300
	1301	} result opts]
	1302
	1303	# Restore the locale
	1304
	1305	if { [info exists oldLocale] } {
	1306	mclocale $oldLocale
	1307	}
	1308
	1309	if { $status == 1 } {
	1310	if { [lindex [dict get $opts -errorcode] 0] eq {clock} } {
	1311	return -code error $result
	1312	} else {
	1313	return -options $opts $result
	1314	}
	1315	} else {
	1316	return $result
	1317	}
	1318
	1319	}
	1320
	1321	#----------------------------------------------------------------------
	1322	#
	1323	# FreeScan --
	1324	#
	1325	# Scans a time in free format
	1326	#
	1327	# Parameters:
	1328	# string - String containing the time to scan
	1329	# base - Base time, expressed in seconds from the Epoch
	1330	# timezone - Default time zone in which the time will be expressed
	1331	# locale - (Unused) Name of the locale where the time will be scanned.
	1332	#
	1333	# Results:
	1334	# Returns the date and time extracted from the string in seconds
	1335	# from the epoch
	1336	#
	1337	#----------------------------------------------------------------------
	1338
	1339	proc ::tcl::clock::FreeScan { string base timezone locale } {
	1340
	1341	variable TZData
	1342
	1343	# Get the data for time changes in the given zone
	1344
	1345	if {[catch {SetupTimeZone $timezone} retval opts]} {
	1346	dict unset opts -errorinfo
	1347	return -options $opts $retval
	1348	}
	1349
	1350	# Extract year, month and day from the base time for the
	1351	# parser to use as defaults
	1352
	1353	set date [GetDateFields \
	1354	$base \
	1355	$TZData($timezone) \
	1356	2361222]
	1357	dict set date secondOfDay [expr { [dict get $date localSeconds]
	1358	% 86400 }]
	1359
	1360	# Parse the date. The parser will return a list comprising
	1361	# date, time, time zone, relative month/day/seconds, relative
	1362	# weekday, ordinal month.
	1363
	1364	set status [catch {
	1365	Oldscan $string \
	1366	[dict get $date year] \
	1367	[dict get $date month] \
	1368	[dict get $date dayOfMonth]
	1369	} result]
	1370	if { $status != 0 } {
	1371	return -code error "unable to convert date-time string \"$string\""
	1372	}
	1373
	1374	lassign $result parseDate parseTime parseZone parseRel \
	1375	parseWeekday parseOrdinalMonth
	1376
	1377	# If the caller supplied a date in the string, update the 'date' dict
	1378	# with the value. If the caller didn't specify a time with the date,
	1379	# default to midnight.
	1380
	1381	if { [llength $parseDate] > 0 } {
	1382	lassign $parseDate y m d
	1383	if { $y < 100 } {
	1384	if { $y >= 39 } {
	1385	incr y 1900
	1386	} else {
	1387	incr y 2000
	1388	}
	1389	}
	1390	dict set date era CE
	1391	dict set date year $y
	1392	dict set date month $m
	1393	dict set date dayOfMonth $d
	1394	if { $parseTime eq {} } {
	1395	set parseTime 0
	1396	}
	1397	}
	1398
	1399	# If the caller supplied a time zone in the string, it comes back
	1400	# as a two-element list; the first element is the number of minutes
	1401	# east of Greenwich, and the second is a Daylight Saving Time
	1402	# indicator ( 1 == yes, 0 == no, -1 == unknown ). We make it into
	1403	# a time zone indicator of +-hhmm.
	1404
	1405	if { [llength $parseZone] > 0 } {
	1406	lassign $parseZone minEast dstFlag
	1407	set timezone [FormatNumericTimeZone \
	1408	[expr { 60 * $minEast + 3600 * $dstFlag }]]
	1409	SetupTimeZone $timezone
	1410	}
	1411	dict set date tzName $timezone
	1412
	1413	# Assemble date, time, zone into seconds-from-epoch
	1414
	1415	set date [GetJulianDayFromEraYearMonthDay $date[set date {}] 2361222]
	1416	if { $parseTime ne {} } {
	1417	dict set date secondOfDay $parseTime
	1418	} elseif { [llength $parseWeekday] != 0
	1419	\|\| [llength $parseOrdinalMonth] != 0
	1420	\|\| ( [llength $parseRel] != 0
	1421	&& ( [lindex $parseRel 0] != 0
	1422	\|\| [lindex $parseRel 1] != 0 ) ) } {
	1423	dict set date secondOfDay 0
	1424	}
	1425
	1426	dict set date localSeconds \
	1427	[expr { -210866803200
	1428	+ ( 86400 * wide([dict get $date julianDay]) )
	1429	+ [dict get $date secondOfDay] }]
	1430	dict set date tzName $timezone
	1431	set date [ConvertLocalToUTC $date[set date {}] $TZData($timezone) 2361222]
	1432	set seconds [dict get $date seconds]
	1433
	1434	# Do relative times
	1435
	1436	if { [llength $parseRel] > 0 } {
	1437	lassign $parseRel relMonth relDay relSecond
	1438	set seconds [add $seconds \
	1439	$relMonth months $relDay days $relSecond seconds \
	1440	-timezone $timezone -locale $locale]
	1441	}
	1442
	1443	# Do relative weekday
	1444
	1445	if { [llength $parseWeekday] > 0 } {
	1446
	1447	lassign $parseWeekday dayOrdinal dayOfWeek
	1448	set date2 [GetDateFields $seconds $TZData($timezone) 2361222]
	1449	dict set date2 era CE
	1450	set jdwkday [WeekdayOnOrBefore $dayOfWeek \
	1451	[expr { [dict get $date2 julianDay]
	1452	+ 6 }]]
	1453	incr jdwkday [expr { 7 * $dayOrdinal }]
	1454	if { $dayOrdinal > 0 } {
	1455	incr jdwkday -7
	1456	}
	1457	dict set date2 secondOfDay \
	1458	[expr { [dict get $date2 localSeconds] % 86400 }]
	1459	dict set date2 julianDay $jdwkday
	1460	dict set date2 localSeconds \
	1461	[expr { -210866803200
	1462	+ ( 86400 * wide([dict get $date2 julianDay]) )
	1463	+ [dict get $date secondOfDay] }]
	1464	dict set date2 tzName $timezone
	1465	set date2 [ConvertLocalToUTC $date2[set date2 {}] $TZData($timezone) \
	1466	2361222]
	1467	set seconds [dict get $date2 seconds]
	1468
	1469	}
	1470
	1471	# Do relative month
	1472
	1473	if { [llength $parseOrdinalMonth] > 0 } {
	1474
	1475	lassign $parseOrdinalMonth monthOrdinal monthNumber
	1476	if { $monthOrdinal > 0 } {
	1477	set monthDiff [expr { $monthNumber - [dict get $date month] }]
	1478	if { $monthDiff <= 0 } {
	1479	incr monthDiff 12
	1480	}
	1481	incr monthOrdinal -1
	1482	} else {
	1483	set monthDiff [expr { [dict get $date month] - $monthNumber }]
	1484	if { $monthDiff >= 0 } {
	1485	incr monthDiff -12
	1486	}
	1487	incr monthOrdinal
	1488	}
	1489	set seconds [add $seconds $monthOrdinal years $monthDiff months \
	1490	-timezone $timezone -locale $locale]
	1491
	1492	}
	1493
	1494	return $seconds
	1495	}
	1496
	1497
	1498	#----------------------------------------------------------------------
	1499	#
	1500	# ParseClockScanFormat --
	1501	#
	1502	# Parses a format string given to [clock scan -format]
	1503	#
	1504	# Parameters:
	1505	# formatString - The format being parsed
	1506	# locale - The current locale
	1507	#
	1508	# Results:
	1509	# Constructs and returns a procedure that accepts the
	1510	# string being scanned, the base time, and the time zone.
	1511	# The procedure will either return the scanned time or
	1512	# else throw an error that should be rethrown to the caller
	1513	# of [clock scan]
	1514	#
	1515	# Side effects:
	1516	# The given procedure is defined in the ::tcl::clock
	1517	# namespace. Scan procedures are not deleted once installed.
	1518	#
	1519	# Why do we parse dates by defining a procedure to parse them?
	1520	# The reason is that by doing so, we have one convenient place to
	1521	# cache all the information: the regular expressions that match the
	1522	# patterns (which will be compiled), the code that assembles the
	1523	# date information, everything lands in one place. In this way,
	1524	# when a given format is reused at run time, all the information
	1525	# of how to apply it is available in a single place.
	1526	#
	1527	#----------------------------------------------------------------------
	1528
	1529	proc ::tcl::clock::ParseClockScanFormat {formatString locale} {
	1530
	1531	# Check whether the format has been parsed previously, and return
	1532	# the existing recognizer if it has.
	1533
	1534	set procName [namespace current]::scanproc'$formatString'$locale
	1535	if { [namespace which $procName] != {} } {
	1536	return $procName
	1537	}
	1538
	1539	variable DateParseActions
	1540	variable TimeParseActions
	1541
	1542	# Localize the %x, %X, etc. groups
	1543
	1544	set formatString [LocalizeFormat $locale $formatString]
	1545
	1546	# Condense whitespace
	1547
	1548	regsub -all {[[:space:]]+} $formatString { } formatString
	1549
	1550	# Walk through the groups of the format string. In this loop, we
	1551	# accumulate:
	1552	# - a regular expression that matches the string,
	1553	# - the count of capturing brackets in the regexp
	1554	# - a set of code that post-processes the fields captured by the regexp,
	1555	# - a dictionary whose keys are the names of fields that are present
	1556	# in the format string.
	1557
	1558	set re {^[[:space:]]*}
	1559	set captureCount 0
	1560	set postcode {}
	1561	set fieldSet [dict create]
	1562	set fieldCount 0
	1563	set postSep {}
	1564	set state {}
	1565
	1566	foreach c [split $formatString {}] {
	1567	switch -exact -- $state {
	1568	{} {
	1569	if { $c eq "%" } {
	1570	set state %
	1571	} elseif { $c eq " " } {
	1572	append re {[[:space:]]+}
	1573	} else {
	1574	if { ! [string is alnum $c] } {
	1575	append re \\
	1576	}
	1577	append re $c
	1578	}
	1579	}
	1580	% {
	1581	set state {}
	1582	switch -exact -- $c {
	1583	% {
	1584	append re %
	1585	}
	1586	{ } {
	1587	append re "\[\[:space:\]\]*"
	1588	}
	1589	a - A { # Day of week, in words
	1590	set l {}
	1591	foreach \
	1592	i {7 1 2 3 4 5 6} \
	1593	abr [mc DAYS_OF_WEEK_ABBREV] \
	1594	full [mc DAYS_OF_WEEK_FULL] {
	1595	dict set l [string tolower $abr] $i
	1596	dict set l [string tolower $full] $i
	1597	incr i
	1598	}
	1599	lassign [UniquePrefixRegexp $l] regex lookup
	1600	append re ( $regex )
	1601	dict set fieldSet dayOfWeek [incr fieldCount]
	1602	append postcode "dict set date dayOfWeek \[" \
	1603	"dict get " [list $lookup] " " \
	1604	\[ {string tolower $field} [incr captureCount] \] \
	1605	"\]\n"
	1606	}
	1607	b - B - h { # Name of month
	1608	set i 0
	1609	set l {}
	1610	foreach \
	1611	abr [mc MONTHS_ABBREV] \
	1612	full [mc MONTHS_FULL] {
	1613	incr i
	1614	dict set l [string tolower $abr] $i
	1615	dict set l [string tolower $full] $i
	1616	}
	1617	lassign [UniquePrefixRegexp $l] regex lookup
	1618	append re ( $regex )
	1619	dict set fieldSet month [incr fieldCount]
	1620	append postcode "dict set date month \[" \
	1621	"dict get " [list $lookup] \
	1622	" " \[ {string tolower $field} \
	1623	[incr captureCount] \] \
	1624	"\]\n"
	1625	}
	1626	C { # Gregorian century
	1627	append re \\s*(\\d\\d?)
	1628	dict set fieldSet century [incr fieldCount]
	1629	append postcode "dict set date century \[" \
	1630	"::scan \$field" [incr captureCount] " %d" \
	1631	"\]\n"
	1632	}
	1633	d - e { # Day of month
	1634	append re \\s*(\\d\\d?)
	1635	dict set fieldSet dayOfMonth [incr fieldCount]
	1636	append postcode "dict set date dayOfMonth \[" \
	1637	"::scan \$field" [incr captureCount] " %d" \
	1638	"\]\n"
	1639	}
	1640	E { # Prefix for locale-specific codes
	1641	set state %E
	1642	}
	1643	g { # ISO8601 2-digit year
	1644	append re \\s*(\\d\\d)
	1645	dict set fieldSet iso8601YearOfCentury \
	1646	[incr fieldCount]
	1647	append postcode \
	1648	"dict set date iso8601YearOfCentury \[" \
	1649	"::scan \$field" [incr captureCount] " %d" \
	1650	"\]\n"
	1651	}
	1652	G { # ISO8601 4-digit year
	1653	append re \\s*(\\d\\d)(\\d\\d)
	1654	dict set fieldSet iso8601Century [incr fieldCount]
	1655	dict set fieldSet iso8601YearOfCentury \
	1656	[incr fieldCount]
	1657	append postcode \
	1658	"dict set date iso8601Century \[" \
	1659	"::scan \$field" [incr captureCount] " %d" \
	1660	"\]\n" \
	1661	"dict set date iso8601YearOfCentury \[" \
	1662	"::scan \$field" [incr captureCount] " %d" \
	1663	"\]\n"
	1664	}
	1665	H - k { # Hour of day
	1666	append re \\s*(\\d\\d?)
	1667	dict set fieldSet hour [incr fieldCount]
	1668	append postcode "dict set date hour \[" \
	1669	"::scan \$field" [incr captureCount] " %d" \
	1670	"\]\n"
	1671	}
	1672	I - l { # Hour, AM/PM
	1673	append re \\s*(\\d\\d?)
	1674	dict set fieldSet hourAMPM [incr fieldCount]
	1675	append postcode "dict set date hourAMPM \[" \
	1676	"::scan \$field" [incr captureCount] " %d" \
	1677	"\]\n"
	1678	}
	1679	j { # Day of year
	1680	append re \\s*(\\d\\d?\\d?)
	1681	dict set fieldSet dayOfYear [incr fieldCount]
	1682	append postcode "dict set date dayOfYear \[" \
	1683	"::scan \$field" [incr captureCount] " %d" \
	1684	"\]\n"
	1685	}
	1686	J { # Julian Day Number
	1687	append re \\s*(\\d+)
	1688	dict set fieldSet julianDay [incr fieldCount]
	1689	append postcode "dict set date julianDay \[" \
	1690	"::scan \$field" [incr captureCount] " %ld" \
	1691	"\]\n"
	1692	}
	1693	m - N { # Month number
	1694	append re \\s*(\\d\\d?)
	1695	dict set fieldSet month [incr fieldCount]
	1696	append postcode "dict set date month \[" \
	1697	"::scan \$field" [incr captureCount] " %d" \
	1698	"\]\n"
	1699	}
	1700	M { # Minute
	1701	append re \\s*(\\d\\d?)
	1702	dict set fieldSet minute [incr fieldCount]
	1703	append postcode "dict set date minute \[" \
	1704	"::scan \$field" [incr captureCount] " %d" \
	1705	"\]\n"
	1706	}
	1707	n { # Literal newline
	1708	append re \\n
	1709	}
	1710	O { # Prefix for locale numerics
	1711	set state %O
	1712	}
	1713	p - P { # AM/PM indicator
	1714	set l [list [string tolower [mc AM]] 0 \
	1715	[string tolower [mc PM]] 1]
	1716	lassign [UniquePrefixRegexp $l] regex lookup
	1717	append re ( $regex )
	1718	dict set fieldSet amPmIndicator [incr fieldCount]
	1719	append postcode "dict set date amPmIndicator \[" \
	1720	"dict get " [list $lookup] " \[string tolower " \
	1721	"\$field" \
	1722	[incr captureCount] \
	1723	"\]\]\n"
	1724	}
	1725	Q { # Hi, Jeff!
	1726	append re {Stardate\s+([-+]?\d+)(\d\d\d)[.](\d)}
	1727	incr captureCount
	1728	dict set fieldSet seconds [incr fieldCount]
	1729	append postcode {dict set date seconds } \[ \
	1730	{ParseStarDate $field} [incr captureCount] \
	1731	{ $field} [incr captureCount] \
	1732	{ $field} [incr captureCount] \
	1733	\] \n
	1734	}
	1735	s { # Seconds from Posix Epoch
	1736	# This next case is insanely difficult,
	1737	# because it's problematic to determine
	1738	# whether the field is actually within
	1739	# the range of a wide integer.
	1740	append re {\s*([-+]?\d+)}
	1741	dict set fieldSet seconds [incr fieldCount]
	1742	append postcode {dict set date seconds } \[ \
	1743	{ScanWide $field} [incr captureCount] \] \n
	1744	}
	1745	S { # Second
	1746	append re \\s*(\\d\\d?)
	1747	dict set fieldSet second [incr fieldCount]
	1748	append postcode "dict set date second \[" \
	1749	"::scan \$field" [incr captureCount] " %d" \
	1750	"\]\n"
	1751	}
	1752	t { # Literal tab character
	1753	append re \\t
	1754	}
	1755	u - w { # Day number within week, 0 or 7 == Sun
	1756	# 1=Mon, 6=Sat
	1757	append re \\s*(\\d)
	1758	dict set fieldSet dayOfWeek [incr fieldCount]
	1759	append postcode {::scan $field} [incr captureCount] \
	1760	{ %d dow} \n \
	1761	{
	1762	if { $dow == 0 } {
	1763	set dow 7
	1764	} elseif { $dow > 7 } {
	1765	return -code error \
	1766	-errorcode [list CLOCK badDayOfWeek] \
	1767	"day of week is greater than 7"
	1768	}
	1769	dict set date dayOfWeek $dow
	1770	}
	1771	}
	1772	U { # Week of year. The
	1773	# first Sunday of the year is the
	1774	# first day of week 01. No scan rule
	1775	# uses this group.
	1776	append re \\s*\\d\\d?
	1777	}
	1778	V { # Week of ISO8601 year
	1779
	1780	append re \\s*(\\d\\d?)
	1781	dict set fieldSet iso8601Week [incr fieldCount]
	1782	append postcode "dict set date iso8601Week \[" \
	1783	"::scan \$field" [incr captureCount] " %d" \
	1784	"\]\n"
	1785	}
	1786	W { # Week of the year (00-53). The first
	1787	# Monday of the year is the first day
	1788	# of week 01. No scan rule uses this
	1789	# group.
	1790	append re \\s*\\d\\d?
	1791	}
	1792	y { # Two-digit Gregorian year
	1793	append re \\s*(\\d\\d?)
	1794	dict set fieldSet yearOfCentury [incr fieldCount]
	1795	append postcode "dict set date yearOfCentury \[" \
	1796	"::scan \$field" [incr captureCount] " %d" \
	1797	"\]\n"
	1798	}
	1799	Y { # 4-digit Gregorian year
	1800	append re \\s*(\\d\\d)(\\d\\d)
	1801	dict set fieldSet century [incr fieldCount]
	1802	dict set fieldSet yearOfCentury [incr fieldCount]
	1803	append postcode \
	1804	"dict set date century \[" \
	1805	"::scan \$field" [incr captureCount] " %d" \
	1806	"\]\n" \
	1807	"dict set date yearOfCentury \[" \
	1808	"::scan \$field" [incr captureCount] " %d" \
	1809	"\]\n"
	1810	}
	1811	z - Z { # Time zone name
	1812	append re {(?:([-+]\d\d(?::?\d\d(?::?\d\d)?)?)\|([[:alnum:]]{1,4}))}
	1813	dict set fieldSet tzName [incr fieldCount]
	1814	append postcode \
	1815	{if } \{ { $field} [incr captureCount] \
	1816	{ ne "" } \} { } \{ \n \
	1817	{dict set date tzName $field} \
	1818	$captureCount \n \
	1819	\} { else } \{ \n \
	1820	{dict set date tzName } \[ \
	1821	{ConvertLegacyTimeZone $field} \
	1822	[incr captureCount] \] \n \
	1823	\} \n \
	1824	}
	1825	% { # Literal percent character
	1826	append re %
	1827	}
	1828	default {
	1829	append re %
	1830	if { ! [string is alnum $c] } {
	1831	append re \\
	1832	}
	1833	append re $c
	1834	}
	1835	}
	1836	}
	1837	%E {
	1838	switch -exact -- $c {
	1839	C { # Locale-dependent era
	1840	set d {}
	1841	foreach triple [mc LOCALE_ERAS] {
	1842	lassign $triple t symbol year
	1843	dict set d [string tolower $symbol] $year
	1844	}
	1845	lassign [UniquePrefixRegexp $d] regex lookup
	1846	append re (?: $regex )
	1847	}
	1848	E {
	1849	set l {}
	1850	dict set l [string tolower [mc BCE]] BCE
	1851	dict set l [string tolower [mc CE]] CE
	1852	dict set l b.c.e. BCE
	1853	dict set l c.e. CE
	1854	dict set l b.c. BCE
	1855	dict set l a.d. CE
	1856	lassign [UniquePrefixRegexp $l] regex lookup
	1857	append re ( $regex )
	1858	dict set fieldSet era [incr fieldCount]
	1859	append postcode "dict set date era \["\
	1860	"dict get " [list $lookup] \
	1861	{ } \[ {string tolower $field} \
	1862	[incr captureCount] \] \
	1863	"\]\n"
	1864	}
	1865	y { # Locale-dependent year of the era
	1866	lassign [LocaleNumeralMatcher $locale] regex lookup
	1867	append re $regex
	1868	incr captureCount
	1869	}
	1870	default {
	1871	append re %E
	1872	if { ! [string is alnum $c] } {
	1873	append re \\
	1874	}
	1875	append re $c
	1876	}
	1877	}
	1878	set state {}
	1879	}
	1880	%O {
	1881	switch -exact -- $c {
	1882	d - e {
	1883	lassign [LocaleNumeralMatcher $locale] regex lookup
	1884	append re $regex
	1885	dict set fieldSet dayOfMonth [incr fieldCount]
	1886	append postcode "dict set date dayOfMonth \[" \
	1887	"dict get " [list $lookup] " \$field" \
	1888	[incr captureCount] \
	1889	"\]\n"
	1890	}
	1891	H - k {
	1892	lassign [LocaleNumeralMatcher $locale] regex lookup
	1893	append re $regex
	1894	dict set fieldSet hour [incr fieldCount]
	1895	append postcode "dict set date hour \[" \
	1896	"dict get " [list $lookup] " \$field" \
	1897	[incr captureCount] \
	1898	"\]\n"
	1899	}
	1900	I - l {
	1901	lassign [LocaleNumeralMatcher $locale] regex lookup
	1902	append re $regex
	1903	dict set fieldSet hourAMPM [incr fieldCount]
	1904	append postcode "dict set date hourAMPM \[" \
	1905	"dict get " [list $lookup] " \$field" \
	1906	[incr captureCount] \
	1907	"\]\n"
	1908	}
	1909	m {
	1910	lassign [LocaleNumeralMatcher $locale] regex lookup
	1911	append re $regex
	1912	dict set fieldSet month [incr fieldCount]
	1913	append postcode "dict set date month \[" \
	1914	"dict get " [list $lookup] " \$field" \
	1915	[incr captureCount] \
	1916	"\]\n"
	1917	}
	1918	M {
	1919	lassign [LocaleNumeralMatcher $locale] regex lookup
	1920	append re $regex
	1921	dict set fieldSet minute [incr fieldCount]
	1922	append postcode "dict set date minute \[" \
	1923	"dict get " [list $lookup] " \$field" \
	1924	[incr captureCount] \
	1925	"\]\n"
	1926	}
	1927	S {
	1928	lassign [LocaleNumeralMatcher $locale] regex lookup
	1929	append re $regex
	1930	dict set fieldSet second [incr fieldCount]
	1931	append postcode "dict set date second \[" \
	1932	"dict get " [list $lookup] " \$field" \
	1933	[incr captureCount] \
	1934	"\]\n"
	1935	}
	1936	u - w {
	1937	lassign [LocaleNumeralMatcher $locale] regex lookup
	1938	append re $regex
	1939	dict set fieldSet dayOfWeek [incr fieldCount]
	1940	append postcode "set dow \[dict get " [list $lookup] \
	1941	{ $field} [incr captureCount] \] \n \
	1942	{
	1943	if { $dow == 0 } {
	1944	set dow 7
	1945	} elseif { $dow > 7 } {
	1946	return -code error \
	1947	-errorcode [list CLOCK badDayOfWeek] \
	1948	"day of week is greater than 7"
	1949	}
	1950	dict set date dayOfWeek $dow
	1951	}
	1952	}
	1953	y {
	1954	lassign [LocaleNumeralMatcher $locale] regex lookup
	1955	append re $regex
	1956	dict set fieldSet yearOfCentury [incr fieldCount]
	1957	append postcode {dict set date yearOfCentury } \[ \
	1958	{dict get } [list $lookup] { $field} \
	1959	[incr captureCount] \] \n
	1960	}
	1961	default {
	1962	append re %O
	1963	if { ! [string is alnum $c] } {
	1964	append re \\
	1965	}
	1966	append re $c
	1967	}
	1968	}
	1969	set state {}
	1970	}
	1971	}
	1972	}
	1973
	1974	# Clean up any unfinished format groups
	1975
	1976	append re $state \\s*\$
	1977
	1978	# Build the procedure
	1979
	1980	set procBody {}
	1981	append procBody "variable ::tcl::clock::TZData" \n
	1982	append procBody "if \{ !\[ regexp -nocase [list $re] \$string ->"
	1983	for { set i 1 } { $i <= $captureCount } { incr i } {
	1984	append procBody " " field $i
	1985	}
	1986	append procBody "\] \} \{" \n
	1987	append procBody {
	1988	return -code error -errorcode [list CLOCK badInputString] \
	1989	{input string does not match supplied format}
	1990	}
	1991	append procBody \}\n
	1992	append procBody "set date \[dict create\]" \n
	1993	append procBody {dict set date tzName $timeZone} \n
	1994	append procBody $postcode
	1995	append procBody [list set changeover [mc GREGORIAN_CHANGE_DATE]] \n
	1996
	1997	# Add code that gets Julian Day Number from the fields.
	1998
	1999	append procBody [MakeParseCodeFromFields $fieldSet $DateParseActions]
	2000
	2001	# Get time of day
	2002
	2003	append procBody [MakeParseCodeFromFields $fieldSet $TimeParseActions]
	2004
	2005	# Assemble seconds, and convert local nominal time to UTC.
	2006
	2007	if { ![dict exists $fieldSet seconds]
	2008	&& ![dict exists $fieldSet starDate] } {
	2009	append procBody {
	2010	if { [dict get $date julianDay] > 5373484 } {
	2011	return -code error -errorcode [list CLOCK dateTooLarge] \
	2012	"requested date too large to represent"
	2013	}
	2014	dict set date localSeconds \
	2015	[expr { -210866803200
	2016	+ ( 86400 * wide([dict get $date julianDay]) )
	2017	+ [dict get $date secondOfDay] }]
	2018	}
	2019	}
	2020
	2021	if { ![dict exists $fieldSet seconds]
	2022	&& ![dict exists $fieldSet starDate] } {
	2023	if { [dict exists $fieldSet tzName] } {
	2024	append procBody {
	2025	set timeZone [dict get $date tzName]
	2026	}
	2027	}
	2028	append procBody {
	2029	::tcl::clock::SetupTimeZone $timeZone
	2030	set date [::tcl::clock::ConvertLocalToUTC $date[set date {}] \
	2031	$TZData($timeZone) \
	2032	$changeover]
	2033	}
	2034	}
	2035
	2036	# Return result
	2037
	2038	append procBody {return [dict get $date seconds]} \n
	2039
	2040	proc $procName { string baseTime timeZone } $procBody
	2041
	2042	# puts [list proc $procName [list string baseTime timeZone] $procBody]
	2043
	2044	return $procName
	2045	}
	2046
	2047	#----------------------------------------------------------------------
	2048	#
	2049	# LocaleNumeralMatcher --
	2050	#
	2051	# Composes a regexp that captures the numerals in the given
	2052	# locale, and a dictionary to map them to conventional numerals.
	2053	#
	2054	# Parameters:
	2055	# locale - Name of the current locale
	2056	#
	2057	# Results:
	2058	# Returns a two-element list comprising the regexp and the
	2059	# dictionary.
	2060	#
	2061	# Side effects:
	2062	# Caches the result.
	2063	#
	2064	#----------------------------------------------------------------------
	2065
	2066	proc ::tcl::clock::LocaleNumeralMatcher {l} {
	2067
	2068	variable LocaleNumeralCache
	2069
	2070	if { ![dict exists $LocaleNumeralCache $l] } {
	2071	set d {}
	2072	set i 0
	2073	set sep \(
	2074	foreach n [mc LOCALE_NUMERALS] {
	2075	dict set d $n $i
	2076	regsub -all {[^[:alnum:]]} $n \\\\& subex
	2077	append re $sep $subex
	2078	set sep \|
	2079	incr i
	2080	}
	2081	append re \)
	2082	dict set LocaleNumeralCache $l [list $re $d]
	2083	}
	2084	return [dict get $LocaleNumeralCache $l]
	2085	}
	2086
	2087
	2088
	2089	#----------------------------------------------------------------------
	2090	#
	2091	# UniquePrefixRegexp --
	2092	#
	2093	# Composes a regexp that performs unique-prefix matching. The
	2094	# RE matches one of a supplied set of strings, or any unique
	2095	# prefix thereof.
	2096	#
	2097	# Parameters:
	2098	# data - List of alternating match-strings and values.
	2099	# Match-strings with distinct values are considered
	2100	# distinct.
	2101	#
	2102	# Results:
	2103	# Returns a two-element list. The first is a regexp that
	2104	# matches any unique prefix of any of the strings. The second
	2105	# is a dictionary whose keys are match values from the regexp
	2106	# and whose values are the corresponding values from 'data'.
	2107	#
	2108	# Side effects:
	2109	# None.
	2110	#
	2111	#----------------------------------------------------------------------
	2112
	2113	proc ::tcl::clock::UniquePrefixRegexp { data } {
	2114
	2115	# The 'successors' dictionary will contain, for each string that
	2116	# is a prefix of any key, all characters that may follow that
	2117	# prefix. The 'prefixMapping' dictionary will have keys that
	2118	# are prefixes of keys and values that correspond to the keys.
	2119
	2120	set prefixMapping [dict create]
	2121	set successors [dict create {} {}]
	2122
	2123	# Walk the key-value pairs
	2124
	2125	foreach { key value } $data {
	2126
	2127	# Construct all prefixes of the key;
	2128
	2129	set prefix {}
	2130	foreach char [split $key {}] {
	2131	set oldPrefix $prefix
	2132	dict set successors $oldPrefix $char {}
	2133	append prefix $char
	2134
	2135	# Put the prefixes in the 'prefixMapping' and 'successors'
	2136	# dictionaries
	2137
	2138	dict lappend prefixMapping $prefix $value
	2139	if { ![dict exists $successors $prefix] } {
	2140	dict set successors $prefix {}
	2141	}
	2142	}
	2143	}
	2144
	2145	# Identify those prefixes that designate unique values, and
	2146	# those that are the full keys
	2147
	2148	set uniquePrefixMapping {}
	2149	dict for { key valueList } $prefixMapping {
	2150	if { [llength $valueList] == 1 } {
	2151	dict set uniquePrefixMapping $key [lindex $valueList 0]
	2152	}
	2153	}
	2154	foreach { key value } $data {
	2155	dict set uniquePrefixMapping $key $value
	2156	}
	2157
	2158	# Construct the re.
	2159
	2160	return [list \
	2161	[MakeUniquePrefixRegexp $successors $uniquePrefixMapping {}] \
	2162	$uniquePrefixMapping]
	2163	}
	2164
	2165	#----------------------------------------------------------------------
	2166	#
	2167	# MakeUniquePrefixRegexp --
	2168	#
	2169	# Service procedure for 'UniquePrefixRegexp' that constructs
	2170	# a regular expresison that matches the unique prefixes.
	2171	#
	2172	# Parameters:
	2173	# successors - Dictionary whose keys are all prefixes
	2174	# of keys passed to 'UniquePrefixRegexp' and whose
	2175	# values are dictionaries whose keys are the characters
	2176	# that may follow those prefixes.
	2177	# uniquePrefixMapping - Dictionary whose keys are the unique
	2178	# prefixes and whose values are not examined.
	2179	# prefixString - Current prefix being processed.
	2180	#
	2181	# Results:
	2182	# Returns a constructed regular expression that matches the set
	2183	# of unique prefixes beginning with the 'prefixString'.
	2184	#
	2185	# Side effects:
	2186	# None.
	2187	#
	2188	#----------------------------------------------------------------------
	2189
	2190	proc ::tcl::clock::MakeUniquePrefixRegexp { successors
	2191	uniquePrefixMapping
	2192	prefixString } {
	2193
	2194	# Get the characters that may follow the current prefix string
	2195
	2196	set schars [lsort -ascii [dict keys [dict get $successors $prefixString]]]
	2197	if { [llength $schars] == 0 } {
	2198	return {}
	2199	}
	2200
	2201	# If there is more than one successor character, or if the current
	2202	# prefix is a unique prefix, surround the generated re with non-capturing
	2203	# parentheses.
	2204
	2205	set re {}
	2206	if { [dict exists $uniquePrefixMapping $prefixString]
	2207	\|\| [llength $schars] > 1 } {
	2208	append re "(?:"
	2209	}
	2210
	2211	# Generate a regexp that matches the successors.
	2212
	2213	set sep ""
	2214	foreach { c } $schars {
	2215	set nextPrefix $prefixString$c
	2216	regsub -all {[^[:alnum:]]} $c \\\\& rechar
	2217	append re $sep $rechar \
	2218	[MakeUniquePrefixRegexp \
	2219	$successors $uniquePrefixMapping $nextPrefix]
	2220	set sep \|
	2221	}
	2222
	2223	# If the current prefix is a unique prefix, make all following text
	2224	# optional. Otherwise, if there is more than one successor character,
	2225	# close the non-capturing parentheses.
	2226
	2227	if { [dict exists $uniquePrefixMapping $prefixString] } {
	2228	append re ")?"
	2229	} elseif { [llength $schars] > 1 } {
	2230	append re ")"
	2231	}
	2232
	2233	return $re
	2234	}
	2235
	2236	#----------------------------------------------------------------------
	2237	#
	2238	# MakeParseCodeFromFields --
	2239	#
	2240	# Composes Tcl code to extract the Julian Day Number from a
	2241	# dictionary containing date fields.
	2242	#
	2243	# Parameters:
	2244	# dateFields -- Dictionary whose keys are fields of the date,
	2245	# and whose values are the rightmost positions
	2246	# at which those fields appear.
	2247	# parseActions -- List of triples: field set, priority, and
	2248	# code to emit. Smaller priorities are better, and
	2249	# the list must be in ascending order by priority
	2250	#
	2251	# Results:
	2252	# Returns a burst of code that extracts the day number from the
	2253	# given date.
	2254	#
	2255	# Side effects:
	2256	# None.
	2257	#
	2258	#----------------------------------------------------------------------
	2259
	2260	proc ::tcl::clock::MakeParseCodeFromFields { dateFields parseActions } {
	2261
	2262	set currPrio 999
	2263	set currFieldPos [list]
	2264	set currCodeBurst {
	2265	error "in ::tcl::clock::MakeParseCodeFromFields: can't happen"
	2266	}
	2267
	2268	foreach { fieldSet prio parseAction } $parseActions {
	2269
	2270	# If we've found an answer that's better than any that follow,
	2271	# quit now.
	2272
	2273	if { $prio > $currPrio } {
	2274	break
	2275	}
	2276
	2277	# Accumulate the field positions that are used in the current
	2278	# field grouping.
	2279
	2280	set fieldPos [list]
	2281	set ok true
	2282	foreach field $fieldSet {
	2283	if { ! [dict exists $dateFields $field] } {
	2284	set ok 0
	2285	break
	2286	}
	2287	lappend fieldPos [dict get $dateFields $field]
	2288	}
	2289
	2290	# Quit if we don't have a complete set of fields
	2291	if { !$ok } {
	2292	continue
	2293	}
	2294
	2295	# Determine whether the current answer is better than the last.
	2296
	2297	set fPos [lsort -integer -decreasing $fieldPos]
	2298
	2299	if { $prio == $currPrio } {
	2300	foreach currPos $currFieldPos newPos $fPos {
	2301	if { ![string is integer $newPos]
	2302	\|\| ![string is integer $currPos]
	2303	\|\| $newPos > $currPos } {
	2304	break
	2305	}
	2306	if { $newPos < $currPos } {
	2307	set ok 0
	2308	break
	2309	}
	2310	}
	2311	}
	2312	if { !$ok } {
	2313	continue
	2314	}
	2315
	2316	# Remember the best possibility for extracting date information
	2317
	2318	set currPrio $prio
	2319	set currFieldPos $fPos
	2320	set currCodeBurst $parseAction
	2321
	2322	}
	2323
	2324	return $currCodeBurst
	2325
	2326	}
	2327
	2328	#----------------------------------------------------------------------
	2329	#
	2330	# EnterLocale --
	2331	#
	2332	# Switch [mclocale] to a given locale if necessary
	2333	#
	2334	# Parameters:
	2335	# locale -- Desired locale
	2336	# oldLocaleVar -- Name of a variable in caller's scope that
	2337	# tracks the previous locale name.
	2338	#
	2339	# Results:
	2340	# Returns the locale that was previously current.
	2341	#
	2342	# Side effects:
	2343	# Does [mclocale]. If necessary, uses [mcload] to load the
	2344	# designated locale's files, and tracks that it has done so
	2345	# in the 'McLoaded' variable.
	2346	#
	2347	#----------------------------------------------------------------------
	2348
	2349	proc ::tcl::clock::EnterLocale { locale oldLocaleVar } {
	2350
	2351	upvar 1 $oldLocaleVar oldLocale
	2352
	2353	variable MsgDir
	2354	variable McLoaded
	2355
	2356	set oldLocale [mclocale]
	2357	if { $locale eq {system} } {
	2358
	2359	if { $::tcl_platform(platform) ne {windows} } {
	2360
	2361	# On a non-windows platform, the 'system' locale is
	2362	# the same as the 'current' locale
	2363
	2364	set locale current
	2365	} else {
	2366
	2367	# On a windows platform, the 'system' locale is
	2368	# adapted from the 'current' locale by applying the
	2369	# date and time formats from the Control Panel.
	2370	# First, load the 'current' locale if it's not yet loaded
	2371
	2372	if {![dict exists $McLoaded $oldLocale] } {
	2373	mcload $MsgDir
	2374	dict set McLoaded $oldLocale {}
	2375	}
	2376
	2377	# Make a new locale string for the system locale, and
	2378	# get the Control Panel information
	2379
	2380	set locale ${oldLocale}_windows
	2381	if { ![dict exists $McLoaded $locale] } {
	2382	LoadWindowsDateTimeFormats $locale
	2383	dict set McLoaded $locale {}
	2384	}
	2385	}
	2386	}
	2387	if { $locale eq {current}} {
	2388	set locale $oldLocale
	2389	unset oldLocale
	2390	} elseif { $locale eq $oldLocale } {
	2391	unset oldLocale
	2392	} else {
	2393	mclocale $locale
	2394	}
	2395	if { ![dict exists $McLoaded $locale] } {
	2396	mcload $MsgDir
	2397	dict set McLoaded $locale {}
	2398	}
	2399
	2400	}
	2401
	2402	#----------------------------------------------------------------------
	2403	#
	2404	# LoadWindowsDateTimeFormats --
	2405	#
	2406	# Load the date/time formats from the Control Panel in Windows
	2407	# and convert them so that they're usable by Tcl.
	2408	#
	2409	# Parameters:
	2410	# locale - Name of the locale in whose message catalog
	2411	# the converted formats are to be stored.
	2412	#
	2413	# Results:
	2414	# None.
	2415	#
	2416	# Side effects:
	2417	# Updates the given message catalog with the locale strings.
	2418	#
	2419	# Presumes that on entry, [mclocale] is set to the current locale,
	2420	# so that default strings can be obtained if the Registry query
	2421	# fails.
	2422	#
	2423	#----------------------------------------------------------------------
	2424
	2425	proc ::tcl::clock::LoadWindowsDateTimeFormats { locale } {
	2426
	2427	# Bail out if we can't find the Registry
	2428
	2429	variable NoRegistry
	2430	if { [info exists NoRegistry] } return
	2431
	2432	if { ![catch {
	2433	registry get "HKEY_CURRENT_USER\\Control Panel\\International" \
	2434	sShortDate
	2435	} string] } {
	2436	set quote {}
	2437	set datefmt {}
	2438	foreach { unquoted quoted } [split $string '] {
	2439	append datefmt $quote [string map {
	2440	dddd %A
	2441	ddd %a
	2442	dd %d
	2443	d %e
	2444	MMMM %B
	2445	MMM %b
	2446	MM %m
	2447	M %N
	2448	yyyy %Y
	2449	yy %y
	2450	y %y
	2451	gg {}
	2452	} $unquoted]
	2453	if { $quoted eq {} } {
	2454	set quote '
	2455	} else {
	2456	set quote $quoted
	2457	}
	2458	}
	2459	::msgcat::mcset $locale DATE_FORMAT $datefmt
	2460	}
	2461
	2462	if { ![catch {
	2463	registry get "HKEY_CURRENT_USER\\Control Panel\\International" \
	2464	sLongDate
	2465	} string] } {
	2466	set quote {}
	2467	set ldatefmt {}
	2468	foreach { unquoted quoted } [split $string '] {
	2469	append ldatefmt $quote [string map {
	2470	dddd %A
	2471	ddd %a
	2472	dd %d
	2473	d %e
	2474	MMMM %B
	2475	MMM %b
	2476	MM %m
	2477	M %N
	2478	yyyy %Y
	2479	yy %y
	2480	y %y
	2481	gg {}
	2482	} $unquoted]
	2483	if { $quoted eq {} } {
	2484	set quote '
	2485	} else {
	2486	set quote $quoted
	2487	}
	2488	}
	2489	::msgcat::mcset $locale LOCALE_DATE_FORMAT $ldatefmt
	2490	}
	2491
	2492	if { ![catch {
	2493	registry get "HKEY_CURRENT_USER\\Control Panel\\International" \
	2494	sTimeFormat
	2495	} string] } {
	2496	set quote {}
	2497	set timefmt {}
	2498	foreach { unquoted quoted } [split $string '] {
	2499	append timefmt $quote [string map {
	2500	HH %H
	2501	H %k
	2502	hh %I
	2503	h %l
	2504	mm %M
	2505	m %M
	2506	ss %S
	2507	s %S
	2508	tt %p
	2509	t %p
	2510	} $unquoted]
	2511	if { $quoted eq {} } {
	2512	set quote '
	2513	} else {
	2514	set quote $quoted
	2515	}
	2516	}
	2517	::msgcat::mcset $locale TIME_FORMAT $timefmt
	2518	}
	2519
	2520	catch {
	2521	::msgcat::mcset $locale DATE_TIME_FORMAT "$datefmt $timefmt"
	2522	}
	2523	catch {
	2524	::msgcat::mcset $locale LOCALE_DATE_TIME_FORMAT "$ldatefmt $timefmt"
	2525	}
	2526
	2527	return
	2528
	2529	}
	2530
	2531	#----------------------------------------------------------------------
	2532	#
	2533	# LocalizeFormat --
	2534	#
	2535	# Map away locale-dependent format groups in a clock format.
	2536	#
	2537	# Parameters:
	2538	# locale -- Current [mclocale] locale, supplied to avoid
	2539	# an extra call
	2540	# format -- Format supplied to [clock scan] or [clock format]
	2541	#
	2542	# Results:
	2543	# Returns the string with locale-dependent composite format
	2544	# groups substituted out.
	2545	#
	2546	# Side effects:
	2547	# None.
	2548	#
	2549	#----------------------------------------------------------------------
	2550
	2551	proc ::tcl::clock::LocalizeFormat { locale format } {
	2552
	2553	variable McLoaded
	2554
	2555	if { [dict exists $McLoaded $locale FORMAT $format] } {
	2556	return [dict get $McLoaded $locale FORMAT $format]
	2557	}
	2558	set inFormat $format
	2559
	2560	# Handle locale-dependent format groups by mapping them out of
	2561	# the input string. Note that the order of the [string map]
	2562	# operations is significant because earlier formats can refer
	2563	# to later ones; for example %c can refer to %X, which in turn
	2564	# can refer to %T.
	2565
	2566	set format [string map [list %c [mc DATE_TIME_FORMAT] \
	2567	%Ec [mc LOCALE_DATE_TIME_FORMAT]] $format]
	2568	set format [string map [list %x [mc DATE_FORMAT] \
	2569	%Ex [mc LOCALE_DATE_FORMAT] \
	2570	%X [mc TIME_FORMAT] \
	2571	%EX [mc LOCALE_TIME_FORMAT]] $format]
	2572	set format [string map [list %r [mc TIME_FORMAT_12] \
	2573	%R [mc TIME_FORMAT_24] \
	2574	%T [mc TIME_FORMAT_24_SECS]] $format]
	2575	set format [string map [list %D %m/%d/%Y \
	2576	%EY [mc LOCALE_YEAR_FORMAT]\
	2577	%+ {%a %b %e %H:%M:%S %Z %Y}] $format]
	2578
	2579	dict set McLoaded $locale FORMAT $inFormat $format
	2580	return $format
	2581	}
	2582
	2583	#----------------------------------------------------------------------
	2584	#
	2585	# FormatNumericTimeZone --
	2586	#
	2587	# Formats a time zone as +hhmmss
	2588	#
	2589	# Parameters:
	2590	# z - Time zone in seconds east of Greenwich
	2591	#
	2592	# Results:
	2593	# Returns the time zone formatted in a numeric form
	2594	#
	2595	# Side effects:
	2596	# None.
	2597	#
	2598	#----------------------------------------------------------------------
	2599
	2600	proc ::tcl::clock::FormatNumericTimeZone { z } {
	2601
	2602	if { $z < 0 } {
	2603	set z [expr { - $z }]
	2604	set retval -
	2605	} else {
	2606	set retval +
	2607	}
	2608	append retval [::format %02d [expr { $z / 3600 }]]
	2609	set z [expr { $z % 3600 }]
	2610	append retval [::format %02d [expr { $z / 60 }]]
	2611	set z [expr { $z % 60 }]
	2612	if { $z != 0 } {
	2613	append retval [::format %02d $z]
	2614	}
	2615	return $retval
	2616
	2617	}
	2618
	2619	#----------------------------------------------------------------------
	2620	#
	2621	# FormatStarDate --
	2622	#
	2623	# Formats a date as a StarDate.
	2624	#
	2625	# Parameters:
	2626	# date - Dictionary containing 'year', 'dayOfYear', and
	2627	# 'localSeconds' fields.
	2628	#
	2629	# Results:
	2630	# Returns the given date formatted as a StarDate.
	2631	#
	2632	# Side effects:
	2633	# None.
	2634	#
	2635	# Jeff Hobbs put this in to support an atrocious pun about Tcl being
	2636	# "Enterprise ready." Now we're stuck with it.
	2637	#
	2638	#----------------------------------------------------------------------
	2639
	2640	proc ::tcl::clock::FormatStarDate { date } {
	2641
	2642	variable Roddenberry
	2643
	2644	# Get day of year, zero based
	2645
	2646	set doy [expr { [dict get $date dayOfYear] - 1 }]
	2647
	2648	# Determine whether the year is a leap year
	2649
	2650	set lp [IsGregorianLeapYear $date]
	2651
	2652	# Convert day of year to a fractional year
	2653
	2654	if { $lp } {
	2655	set fractYear [expr { 1000 * $doy / 366 }]
	2656	} else {
	2657	set fractYear [expr { 1000 * $doy / 365 }]
	2658	}
	2659
	2660	# Put together the StarDate
	2661
	2662	return [::format "Stardate %02d%03d.%1d" \
	2663	[expr { [dict get $date year] - $Roddenberry }] \
	2664	$fractYear \
	2665	[expr { [dict get $date localSeconds] % 86400
	2666	/ ( 86400 / 10 ) }]]
	2667	}
	2668
	2669	#----------------------------------------------------------------------
	2670	#
	2671	# ParseStarDate --
	2672	#
	2673	# Parses a StarDate
	2674	#
	2675	# Parameters:
	2676	# year - Year from the Roddenberry epoch
	2677	# fractYear - Fraction of a year specifiying the day of year.
	2678	# fractDay - Fraction of a day
	2679	#
	2680	# Results:
	2681	# Returns a count of seconds from the Posix epoch.
	2682	#
	2683	# Side effects:
	2684	# None.
	2685	#
	2686	# Jeff Hobbs put this in to support an atrocious pun about Tcl being
	2687	# "Enterprise ready." Now we're stuck with it.
	2688	#
	2689	#----------------------------------------------------------------------
	2690
	2691	proc ::tcl::clock::ParseStarDate { year fractYear fractDay } {
	2692
	2693	variable Roddenberry
	2694
	2695	# Build a tentative date from year and fraction.
	2696
	2697	set date [dict create \
	2698	gregorian 1 \
	2699	era CE \
	2700	year [expr { $year + $Roddenberry }] \
	2701	dayOfYear [expr { $fractYear * 365 / 1000 + 1 }]]
	2702	set date [GetJulianDayFromGregorianEraYearDay $date[set date {}]]
	2703
	2704	# Determine whether the given year is a leap year
	2705
	2706	set lp [IsGregorianLeapYear $date]
	2707
	2708	# Reconvert the fractional year according to whether the given
	2709	# year is a leap year
	2710
	2711	if { $lp } {
	2712	dict set date dayOfYear \
	2713	[expr { $fractYear * 366 / 1000 + 1 }]
	2714	} else {
	2715	dict set date dayOfYear \
	2716	[expr { $fractYear * 365 / 1000 + 1 }]
	2717	}
	2718	dict unset date julianDay
	2719	dict unset date gregorian
	2720	set date [GetJulianDayFromGregorianEraYearDay $date[set date {}]]
	2721
	2722	return [expr { 86400 * [dict get $date julianDay]
	2723	- 210866803200
	2724	+ ( 86400 / 10 ) * $fractDay }]
	2725
	2726	}
	2727
	2728	#----------------------------------------------------------------------
	2729	#
	2730	# ScanWide --
	2731	#
	2732	# Scans a wide integer from an input
	2733	#
	2734	# Parameters:
	2735	# str - String containing a decimal wide integer
	2736	#
	2737	# Results:
	2738	# Returns the string as a pure wide integer. Throws an error if
	2739	# the string is misformatted or out of range.
	2740	#
	2741	#----------------------------------------------------------------------
	2742
	2743	proc ::tcl::clock::ScanWide { str } {
	2744	set count [::scan $str {%ld %c} result junk]
	2745	if { $count != 1 } {
	2746	return -code error -errorcode [list CLOCK notAnInteger $str] \
	2747	"\"$str\" is not an integer"
	2748	}
	2749	if { [incr result 0] != $str } {
	2750	return -code error -errorcode [list CLOCK integervalueTooLarge] \
	2751	"integer value too large to represent"
	2752	}
	2753	return $result
	2754	}
	2755
	2756	#----------------------------------------------------------------------
	2757	#
	2758	# InterpretTwoDigitYear --
	2759	#
	2760	# Given a date that contains only the year of the century,
	2761	# determines the target value of a two-digit year.
	2762	#
	2763	# Parameters:
	2764	# date - Dictionary containing fields of the date.
	2765	# baseTime - Base time relative to which the date is expressed.
	2766	# twoDigitField - Name of the field that stores the two-digit year.
	2767	# Default is 'yearOfCentury'
	2768	# fourDigitField - Name of the field that will receive the four-digit
	2769	# year. Default is 'year'
	2770	#
	2771	# Results:
	2772	# Returns the dictionary augmented with the four-digit year, stored in
	2773	# the given key.
	2774	#
	2775	# Side effects:
	2776	# None.
	2777	#
	2778	# The current rule for interpreting a two-digit year is that the year
	2779	# shall be between 1937 and 2037, thus staying within the range of a
	2780	# 32-bit signed value for time. This rule may change to a sliding
	2781	# window in future versions, so the 'baseTime' parameter (which is
	2782	# currently ignored) is provided in the procedure signature.
	2783	#
	2784	#----------------------------------------------------------------------
	2785
	2786	proc ::tcl::clock::InterpretTwoDigitYear { date baseTime
	2787	{ twoDigitField yearOfCentury }
	2788	{ fourDigitField year } } {
	2789
	2790	set yr [dict get $date $twoDigitField]
	2791	if { $yr <= 37 } {
	2792	dict set date $fourDigitField [expr { $yr + 2000 }]
	2793	} else {
	2794	dict set date $fourDigitField [expr { $yr + 1900 }]
	2795	}
	2796	return $date
	2797
	2798	}
	2799
	2800	#----------------------------------------------------------------------
	2801	#
	2802	# AssignBaseYear --
	2803	#
	2804	# Places the number of the current year into a dictionary.
	2805	#
	2806	# Parameters:
	2807	# date - Dictionary value to update
	2808	# baseTime - Base time from which to extract the year, expressed
	2809	# in seconds from the Posix epoch
	2810	# timezone - the time zone in which the date is being scanned
	2811	# changeover - the Julian Day on which the Gregorian calendar
	2812	# was adopted in the target locale.
	2813	#
	2814	# Results:
	2815	# Returns the dictionary with the current year assigned.
	2816	#
	2817	# Side effects:
	2818	# None.
	2819	#
	2820	#----------------------------------------------------------------------
	2821
	2822	proc ::tcl::clock::AssignBaseYear { date baseTime timezone changeover } {
	2823
	2824	variable TZData
	2825
	2826	# Find the Julian Day Number corresponding to the base time, and
	2827	# find the Gregorian year corresponding to that Julian Day.
	2828
	2829	set date2 [GetDateFields $baseTime $TZData($timezone) $changeover]
	2830
	2831	# Store the converted year
	2832
	2833	dict set date era [dict get $date2 era]
	2834	dict set date year [dict get $date2 year]
	2835
	2836	return $date
	2837
	2838	}
	2839
	2840	#----------------------------------------------------------------------
	2841	#
	2842	# AssignBaseIso8601Year --
	2843	#
	2844	# Determines the base year in the ISO8601 fiscal calendar.
	2845	#
	2846	# Parameters:
	2847	# date - Dictionary containing the fields of the date that
	2848	# is to be augmented with the base year.
	2849	# baseTime - Base time expressed in seconds from the Posix epoch.
	2850	# timeZone - Target time zone
	2851	# changeover - Julian Day of adoption of the Gregorian calendar in
	2852	# the target locale.
	2853	#
	2854	# Results:
	2855	# Returns the given date with "iso8601Year" set to the
	2856	# base year.
	2857	#
	2858	# Side effects:
	2859	# None.
	2860	#
	2861	#----------------------------------------------------------------------
	2862
	2863	proc ::tcl::clock::AssignBaseIso8601Year {date baseTime timeZone changeover} {
	2864
	2865	variable TZData
	2866
	2867	# Find the Julian Day Number corresponding to the base time
	2868
	2869	set date2 [GetDateFields $baseTime $TZData($timeZone) $changeover]
	2870
	2871	# Calculate the ISO8601 date and transfer the year
	2872
	2873	dict set date era CE
	2874	dict set date iso8601Year [dict get $date2 iso8601Year]
	2875	return $date
	2876	}
	2877
	2878	#----------------------------------------------------------------------
	2879	#
	2880	# AssignBaseMonth --
	2881	#
	2882	# Places the number of the current year and month into a
	2883	# dictionary.
	2884	#
	2885	# Parameters:
	2886	# date - Dictionary value to update
	2887	# baseTime - Time from which the year and month are to be
	2888	# obtained, expressed in seconds from the Posix epoch.
	2889	# timezone - Name of the desired time zone
	2890	# changeover - Julian Day on which the Gregorian calendar was adopted.
	2891	#
	2892	# Results:
	2893	# Returns the dictionary with the base year and month assigned.
	2894	#
	2895	# Side effects:
	2896	# None.
	2897	#
	2898	#----------------------------------------------------------------------
	2899
	2900	proc ::tcl::clock::AssignBaseMonth {date baseTime timezone changeover} {
	2901
	2902	variable TZData
	2903
	2904	# Find the year and month corresponding to the base time
	2905
	2906	set date2 [GetDateFields $baseTime $TZData($timezone) $changeover]
	2907	dict set date era [dict get $date2 era]
	2908	dict set date year [dict get $date2 year]
	2909	dict set date month [dict get $date2 month]
	2910	return $date
	2911
	2912	}
	2913
	2914	#----------------------------------------------------------------------
	2915	#
	2916	# AssignBaseWeek --
	2917	#
	2918	# Determines the base year and week in the ISO8601 fiscal calendar.
	2919	#
	2920	# Parameters:
	2921	# date - Dictionary containing the fields of the date that
	2922	# is to be augmented with the base year and week.
	2923	# baseTime - Base time expressed in seconds from the Posix epoch.
	2924	# changeover - Julian Day on which the Gregorian calendar was adopted
	2925	# in the target locale.
	2926	#
	2927	# Results:
	2928	# Returns the given date with "iso8601Year" set to the
	2929	# base year and "iso8601Week" to the week number.
	2930	#
	2931	# Side effects:
	2932	# None.
	2933	#
	2934	#----------------------------------------------------------------------
	2935
	2936	proc ::tcl::clock::AssignBaseWeek {date baseTime timeZone changeover} {
	2937
	2938	variable TZData
	2939
	2940	# Find the Julian Day Number corresponding to the base time
	2941
	2942	set date2 [GetDateFields $baseTime $TZData($timeZone) $changeover]
	2943
	2944	# Calculate the ISO8601 date and transfer the year
	2945
	2946	dict set date era CE
	2947	dict set date iso8601Year [dict get $date2 iso8601Year]
	2948	dict set date iso8601Week [dict get $date2 iso8601Week]
	2949	return $date
	2950	}
	2951
	2952	#----------------------------------------------------------------------
	2953	#
	2954	# AssignBaseJulianDay --
	2955	#
	2956	# Determines the base day for a time-of-day conversion.
	2957	#
	2958	# Parameters:
	2959	# date - Dictionary that is to get the base day
	2960	# baseTime - Base time expressed in seconds from the Posix epoch
	2961	# changeover - Julian day on which the Gregorian calendar was
	2962	# adpoted in the target locale.
	2963	#
	2964	# Results:
	2965	# Returns the given dictionary augmented with a 'julianDay' field
	2966	# that contains the base day.
	2967	#
	2968	# Side effects:
	2969	# None.
	2970	#
	2971	#----------------------------------------------------------------------
	2972
	2973	proc ::tcl::clock::AssignBaseJulianDay { date baseTime timeZone changeover } {
	2974
	2975	variable TZData
	2976
	2977	# Find the Julian Day Number corresponding to the base time
	2978
	2979	set date2 [GetDateFields $baseTime $TZData($timeZone) $changeover]
	2980	dict set date julianDay [dict get $date2 julianDay]
	2981
	2982	return $date
	2983	}
	2984
	2985	#----------------------------------------------------------------------
	2986	#
	2987	# InterpretHMSP --
	2988	#
	2989	# Interprets a time in the form "hh:mm:ss am".
	2990	#
	2991	# Parameters:
	2992	# date -- Dictionary containing "hourAMPM", "minute", "second"
	2993	# and "amPmIndicator" fields.
	2994	#
	2995	# Results:
	2996	# Returns the number of seconds from local midnight.
	2997	#
	2998	# Side effects:
	2999	# None.
	3000	#
	3001	#----------------------------------------------------------------------
	3002
	3003	proc ::tcl::clock::InterpretHMSP { date } {
	3004
	3005	set hr [dict get $date hourAMPM]
	3006	if { $hr == 12 } {
	3007	set hr 0
	3008	}
	3009	if { [dict get $date amPmIndicator] } {
	3010	incr hr 12
	3011	}
	3012	dict set date hour $hr
	3013	return [InterpretHMS $date[set date {}]]
	3014
	3015	}
	3016
	3017	#----------------------------------------------------------------------
	3018	#
	3019	# InterpretHMS --
	3020	#
	3021	# Interprets a 24-hour time "hh:mm:ss"
	3022	#
	3023	# Parameters:
	3024	# date -- Dictionary containing the "hour", "minute" and "second"
	3025	# fields.
	3026	#
	3027	# Results:
	3028	# Returns the given dictionary augmented with a "secondOfDay"
	3029	# field containing the number of seconds from local midnight.
	3030	#
	3031	# Side effects:
	3032	# None.
	3033	#
	3034	#----------------------------------------------------------------------
	3035
	3036	proc ::tcl::clock::InterpretHMS { date } {
	3037
	3038	return [expr { ( [dict get $date hour] * 60
	3039	+ [dict get $date minute] ) * 60
	3040	+ [dict get $date second] }]
	3041
	3042	}
	3043
	3044	#----------------------------------------------------------------------
	3045	#
	3046	# GetSystemTimeZone --
	3047	#
	3048	# Determines the system time zone, which is the default for the
	3049	# 'clock' command if no other zone is supplied.
	3050	#
	3051	# Parameters:
	3052	# None.
	3053	#
	3054	# Results:
	3055	# Returns the system time zone.
	3056	#
	3057	# Side effects:
	3058	# Stores the sustem time zone in the 'CachedSystemTimeZone'
	3059	# variable, since determining it may be an expensive process.
	3060	#
	3061	#----------------------------------------------------------------------
	3062
	3063	proc ::tcl::clock::GetSystemTimeZone {} {
	3064
	3065	variable CachedSystemTimeZone
	3066	variable TimeZoneBad
	3067
	3068	if {[set result [getenv TCL_TZ]] ne {}} {
	3069	set timezone $result
	3070	} elseif {[set result [getenv TZ]] ne {}} {
	3071	set timezone $result
	3072	} elseif { [info exists CachedSystemTimeZone] } {
	3073	set timezone $CachedSystemTimeZone
	3074	} elseif { $::tcl_platform(platform) eq {windows} } {
	3075	set timezone [GuessWindowsTimeZone]
	3076	} elseif { [file exists /etc/localtime]
	3077	&& ![catch {ReadZoneinfoFile \
	3078	Tcl/Localtime /etc/localtime}] } {
	3079	set timezone :Tcl/Localtime
	3080	} else {
	3081	set timezone :localtime
	3082	}
	3083	set CachedSystemTimeZone $timezone
	3084	if { ![dict exists $TimeZoneBad $timezone] } {
	3085	dict set TimeZoneBad $timezone [catch {SetupTimeZone $timezone}]
	3086	}
	3087	if { [dict get $TimeZoneBad $timezone] } {
	3088	return :localtime
	3089	} else {
	3090	return $timezone
	3091	}
	3092
	3093	}
	3094
	3095	#----------------------------------------------------------------------
	3096	#
	3097	# ConvertLegacyTimeZone --
	3098	#
	3099	# Given an alphanumeric time zone identifier and the system
	3100	# time zone, convert the alphanumeric identifier to an
	3101	# unambiguous time zone.
	3102	#
	3103	# Parameters:
	3104	# tzname - Name of the time zone to convert
	3105	#
	3106	# Results:
	3107	# Returns a time zone name corresponding to tzname, but
	3108	# in an unambiguous form, generally +hhmm.
	3109	#
	3110	# This procedure is implemented primarily to allow the parsing of
	3111	# RFC822 date/time strings. Processing a time zone name on input
	3112	# is not recommended practice, because there is considerable room
	3113	# for ambiguity; for instance, is BST Brazilian Standard Time, or
	3114	# British Summer Time?
	3115	#
	3116	#----------------------------------------------------------------------
	3117
	3118	proc ::tcl::clock::ConvertLegacyTimeZone { tzname } {
	3119
	3120	variable LegacyTimeZone
	3121
	3122	set tzname [string tolower $tzname]
	3123	if { ![dict exists $LegacyTimeZone $tzname] } {
	3124	return -code error -errorcode [list CLOCK badTZName $tzname] \
	3125	"time zone \"$tzname\" not found"
	3126	} else {
	3127	return [dict get $LegacyTimeZone $tzname]
	3128	}
	3129
	3130	}
	3131
	3132	#----------------------------------------------------------------------
	3133	#
	3134	# SetupTimeZone --
	3135	#
	3136	# Given the name or specification of a time zone, sets up
	3137	# its in-memory data.
	3138	#
	3139	# Parameters:
	3140	# tzname - Name of a time zone
	3141	#
	3142	# Results:
	3143	# Unless the time zone is ':localtime', sets the TZData array
	3144	# to contain the lookup table for local<->UTC conversion.
	3145	# Returns an error if the time zone cannot be parsed.
	3146	#
	3147	#----------------------------------------------------------------------
	3148
	3149	proc ::tcl::clock::SetupTimeZone { timezone } {
	3150
	3151	variable TZData
	3152
	3153	if {! [info exists TZData($timezone)] } {
	3154	variable MINWIDE
	3155	if { $timezone eq {:localtime} } {
	3156
	3157	# Nothing to do, we'll convert using the localtime function
	3158
	3159	} elseif { [regexp {^([-+])(\d\d)(?::?(\d\d)(?::?(\d\d))?)?} $timezone \
	3160	-> s hh mm ss] } {
	3161
	3162	# Make a fixed offset
	3163
	3164	::scan $hh %d hh
	3165	if { $mm eq {} } {
	3166	set mm 0
	3167	} else {
	3168	::scan $mm %d mm
	3169	}
	3170	if { $ss eq {} } {
	3171	set ss 0
	3172	} else {
	3173	::scan $ss %d ss
	3174	}
	3175	set offset [expr { ( $hh * 60 + $mm ) * 60 + $ss }]
	3176	if { $s eq {-} } {
	3177	set offset [expr { - $offset }]
	3178	}
	3179	set TZData($timezone) [list [list $MINWIDE $offset -1 $timezone]]
	3180
	3181	} elseif { [string index $timezone 0] eq {:} } {
	3182
	3183	# Convert using a time zone file
	3184
	3185	if {
	3186	[catch {
	3187	LoadTimeZoneFile [string range $timezone 1 end]
	3188	}]
	3189	&& [catch {
	3190	LoadZoneinfoFile [string range $timezone 1 end]
	3191	}]
	3192	} {
	3193	return -code error \
	3194	-errorcode [list CLOCK badTimeZone $timezone] \
	3195	"time zone \"$timezone\" not found"
	3196	}
	3197
	3198	} elseif { ![catch {ParsePosixTimeZone $timezone} tzfields] } {
	3199
	3200	# This looks like a POSIX time zone - try to process it
	3201
	3202	if { [catch {ProcessPosixTimeZone $tzfields} data opts] } {
	3203	if { [lindex [dict get $opts -errorcode] 0] eq {CLOCK} } {
	3204	dict unset opts -errorinfo
	3205	}
	3206	return -options $opts $data
	3207	} else {
	3208	set TZData($timezone) $data
	3209	}
	3210
	3211	} else {
	3212
	3213	# We couldn't parse this as a POSIX time zone. Try
	3214	# again with a time zone file - this time without a colon
	3215
	3216	if { [catch { LoadTimeZoneFile $timezone }]
	3217	&& [catch { ZoneinfoFile $timezone } - opts] } {
	3218	dict unset opts -errorinfo
	3219	return -options $opts "time zone $timezone not found"
	3220	}
	3221	set TZData($timezone) $TZData(:$timezone)
	3222	}
	3223	}
	3224
	3225	return
	3226	}
	3227
	3228	#----------------------------------------------------------------------
	3229	#
	3230	# GuessWindowsTimeZone --
	3231	#
	3232	# Determines the system time zone on windows.
	3233	#
	3234	# Parameters:
	3235	# None.
	3236	#
	3237	# Results:
	3238	# Returns a time zone specifier that corresponds to the system
	3239	# time zone information found in the Registry.
	3240	#
	3241	# Bugs:
	3242	# Fixed dates for DST change are unimplemented at present, because
	3243	# no time zone information supplied with Windows actually uses
	3244	# them!
	3245	#
	3246	# On a Windows system where neither $env(TCL_TZ) nor $env(TZ) is
	3247	# specified, GuessWindowsTimeZone looks in the Registry for the
	3248	# system time zone information. It then attempts to find an entry
	3249	# in WinZoneInfo for a time zone that uses the same rules. If
	3250	# it finds one, it returns it; otherwise, it constructs a Posix-style
	3251	# time zone string and returns that.
	3252	#
	3253	#----------------------------------------------------------------------
	3254
	3255	proc ::tcl::clock::GuessWindowsTimeZone {} {
	3256
	3257	variable WinZoneInfo
	3258	variable NoRegistry
	3259	variable TimeZoneBad
	3260
	3261	if { [info exists NoRegistry] } {
	3262	return :localtime
	3263	}
	3264
	3265	# Dredge time zone information out of the registry
	3266
	3267	if { [catch {
	3268	set rpath HKEY_LOCAL_MACHINE\\System\\CurrentControlSet\\Control\\TimeZoneInformation
	3269	set data [list \
	3270	[expr { -60
	3271	* [registry get $rpath Bias] }] \
	3272	[expr { -60
	3273	* [registry get $rpath StandardBias] }] \
	3274	[expr { -60 \
	3275	* [registry get $rpath DaylightBias] }]]
	3276	set stdtzi [registry get $rpath StandardStart]
	3277	foreach ind {0 2 14 4 6 8 10 12} {
	3278	binary scan $stdtzi @${ind}s val
	3279	lappend data $val
	3280	}
	3281	set daytzi [registry get $rpath DaylightStart]
	3282	foreach ind {0 2 14 4 6 8 10 12} {
	3283	binary scan $daytzi @${ind}s val
	3284	lappend data $val
	3285	}
	3286	}] } {
	3287
	3288	# Missing values in the Registry - bail out
	3289
	3290	return :localtime
	3291	}
	3292
	3293	# Make up a Posix time zone specifier if we can't find one.
	3294	# Check here that the tzdata file exists, in case we're running
	3295	# in an environment (e.g. starpack) where tzdata is incomplete.
	3296	# (Bug 1237907)
	3297
	3298	if { [dict exists $WinZoneInfo $data] } {
	3299	set tzname [dict get $WinZoneInfo $data]
	3300	if { ! [dict exists $TimeZoneBad $tzname] } {
	3301	dict set TimeZoneBad $tzname [catch {SetupTimeZone $tzname}]
	3302	}
	3303	} else {
	3304	set tzname {}
	3305	}
	3306	if { $tzname eq {} \|\| [dict get $TimeZoneBad $tzname] } {
	3307	lassign $data \
	3308	bias stdBias dstBias \
	3309	stdYear stdMonth stdDayOfWeek stdDayOfMonth \
	3310	stdHour stdMinute stdSecond stdMillisec \
	3311	dstYear dstMonth dstDayOfWeek dstDayOfMonth \
	3312	dstHour dstMinute dstSecond dstMillisec
	3313	set stdDelta [expr { $bias + $stdBias }]
	3314	set dstDelta [expr { $bias + $dstBias }]
	3315	if { $stdDelta <= 0 } {
	3316	set stdSignum +
	3317	set stdDelta [expr { - $stdDelta }]
	3318	set dispStdSignum -
	3319	} else {
	3320	set stdSignum -
	3321	set dispStdSignum +
	3322	}
	3323	set hh [::format %02d [expr { $stdDelta / 3600 }]]
	3324	set mm [::format %02d [expr { ($stdDelta / 60 ) % 60 }]]
	3325	set ss [::format %02d [expr { $stdDelta % 60 }]]
	3326	set tzname {}
	3327	append tzname < $dispStdSignum $hh $mm > $stdSignum $hh : $mm : $ss
	3328	if { $stdMonth >= 0 } {
	3329	if { $dstDelta <= 0 } {
	3330	set dstSignum +
	3331	set dstDelta [expr { - $dstDelta }]
	3332	set dispDstSignum -
	3333	} else {
	3334	set dstSignum -
	3335	set dispDstSignum +
	3336	}
	3337	set hh [::format %02d [expr { $dstDelta / 3600 }]]
	3338	set mm [::format %02d [expr { ($dstDelta / 60 ) % 60 }]]
	3339	set ss [::format %02d [expr { $dstDelta % 60 }]]
	3340	append tzname < $dispDstSignum $hh $mm > $dstSignum $hh : $mm : $ss
	3341	if { $dstYear == 0 } {
	3342	append tzname ,M $dstMonth . $dstDayOfMonth . $dstDayOfWeek
	3343	} else {
	3344	# I have not been able to find any locale on which
	3345	# Windows converts time zone on a fixed day of the year,
	3346	# hence don't know how to interpret the fields.
	3347	# If someone can inform me, I'd be glad to code it up.
	3348	# For right now, we bail out in such a case.
	3349	return :localtime
	3350	}
	3351	append tzname / [::format %02d $dstHour] \
	3352	: [::format %02d $dstMinute] \
	3353	: [::format %02d $dstSecond]
	3354	if { $stdYear == 0 } {
	3355	append tzname ,M $stdMonth . $stdDayOfMonth . $stdDayOfWeek
	3356	} else {
	3357	# I have not been able to find any locale on which
	3358	# Windows converts time zone on a fixed day of the year,
	3359	# hence don't know how to interpret the fields.
	3360	# If someone can inform me, I'd be glad to code it up.
	3361	# For right now, we bail out in such a case.
	3362	return :localtime
	3363	}
	3364	append tzname / [::format %02d $stdHour] \
	3365	: [::format %02d $stdMinute] \
	3366	: [::format %02d $stdSecond]
	3367	}
	3368	dict set WinZoneInfo $data $tzname
	3369	}
	3370
	3371	return [dict get $WinZoneInfo $data]
	3372
	3373	}
	3374
	3375	#----------------------------------------------------------------------
	3376	#
	3377	# LoadTimeZoneFile --
	3378	#
	3379	# Load the data file that specifies the conversion between a
	3380	# given time zone and Greenwich.
	3381	#
	3382	# Parameters:
	3383	# fileName -- Name of the file to load
	3384	#
	3385	# Results:
	3386	# None.
	3387	#
	3388	# Side effects:
	3389	# TZData(:fileName) contains the time zone data
	3390	#
	3391	#----------------------------------------------------------------------
	3392
	3393	proc ::tcl::clock::LoadTimeZoneFile { fileName } {
	3394	variable DataDir
	3395	variable TZData
	3396
	3397	if { [info exists TZData($fileName)] } {
	3398	return
	3399	}
	3400
	3401	# Since an unsafe interp uses the [clock] command in the master,
	3402	# this code is security sensitive. Make sure that the path name
	3403	# cannot escape the given directory.
	3404
	3405	if { ![regexp {^[[.-.][:alpha:]_]+(?:/[[.-.][:alpha:]_]+)*$} $fileName] } {
	3406	return -code error \
	3407	-errorcode [list CLOCK badTimeZone $:fileName] \
	3408	"time zone \":$fileName\" not valid"
	3409	}
	3410	if { [catch {
	3411	source -encoding utf-8 [file join $DataDir $fileName]
	3412	}] } {
	3413	return -code error \
	3414	-errorcode [list CLOCK badTimeZone :$fileName] \
	3415	"time zone \":$fileName\" not found"
	3416	}
	3417	return
	3418	}
	3419
	3420	#----------------------------------------------------------------------
	3421	#
	3422	# LoadZoneinfoFile --
	3423	#
	3424	# Loads a binary time zone information file in Olson format.
	3425	#
	3426	# Parameters:
	3427	# fileName - Relative path name of the file to load.
	3428	#
	3429	# Results:
	3430	# Returns an empty result normally; returns an error if no
	3431	# Olson file was found or the file was malformed in some way.
	3432	#
	3433	# Side effects:
	3434	# TZData(:fileName) contains the time zone data
	3435	#
	3436	#----------------------------------------------------------------------
	3437
	3438	proc ::tcl::clock::LoadZoneinfoFile { fileName } {
	3439
	3440	variable ZoneinfoPaths
	3441
	3442	# Since an unsafe interp uses the [clock] command in the master,
	3443	# this code is security sensitive. Make sure that the path name
	3444	# cannot escape the given directory.
	3445
	3446	if { ![regexp {^[[.-.][:alpha:]_]+(?:/[[.-.][:alpha:]_]+)*$} $fileName] } {
	3447	return -code error \
	3448	-errorcode [list CLOCK badTimeZone $:fileName] \
	3449	"time zone \":$fileName\" not valid"
	3450	}
	3451	foreach d $ZoneinfoPaths {
	3452	set fname [file join $d $fileName]
	3453	if { [file readable $fname] && [file isfile $fname] } {
	3454	break
	3455	}
	3456	unset fname
	3457	}
	3458	ReadZoneinfoFile $fileName $fname
	3459	}
	3460
	3461	#----------------------------------------------------------------------
	3462	#
	3463	# ReadZoneinfoFile --
	3464	#
	3465	# Loads a binary time zone information file in Olson format.
	3466	#
	3467	# Parameters:
	3468	# fileName - Name of the time zone (relative path name of the
	3469	# file).
	3470	# fname - Absolute path name of the file.
	3471	#
	3472	# Results:
	3473	# Returns an empty result normally; returns an error if no
	3474	# Olson file was found or the file was malformed in some way.
	3475	#
	3476	# Side effects:
	3477	# TZData(:fileName) contains the time zone data
	3478	#
	3479	#----------------------------------------------------------------------
	3480
	3481
	3482	proc ::tcl::clock::ReadZoneinfoFile {fileName fname} {
	3483	variable MINWIDE
	3484	variable TZData
	3485	if { ![info exists fname] } {
	3486	return -code error "$fileName not found"
	3487	}
	3488
	3489	if { [file size $fname] > 262144 } {
	3490	return -code error "$fileName too big"
	3491	}
	3492
	3493	# Suck in all the data from the file
	3494
	3495	set f [open $fname r]
	3496	fconfigure $f -translation binary
	3497	set d [read $f]
	3498	close $f
	3499
	3500	# The file begins with a magic number, sixteen reserved bytes,
	3501	# and then six 4-byte integers giving counts of fileds in the file.
	3502
	3503	binary scan $d a4a1x15IIIIII \
	3504	magic version nIsGMT nIsStd nLeap nTime nType nChar
	3505	set seek 44
	3506	set ilen 4
	3507	set iformat I
	3508	if { $magic != {TZif} } {
	3509	return -code error "$fileName not a time zone information file"
	3510	}
	3511	if { $nType > 255 } {
	3512	return -code error "$fileName contains too many time types"
	3513	}
	3514	# Accept only Posix-style zoneinfo. Sorry, 'leaps' bigots.
	3515	if { $nLeap != 0 } {
	3516	return -code error "$fileName contains leap seconds"
	3517	}
	3518
	3519	# In a version 2 file, we use the second part of the file, which
	3520	# contains 64-bit transition times.
	3521
	3522	if {$version eq "2"} {
	3523	set seek [expr {44
	3524	+ 5 * $nTime
	3525	+ 6 * $nType
	3526	+ 4 * $nLeap
	3527	+ $nIsStd
	3528	+ $nIsGMT
	3529	+ $nChar
	3530	}]
	3531	binary scan $d @${seek}a4a1x15IIIIII \
	3532	magic version nIsGMT nIsStd nLeap nTime nType nChar
	3533	if {$magic ne {TZif}} {
	3534	return -code error "seek address $seek miscomputed, magic = $magic"
	3535	}
	3536	set iformat W
	3537	set ilen 8
	3538	incr seek 44
	3539	}
	3540
	3541	# Next come ${nTime} transition times, followed by ${nTime} time type
	3542	# codes. The type codes are unsigned 1-byte quantities. We insert an
	3543	# arbitrary start time in front of the transitions.
	3544
	3545	binary scan $d @${seek}${iformat}${nTime}c${nTime} times tempCodes
	3546	incr seek [expr { ($ilen + 1) * $nTime }]
	3547	set times [linsert $times 0 $MINWIDE]
	3548	set codes {}
	3549	foreach c $tempCodes {
	3550	lappend codes [expr { $c & 0xff }]
	3551	}
	3552	set codes [linsert $codes 0 0]
	3553
	3554	# Next come ${nType} time type descriptions, each of which has an
	3555	# offset (seconds east of GMT), a DST indicator, and an index into
	3556	# the abbreviation text.
	3557
	3558	for { set i 0 } { $i < $nType } { incr i } {
	3559	binary scan $d @${seek}Icc gmtOff isDst abbrInd
	3560	lappend types [list $gmtOff $isDst $abbrInd]
	3561	incr seek 6
	3562	}
	3563
	3564	# Next come $nChar characters of time zone name abbreviations,
	3565	# which are null-terminated.
	3566	# We build them up into a dictionary indexed by character index,
	3567	# because that's what's in the indices above.
	3568
	3569	binary scan $d @${seek}a${nChar} abbrs
	3570	incr seek ${nChar}
	3571	set abbrList [split $abbrs \0]
	3572	set i 0
	3573	set abbrevs {}
	3574	foreach a $abbrList {
	3575	dict set abbrevs $i $a
	3576	incr i [expr { [string length $a] + 1 }]
	3577	}
	3578
	3579	# Package up a list of tuples, each of which contains transition time,
	3580	# seconds east of Greenwich, DST flag and time zone abbreviation.
	3581
	3582	set r {}
	3583	set lastTime $MINWIDE
	3584	foreach t $times c $codes {
	3585	if { $t < $lastTime } {
	3586	return -code error "$fileName has times out of order"
	3587	}
	3588	set lastTime $t
	3589	lassign [lindex $types $c] gmtoff isDst abbrInd
	3590	set abbrev [dict get $abbrevs $abbrInd]
	3591	lappend r [list $t $gmtoff $isDst $abbrev]
	3592	}
	3593
	3594	# In a version 2 file, there is also a POSIX-style time zone description
	3595	# at the very end of the file. To get to it, skip over
	3596	# nLeap leap second values (8 bytes each),
	3597	# nIsStd standard/DST indicators and nIsGMT UTC/local indicators.
	3598
	3599	if {$version eq {2}} {
	3600	set seek [expr {$seek + 8 * $nLeap + $nIsStd + $nIsGMT + 1}]
	3601	set last [string first \n $d $seek]
	3602	set posix [string range $d $seek [expr {$last-1}]]
	3603	if {[llength $posix] > 0} {
	3604	set posixFields [ParsePosixTimeZone $posix]
	3605	foreach tuple [ProcessPosixTimeZone $posixFields] {
	3606	lassign $tuple t gmtoff isDst abbrev
	3607	if {$t > $lastTime} {
	3608	lappend r $tuple
	3609	}
	3610	}
	3611	}
	3612	}
	3613
	3614	set TZData(:$fileName) $r
	3615
	3616	return
	3617	}
	3618
	3619	#----------------------------------------------------------------------
	3620	#
	3621	# ParsePosixTimeZone --
	3622	#
	3623	# Parses the TZ environment variable in Posix form
	3624	#
	3625	# Parameters:
	3626	# tz Time zone specifier to be interpreted
	3627	#
	3628	# Results:
	3629	# Returns a dictionary whose values contain the various pieces of
	3630	# the time zone specification.
	3631	#
	3632	# Side effects:
	3633	# None.
	3634	#
	3635	# Errors:
	3636	# Throws an error if the syntax of the time zone is incorrect.
	3637	#
	3638	# The following keys are present in the dictionary:
	3639	# stdName - Name of the time zone when Daylight Saving Time
	3640	# is not in effect.
	3641	# stdSignum - Sign (+, -, or empty) of the offset from Greenwich
	3642	# to the given (non-DST) time zone. + and the empty
	3643	# string denote zones west of Greenwich, - denotes east
	3644	# of Greenwich; this is contrary to the ISO convention
	3645	# but follows Posix.
	3646	# stdHours - Hours part of the offset from Greenwich to the given
	3647	# (non-DST) time zone.
	3648	# stdMinutes - Minutes part of the offset from Greenwich to the
	3649	# given (non-DST) time zone. Empty denotes zero.
	3650	# stdSeconds - Seconds part of the offset from Greenwich to the
	3651	# given (non-DST) time zone. Empty denotes zero.
	3652	# dstName - Name of the time zone when DST is in effect, or the
	3653	# empty string if the time zone does not observe Daylight
	3654	# Saving Time.
	3655	# dstSignum, dstHours, dstMinutes, dstSeconds -
	3656	# Fields corresponding to stdSignum, stdHours, stdMinutes,
	3657	# stdSeconds for the Daylight Saving Time version of the
	3658	# time zone. If dstHours is empty, it is presumed to be 1.
	3659	# startDayOfYear - The ordinal number of the day of the year on which
	3660	# Daylight Saving Time begins. If this field is
	3661	# empty, then DST begins on a given month-week-day,
	3662	# as below.
	3663	# startJ - The letter J, or an empty string. If a J is present in
	3664	# this field, then startDayOfYear does not count February 29
	3665	# even in leap years.
	3666	# startMonth - The number of the month in which Daylight Saving Time
	3667	# begins, supplied if startDayOfYear is empty. If both
	3668	# startDayOfYear and startMonth are empty, then US rules
	3669	# are presumed.
	3670	# startWeekOfMonth - The number of the week in the month in which
	3671	# Daylight Saving Time begins, in the range 1-5.
	3672	# 5 denotes the last week of the month even in a
	3673	# 4-week month.
	3674	# startDayOfWeek - The number of the day of the week (Sunday=0,
	3675	# Saturday=6) on which Daylight Saving Time begins.
	3676	# startHours - The hours part of the time of day at which Daylight
	3677	# Saving Time begins. An empty string is presumed to be 2.
	3678	# startMinutes - The minutes part of the time of day at which DST begins.
	3679	# An empty string is presumed zero.
	3680	# startSeconds - The seconds part of the time of day at which DST begins.
	3681	# An empty string is presumed zero.
	3682	# endDayOfYear, endJ, endMonth, endWeekOfMonth, endDayOfWeek,
	3683	# endHours, endMinutes, endSeconds -
	3684	# Specify the end of DST in the same way that the start* fields
	3685	# specify the beginning of DST.
	3686	#
	3687	# This procedure serves only to break the time specifier into fields.
	3688	# No attempt is made to canonicalize the fields or supply default values.
	3689	#
	3690	#----------------------------------------------------------------------
	3691
	3692	proc ::tcl::clock::ParsePosixTimeZone { tz } {
	3693
	3694	if {[regexp -expanded -nocase -- {
	3695	^
	3696	# 1 - Standard time zone name
	3697	([[:alpha:]]+ \| <[-+[:alnum:]]+>)
	3698	# 2 - Standard time zone offset, signum
	3699	([-+]?)
	3700	# 3 - Standard time zone offset, hours
	3701	([[:digit:]]{1,2})
	3702	(?:
	3703	# 4 - Standard time zone offset, minutes
	3704	: ([[:digit:]]{1,2})
	3705	(?:
	3706	# 5 - Standard time zone offset, seconds
	3707	: ([[:digit:]]{1,2} )
	3708	)?
	3709	)?
	3710	(?:
	3711	# 6 - DST time zone name
	3712	([[:alpha:]]+ \| <[-+[:alnum:]]+>)
	3713	(?:
	3714	(?:
	3715	# 7 - DST time zone offset, signum
	3716	([-+]?)
	3717	# 8 - DST time zone offset, hours
	3718	([[:digit:]]{1,2})
	3719	(?:
	3720	# 9 - DST time zone offset, minutes
	3721	: ([[:digit:]]{1,2})
	3722	(?:
	3723	# 10 - DST time zone offset, seconds
	3724	: ([[:digit:]]{1,2})
	3725	)?
	3726	)?
	3727	)?
	3728	(?:
	3729	,
	3730	(?:
	3731	# 11 - Optional J in n and Jn form 12 - Day of year
	3732	( J ? ) ( [[:digit:]]+ )
	3733	\| M
	3734	# 13 - Month number 14 - Week of month 15 - Day of week
	3735	( [[:digit:]] + )
	3736	[.] ( [[:digit:]] + )
	3737	[.] ( [[:digit:]] + )
	3738	)
	3739	(?:
	3740	# 16 - Start time of DST - hours
	3741	/ ( [[:digit:]]{1,2} )
	3742	(?:
	3743	# 17 - Start time of DST - minutes
	3744	: ( [[:digit:]]{1,2} )
	3745	(?:
	3746	# 18 - Start time of DST - seconds
	3747	: ( [[:digit:]]{1,2} )
	3748	)?
	3749	)?
	3750	)?
	3751	,
	3752	(?:
	3753	# 19 - Optional J in n and Jn form 20 - Day of year
	3754	( J ? ) ( [[:digit:]]+ )
	3755	\| M
	3756	# 21 - Month number 22 - Week of month 23 - Day of week
	3757	( [[:digit:]] + )
	3758	[.] ( [[:digit:]] + )
	3759	[.] ( [[:digit:]] + )
	3760	)
	3761	(?:
	3762	# 24 - End time of DST - hours
	3763	/ ( [[:digit:]]{1,2} )
	3764	(?:
	3765	# 25 - End time of DST - minutes
	3766	: ( [[:digit:]]{1,2} )
	3767	(?:
	3768	# 26 - End time of DST - seconds
	3769	: ( [[:digit:]]{1,2} )
	3770	)?
	3771	)?
	3772	)?
	3773	)?
	3774	)?
	3775	)?
	3776	$
	3777	} $tz -> x(stdName) x(stdSignum) x(stdHours) x(stdMinutes) x(stdSeconds) \
	3778	x(dstName) x(dstSignum) x(dstHours) x(dstMinutes) x(dstSeconds) \
	3779	x(startJ) x(startDayOfYear) \
	3780	x(startMonth) x(startWeekOfMonth) x(startDayOfWeek) \
	3781	x(startHours) x(startMinutes) x(startSeconds) \
	3782	x(endJ) x(endDayOfYear) \
	3783	x(endMonth) x(endWeekOfMonth) x(endDayOfWeek) \
	3784	x(endHours) x(endMinutes) x(endSeconds)] } {
	3785
	3786	# it's a good timezone
	3787
	3788	return [array get x]
	3789
	3790	} else {
	3791
	3792	return -code error\
	3793	-errorcode [list CLOCK badTimeZone $tz] \
	3794	"unable to parse time zone specification \"$tz\""
	3795
	3796	}
	3797
	3798	}
	3799
	3800	#----------------------------------------------------------------------
	3801	#
	3802	# ProcessPosixTimeZone --
	3803	#
	3804	# Handle a Posix time zone after it's been broken out into
	3805	# fields.
	3806	#
	3807	# Parameters:
	3808	# z - Dictionary returned from 'ParsePosixTimeZone'
	3809	#
	3810	# Results:
	3811	# Returns time zone information for the 'TZData' array.
	3812	#
	3813	# Side effects:
	3814	# None.
	3815	#
	3816	#----------------------------------------------------------------------
	3817
	3818	proc ::tcl::clock::ProcessPosixTimeZone { z } {
	3819
	3820	variable MINWIDE
	3821	variable TZData
	3822
	3823	# Determine the standard time zone name and seconds east of Greenwich
	3824
	3825	set stdName [dict get $z stdName]
	3826	if { [string index $stdName 0] eq {<} } {
	3827	set stdName [string range $stdName 1 end-1]
	3828	}
	3829	if { [dict get $z stdSignum] eq {-} } {
	3830	set stdSignum +1
	3831	} else {
	3832	set stdSignum -1
	3833	}
	3834	set stdHours [lindex [::scan [dict get $z stdHours] %d] 0]
	3835	if { [dict get $z stdMinutes] ne {} } {
	3836	set stdMinutes [lindex [::scan [dict get $z stdMinutes] %d] 0]
	3837	} else {
	3838	set stdMinutes 0
	3839	}
	3840	if { [dict get $z stdSeconds] ne {} } {
	3841	set stdSeconds [lindex [::scan [dict get $z stdSeconds] %d] 0]
	3842	} else {
	3843	set stdSeconds 0
	3844	}
	3845	set stdOffset [expr { ( ( $stdHours * 60 + $stdMinutes )
	3846	* 60 + $stdSeconds )
	3847	* $stdSignum }]
	3848	set data [list [list $MINWIDE $stdOffset 0 $stdName]]
	3849
	3850	# If there's no daylight zone, we're done
	3851
	3852	set dstName [dict get $z dstName]
	3853	if { $dstName eq {} } {
	3854	return $data
	3855	}
	3856	if { [string index $dstName 0] eq {<} } {
	3857	set dstName [string range $dstName 1 end-1]
	3858	}
	3859
	3860	# Determine the daylight name
	3861
	3862	if { [dict get $z dstSignum] eq {-} } {
	3863	set dstSignum +1
	3864	} else {
	3865	set dstSignum -1
	3866	}
	3867	if { [dict get $z dstHours] eq {} } {
	3868	set dstOffset [expr { 3600 + $stdOffset }]
	3869	} else {
	3870	set dstHours [lindex [::scan [dict get $z dstHours] %d] 0]
	3871	if { [dict get $z dstMinutes] ne {} } {
	3872	set dstMinutes [lindex [::scan [dict get $z dstMinutes] %d] 0]
	3873	} else {
	3874	set dstMinutes 0
	3875	}
	3876	if { [dict get $z dstSeconds] ne {} } {
	3877	set dstSeconds [lindex [::scan [dict get $z dstSeconds] %d] 0]
	3878	} else {
	3879	set dstSeconds 0
	3880	}
	3881	set dstOffset [expr { ( ( $dstHours * 60 + $dstMinutes )
	3882	* 60 + $dstSeconds )
	3883	* $dstSignum }]
	3884	}
	3885
	3886	# Fill in defaults for US DST rules
	3887
	3888	if { [dict get $z startDayOfYear] eq {}
	3889	&& [dict get $z startMonth] eq {} } {
	3890	dict set z startMonth 3
	3891	dict set z startWeekOfMonth 2
	3892	dict set z startDayOfWeek 0
	3893	dict set z startHours 2
	3894	dict set z startMinutes 0
	3895	dict set z startSeconds 0
	3896	}
	3897	if { [dict get $z endDayOfYear] eq {}
	3898	&& [dict get $z endMonth] eq {} } {
	3899	dict set z endMonth 11
	3900	dict set z endWeekOfMonth 1
	3901	dict set z endDayOfWeek 0
	3902	dict set z endHours 2
	3903	dict set z endMinutes 0
	3904	dict set z endSeconds 0
	3905	}
	3906
	3907	# Put DST in effect in all years from 1916 to 2099.
	3908
	3909	for { set y 1916 } { $y < 2099 } { incr y } {
	3910	set startTime [DeterminePosixDSTTime $z start $y]
	3911	incr startTime [expr { - wide($stdOffset) }]
	3912	set endTime [DeterminePosixDSTTime $z end $y]
	3913	incr endTime [expr { - wide($dstOffset) }]
	3914	if { $startTime < $endTime } {
	3915	lappend data \
	3916	[list $startTime $dstOffset 1 $dstName] \
	3917	[list $endTime $stdOffset 0 $stdName]
	3918	} else {
	3919	lappend data \
	3920	[list $endTime $stdOffset 0 $stdName] \
	3921	[list $startTime $dstOffset 1 $dstName]
	3922	}
	3923	}
	3924
	3925	return $data
	3926
	3927	}
	3928
	3929	#----------------------------------------------------------------------
	3930	#
	3931	# DeterminePosixDSTTime --
	3932	#
	3933	# Determines the time that Daylight Saving Time starts or ends
	3934	# from a Posix time zone specification.
	3935	#
	3936	# Parameters:
	3937	# z - Time zone data returned from ParsePosixTimeZone.
	3938	# Missing fields are expected to be filled in with
	3939	# default values.
	3940	# bound - The word 'start' or 'end'
	3941	# y - The year for which the transition time is to be determined.
	3942	#
	3943	# Results:
	3944	# Returns the transition time as a count of seconds from
	3945	# the epoch. The time is relative to the wall clock, not UTC.
	3946	#
	3947	#----------------------------------------------------------------------
	3948
	3949	proc ::tcl::clock::DeterminePosixDSTTime { z bound y } {
	3950
	3951	variable FEB_28
	3952
	3953	# Determine the start or end day of DST
	3954
	3955	set date [dict create era CE year $y]
	3956	set doy [dict get $z ${bound}DayOfYear]
	3957	if { $doy ne {} } {
	3958
	3959	# Time was specified as a day of the year
	3960
	3961	if { [dict get $z ${bound}J] ne {}
	3962	&& [IsGregorianLeapYear $y]
	3963	&& ( $doy > $FEB_28 ) } {
	3964	incr doy
	3965	}
	3966	dict set date dayOfYear $doy
	3967	set date [GetJulianDayFromEraYearDay $date[set date {}] 2361222]
	3968	} else {
	3969
	3970	# Time was specified as a day of the week within a month
	3971
	3972	dict set date month [dict get $z ${bound}Month]
	3973	dict set date dayOfWeek [dict get $z ${bound}DayOfWeek]
	3974	set dowim [dict get $z ${bound}WeekOfMonth]
	3975	if { $dowim >= 5 } {
	3976	set dowim -1
	3977	}
	3978	dict set date dayOfWeekInMonth $dowim
	3979	set date [GetJulianDayFromEraYearMonthWeekDay $date[set date {}] 2361222]
	3980
	3981	}
	3982
	3983	set jd [dict get $date julianDay]
	3984	set seconds [expr { wide($jd) * wide(86400)
	3985	- wide(210866803200) }]
	3986
	3987	set h [dict get $z ${bound}Hours]
	3988	if { $h eq {} } {
	3989	set h 2
	3990	} else {
	3991	set h [lindex [::scan $h %d] 0]
	3992	}
	3993	set m [dict get $z ${bound}Minutes]
	3994	if { $m eq {} } {
	3995	set m 0
	3996	} else {
	3997	set m [lindex [::scan $m %d] 0]
	3998	}
	3999	set s [dict get $z ${bound}Seconds]
	4000	if { $s eq {} } {
	4001	set s 0
	4002	} else {
	4003	set s [lindex [::scan $s %d] 0]
	4004	}
	4005	set tod [expr { ( $h * 60 + $m ) * 60 + $s }]
	4006	return [expr { $seconds + $tod }]
	4007
	4008	}
	4009
	4010	#----------------------------------------------------------------------
	4011	#
	4012	# GetLocaleEra --
	4013	#
	4014	# Given local time expressed in seconds from the Posix epoch,
	4015	# determine localized era and year within the era.
	4016	#
	4017	# Parameters:
	4018	# date - Dictionary that must contain the keys, 'localSeconds',
	4019	# whose value is expressed as the appropriate local time;
	4020	# and 'year', whose value is the Gregorian year.
	4021	# etable - Value of the LOCALE_ERAS key in the message catalogue
	4022	# for the target locale.
	4023	#
	4024	# Results:
	4025	# Returns the dictionary, augmented with the keys, 'localeEra'
	4026	# and 'localeYear'.
	4027	#
	4028	#----------------------------------------------------------------------
	4029
	4030	proc ::tcl::clock::GetLocaleEra { date etable } {
	4031
	4032	set index [BSearch $etable [dict get $date localSeconds]]
	4033	if { $index < 0} {
	4034	dict set date localeEra \
	4035	[::format %02d [expr { [dict get $date year] / 100 }]]
	4036	dict set date localeYear \
	4037	[expr { [dict get $date year] % 100 }]
	4038	} else {
	4039	dict set date localeEra [lindex $etable $index 1]
	4040	dict set date localeYear [expr { [dict get $date year]
	4041	- [lindex $etable $index 2] }]
	4042	}
	4043	return $date
	4044
	4045	}
	4046
	4047	#----------------------------------------------------------------------
	4048	#
	4049	# GetJulianDayFromEraYearDay --
	4050	#
	4051	# Given a year, month and day on the Gregorian calendar, determines
	4052	# the Julian Day Number beginning at noon on that date.
	4053	#
	4054	# Parameters:
	4055	# date -- A dictionary in which the 'era', 'year', and
	4056	# 'dayOfYear' slots are populated. The calendar in use
	4057	# is determined by the date itself relative to:
	4058	# changeover -- Julian day on which the Gregorian calendar was
	4059	# adopted in the current locale.
	4060	#
	4061	# Results:
	4062	# Returns the given dictionary augmented with a 'julianDay' key
	4063	# whose value is the desired Julian Day Number, and a 'gregorian'
	4064	# key that specifies whether the calendar is Gregorian (1) or
	4065	# Julian (0).
	4066	#
	4067	# Side effects:
	4068	# None.
	4069	#
	4070	# Bugs:
	4071	# This code needs to be moved to the C layer.
	4072	#
	4073	#----------------------------------------------------------------------
	4074
	4075	proc ::tcl::clock::GetJulianDayFromEraYearDay {date changeover} {
	4076
	4077	# Get absolute year number from the civil year
	4078
	4079	switch -exact -- [dict get $date era] {
	4080	BCE {
	4081	set year [expr { 1 - [dict get $date year] }]
	4082	}
	4083	CE {
	4084	set year [dict get $date year]
	4085	}
	4086	}
	4087	set ym1 [expr { $year - 1 }]
	4088
	4089	# Try the Gregorian calendar first.
	4090
	4091	dict set date gregorian 1
	4092	set jd [expr { 1721425
	4093	+ [dict get $date dayOfYear]
	4094	+ ( 365 * $ym1 )
	4095	+ ( $ym1 / 4 )
	4096	- ( $ym1 / 100 )
	4097	+ ( $ym1 / 400 ) }]
	4098
	4099	# If the date is before the Gregorian change, use the Julian calendar.
	4100
	4101	if { $jd < $changeover } {
	4102	dict set date gregorian 0
	4103	set jd [expr { 1721423
	4104	+ [dict get $date dayOfYear]
	4105	+ ( 365 * $ym1 )
	4106	+ ( $ym1 / 4 ) }]
	4107	}
	4108
	4109	dict set date julianDay $jd
	4110	return $date
	4111	}
	4112
	4113	#----------------------------------------------------------------------
	4114	#
	4115	# GetJulianDayFromEraYearMonthWeekDay --
	4116	#
	4117	# Determines the Julian Day number corresponding to the nth
	4118	# given day-of-the-week in a given month.
	4119	#
	4120	# Parameters:
	4121	# date - Dictionary containing the keys, 'era', 'year', 'month'
	4122	# 'weekOfMonth', 'dayOfWeek', and 'dayOfWeekInMonth'.
	4123	# changeover - Julian Day of adoption of the Gregorian calendar
	4124	#
	4125	# Results:
	4126	# Returns the given dictionary, augmented with a 'julianDay' key.
	4127	#
	4128	# Side effects:
	4129	# None.
	4130	#
	4131	# Bugs:
	4132	# This code needs to be moved to the C layer.
	4133	#
	4134	#----------------------------------------------------------------------
	4135
	4136	proc ::tcl::clock::GetJulianDayFromEraYearMonthWeekDay {date changeover} {
	4137
	4138	# Come up with a reference day; either the zeroeth day of the
	4139	# given month (dayOfWeekInMonth >= 0) or the seventh day of the
	4140	# following month (dayOfWeekInMonth < 0)
	4141
	4142	set date2 $date
	4143	set week [dict get $date dayOfWeekInMonth]
	4144	if { $week >= 0 } {
	4145	dict set date2 dayOfMonth 0
	4146	} else {
	4147	dict incr date2 month
	4148	dict set date2 dayOfMonth 7
	4149	}
	4150	set date2 [GetJulianDayFromEraYearMonthDay $date2[set date2 {}] \
	4151	$changeover]
	4152	set wd0 [WeekdayOnOrBefore [dict get $date dayOfWeek] \
	4153	[dict get $date2 julianDay]]
	4154	dict set date julianDay [expr { $wd0 + 7 * $week }]
	4155	return $date
	4156
	4157	}
	4158
	4159	#----------------------------------------------------------------------
	4160	#
	4161	# IsGregorianLeapYear --
	4162	#
	4163	# Determines whether a given date represents a leap year in the
	4164	# Gregorian calendar.
	4165	#
	4166	# Parameters:
	4167	# date -- The date to test. The fields, 'era', 'year' and 'gregorian'
	4168	# must be set.
	4169	#
	4170	# Results:
	4171	# Returns 1 if the year is a leap year, 0 otherwise.
	4172	#
	4173	# Side effects:
	4174	# None.
	4175	#
	4176	#----------------------------------------------------------------------
	4177
	4178	proc ::tcl::clock::IsGregorianLeapYear { date } {
	4179
	4180	switch -exact -- [dict get $date era] {
	4181	BCE {
	4182	set year [expr { 1 - [dict get $date year]}]
	4183	}
	4184	CE {
	4185	set year [dict get $date year]
	4186	}
	4187	}
	4188	if { $year % 4 != 0 } {
	4189	return 0
	4190	} elseif { ![dict get $date gregorian] } {
	4191	return 1
	4192	} elseif { $year % 400 == 0 } {
	4193	return 1
	4194	} elseif { $year % 100 == 0 } {
	4195	return 0
	4196	} else {
	4197	return 1
	4198	}
	4199
	4200	}
	4201
	4202	#----------------------------------------------------------------------
	4203	#
	4204	# WeekdayOnOrBefore --
	4205	#
	4206	# Determine the nearest day of week (given by the 'weekday'
	4207	# parameter, Sunday==0) on or before a given Julian Day.
	4208	#
	4209	# Parameters:
	4210	# weekday -- Day of the week
	4211	# j -- Julian Day number
	4212	#
	4213	# Results:
	4214	# Returns the Julian Day Number of the desired date.
	4215	#
	4216	# Side effects:
	4217	# None.
	4218	#
	4219	#----------------------------------------------------------------------
	4220
	4221	proc ::tcl::clock::WeekdayOnOrBefore { weekday j } {
	4222
	4223	set k [expr { ( $weekday + 6 ) % 7 }]
	4224	return [expr { $j - ( $j - $k ) % 7 }]
	4225
	4226	}
	4227
	4228	#----------------------------------------------------------------------
	4229	#
	4230	# BSearch --
	4231	#
	4232	# Service procedure that does binary search in several places
	4233	# inside the 'clock' command.
	4234	#
	4235	# Parameters:
	4236	# list - List of lists, sorted in ascending order by the
	4237	# first elements
	4238	# key - Value to search for
	4239	#
	4240	# Results:
	4241	# Returns the index of the greatest element in $list that is less
	4242	# than or equal to $key.
	4243	#
	4244	# Side effects:
	4245	# None.
	4246	#
	4247	#----------------------------------------------------------------------
	4248
	4249	proc ::tcl::clock::BSearch { list key } {
	4250
	4251	if {[llength $list] == 0} {
	4252	return -1
	4253	}
	4254	if { $key < [lindex $list 0 0] } {
	4255	return -1
	4256	}
	4257
	4258	set l 0
	4259	set u [expr { [llength $list] - 1 }]
	4260
	4261	while { $l < $u } {
	4262
	4263	# At this point, we know that
	4264	# $k >= [lindex $list $l 0]
	4265	# Either $u == [llength $list] or else $k < [lindex $list $u+1 0]
	4266	# We find the midpoint of the interval {l,u} rounded UP, compare
	4267	# against it, and set l or u to maintain the invariant. Note
	4268	# that the interval shrinks at each step, guaranteeing convergence.
	4269
	4270	set m [expr { ( $l + $u + 1 ) / 2 }]
	4271	if { $key >= [lindex $list $m 0] } {
	4272	set l $m
	4273	} else {
	4274	set u [expr { $m - 1 }]
	4275	}
	4276	}
	4277
	4278	return $l
	4279	}
	4280
	4281	#----------------------------------------------------------------------
	4282	#
	4283	# clock add --
	4284	#
	4285	# Adds an offset to a given time.
	4286	#
	4287	# Syntax:
	4288	# clock add clockval ?count unit?... ?-option value?
	4289	#
	4290	# Parameters:
	4291	# clockval -- Starting time value
	4292	# count -- Amount of a unit of time to add
	4293	# unit -- Unit of time to add, must be one of:
	4294	# years year months month weeks week
	4295	# days day hours hour minutes minute
	4296	# seconds second
	4297	#
	4298	# Options:
	4299	# -gmt BOOLEAN
	4300	# (Deprecated) Flag synonymous with '-timezone :GMT'
	4301	# -timezone ZONE
	4302	# Name of the time zone in which calculations are to be done.
	4303	# -locale NAME
	4304	# Name of the locale in which calculations are to be done.
	4305	# Used to determine the Gregorian change date.
	4306	#
	4307	# Results:
	4308	# Returns the given time adjusted by the given offset(s) in
	4309	# order.
	4310	#
	4311	# Notes:
	4312	# It is possible that adding a number of months or years will adjust
	4313	# the day of the month as well. For instance, the time at
	4314	# one month after 31 January is either 28 or 29 February, because
	4315	# February has fewer than 31 days.
	4316	#
	4317	#----------------------------------------------------------------------
	4318
	4319	proc ::tcl::clock::add { clockval args } {
	4320
	4321	if { [llength $args] % 2 != 0 } {
	4322	set cmdName "clock add"
	4323	return -code error \
	4324	-errorcode [list CLOCK wrongNumArgs] \
	4325	"wrong \# args: should be\
	4326	\"$cmdName clockval ?number units?...\
	4327	?-gmt boolean? ?-locale LOCALE? ?-timezone ZONE?\""
	4328	}
	4329	if { [catch { expr {wide($clockval)} } result] } {
	4330	return -code error $result
	4331	}
	4332
	4333	set offsets {}
	4334	set gmt 0
	4335	set locale c
	4336	set timezone [GetSystemTimeZone]
	4337
	4338	foreach { a b } $args {
	4339
	4340	if { [string is integer -strict $a] } {
	4341
	4342	lappend offsets $a $b
	4343
	4344	} else {
	4345
	4346	switch -exact -- $a {
	4347
	4348	-g - -gm - -gmt {
	4349	set gmt $b
	4350	}
	4351	-l - -lo - -loc - -loca - -local - -locale {
	4352	set locale [string tolower $b]
	4353	}
	4354	-t - -ti - -tim - -time - -timez - -timezo - -timezon -
	4355	-timezone {
	4356	set timezone $b
	4357	}
	4358	default {
	4359	return -code error \
	4360	-errorcode [list CLOCK badSwitch $flag] \
	4361	"bad switch \"$flag\",\
	4362	must be -gmt, -locale or -timezone"
	4363	}
	4364	}
	4365	}
	4366	}
	4367
	4368	# Check options for validity
	4369
	4370	if { [info exists saw(-gmt)] && [info exists saw(-timezone)] } {
	4371	return -code error \
	4372	-errorcode [list CLOCK gmtWithTimezone] \
	4373	"cannot use -gmt and -timezone in same call"
	4374	}
	4375	if { [catch { expr { wide($clockval) } } result] } {
	4376	return -code error \
	4377	"expected integer but got \"$clockval\""
	4378	}
	4379	if { ![string is boolean $gmt] } {
	4380	return -code error \
	4381	"expected boolean value but got \"$gmt\""
	4382	} else {
	4383	if { $gmt } {
	4384	set timezone :GMT
	4385	}
	4386	}
	4387
	4388	EnterLocale $locale oldLocale
	4389
	4390	set changeover [mc GREGORIAN_CHANGE_DATE]
	4391
	4392	if {[catch {SetupTimeZone $timezone} retval opts]} {
	4393	dict unset opts -errorinfo
	4394	return -options $opts $retval
	4395	}
	4396
	4397	set status [catch {
	4398
	4399	foreach { quantity unit } $offsets {
	4400
	4401	switch -exact -- $unit {
	4402
	4403	years - year {
	4404	set clockval \
	4405	[AddMonths [expr { 12 * $quantity }] \
	4406	$clockval $timezone $changeover]
	4407	}
	4408	months - month {
	4409	set clockval [AddMonths $quantity $clockval $timezone \
	4410	$changeover]
	4411	}
	4412
	4413	weeks - week {
	4414	set clockval [AddDays [expr { 7 * $quantity }] \
	4415	$clockval $timezone $changeover]
	4416	}
	4417	days - day {
	4418	set clockval [AddDays $quantity $clockval $timezone \
	4419	$changeover]
	4420	}
	4421
	4422	hours - hour {
	4423	set clockval [expr { 3600 * $quantity + $clockval }]
	4424	}
	4425	minutes - minute {
	4426	set clockval [expr { 60 * $quantity + $clockval }]
	4427	}
	4428	seconds - second {
	4429	set clockval [expr { $quantity + $clockval }]
	4430	}
	4431
	4432	default {
	4433	error "unknown unit \"$unit\", must be \
	4434	years, months, weeks, days, hours, minutes or seconds" \
	4435	"unknown unit \"$unit\", must be \
	4436	years, months, weeks, days, hours, minutes or seconds" \
	4437	[list CLOCK badUnit $unit]
	4438	}
	4439	}
	4440	}
	4441	} result opts]
	4442
	4443	# Restore the locale
	4444
	4445	if { [info exists oldLocale] } {
	4446	mclocale $oldLocale
	4447	}
	4448
	4449	if { $status == 1 } {
	4450	if { [lindex [dict get $opts -errorcode] 0] eq {CLOCK} } {
	4451	dict unset opts -errorinfo
	4452	}
	4453	return -options $opts $result
	4454	} else {
	4455	return $clockval
	4456	}
	4457
	4458	}
	4459
	4460	#----------------------------------------------------------------------
	4461	#
	4462	# AddMonths --
	4463	#
	4464	# Add a given number of months to a given clock value in a given
	4465	# time zone.
	4466	#
	4467	# Parameters:
	4468	# months - Number of months to add (may be negative)
	4469	# clockval - Seconds since the epoch before the operation
	4470	# timezone - Time zone in which the operation is to be performed
	4471	#
	4472	# Results:
	4473	# Returns the new clock value as a number of seconds since
	4474	# the epoch.
	4475	#
	4476	# Side effects:
	4477	# None.
	4478	#
	4479	#----------------------------------------------------------------------
	4480
	4481	proc ::tcl::clock::AddMonths { months clockval timezone changeover } {
	4482
	4483	variable DaysInRomanMonthInCommonYear
	4484	variable DaysInRomanMonthInLeapYear
	4485	variable TZData
	4486
	4487	# Convert the time to year, month, day, and fraction of day.
	4488
	4489	set date [GetDateFields $clockval $TZData($timezone) $changeover]
	4490	dict set date secondOfDay [expr { [dict get $date localSeconds]
	4491	% 86400 }]
	4492	dict set date tzName $timezone
	4493
	4494	# Add the requisite number of months
	4495
	4496	set m [dict get $date month]
	4497	incr m $months
	4498	incr m -1
	4499	set delta [expr { $m / 12 }]
	4500	set mm [expr { $m % 12 }]
	4501	dict set date month [expr { $mm + 1 }]
	4502	dict incr date year $delta
	4503
	4504	# If the date doesn't exist in the current month, repair it
	4505
	4506	if { [IsGregorianLeapYear $date] } {
	4507	set hath [lindex $DaysInRomanMonthInLeapYear $mm]
	4508	} else {
	4509	set hath [lindex $DaysInRomanMonthInCommonYear $mm]
	4510	}
	4511	if { [dict get $date dayOfMonth] > $hath } {
	4512	dict set date dayOfMonth $hath
	4513	}
	4514
	4515	# Reconvert to a number of seconds
	4516
	4517	set date [GetJulianDayFromEraYearMonthDay \
	4518	$date[set date {}]\
	4519	$changeover]
	4520	dict set date localSeconds \
	4521	[expr { -210866803200
	4522	+ ( 86400 * wide([dict get $date julianDay]) )
	4523	+ [dict get $date secondOfDay] }]
	4524	set date [ConvertLocalToUTC $date[set date {}] $TZData($timezone) \
	4525	$changeover]
	4526
	4527	return [dict get $date seconds]
	4528
	4529	}
	4530
	4531	#----------------------------------------------------------------------
	4532	#
	4533	# AddDays --
	4534	#
	4535	# Add a given number of days to a given clock value in a given
	4536	# time zone.
	4537	#
	4538	# Parameters:
	4539	# days - Number of days to add (may be negative)
	4540	# clockval - Seconds since the epoch before the operation
	4541	# timezone - Time zone in which the operation is to be performed
	4542	# changeover - Julian Day on which the Gregorian calendar was adopted
	4543	# in the target locale.
	4544	#
	4545	# Results:
	4546	# Returns the new clock value as a number of seconds since
	4547	# the epoch.
	4548	#
	4549	# Side effects:
	4550	# None.
	4551	#
	4552	#----------------------------------------------------------------------
	4553
	4554	proc ::tcl::clock::AddDays { days clockval timezone changeover } {
	4555
	4556	variable TZData
	4557
	4558	# Convert the time to Julian Day
	4559
	4560	set date [GetDateFields $clockval $TZData($timezone) $changeover]
	4561	dict set date secondOfDay [expr { [dict get $date localSeconds]
	4562	% 86400 }]
	4563	dict set date tzName $timezone
	4564
	4565	# Add the requisite number of days
	4566
	4567	dict incr date julianDay $days
	4568
	4569	# Reconvert to a number of seconds
	4570
	4571	dict set date localSeconds \
	4572	[expr { -210866803200
	4573	+ ( 86400 * wide([dict get $date julianDay]) )
	4574	+ [dict get $date secondOfDay] }]
	4575	set date [ConvertLocalToUTC $date[set date {}] $TZData($timezone) \
	4576	$changeover]
	4577
	4578	return [dict get $date seconds]
	4579
	4580	}
	4581
	4582	#----------------------------------------------------------------------
	4583	#
	4584	# mc --
	4585	#
	4586	# Wrapper around ::msgcat::mc that caches the result according
	4587	# to the locale.
	4588	#
	4589	# Parameters:
	4590	# Accepts the name of the message to retrieve.
	4591	#
	4592	# Results:
	4593	# Returns the message text.
	4594	#
	4595	# Side effects:
	4596	# Caches the message text.
	4597	#
	4598	# Notes:
	4599	# Only the single-argument version of [mc] is supported.
	4600	#
	4601	#----------------------------------------------------------------------
	4602
	4603	proc ::tcl::clock::mc { name } {
	4604	variable McLoaded
	4605	set Locale [mclocale]
	4606	if { [dict exists $McLoaded $Locale $name] } {
	4607	return [dict get $McLoaded $Locale $name]
	4608	} else {
	4609	set val [::msgcat::mc $name]
	4610	dict set McLoaded $Locale $name $val
	4611	return $val
	4612	}
	4613	}
	4614
	4615	#----------------------------------------------------------------------
	4616	#
	4617	# ClearCaches --
	4618	#
	4619	# Clears all caches to reclaim the memory used in [clock]
	4620	#
	4621	# Parameters:
	4622	# None.
	4623	#
	4624	# Results:
	4625	# None.
	4626	#
	4627	# Side effects:
	4628	# Caches are cleared.
	4629	#
	4630	#----------------------------------------------------------------------
	4631
	4632	proc ::tcl::clock::ClearCaches {} {
	4633
	4634	variable FormatProc
	4635	variable LocaleNumeralCache
	4636	variable McLoaded
	4637	variable CachedSystemTimeZone
	4638	variable TimeZoneBad
	4639
	4640	foreach p [info procs [namespace current]::scanproc'*] {
	4641	rename $p {}
	4642	}
	4643	foreach p [info procs [namespace current]::formatproc'*] {
	4644	rename $p {}
	4645	}
	4646
	4647	catch {unset FormatProc}
	4648	set LocaleNumeralCache {}
	4649	set McLoaded {}
	4650	catch {unset CachedSystemTimeZone}
	4651	set TimeZoneBad {}
	4652	InitTZData
	4653
	4654	}

Note: See TracBrowser for help on using the repository browser.

Download in other formats: