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.
456 lines
12 KiB
456 lines
12 KiB
##+########################################################################## |
|
# |
|
# datefield.tcl |
|
# |
|
# Implements a datefield entry widget ala Iwidget::datefield |
|
# by Keith Vetter (keith@ebook.gemstar.com) |
|
# |
|
# Datefield creates an entry widget but with a special binding to KeyPress |
|
# (based on Iwidget::datefield) to ensure that the current value is always |
|
# a valid date. All normal entry commands and configurations still work. |
|
# |
|
# Usage: |
|
# ::datefield::datefield .df -background yellow -textvariable myDate \ |
|
# -format "%Y-%m-%d" |
|
# pack .df |
|
# |
|
# Bugs: |
|
# o won't work if you programmatically put in an invalid date |
|
# e.g. .df insert end "abc" will cause it to behave erratically |
|
# |
|
# Revisions: |
|
# KPV Feb 07, 2002 - initial revision |
|
# TW Mar 26, 2017 - support more keys and the mouse wheel |
|
# - add option -format to support 3 date-styles: |
|
# "%d.%m.%Y" (for German) |
|
# "%m/%d/%Y" (for English, standard) |
|
# "%Y-%m-%d" (for ISO) |
|
# |
|
##+########################################################################## |
|
############################################################################# |
|
|
|
package require Tk 8.0- |
|
package provide datefield 0.3 |
|
|
|
namespace eval ::datefield { |
|
namespace export datefield |
|
|
|
# Have the widget use tile/ttk should it be available. |
|
|
|
variable entry entry |
|
if {![catch { |
|
package require tile |
|
}]} { |
|
set entry ttk::entry |
|
} |
|
|
|
proc datefield {w args} { |
|
variable entry |
|
variable Format |
|
variable Separator |
|
|
|
set i [lsearch $args "-form*"] |
|
if {$i == -1} { # Default English |
|
set Format($w) "%m/%d/%Y" |
|
} else { |
|
set Format($w) [lindex [lreplace $args $i $i] $i] |
|
switch -- $Format($w) { |
|
"%d.%m.%Y" { # German |
|
} |
|
"%m/%d/%Y" { # English |
|
} |
|
"%Y-%m-%d" { # ISO |
|
} |
|
default { # Error |
|
error "ERROR: Unknown value for option -format on datefield $w $args" |
|
} |
|
} |
|
set args [lreplace $args $i $i] |
|
set args [lreplace $args $i $i] |
|
} |
|
set Separator($w) [string range $Format($w) 2 2] |
|
eval $entry $w -width 10 -justify center $args |
|
if {([$w get] eq "") \ |
|
|| [catch {clock scan [$w get] -format $Format($w)} base]} { |
|
$w delete 0 end |
|
$w insert end [clock format [clock seconds] -format $Format($w)] |
|
} |
|
$w icursor 0 |
|
bind $w <KeyPress> [list ::datefield::KeyPress $w %A %K %s] |
|
bind $w <MouseWheel> [list ::datefield::MouseWheel $w %D] |
|
bind $w <Button1-Motion> break |
|
bind $w <Button2-Motion> break |
|
bind $w <Double-Button> break |
|
bind $w <Triple-Button> break |
|
bind $w <2> break |
|
return $w |
|
} |
|
|
|
proc Spin {w dir unit code} { |
|
variable Format |
|
|
|
set base [clock scan [$w get] -format $Format($w)] |
|
set new [clock add $base $dir $unit] |
|
set date [clock format $new -format $Format($w)] |
|
set icursor [$w index insert] |
|
$w delete 0 end |
|
$w insert end $date |
|
$w icursor $icursor |
|
return $code |
|
} |
|
|
|
proc MouseWheel {w dir} { |
|
$w selection clear |
|
set Dir [expr {$dir / 120}] |
|
return -code [Spin $w $Dir "day" continue] |
|
} |
|
|
|
# internal routine for all key presses in the datefield entry widget |
|
proc KeyPress {w char sym state} { |
|
variable Format |
|
variable Separator |
|
|
|
proc Move {w dir} { |
|
variable Format |
|
|
|
set icursor [$w index insert] |
|
set icursor [expr {($icursor + 10 + $dir) % 10}] |
|
if {$Format($w) ne "%Y-%m-%d"} { # English or German |
|
if {($icursor == 2) || ($icursor == 5)} { # Don't land on a / or . |
|
set icursor [expr {($icursor + 10 + $dir) % 10}] |
|
} |
|
} \ |
|
elseif {($icursor == 4) || ($icursor == 7)} { # ISO # Don't land on a - |
|
set icursor [expr {($icursor + 10 + $dir) % 10}] |
|
} |
|
$w icursor $icursor |
|
} |
|
|
|
set icursor [$w index insert] |
|
$w selection clear |
|
# Handle some non-number characters first |
|
switch -exact -- $sym { |
|
"Down" {return -code [Spin $w -1 "day" continue]} |
|
"End" {$w icursor 9; return -code break} |
|
"minus" {return -code [Spin $w -1 "day" break]} |
|
"Next" {return -code [Spin $w -1 "month" continue]} |
|
"plus" {return -code [Spin $w 1 "day" break]} |
|
"Prior" {return -code [Spin $w 1 "month" continue]} |
|
"Up" {return -code [Spin $w 1 "day" continue]} |
|
"BackSpace" - |
|
"Delete" - |
|
"Left" {Move $w -1; return -code break} |
|
"Right" {Move $w 1; return -code break} |
|
"Tab" { |
|
if {$Format($w) ne "%Y-%m-%d"} { # English or German |
|
if {($state & 5) == 0} { # ->| |
|
if {$icursor < 3} { # from 1st to 2nd |
|
$w icursor 3 |
|
} \ |
|
elseif {$icursor < 6} { # from 2nd to 10th-year |
|
$w icursor 8 |
|
} else { # next widget |
|
return -code continue |
|
} |
|
} \ |
|
elseif {$icursor > 4} { # |<- |
|
$w icursor 3 ;# from year to 2nd |
|
} \ |
|
elseif {$icursor > 1} { # from 2nd to 1st |
|
$w icursor 0 |
|
} else { # previous widget |
|
return -code continue |
|
} |
|
} \ |
|
elseif {($state & 5) == 0} { # ->| ISO |
|
if {$icursor < 5} { # from year to month |
|
$w icursor 5 |
|
} \ |
|
elseif {$icursor < 8} { # from month to day |
|
$w icursor 8 |
|
} else { # next widget |
|
return -code continue |
|
} |
|
} \ |
|
elseif {$icursor > 6} { # |<- |
|
$w icursor 5 ;# from day to month |
|
} \ |
|
elseif {$icursor > 2} { # from month to 10th-year |
|
$w icursor 2 |
|
} else { # previous widget |
|
return -code continue |
|
} |
|
return -code break |
|
} |
|
} |
|
if {$char eq ""} { # remaining special keys |
|
return -code continue |
|
} |
|
if {! [regexp -- {[0-9]} $char]} { # Unknown character |
|
bell |
|
return -code break |
|
} |
|
if {$icursor >= 10} { # Can't add beyond end |
|
bell |
|
return -code break |
|
} |
|
switch -- $Separator($w) { |
|
"." { # German |
|
foreach {day month year} [split [$w get] $Separator($w)] break |
|
if {$icursor < 2} { # DAY SECTION |
|
set endday [lastDay $month $year] |
|
foreach {d1 d2} [split $day ""] break |
|
set cursor 3 ;# Where to leave the cursor |
|
if {$icursor == 0} { # 1st digit of day |
|
if {($char < 3) \ |
|
|| (($char == 3) && ($month ne "02"))} { |
|
set day "$char$d2" |
|
if {$day eq "00"} {set day "01"} |
|
if {$day > $endday} {set day $endday} |
|
set cursor 1 |
|
} else { |
|
set day "0$char" |
|
} |
|
} else { # 2nd digit of day |
|
set day "$d1$char" |
|
if {($day > $endday) || ($day eq "00")} { |
|
bell |
|
return -code break |
|
} |
|
} |
|
$w delete 0 2 |
|
$w insert 0 $day |
|
$w icursor $cursor |
|
return -code break |
|
} |
|
if {$icursor < 5} { # MONTH SECTION |
|
foreach {m1 m2} [split $month ""] break |
|
set cursor 6 ;# Where to leave the cursor |
|
if {$icursor == 3} { # 1st digit of month |
|
if {$char < 2} { |
|
set month "$char$m2" |
|
set cursor 4 |
|
} else { |
|
set month "0$char" |
|
} |
|
if {$month > 12} {set month "10"} |
|
if {$month eq "00"} {set month "01"} |
|
} else { # 2nd digit of month |
|
set month "$m1$char" |
|
if {$month > 12} {set month "0$char"} |
|
if {$month eq "00"} { |
|
bell |
|
return -code break |
|
} |
|
} |
|
$w delete 3 5 |
|
$w insert 3 $month |
|
# Validate the day of the month |
|
if {$day > [set endday [lastDay $month $year]]} { |
|
$w delete 0 2 |
|
$w insert 0 $endday |
|
} |
|
$w icursor $cursor |
|
return -code break |
|
} |
|
set y1 [string range $year 0 0]; # YEAR SECTION |
|
if {$icursor < 7} { # 1st digit of year |
|
if {($char ne "1") && ($char ne "2")} { |
|
bell |
|
return -code break |
|
} |
|
if {$char != $y1} { # Different century |
|
set y 1999 |
|
if {$char eq "2"} {set y 2000} |
|
$w delete 6 end |
|
$w insert end $y |
|
} |
|
$w icursor 7 |
|
return -code break |
|
} |
|
$w delete $icursor |
|
$w insert $icursor $char |
|
if {[catch {clock scan [$w get] -format $Format($w)}] != 0} { # Validate the year |
|
$w delete 6 end |
|
$w insert end $year ;# Put back in the old year |
|
$w icursor $icursor |
|
bell |
|
} |
|
} |
|
"/" { # English |
|
foreach {month day year} [split [$w get] $Separator($w)] break |
|
if {$icursor < 2} { # MONTH SECTION |
|
foreach {m1 m2} [split $month ""] break |
|
set cursor 3 ;# Where to leave the cursor |
|
if {$icursor == 0} { # 1st digit of month |
|
if {$char < 2} { |
|
set month "$char$m2" |
|
set cursor 1 |
|
} else { |
|
set month "0$char" |
|
} |
|
if {$month > 12} {set month "10"} |
|
if {$month eq "00"} {set month "01"} |
|
} else { # 2nd digit of month |
|
set month "$m1$char" |
|
if {$month > 12} {set month "0$char"} |
|
if {$month eq "00"} { |
|
bell |
|
return -code break |
|
} |
|
} |
|
$w delete 0 2 |
|
$w insert 0 $month |
|
# Validate the day of the month |
|
if {$day > [set endday [lastDay $month $year]]} { |
|
$w delete 3 5 |
|
$w insert 3 $endday |
|
} |
|
$w icursor $cursor |
|
return -code break |
|
} |
|
if {$icursor < 5} { # DAY SECTION |
|
set endday [lastDay $month $year] |
|
foreach {d1 d2} [split $day ""] break |
|
set cursor 6 ;# Where to leave the cursor |
|
if {$icursor == 3} { # 1st digit of day |
|
if {($char < 3) \ |
|
|| (($char == 3) && ($month ne "02"))} { |
|
set day "$char$d2" |
|
if {$day eq "00"} {set day "01"} |
|
if {$day > $endday} {set day $endday} |
|
set cursor 4 |
|
} else { |
|
set day "0$char" |
|
} |
|
} else { # 2nd digit of day |
|
set day "$d1$char" |
|
if {($day > $endday) || ($day eq "00")} { |
|
bell |
|
return -code break |
|
} |
|
} |
|
$w delete 3 5 |
|
$w insert 3 $day |
|
$w icursor $cursor |
|
return -code break |
|
} |
|
set y1 [string range $year 0 0]; # YEAR SECTION |
|
if {$icursor < 7} { # 1st digit of year |
|
if {($char ne "1") && ($char ne "2")} { |
|
bell |
|
return -code break |
|
} |
|
if {$char != $y1} { # Different century |
|
set y 1999 |
|
if {$char eq "2"} {set y 2000} |
|
$w delete 6 end |
|
$w insert end $y |
|
} |
|
$w icursor 7 |
|
return -code break |
|
} |
|
$w delete $icursor |
|
$w insert $icursor $char |
|
if {[catch {clock scan [$w get] -format $Format($w)}] != 0} { # Validate the year |
|
$w delete 6 end |
|
$w insert end $year ;# Put back in the old year |
|
$w icursor $icursor |
|
bell |
|
} |
|
} |
|
default { # ISO |
|
foreach {year month day} [split [$w get] $Separator($w)] break |
|
if {$icursor < 4} { # YEAR SECTION |
|
set y1 [string range $year 0 0]; |
|
if {$icursor == 0} { # 1st digit of year |
|
if {($char ne "1") && ($char ne "2")} { |
|
bell |
|
return -code break |
|
} |
|
if {$char != $y1} { # Different century |
|
set y 1999 |
|
if {$char eq "2"} {set y 2000} |
|
$w delete 0 4 |
|
$w insert 0 $y |
|
} |
|
$w icursor 1 |
|
return -code break |
|
} |
|
$w delete $icursor |
|
$w insert $icursor $char |
|
if {[catch {clock scan [$w get] -format $Format($w)}] != 0} { # Validate the year |
|
$w delete 0 4 |
|
$w insert 0 $year ;# Put back in the old year |
|
$w icursor $icursor |
|
bell |
|
} |
|
if {$icursor == 3} { # last digit of year |
|
$w icursor 5 ;# Don't land on a - |
|
} |
|
return -code break |
|
} |
|
if {$icursor < 7} { # MONTH SECTION |
|
foreach {m1 m2} [split $month ""] break |
|
set cursor 8 ;# Where to leave the cursor |
|
if {$icursor == 5} { # 1st digit of month |
|
if {$char < 2} { |
|
set month "$char$m2" |
|
set cursor 6 |
|
} else { |
|
set month "0$char" |
|
} |
|
if {$month > 12} {set month "10"} |
|
if {$month eq "00"} {set month "01"} |
|
} else { # 2nd digit of month |
|
set month "$m1$char" |
|
if {$month > 12} {set month "0$char"} |
|
if {$month eq "00"} { |
|
bell |
|
return -code break |
|
} |
|
} |
|
$w delete 5 7 |
|
$w insert 5 $month |
|
# Validate the day of the month |
|
if {$day > [set endday [lastDay $month $year]]} { |
|
$w delete 8 end |
|
$w insert end $endday |
|
} |
|
$w icursor $cursor |
|
return -code break |
|
} |
|
set endday [lastDay $month $year] ;# DAY SECTION |
|
foreach {d1 d2} [split $day ""] break |
|
set cursor 10 ;# Where to leave the cursor |
|
if {$icursor == 8} { # 1st digit of day |
|
if {($char < 3) \ |
|
|| (($char == 3) && ($month ne "02"))} { |
|
set day "$char$d2" |
|
if {$day eq "00"} {set day "01"} |
|
if {$day > $endday} {set day $endday} |
|
set cursor 9 |
|
} else { |
|
set day "0$char" |
|
} |
|
} else { # 2nd digit of day |
|
set day "$d1$char" |
|
if {($day > $endday) || ($day eq "00")} { |
|
bell |
|
return -code break |
|
} |
|
} |
|
$w delete 8 end |
|
$w insert end $day |
|
$w icursor $cursor |
|
} |
|
} |
|
return -code break |
|
} |
|
|
|
# internal routine that returns the last valid day of a given month and year |
|
proc lastDay {month year} { |
|
return [clock format [clock scan "+1 month -1 day" \ |
|
-base [clock scan "$month/01/$year"]] -format %d] |
|
} |
|
}
|
|
|