Tcl Source Code

Artifact [67f03ffc59]
Login
EuroTcl/OpenACS 11 - 12 JULY 2024, VIENNA

Artifact 67f03ffc598bdf0bb6dc0c9d7058a3cab5879b6a:

Attachment "clock.tcl.patch" to ticket [3475995fff] added by sebres 2012-01-19 17:58:42.
Index: clock.tcl
===================================================================
--- clock.tcl	(revision 78)
+++ clock.tcl	(working copy)
@@ -740,7 +740,7 @@
     # Return either the error or the proc name
 
     if { $status == 1 } {
-	if { [lindex [dict get $opts -errorcode] 0] eq {clock} } {
+	if { [lindex [dict get $opts -errorcode] 0] eq {CLOCK} } {
 	    return -code error $result
 	} else {
 	    return -options $opts $result
@@ -1213,7 +1213,7 @@
              \"$cmdName string\
              ?-base seconds?\
              ?-format string? ?-gmt boolean?\
-             ?-locale LOCALE? ?-timezone ZONE?\""
+             ?-locale LOCALE? ?-timezone ZONE? ?-valid 1|0?\""
     }
 
     # Set defaults
@@ -1224,6 +1224,7 @@
     set gmt 0
     set locale c
     set timezone [GetSystemTimeZone]
+    set validate 1
 
     # Pick up command line options.
 
@@ -1245,6 +1246,9 @@
 	    -t - -ti - -tim - -time - -timez - -timezo - -timezon - -timezone {
 		set timezone $value
 	    }
+	    -v - -valid {
+		set validate $value
+	    }
 	    default {
 		return -code error \
 		    -errorcode [list CLOCK badSwitch $flag] \
@@ -1283,7 +1287,7 @@
 		"legacy \[clock scan\] does not support -locale"
 
 	}
-	return [FreeScan $string $base $timezone $locale]
+	return [FreeScan $string $base $timezone $locale $validate]
     }
 
     # Change locale if a fresh locale has been given on the command line.
@@ -1295,7 +1299,7 @@
 	# Map away the locale-dependent composite format groups
 
 	set scanner [ParseClockScanFormat $format $locale]
-	$scanner $string $base $timezone
+	$scanner $string $base $timezone $validate
 
     } result opts]
 
