Updated 2013-02-24 00:30:29 by RLE

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