Keith Vetter 2002-02-20 : I recently needed a datefield widget but didn't want to include the whole iwidget package. So, I just took the iwidget datefield code and modified to work under tcl only. This is part of TkLib.
KPV 2004-12-02 : I've modified the code to allow various different date formats via an optional -format <fmt> option. The format must five characters long and be of the form: AxByC where ABC is some ordering of "y", "m" and "d" and xy are any two separator characters. Some common format strings include: m/d/y, m-d-y, y/m/d, y:m:d.
ofv 2005-11-24 : This widget is hardly usable for certain date formats. For instance, when the widget shows 10-02-2005 (in d-m-y format) and the user wants 31-12-2005, overwriting '10' with '31' gives '28' as the day, as the too-smart widget knows that February has not 31 days. You are forced to first edit the month, go backwards and edit the day. Confusing and annoying. I'm afraid validate-on-focus-exit is the only cure for this.
beernutmark 2008-09-20 : One other major difference between this datefield and the iwidgets::datefield is the ability to set the intelligence to low. In my application I need to be able to set a date of 0000-00-00 (which can be stored in the mysql database) to indicate that the date has not been determined. Then the system knows to look for entries with that date and do whatever it needs to with it.
##+##########################################################################
#
# datefield.tcl
#
# Implements a datefield entry widget ala Iwidget::datefield
# by Keith Vetter
#
# Datefield creates an entry widget but with a special binding to
# KeyPress to ensure that the current value is always a valid date.
# All normal entry commands and configurations still work.
#
# Usage:
# ::datefield::datefield <widget> ?-format y/m/d?
#
# Example Usage:
# ::datefield::datefield .df -format m/d/y -bg yellow -textvariable myDate
# pack .df
#
# Formats: format must be 5 characters long and of the form: AxByC
# where ABC is some ordering of "y", "m" and "d" and xy are two
# arbitrary separator characters. Some valid formats include:
# m/d/y, m-d-y, y/m/d, y:m:d
#
# 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
# KPV Oct 09, 2002 - Made to understand multiple fixed-length formats
# Ferenc Engard Jan 11, 2004 - fixed tab handling, focus in and home/end
# KPV Dec 02, 2004 - allow multiple simultaneous formats
#
##+##########################################################################
#############################################################################
namespace eval ::datefield {
namespace export datefield
variable instanceID 0
variable pos
variable DEFAULT
variable FORMATS
array set DEFAULT {format "y/m/d"}
array set FORMATS {
mdy {0 2 3 5 6 10 10 "%m/%d/%Y"}
myd {0 2 8 10 3 7 10 "%m/%Y/%d"}
dmy {3 5 0 2 6 10 10 "%d/%m/%Y"}
dym {8 10 0 2 3 7 10 "%d/%Y/%m"}
ymd {5 7 8 10 0 4 10 "%Y/%m/%d"}
ydm {8 10 5 7 0 4 10 "%Y/%d/%m"}
}
proc datefield {w args} {
variable pos
variable instanceID
set id [incr instanceID]
for {set i 1} {$i < $id} {incr i} { ;# Garbage collect
if {[info exists pos($i,widget)] && ! [winfo exists $pos($i,widget)]} {
catch {array unset pos $i,*}
}
}
set args [processArgs $id $args]
set pos($id,widget) $w
eval entry $w -width 10 -justify center $args
$w insert end [clock format [clock seconds] -format $pos($id,cformat)]
$w icursor 0
bind $w <KeyPress> [list ::datefield::dfKeyPress $id $w %A %K %s]
bind $w <FocusIn> "$w selection clear; $w icursor 0"
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 processArgs {id arglist} {
variable pos
variable DEFAULT
variable FORMATS
foreach arg [array names DEFAULT] { ;# Process options we care about
set opts($arg) $DEFAULT($arg)
set n [lsearch $arglist "-$arg"]
if {$n == -1} continue
set opts($arg) [lindex $arglist [expr {$n + 1}]]
set arglist [lreplace $arglist $n [expr {$n + 1}]]
}
if {[string length $opts(format)] != 5} {
error "xunknown date format \"$opts(format)\""
}
foreach {a sep1 b sep2 c} [split $opts(format) ""] break
set nformat [string tolower "$a$b$c"]
if {! [info exists FORMATS($nformat)]} {
error "unknown date format \"$opts(format)\""
}
if {[string is integer $sep1] || [string is integer $sep2]} {
error "illegal date format \"$opts(format)\""
}
foreach var [list m1 m2 d1 d2 y1 y2 len cformat] f $FORMATS($nformat) {
set pos($id,$var) $f
}
regsub {/} $pos($id,cformat) $sep1 pos($id,cformat)
regsub {/} $pos($id,cformat) $sep2 pos($id,cformat)
return $arglist
}
# internal routine for all key presses in the datefield entry widget
proc dfKeyPress {id w char sym state} {
variable pos
set icursor [$w index insert]
# Handle some non-number characters first
if {$sym == "plus" || $sym == "Up" || \
$sym == "minus" || $sym == "Down"} {
set dir "1 day"
if {$sym == "minus" || $sym == "Down"} {
set dir "-1 day"
}
set base [clock scan [Normalize $id $w]]
if {[catch {set new [clock scan $dir -base $base]}] != 0} {
bell
return -code break
}
set xdate [clock format $new -format "%m/%d/%Y"]
if {[catch {clock scan $xdate}]} {
bell
return -code break
}
$w delete 0 end
$w insert end [clock format $new -format $pos($id,cformat)]
$w icursor $icursor
return -code break
} elseif {$sym == "Right" || $sym == "Left" || $sym == "BackSpace" || \
$sym == "Delete"} {
set dir -1
if {$sym == "Right"} {set dir 1}
set icursor [expr {($icursor+$pos($id,len) + $dir) % $pos($id,len)}]
;# Don't land on a slash
if {$icursor == $pos($id,m2) || $icursor == $pos($id,d2) \
|| $icursor == $pos($id,y2)} {
set icursor [expr {($icursor+$pos($id,len)+$dir)%$pos($id,len)}]
}
$w icursor $icursor
return -code break
} elseif {($sym == "Control_L") || ($sym == "Shift_L") || \
($sym == "Control_R") || ($sym == "Shift_R")} {
return -code break
} elseif {$sym == "Home"} {
$w icursor 0
return -code break
} elseif {$sym == "End"} {
$w icursor end
return -code break
} elseif {$sym == "Tab" || $sym == "ISO_Left_Tab"} {;# Tab key
return -code continue ;# Just leave the widget
} elseif {$sym == "Tab" && ($state & (0x01 + 0x04)) == 0} {;# Tab key
if {$icursor == $pos($id,len)} {return -code continue}
if {$icursor >= $pos($id,m1) && $icursor < $pos($id,m2)} {
set cursor $pos($id,m2)
} elseif {$icursor >= $pos($id,d1) && $icursor < $pos($id,d2)} {
set cursor $pos($id,d2)
} else {
set cursor $pos($id,y2)
}
if {[incr cursor] >= $pos($id,len)} {
return -code continue ;# Tabbed out of the widget
}
$w icursor $cursor
return -code break
} elseif {$sym == "Tab" && ($state && (0x01 + 0x04)) != 0} {
return -code continue ;# Just leave the widget
set cursor -1
if {$icursor > $pos($id,m2) && $pos($id,m1) > $cursor} {set cursor $pos($id,m1)}
if {$icursor > $pos($id,d2) && $pos($id,d1) > $cursor} {set cursor $pos($id,d1)}
if {$icursor > $pos($id,y2) && $pos($id,y1) > $cursor} {set cursor $pos($id,y1)}
if {$cursor < 0} {
return -code continue ;# Tabbed out of the widget
}
$w icursor $cursor
return -code break
}
if {! [regexp {[0-9]} $char]} { ;# Unknown character
bell
return -code break
}
if {$icursor >= $pos($id,len)} { ;# Can't add beyond end
bell
return -code break
}
foreach {month day year} [split [Normalize $id $w] "/"] break
#puts "[$w get] => [Normalize $id $w] = $month/$day/$year"
# MONTH SECTION
if {$icursor >= $pos($id,m1) && $icursor < $pos($id,m2)} {
#puts "in month"
foreach {m1 m2} [split $month ""] break
set cursor [expr {$pos($id,m2) + 1}] ;# Where to leave the cursor
if {$icursor == $pos($id,m1)} { ;# 1st digit of month
if {$char < 2} {
set month "$char$m2"
set cursor [expr {$pos($id,m1) + 1}]
} else {
set month "0$char"
}
if {$month > 12} {set month 10}
if {$month == "00"} {set month "01"}
} else { ;# 2nd digit of month
set month "$m1$char"
if {$month > 12} {set month "0$char"}
if {$month == "00"} {
bell
return -code break
}
}
$w delete $pos($id,m1) $pos($id,m2)
$w insert $pos($id,m1) $month
# Validate the day of the month
if {$day > [set endday [lastDay $month $year]]} {
$w delete $pos($id,d1) $pos($id,d2)
$w insert $pos($id,d1) $endday
}
$w icursor $cursor
return -code break
}
# DAY SECTION
if {$icursor >= $pos($id,d1) && $icursor < $pos($id,d2)} {
#puts "in day"
set endday [lastDay $month $year]
foreach {d1 d2} [split $day ""] break
set cursor [expr {$pos($id,d2) + 1}] ;# Where to leave the cursor
if {$icursor <= $pos($id,d1)} { ;# 1st digit of day
if {$char < 3 || ($char == 3 && $month != "02")} {
set day "$char$d2"
if {$day == "00"} { set day "01" }
if {$day > $endday} {set day $endday}
set cursor [expr {$pos($id,d1) + 1}]
} else {
set day "0$char"
}
} else { ;# 2nd digit of day
set day "$d1$char"
if {$day > $endday || $day == "00"} {
bell
return -code break
}
}
$w delete $pos($id,d1) $pos($id,d2)
$w insert $pos($id,d1) $day
$w icursor $cursor
return -code break
}
# YEAR SECTION
#puts "in year"
set y1 [string index $year 0]
if {$icursor == $pos($id,y1)} { ;# 1st digit of year
if {$char != "1" && $char != "2"} {
bell
return -code break
}
if {$char != $y1} { ;# Different century
set y 1999
if {$char == "2"} {set y 2000 }
$w delete $pos($id,y1) $pos($id,y2)
$w insert $pos($id,y1) $y
}
$w icursor [expr {$pos($id,y1) + 1}]
return -code break
}
$w delete $icursor
$w insert $icursor $char
if {[catch {clock scan [Normalize $id $w]}] != 0} { ;# Validate year
$w delete $pos($id,y1) $pos($id,y2)
$w insert $pos($id,y1) $year ;# Put back in the old year
$w icursor $icursor
bell
return -code break
}
if {$icursor == $pos($id,y2)-1} {
$w icursor [expr {$icursor + 2}]
}
return -code break
}
# internal routine that returns the last valid day of a given month and year
proc lastDay {month year} {
set days [clock format [clock scan "+1 month -1 day" \
-base [clock scan "$month/01/$year"]] -format %d]
}
proc Normalize {id w} {
variable pos
set date [$w get]
set m [string range $date $pos($id,m1) [expr {$pos($id,m2) - 1}]]
set d [string range $date $pos($id,d1) [expr {$pos($id,d2) - 1}]]
set y [string range $date $pos($id,y1) [expr {$pos($id,y2) - 1}]]
return "$m/$d/$y"
}
}
################################################################
################################################################
#
# DEMO CODE
#
catch {. config -padx 10 -pady 10}
set tests {"default" "y/m/d" "m/d/y" "d/m/y"}
set id 0
foreach fmt $tests {
incr id
label .l$id -text "Format: $fmt => "
if {$fmt eq "default"} {
::datefield::datefield .e$id
} else {
::datefield::datefield .e$id -format $fmt
}
grid .l$id .e$id -pady 10
}
focus .e1TWu - 2024-07-30 18:23:10
As of Mar 26, 2017 there is an intermediate enhanced version 0.3 in the repository of tklib. I was not aware of the changes on this page.
KPV -- 2024-08-02
It looks like the tklib version contain none of the revisions made to the code on this page.
TWu - 2024-08-05 21:0:45
Yes, I started with the version 0.2 from ActiveState repository in 2017. As noted before, I did not know these enhancements and page.
I had only the need of dates in ISO- and German-format - and like You - have individual settings for each widget.
Now a merge to the above is the way forward, or is a simple replace better? Keith, what's Your opinion on this? Thanks!