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.
##+##########################################################################
#
# 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 .e1