You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
715 lines
28 KiB
715 lines
28 KiB
# -*- tcl -*- |
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
|
# |
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# (C) 2023 |
|
# |
|
# @@ Meta Begin |
|
# Application punk::timeinterval 0.1.0 |
|
# Meta platform tcl |
|
# Meta license <unspecified> |
|
# @@ Meta End |
|
|
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Requirements |
|
package require punk::args |
|
|
|
|
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# shamelessly grabbed from: |
|
#https://wiki.tcl-lang.org/page/Measuring+time+intervals+%28between+two+timestamps%29+with+months+etc |
|
# |
|
namespace eval punk::timeinterval { |
|
|
|
#The free-form 'clock scan' is deprecated. It worked in 8.4 to 8.6/8.7 (and earlier?) - but doesn't work in tcl9 |
|
#proc clock_scan_interval { seconds delta units } { |
|
# # clock_scan_interval formats $seconds to a string for processing by clock scan |
|
# # then returns new timestamp in seconds |
|
# set stamp [clock format $seconds -format "%Y%m%dT%H%M%S"] |
|
# if { $delta < 0 } { |
|
# append stamp " - " [expr { abs( $delta ) } ] " " $units |
|
# } else { |
|
# append stamp " + " $delta " " $units |
|
# } |
|
# return [clock scan $stamp] |
|
#} |
|
|
|
#proc clock_scan_interval { seconds delta units } { |
|
# #8.6+ |
|
# clock add $seconds $delta $units |
|
#} |
|
|
|
namespace export difference |
|
|
|
lappend PUNKARGS [list { |
|
@id -id "::punk::timeinterval::difference" |
|
@cmd -name "punk::timeinterval::difference" -help\ |
|
"difference calculates the interval of time between |
|
the earliest date and the last date |
|
by starting to count at the earliest date. |
|
It returns a dictionary with keys: |
|
years months days hours minutes seconds" |
|
@opts |
|
-maxunit -default years -choices {years months days hours minutes seconds} -help\ |
|
"If maxunit is specified, the resulting dict will still contain all keys, |
|
but keys for larger units will be zero. |
|
e.g when -maxunit is months, years will be zero but months could be |
|
something like 36. |
|
" |
|
-timezone -default "" -help\ |
|
"If unspecified, the timezone will be the |
|
current time zone on the system" |
|
@values -min 2 -max 2 |
|
s1 |
|
s2 |
|
}] |
|
proc difference {args} { |
|
set argd [punk::args::parse $args withid ::punk::timeinterval::difference] |
|
lassign [dict values $argd] leaders opts values received |
|
set maxunit [dict get $opts -maxunit] |
|
set timezone [dict get $opts -timezone] |
|
set s1 [dict get $values s1] |
|
set s2 [dict get $values s2] |
|
|
|
# This proc has audit features. It will automatically |
|
# attempt to correct and report any discrepancies it finds. |
|
|
|
# if s1 and s2 aren't in seconds, convert to seconds. |
|
if { ![string is integer -strict $s1] } { |
|
set s1 [clock scan $s1 -timezone $timezone] |
|
} |
|
if { ![string is integer -strict $s2] } { |
|
set s2 [clock scan $s2 -timezone $timezone] |
|
} |
|
# postgreSQL intervals determine month length based on earliest date in interval calculations. |
|
|
|
# set s1 to s2 in chronological sequence |
|
set sn_list [lsort -integer [list $s1 $s2]] |
|
set s1 [lindex $sn_list 0] |
|
set s2 [lindex $sn_list 1] |
|
|
|
# Arithmetic is done from most significant to least significant |
|
# The interval is spanned in largest units first. |
|
# A new position s1_pN is calculated for the Nth move along the interval. |
|
# s1 is s1_p0 |
|
|
|
# Calculate years from s1_p0 to s2 |
|
set y_count 0 |
|
set s1_p0 $s1 |
|
if {$maxunit eq "years"} { |
|
set s2_y_check $s1_p0 |
|
while { $s2_y_check <= $s2 } { |
|
set s1_p1 $s2_y_check |
|
set y $y_count |
|
incr y_count |
|
set s2_y_check [clock add $s1_p0 $y_count years -timezone $timezone] |
|
} |
|
# interval s1_p0 to s1_p1 counted in y years |
|
|
|
# is the base offset incremented one too much? |
|
set s2_y_check [clock add $s1 $y years -timezone $timezone] |
|
if { $s2_y_check > $s2 } { |
|
set y [expr { $y - 1 } ] |
|
set s2_y_check [clock add $s1 $y years -timezone $timezone] |
|
} |
|
# increment s1 (s1_p0) forward y years to s1_p1 |
|
if { $y == 0 } { |
|
set s1_p1 $s1 |
|
} else { |
|
set s1_p1 [clock add $s1 $y years -timezone $timezone] |
|
} |
|
} else { |
|
set y 0 |
|
set s1_p1 $s1 |
|
} |
|
# interval s1 to s1_p1 counted in y years |
|
|
|
# Calculate months from s1_p1 to s2 |
|
set m_count 0 |
|
set s2_m_check $s1_p1 |
|
set s1_p2 $s1_p1 ;#? |
|
set m 0 |
|
if {$maxunit in {years months}} { |
|
while { $s2_m_check <= $s2 } { |
|
set s1_p2 $s2_m_check |
|
set m $m_count |
|
incr m_count |
|
set s2_m_check [clock add $s1_p1 $m_count months -timezone $timezone] |
|
} |
|
} |
|
# interval s1_p1 to s1_p2 counted in m months |
|
|
|
|
|
set d 0 |
|
set s1_p3 $s1_p2 |
|
if {$maxunit in {years months days}} { |
|
# Calculate interval s1_p2 to s2 in days |
|
# day_in_sec [expr { 60 * 60 * 24 } ] |
|
# 86400 |
|
# Since length of month is not relative, use math. |
|
# Clip any fractional part. |
|
set d [expr { int( ( $s2 - $s1_p2 ) / 86400. ) } ] |
|
# Ideally, this should always be true, but daylight savings.. |
|
# so, go backward one day and make hourly steps for last day. |
|
if { $d > 0 } { |
|
incr d -1 |
|
} |
|
# Move interval from s1_p2 to s1_p3 |
|
set s1_p3 [clock add $s1_p2 $d days -timezone $timezone] |
|
} |
|
|
|
# s1_p3 is less than a day from s2 |
|
|
|
|
|
set h 0 |
|
set s1_p4 $s1_p3 |
|
if {$maxunit in {years months days hours}} { |
|
# Calculate interval s1_p3 to s2 in hours |
|
# hour_in_sec [expr { 60 * 60 } ] |
|
# 3600 |
|
set h [expr { int( ( $s2 - $s1_p3 ) / 3600. ) } ] |
|
# Move interval from s1_p3 to s1_p4 |
|
set s1_p4 [clock add $s1_p3 $h hours -timezone $timezone] |
|
# s1_p4 is less than an hour from s2 |
|
} |
|
|
|
|
|
# Sometimes h = 24, yet is already included as a day! |
|
# For example, this case: |
|
# difference 20010410T000000 19570613T000000 |
|
# from Age() example in PostgreSQL documentation: |
|
# http://www.postgresql.org/docs/9.1/static/functions-datetime.html |
|
# psql test=# select age(timestamp '2001-04-10', timestamp '1957-06-13'); |
|
# age |
|
# ------------------------- |
|
# 43 years 9 mons 27 days |
|
# (1 row) |
|
# According to LibreCalc, the difference is 16007 days |
|
#puts "s2=s1+16007days? [clock format [clock add $s1 16007 days] -format %Y%m%dT%H%M%S]" |
|
# ^ this calc is consistent with 16007 days |
|
# So, let's ignore the Postgresql irregularity for now. |
|
# Here's more background: |
|
# http://www.postgresql.org/message-id/5A86CA18-593F-4517-BB83-995115A6A402@morth.org |
|
# http://www.postgresql.org/message-id/200707060844.l668i89w097496@wwwmaster.postgresql.org |
|
# So, Postgres had a bug.. |
|
|
|
if {$maxunit in {years months days}} { |
|
# Sanity check: if over 24 or 48 hours, push it up to a day unit |
|
set h_in_days [expr { int( $h / 24. ) } ] |
|
if { $h >= 1 } { |
|
# adjust hours to less than a day |
|
set h [expr { $h - ( 24 * $h_in_days ) } ] |
|
incr d $h_in_days |
|
set h_correction_p 1 |
|
} else { |
|
set h_correction_p 0 |
|
} |
|
} |
|
|
|
|
|
set mm 0 |
|
set s1_p5 $s1_p4 |
|
if {$maxunit in {years months days hours minutes}} { |
|
# Calculate interval s1_p4 to s2 in minutes |
|
# minute_in_sec [expr { 60 } ] |
|
# 60 |
|
set mm [expr { int( ( $s2 - $s1_p4 ) / 60. ) } ] |
|
# Move interval from s1_p4 to s1_p5 |
|
set s1_p5 [clock add $s1_p4 $mm minutes -timezone $timezone] |
|
} |
|
|
|
if {$maxunit in {years months days hours}} { |
|
# Sanity check: if 60 minutes, push it up to an hour unit |
|
if { $mm >= 60 } { |
|
# adjust 60 minutes to 1 hour |
|
# puts "difference: debug info mm - 60, h + 1" |
|
set mm [expr { $mm - 60 } ] |
|
incr h |
|
set mm_correction_p 1 |
|
} else { |
|
set mm_correction_p 0 |
|
} |
|
} |
|
|
|
# Calculate interval s1_p5 to s2 in seconds |
|
set s [expr { int( $s2 - $s1_p5 ) } ] |
|
|
|
if {$maxunit in {years months days hours minutes}} { |
|
# Sanity check: if 60 seconds, push it up to one minute unit |
|
if { $s >= 60 } { |
|
# adjust 60 minutes to 1 hour |
|
set s [expr { $s - 60 } ] |
|
incr mm |
|
set s_correction_p 1 |
|
} else { |
|
set s_correction_p 0 |
|
} |
|
} |
|
|
|
#set return_list [list $y $m $d $h $mm $s] |
|
set return_list [dict create years $y months $m days $d hours $h minutes $mm seconds $s] |
|
|
|
# test results by adding difference to s1 to get s2: |
|
set signs_inconsistent_p 0 |
|
set diffterms [list] |
|
dict for {unit t_term} $return_list { |
|
if {$t_term != 0} { |
|
if { $t_term > 0 } { |
|
lappend diffterms +$t_term $unit |
|
} else { |
|
lappend diffterms -[expr { abs( $t_term ) }] $unit |
|
set signs_inconsistent_p 1 |
|
} |
|
} |
|
} |
|
|
|
|
|
#set s2_test [clock scan $s1_test] |
|
set s2_test [clock add $s1 {*}$diffterms -timezone $timezone] |
|
|
|
# puts "test s2 '$s2_test' from: '$s1_test'" |
|
set counter 0 |
|
while { $s2 ne $s2_test && $counter < 30 } { |
|
set s2_diff [expr { $s2_test - $s2 } ] |
|
puts "difference: debug s1 $s1 s2 $s2 y $y m $m d $d h $h s $s s2_diff $s2_diff" |
|
set absdiff [expr {abs($s2_diff)}] |
|
if { $absdiff > 86399 } { |
|
if { $s2_diff > 0 } { |
|
incr d -1 |
|
puts "difference: debug, audit adjustment. decreasing 1 day to $d" |
|
} else { |
|
incr d |
|
puts "difference: debug, audit adjustment. increasing 1 day to $d" |
|
} |
|
} elseif { $absdiff > 3599 } { |
|
if { $s2_diff > 0 } { |
|
incr h -1 |
|
puts "difference: debug, audit adjustment. decreasing 1 hour to $h" |
|
} else { |
|
incr h |
|
puts "difference: debug, audit adjustment. increasing 1 hour to $h" |
|
} |
|
} elseif { $absdiff > 59 } { |
|
if { $s2_diff > 0 } { |
|
incr mm -1 |
|
puts "difference: debug, audit adjustment. decreasing 1 minute to $mm" |
|
} else { |
|
incr mm |
|
puts "difference: debug, audit adjustment. increasing 1 minute to $mm" |
|
} |
|
} elseif { $absdiff > 0 } { |
|
if { $s2_diff > 0 } { |
|
incr s -1 |
|
puts "difference: debug, audit adjustment. decreasing 1 second to $s" |
|
} else { |
|
incr s |
|
puts "difference: debug, audit adjustment. increasing 1 second to $s" |
|
} |
|
} |
|
|
|
set return_list [dict create years $y months $m days $d hours $h minutes $mm seconds $s] |
|
# set return_list [list [expr { abs($y) } ] [expr { abs($m) } ] [expr { abs($d) } ] [expr { abs($h) } ] [expr { abs($mm) } ] [expr { abs($s) } ]] |
|
|
|
# test results by adding difference to s1 to get s2: |
|
set diffterms [list] |
|
dict for {unit t_term} $return_list { |
|
if { $t_term != 0 } { |
|
if { $t_term > 0 } { |
|
lappend diffterms +$t_term $unit |
|
} else { |
|
lappend diffterms -[expr { abs( $t_term ) }] $unit |
|
} |
|
} |
|
} |
|
set s2_test [clock add $s1 {*}$diffterms -timezone $timezone] |
|
|
|
incr counter |
|
} |
|
#if { ( $counter > 0 || $signs_inconsistent_p ) && ( $h_correction_p || $mm_correction_p || $s_correction_p ) } { |
|
# puts "difference: Corrections in the main calculation were applied: h ${h_correction_p}, mm ${mm_correction_p}, s ${s_correction_p}" |
|
#} |
|
if { $signs_inconsistent_p } { |
|
puts "\punk::timeinterval::difference - signs inconsistent y $y m $m d $d h $h mm $mm s $s" |
|
} |
|
if { $s2 eq $s2_test } { |
|
return $return_list |
|
} else { |
|
set s2_diff [expr { $s2_test - $s2 } ] |
|
puts "debug s1 $s1 s1_p1 $s1_p1 s1_p2 $s1_p2 s1_p3 $s1_p3 s1_p4 $s1_p4" |
|
puts "debug y $y m $m d $d h $h mm $mm s $s" |
|
puts "punk::timeinterval::difference - error: s2 is '$s2' but s2_test is '$s2_test' a difference of ${s2_diff} from s1 '$s1_test'." |
|
error "punk::timeinterval::difference result audit fail" "error: s2 is $s2 but s2_test is '$s2_test' a difference of ${s2_diff} from: '$s1_test'." |
|
} |
|
} |
|
|
|
|
|
} |
|
|
|
tcl::namespace::eval punk::timeinterval::experimental { |
|
#The interval_remains.. functions were part of the original code from the wiki |
|
#Updated to use clock add etc - but the result seems to be off by one for the value of days - review |
|
#The original purpose of these functions isn't clearly understood - perhaps it was just a different |
|
#mechanism to calculate the interval as a crosscheck? |
|
|
|
|
|
proc interval_remains_ymdhs { s1 s2 } { |
|
# interval_remains_ymdhs calculates the interval of time between |
|
# the earliest date and the last date |
|
# by starting to count at the last date and work backwards in time. |
|
|
|
# This proc has audit features. It will automatically |
|
# attempt to correct and report any discrepancies it finds. |
|
|
|
# if s1 and s2 aren't in seconds, convert to seconds. |
|
if { ![string is integer -strict $s1] } { |
|
set s1 [clock scan $s1] |
|
} |
|
if { ![string is integer -strict $s2] } { |
|
set s2 [clock scan $s2] |
|
} |
|
# set s1 to s2 in reverse chronological sequence |
|
set sn_list [lsort -decreasing -integer [list $s1 $s2]] |
|
set s1 [lindex $sn_list 0] |
|
set s2 [lindex $sn_list 1] |
|
|
|
# Arithmetic is done from most significant to least significant |
|
# The interval is spanned in largest units first. |
|
# A new position s1_pN is calculated for the Nth move along the interval. |
|
# s1 is s1_p0 |
|
|
|
# Calculate years from s1_p0 to s2 |
|
set y_count 0 |
|
set s1_p0 $s1 |
|
set s2_y_check $s1_p0 |
|
while { $s2_y_check > $s2 } { |
|
set s1_p1 $s2_y_check |
|
set y $y_count |
|
incr y_count -1 |
|
set s2_y_check [clock add $s1_p0 $y_count years] |
|
} |
|
# interval s1_p0 to s1_p1 counted in y years |
|
|
|
|
|
# Calculate months from s1_p1 to s2 |
|
set m_count 0 |
|
set s2_m_check $s1_p1 |
|
while { $s2_m_check > $s2 } { |
|
set s1_p2 $s2_m_check |
|
set m $m_count |
|
incr m_count -1 |
|
set s2_m_check [clock add $s1_p1 $m_count months] |
|
} |
|
# interval s1_p1 to s1_p2 counted in m months |
|
|
|
# Calculate interval s1_p2 to s2 in days |
|
# day_in_sec [expr { 60 * 60 * 24 } ] |
|
# 86400 |
|
# Since length of month is not relative, use math. |
|
# Clip any fractional part. |
|
set d [expr { int( ceil( ( $s2 - $s1_p2 ) / 86400. ) ) } ] |
|
# Ideally, this should always be true, but daylight savings.. |
|
# so, go backward one day and make hourly steps for last day. |
|
if { $d < 0 } { |
|
incr d |
|
} |
|
|
|
# Move interval from s1_p2 to s1_p3 |
|
set s1_p3 [clock add $s1_p2 $d days] |
|
# s1_p3 is less than a day from s2 |
|
|
|
|
|
# Calculate interval s1_p3 to s2 in hours |
|
# hour_in_sec [expr { 60 * 60 } ] |
|
# 3600 |
|
set h [expr { int( ceil( ( $s2 - $s1_p3 ) / 3600. ) ) } ] |
|
# Move interval from s1_p3 to s1_p4 |
|
set s1_p4 [clock add $s1_p3 $h hours] |
|
# s1_p4 is less than an hour from s2 |
|
|
|
# Sanity check: if over 24 or 48 hours, push it up to a day unit |
|
set h_in_days [expr { int( ceil( $h / 24. ) ) } ] |
|
if { $h_in_days <= -1 } { |
|
# adjust hours to less than a day |
|
set h [expr { $h - ( 24 * $h_in_days ) } ] |
|
incr d $h_in_days |
|
set h_correction_p 1 |
|
} else { |
|
set h_correction_p 0 |
|
} |
|
|
|
# Calculate interval s1_p4 to s2 in minutes |
|
# minute_in_sec [expr { 60 } ] |
|
# 60 |
|
set mm [expr { int( ceil( ( $s2 - $s1_p4 ) / 60. ) ) } ] |
|
# Move interval from s1_p4 to s1_p5 |
|
set s1_p5 [clock add $s1_p4 $mm minutes] |
|
|
|
# Sanity check: if 60 minutes, push it up to an hour unit |
|
if { $mm <= -60 } { |
|
# adjust 60 minutes to 1 hour |
|
# puts "interval_remains_ymdhs: debug info mm + 60, h - 1" |
|
set mm [expr { $mm + 60 } ] |
|
incr h -1 |
|
set mm_correction_p 1 |
|
} else { |
|
set mm_correction_p 0 |
|
} |
|
|
|
# Calculate interval s1_p5 to s2 in seconds |
|
set s [expr { $s2 - $s1_p5 } ] |
|
|
|
# Sanity check: if 60 seconds, push it up to one minute unit |
|
if { $s <= -60 } { |
|
# adjust 60 minutes to 1 hour |
|
set s [expr { $s + 60 } ] |
|
incr mm -1 |
|
set s_correction_p 1 |
|
} else { |
|
set s_correction_p 0 |
|
} |
|
|
|
set return_list [list $y $m $d $h $mm $s] |
|
# set return_list [list [expr { abs($y) } ] [expr { abs($m) } ] [expr { abs($d) } ] [expr { abs($h) } ] [expr { abs($mm) } ] [expr { abs($s) } ]] |
|
|
|
# test results by adding difference to s1 to get s2: |
|
set i 0 |
|
#set s1_test [clock format $s1 -format "%Y%m%dT%H%M%S"] |
|
set signs_inconsistent_p 0 |
|
set diffterms [list] |
|
foreach unit {years months days hours minutes seconds} { |
|
set t_term [lindex $return_list $i] |
|
if { $t_term != 0 } { |
|
if { $t_term > 0 } { |
|
#append s1_test " + $t_term $unit" |
|
lappend diffterms +$t_term $unit |
|
set signs_inconsistent_p 1 |
|
} else { |
|
#append s1_test " - [expr { abs( $t_term ) } ] $unit" |
|
lappend diffterms -[expr { abs( $t_term ) } ] $unit |
|
} |
|
} |
|
incr i |
|
} |
|
#set s2_test [clock scan $s1_test] |
|
set s2_test [clock add $s1 {*}$diffterms] |
|
|
|
set counter 0 |
|
while { $s2 ne $s2_test && $counter < 3 } { |
|
set s2_diff [expr { $s2_test - $s2 } ] |
|
puts "\ninterval_remains_ymdhs: debug s1 $s1 s2 $s2 y $y m $m d $d h $h s $s s2_diff $s2_diff" |
|
set absdiff [expr {abs($s2_diff)}] |
|
if { $absdiff >= 86399 } { |
|
if { $s2_diff > 0 } { |
|
incr d -1 |
|
puts "interval_remains_ymdhs: debug, audit adjustment. decreasing 1 day to $d" |
|
} else { |
|
incr d |
|
puts "interval_remains_ymdhs: debug, audit adjustment. increasing 1 day to $d" |
|
} |
|
} elseif { $absdiff > 3599 } { |
|
if { $s2_diff > 0 } { |
|
incr h -1 |
|
puts "interval_remains_ymdhs: debug, audit adjustment. decreasing 1 hour to $h" |
|
} else { |
|
incr h |
|
puts "interval_remains_ymdhs: debug, audit adjustment. increasing 1 hour to $h" |
|
} |
|
} elseif { $absdiff > 59 } { |
|
if { $s2_diff > 0 } { |
|
incr mm -1 |
|
puts "interval_remains_ymdhs: debug, audit adjustment. decreasing 1 minute to $mm" |
|
} else { |
|
incr mm |
|
puts "interval_remains_ymdhs: debug, audit adjustment. increasing 1 minute to $mm" |
|
} |
|
} elseif { $absdiff > 0 } { |
|
if { $s2_diff > 0 } { |
|
incr s -1 |
|
puts "interval_remains_ymdhs: debug, audit adjustment. decreasing 1 second to $s" |
|
} else { |
|
incr s |
|
puts "interval_remains_ymdhs: debug, audit adjustment. increasing 1 second to $s" |
|
} |
|
} |
|
|
|
set return_list [list $y $m $d $h $mm $s] |
|
# set return_list [list [expr { abs($y) } ] [expr { abs($m) } ] [expr { abs($d) } ] [expr { abs($h) } ] [expr { abs($mm) } ] [expr { abs($s) } ]] |
|
|
|
# test results by adding difference to s1 to get s2: |
|
set i 0 |
|
#set s1_test [clock format $s1 -format "%Y%m%dT%H%M%S"] |
|
set diffterms [list] |
|
foreach unit {years months days hours minutes seconds} { |
|
set t_term [lindex $return_list $i] |
|
if { $t_term != 0 } { |
|
if { $t_term > 0 } { |
|
#append s1_test " + $t_term $unit" |
|
lappend diffterms +$t_term $unit |
|
} else { |
|
#append s1_test " - [expr { abs( $t_term ) } ] $unit" |
|
lappend diffterms -[expr { abs( $t_term ) } ] $unit |
|
} |
|
} |
|
incr i |
|
} |
|
#set s2_test [clock scan $s1_test] |
|
set s2_test [clock add $s1 {*}$diffterms] |
|
incr counter |
|
} |
|
if { ( $counter > 0 || $signs_inconsistent_p ) && ( $h_correction_p || $mm_correction_p || $s_correction_p ) } { |
|
# puts "interval_remains_ymdhs: Corrections in the main calculation were applied: h ${h_correction_p}, mm ${mm_correction_p}, s ${s_correction_p}" |
|
} |
|
if { $signs_inconsistent_p } { |
|
puts "\ninterval_remains_ymdhs: signs inconsistent y $y m $m d $d h $h mm $mm s $s" |
|
} |
|
if { $s2 eq $s2_test } { |
|
return $return_list |
|
} else { |
|
set s2_diff [expr { $s2_test - $s2 } ] |
|
puts "debug s1 $s1 s1_p1 $s1_p1 s1_p2 $s1_p2 s1_p3 $s1_p3 s1_p4 $s1_p4" |
|
puts "debug y $y m $m d $d h $h mm $mm s $s" |
|
puts "interval_remains_ymdhs error: s2 is '$s2' but s2_test is '$s2_test' a difference of ${s2_diff} from s1 '$s1_test'." |
|
# error "result audit fails" "error: s2 is $s2 but s2_test is '$s2_test' a difference of ${s2_diff} from: '$s1_test'." |
|
} |
|
|
|
} |
|
|
|
|
|
proc interval_remains_ymdhs_w_units { t1 t2 } { |
|
# interval_remains_ymdhs_w_units |
|
# returns interval_remains_ymdhs values with units |
|
set v_list [interval_remains_ymdhs $t2 $t1] |
|
set i 0 |
|
set a "" |
|
foreach f {years months days hours minutes seconds} { |
|
append a "[lindex $v_list $i] $f \n" |
|
incr i |
|
} |
|
return $a |
|
} |
|
|
|
|
|
} |
|
|
|
|
|
|
|
# == === === === === === === === === === === === === === === |
|
# Sample 'about' function with punk::args documentation |
|
# == === === === === === === === === === === === === === === |
|
tcl::namespace::eval punk::timeinterval { |
|
tcl::namespace::export {[a-zA-Z]*} ;# Convention: export all lowercase |
|
variable PUNKARGS |
|
variable PUNKARGS_aliases |
|
|
|
lappend PUNKARGS [list { |
|
@id -id "(package)punk::timeinterval" |
|
@package -name "punk::timeinterval" -help\ |
|
"time interval from wiki" |
|
}] |
|
|
|
namespace eval argdoc { |
|
#namespace for custom argument documentation |
|
proc package_name {} { |
|
return punk::timeinterval |
|
} |
|
proc about_topics {} { |
|
#info commands results are returned in an arbitrary order (like array keys) |
|
set topic_funs [info commands [namespace current]::get_topic_*] |
|
set about_topics [list] |
|
foreach f $topic_funs { |
|
set tail [namespace tail $f] |
|
lappend about_topics [string range $tail [string length get_topic_] end] |
|
} |
|
#Adjust this function or 'default_topics' if a different order is required |
|
return [lsort $about_topics] |
|
} |
|
proc default_topics {} {return [list Description *]} |
|
|
|
# ------------------------------------------------------------- |
|
# get_topic_ functions add more to auto-include in about topics |
|
# ------------------------------------------------------------- |
|
proc get_topic_Description {} { |
|
punk::args::lib::tstr [string trim { |
|
package punk::timeinterval |
|
basic time interval calculations |
|
} \n] |
|
} |
|
proc get_topic_License {} { |
|
return "X11" |
|
} |
|
proc get_topic_Version {} { |
|
return "$::punk::timeinterval::version" |
|
} |
|
proc get_topic_Contributors {} { |
|
set authors {{various "https://wiki.tcl-lang.org/page/Measuring+time+intervals+%28between+two+timestamps%29+with+months+etc"} {Julian Noble <julian@precisium.com.au>}} |
|
set contributors "" |
|
foreach a $authors { |
|
append contributors $a \n |
|
} |
|
if {[string index $contributors end] eq "\n"} { |
|
set contributors [string range $contributors 0 end-1] |
|
} |
|
return $contributors |
|
} |
|
proc get_topic_notes {} { |
|
punk::args::lib::tstr -return string { |
|
X11 license - is MIT with additional clause regarding use of contributor names. |
|
} |
|
} |
|
# ------------------------------------------------------------- |
|
} |
|
|
|
# we re-use the argument definition from punk::args::standard_about and override some items |
|
set overrides [dict create] |
|
dict set overrides @id -id "::punk::timeinterval::about" |
|
dict set overrides @cmd -name "punk::timeinterval::about" |
|
dict set overrides @cmd -help [string trim [punk::args::lib::tstr { |
|
About punk::timeinterval |
|
}] \n] |
|
dict set overrides topic -choices [list {*}[punk::timeinterval::argdoc::about_topics] *] |
|
dict set overrides topic -choicerestricted 1 |
|
dict set overrides topic -default [punk::timeinterval::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict |
|
set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] |
|
lappend PUNKARGS [list $newdef] |
|
proc about {args} { |
|
package require punk::args |
|
#standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on |
|
set argd [punk::args::parse $args withid ::punk::timeinterval::about] |
|
lassign [dict values $argd] _leaders opts values _received |
|
punk::args::package::standard_about -package_about_namespace ::punk::timeinterval::argdoc {*}$opts {*}[dict get $values topic] |
|
} |
|
} |
|
# end of sample 'about' function |
|
# == === === === === === === === === === === === === === === |
|
|
|
|
|
# ----------------------------------------------------------------------------- |
|
# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked |
|
# ----------------------------------------------------------------------------- |
|
# variable PUNKARGS |
|
# variable PUNKARGS_aliases |
|
namespace eval ::punk::args::register { |
|
#use fully qualified so 8.6 doesn't find existing var in global namespace |
|
lappend ::punk::args::register::NAMESPACES ::punk::timeinterval |
|
} |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Ready |
|
package provide punk::timeinterval [namespace eval punk::timeinterval { |
|
variable version |
|
set version 0.1.0 |
|
}] |
|
return
|
|
|