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