@@ -1306,11 +1310,10 @@
     }
 
     if { $status == 1 } {
-	if { [lindex [dict get $opts -errorcode] 0] eq {clock} } {
-	    return -code error $result
-	} else {
-	    return -options $opts $result
+	if { [lindex [dict get $opts -errorcode] 0] eq {CLOCK} } {
+	  dict unset opts -errorinfo
 	}
+	return -options $opts -code error -level 1 $result
     } else {
 	return $result
     }
@@ -1335,7 +1338,7 @@
 #
 #----------------------------------------------------------------------
 
-proc ::tcl::clock::FreeScan { string base timezone locale } {
+proc ::tcl::clock::FreeScan { string base timezone locale {validate 1} } {
 
     variable TZData
 
@@ -1422,6 +1425,16 @@
 	dict set date secondOfDay 0
     }
 
+    if {$validate} {
+	if {[catch {
+	  ValidDate $date $string
+	} result opts]} {
+	  if { [lindex [dict get $opts -errorcode] 0] eq {CLOCK} } {
+	    dict unset opts -errorinfo
+	  }
+	  return -options $opts -code error -level 2 $result
+	}
+    }
     dict set date localSeconds \
 	[expr { -210866803200
 		+ ( 86400 * wide([dict get $date julianDay]) )
@@ -2034,6 +2047,10 @@
 	    set date [::tcl::clock::ConvertLocalToUTC $date[set date {}] \
 			  $TZData($timeZone) \
 			  $changeover]
+	
+	    if {$validate} {
+		ValidDate $date $string
+	    }
 	}
     }
 
@@ -2041,7 +2058,7 @@
 
     append procBody {return [dict get $date seconds]} \n
 
-    proc $procName { string baseTime timeZone } $procBody
+    proc $procName { string baseTime timeZone {validate 1} } $procBody
 
     # puts [list proc $procName [list string baseTime timeZone] $procBody]
 
@@ -3068,8 +3085,13 @@
 #----------------------------------------------------------------------
 
 proc ::tcl::clock::GetSystemTimeZone {} {
-
     variable CachedSystemTimeZone
+    if { [info exists CachedSystemTimeZone] } {
+      ## if not switched to another time zone (simply check cached every 10 minutes) :
+      if {abs([clock seconds] - [lindex $CachedSystemTimeZone 1]) < 600} {
+        return [lindex $CachedSystemTimeZone 0]
+      }
+    }
     variable TimeZoneBad
 
     if {[set result [getenv TCL_TZ]] ne {}} {
@@ -3080,28 +3102,25 @@
     if {![info exists timezone]} {
         # Cache the time zone only if it was detected by one of the
         # expensive methods.
-        if { [info exists CachedSystemTimeZone] } {
-            set timezone $CachedSystemTimeZone
-        } elseif { $::tcl_platform(platform) eq {windows} } {
-            set timezone [GuessWindowsTimeZone]
-        } elseif { [file exists /etc/localtime]
-                   && ![catch {ReadZoneinfoFile \
-                                   Tcl/Localtime /etc/localtime}] } {
-            set timezone :Tcl/Localtime
-        } else {
-            set timezone :localtime
-        }
-	set CachedSystemTimeZone $timezone
+	if { $::tcl_platform(platform) eq {windows} } {
+	    set timezone [GuessWindowsTimeZone]
+	} elseif { [file exists /etc/localtime]
+	       && ![catch {ReadZoneinfoFile \
+		       Tcl/Localtime /etc/localtime}] } {
+	    set timezone :Tcl/Localtime
+	} else {
+	    set timezone :localtime
+	}
     }
     if { ![dict exists $TimeZoneBad $timezone] } {
 	dict set TimeZoneBad $timezone [catch {SetupTimeZone $timezone}]
     }
     if { [dict get $TimeZoneBad $timezone] } {
-	return :localtime
-    } else {
-	return $timezone
+	set timezone :localtime
     }
-
+    ## cache (simply check cached every 10 minutes (rounded to 00:10:00)):
+    set CachedSystemTimeZone [list $timezone [expr {[set switchtime [clock seconds]] - $switchtime % 600}]]
+    return $timezone
 }
 
 #----------------------------------------------------------------------
@@ -4691,3 +4710,206 @@
     InitTZData
 
 }
+
+
+#----------------------------------------------------------------------
+# [SEBRES] extension:
+#   - validate :
+#   - create date direct from args (without parsing string) :
+#----------------------------------------------------------------------
+
+proc ::tcl::clock::ValidDate {date string} {
+  ## check date :
+  if {[dict exists $date month] && [dict exists $date dayOfMonth]} {
+    ## first - month :
+    if { [set month [dict get $date month]] > 12 || $month < 1 } {
+      return -code error -errorcode [list CLOCK invalidArgs] "unable to convert date-time string \"$string\": invalid month"
+    }
+    ## by february check leap year :
+    if {$month == 2} {
+      # Todo: correct this for not grigorian:
+      if {![dict exists $date gregorian]} {
+        dict set date gregorian 1
+      }
+      if { [IsGregorianLeapYear $date] } {
+        variable DaysInRomanMonthInLeapYear
+        set hath [lindex $DaysInRomanMonthInLeapYear [expr {$month - 1}]]
+      } else {
+        variable DaysInRomanMonthInCommonYear
+        set hath [lindex $DaysInRomanMonthInCommonYear [expr {$month - 1}]]
+      }
+    } else {
+      variable DaysInRomanMonthInCommonYear
+      set hath [lindex $DaysInRomanMonthInCommonYear [expr {$month - 1}]]
+    }
+    ## check day in month :
+    if { [set day [dict get $date dayOfMonth]] > $hath || $day < 1 } {
+      return -code error -errorcode [list CLOCK invalidArgs] "unable to convert date-time string \"$string\": invalid day"
+    }
+  }
+  ## Oldscan could returns secondOfDay (parsedTime) -1 by invalid time (ex.: 25:00:00) :
+  if {[dict exists $date secondOfDay] && [dict get $date secondOfDay] == -1} {
+    return -code error -errorcode [list CLOCK invalidArgs] "unable to convert date-time string \"$string\": invalid time"
+  }
+  ## check time (00:00:00 - 23:59:59 or 00:00:00[ap]m - 12:00:00[ap]m) :
+  if {[dict exists $date hour]} {
+    if {[set v [dict get $date hour]] < 0 || $v > 23} {
+      return -code error -errorcode [list CLOCK invalidArgs] "unable to convert date-time string \"$string\": invalid time (hour)"
+    }
+    if {[dict exists $date amPmIndicator] && $v > 12} {
+      return -code error -errorcode [list CLOCK invalidArgs] "unable to convert date-time string \"$string\": invalid time (hour/am:pm)"
+    }
+  }
+  if {[dict exists $date minute] && ([set v [dict get $date minute]] < 0 || $v > 59)} {
+    return -code error -errorcode [list CLOCK invalidArgs] "unable to convert date-time string \"$string\": invalid time (minute)"
+  }
+  if {[dict exists $date second] && ([set v [dict get $date second]] < 0 || $v > 59)} {
+    return -code error -errorcode [list CLOCK invalidArgs] "unable to convert date-time string \"$string\": invalid time (second)"
+  }
+}
+
+#----------------------------------------------------------------------
+
+proc ::tcl::clock::MakeDate {args} {
+	set date $args[set args {}]
+	
+	if {![dict exists $date baseTime]} {
+		set baseTime [clock seconds]
+	} else {
+		set baseTime [dict get $date baseTime]
+	}
+
+	set changeover 2361222; #[tcl::clock::mc GREGORIAN_CHANGE_DATE]
+	set tz {}
+	if {[dict exists $date tzName]} {
+		set tz [dict get $date tzName]
+		if {$tz == {}} {
+			set tz [::tcl::clock::GetSystemTimeZone]
+		} elseif {$tz in {:UTC :GMT}} {
+			set tz {}
+		}
+		if {$tz != {}} {
+			variable TZData
+			if {![info exists TZData($tz)]} {
+				::tcl::clock::SetupTimeZone $tz
+			}
+		}
+	}
+
+	dict set date era CE
+	# Julian Day Number from the fields.
+	if {![dict exists $date year]} {
+		if {![dict exists $date yearOfCentury]} {
+			set date [AssignBaseYear $date[set date {}] \
+				$baseTime $tz $changeover]
+		} else {
+			set date [InterpretTwoDigitYear $date[set date {}] $baseTime]
+		}
+	}
+	if {![dict exists $date month]} {
+		set date [AssignBaseMonth $date[set date {}] \
+			$baseTime $tz $changeover]
+	}
+	if {![dict exists $date dayOfMonth]} {
+		variable TZData
+		set date2 [GetDateFields $baseTime $TZData($tz) $changeover]
+		dict set date dayOfMonth [dict get $date2 dayOfMonth]
+	}
+	if {[catch {
+		set date [::tcl::clock::GetJulianDayFromEraYearMonthDay $date[set date {}] $changeover]
+	} msg]} {
+		return -code error -errorcode [list CLOCK invalidArgs] $msg
+	}
+	# Get time of day
+	dict set date secondOfDay [::tcl::clock::InterpretHMS $date]
+	# Assemble seconds, and convert local nominal time to UTC.
+	if { [dict get $date julianDay] > 5373484 } {
+		return -code error -errorcode [list CLOCK dateTooLarge] "requested date too large to represent"
+	}
+	dict set date localSeconds [set secs [expr { -210866803200
+		+ ( 86400 * wide([dict get $date julianDay]) )
+		+ [dict get $date secondOfDay] }]]
+	if {$tz != {}} {
+		set date [::tcl::clock::ConvertLocalToUTC $date[set date {}] $TZData($tz) $changeover]
+		return $date
+	}
+	# set seconds to localSeconds
+	dict set date seconds $secs
+	return $date
+}
+
+#----------------------------------------------------------------------
+
+proc ::tcl::clock::ConvertToSeconds {Y m d H M S {tz {}}} {
+	set date [list \
+		year $Y \
+		month $m \
+		dayOfMonth $d \
+		hour $H \
+		minute $M \
+		second $S \
+	]
+
+	set changeover 2361222; #[tcl::clock::mc GREGORIAN_CHANGE_DATE]
+	if {$tz == {}} {
+		set tz [GetSystemTimeZone]
+	} elseif {$tz ni {:UTC :GMT}} {
+		variable TZData
+		if {![info exists TZData($tz)]} {
+			SetupTimeZone $tz
+		}
+	} else {
+		## don't convert in local :
+		set tz {}
+	}
+
+	dict set date era CE
+	# Julian Day Number from the fields.
+	if {[catch {
+		set date [GetJulianDayFromEraYearMonthDay $date[set date {}] $changeover]
+	} msg]} {
+		return -code error -errorcode [list CLOCK invalidArgs] $msg
+	}
+	# Get time of day
+	dict set date secondOfDay [InterpretHMS $date]
+	# Assemble seconds, and convert local nominal time to UTC.
+	if { [dict get $date julianDay] > 5373484 } {
+		return -code error -errorcode [list CLOCK dateTooLarge] "requested date too large to represent"
+	}
+	set secs [expr { -210866803200
+		+ ( 86400 * wide([dict get $date julianDay]) )
+		+ [dict get $date secondOfDay] }]
+	if {$tz != {}} {
+		variable TZData
+		dict set date localSeconds $secs
+		set date [ConvertLocalToUTC $date[set date {}] $TZData($tz) $changeover]
+		# return utc :
+		return [dict get $date seconds]
+	}
+	# return localSeconds (already utc)
+	return $secs
+}
+
+#----------------------------------------------------------------------
+
+proc ::tcl::clock::ConvertFromSeconds {clock {tz {}}} {
+	variable TZData
+
+	set changeover 2361222; #[tcl::clock::mc GREGORIAN_CHANGE_DATE]
+	if {$tz == {}} {
+		set tz [GetSystemTimeZone]
+	} elseif {$tz ni {:UTC :GMT}} {
+		if {![info exists TZData($tz)]} {
+			SetupTimeZone $tz
+		}
+	}
+	## get date var :
+	set date [GetDateFields $clock $TZData($tz) $changeover]
+	set time [dict get $date localSeconds]
+	## return list Y m d H M S
+	list \
+		[dict get $date year] [dict get $date month] [dict get $date dayOfMonth] \
+		[expr {$time / 3600 % 24}] [expr {$time / 60 % 60}] [expr {$time % 60}]
+}
+
+#----------------------------------------------------------------------