timebox

AMG: Timebox is a time entry megawidget for Tcl/Tk. It's a bit different from the average megawidget in that it is in fact just a spinbox, rather than a bunch of widgets packed into a frame. At any rate, it facilitates entry of time and date, and it supports many of the same field format codes as clock.

Neat features:

  • Text entry: Typing in a time value works fairly naturally. Typing is destructive, overwriting text already present to preserve the fixed format: Backspace works like the left arrow key.
  • Spinner entry: The up and down arrows and the spinner buttons increment and decrement the currently selected field, so you can easily advance through days, months, and years.
  • Linked variables: A timebox can be linked to procedures or other widgets via linked variables. Linked variables can be numeric (seconds since 1970) or textual (formatted time string). This linkage works both ways; setting the linked variable will update the timebox as well.
  • Copy and paste: Copy and paste work. Pasted text replaces text already in the timebox widget.
  • Validation: The time is constantly validated. No keypress which would result in an invalid time is allowed. Somehow timebox manages to do this without being annoying, and anyone who has had experience with key validation knows that's an impressive feat.

The most important feature is timebox supports date entry as well as time-of-day entry.

Timebox accepts any of spinbox's configure options at widget creation time, plus it supports some additional options:

  • -variable: Specify linked integer time variable.
  • -textvariable: Specify linked string time variable.
  • -format: Set format string. See below for format codes.
  • -value: Set initial value.
  • -base: Base time when date fields are not used.
  • -timezone: Time zone.
  • -command: Script to execute on value change. The new integer time value is appended to the script.
  • -help: Provide a usage summary message.

The -format option accepts the following format codes, in addition to literal text:

  • %Y: four-digit year (2007)
  • %b: month of year (Jan-Dec)
  • %m: month of year (01-12)
  • %a: day of week (Sun-Sat)
  • %d: day of month (01-31)
  • %P: half-day indicator (am,pm)
  • %p: half-day indicator (AM,PM)
  • %H: military hour (00-23)
  • %I: civilian hour (12-11)
  • %M: minute of hour (00-59)
  • %S: second of minute (00-59)
  • %%: literal %

Timebox's predecessor is [timeentry].

Alas, timebox is not internationalized. It also doesn't gracefully handle 32-bit overflow. As megawidgets go, it's very limited; the created widget is just a spinbox, so it doesn't support any bindings nor extra widget configure options. ttk::spinbox is not (yet) used.

timebox screenshot

# timebox.tcl
#
# Andy Goth <[email protected]>
#
# This code is available under the same license as Tcl/Tk, available online at
# https://www.tcl-lang.org/software/tcltk/license.html for your review.

package require Tcl 8.5

namespace eval ::timebox {
    namespace export widget
    namespace path {::tcl::mathop ::tcl::mathfunc}

    # Format field code definition table.  Columns: (0) code character, (1)
    # field width, (2) time unit, (3) type, (4) list of valid strings.  Codes
    # are sorted in order of decreasing significance, i.e. years to seconds.
    variable Codes {
        {Y 4 year   int}
        {b 3 month  str {Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec}}
        {m 2 month  int}
        {a 3 day    other}
        {d 2 day    int}
        {P 2 ampm   str {am pm}}
        {p 2 ampm   str {AM PM}}
        {H 2 hour   int}
        {I 2 hour   int}
        {M 2 minute int}
        {S 2 second int}
    }
}

# Do nothing.
proc ::timebox::Noop {args} {}

# Scan a time string into an integer.
proc ::timebox::Scan {win time} {
    variable ${win}::fmt
    variable ${win}::base
    variable ${win}::timezone

    set arguments [list -format $fmt]
    if {$base ne "now"} {
        lappend arguments -base $base
    }
    if {$timezone ne ""} {
        lappend arguments -timezone $timezone
    }
    clock scan $time {*}$arguments
}

# Format an integer into a time string.
proc ::timebox::Format {win time} {
    variable ${win}::fmt
    variable ${win}::timezone
    clock format $time -format $fmt -timezone $timezone
}

# Perform clock arithmetic.
proc ::timebox::Add {win time args} {
    variable ${win}::timezone
    if {$timezone ne ""} {
        lappend args -timezone $timezone
    }
    clock add $time {*}$args
}

# Create traces for linked variables.
proc ::timebox::Create_variable_traces {win} {
    variable ${win}::numvar
    variable ${win}::textvar

    # Create traces for the numeric and textual variables, if they exist.
    foreach {var type} [list $numvar integer $textvar string] {
        if {$var ne ""} {
            trace add variable $var {write unset}\
                    [list ::timebox::Trace_variable $win $type]
        }
    }
}

# Delete traces for linked variables.
proc ::timebox::Delete_variable_traces {win} {
    variable ${win}::numvar
    variable ${win}::textvar

    # Delete traces for the numeric and textual variables.
    foreach {var type} [list $numvar integer $textvar string] {
        if {$var ne ""} {
            trace remove variable $var {write unset}\
                    [list ::timebox::Trace_variable $win $type]
        }
    }
}

# Variable write/unset handler.
proc ::timebox::Trace_variable {win type varname _ op} {
    upvar #0 $varname var

    # Handle the variable operation.  Determine if this operation is valid.
    set reject 0
    if {$op eq "write"} {
        # Validate on write.  Convert the time to an integer so the time
        # string can be regenerated below.
        if {$type eq "integer"} {
            if {![regexp {^-?\d+$} $var]} {
                set reject 1
            } else {
                set time $var
            }
        } elseif {[catch {Scan $win $var} time]} {
            set reject 1
        }
    } elseif {$op eq "unset"} {
        # Prevent unsetting the variable.
        set reject 1
    }

    # If the variable change is rejected, restore the old value.  If the
    # variable change is accepted, update the widget text to match.
    if {$reject} {
        if {$type eq "integer"} {
            set var [Scan $win [$win get]]
        } else {
            set var [$win get]
        }
    } else {
        # Update the widget, using the correct time format.
        $win set [Format $win $time]

        # Ensure string variables are canonicalized.
        if {$type eq "string"} {
            set var [$win get]
        }
    }
}

# Command rename/delete handler.
proc ::timebox::Trace_command {old_win new_win op} {
    # Strip namespace qualifiers from the old and new command names.
    set old_win [namespace tail $old_win]
    set new_win [namespace tail $new_win]

    # Delete the old variable traces.
    Delete_variable_traces $old_win

    # Create new traces if the widget is being renamed not deleted, and
    # create a new namespace for the state variables.  IMPORTANT: Tk itself
    # doesn't seem to properly support widget renaming, so things are likely
    # to break anyway.
    if {$op eq "rename"} {
        # Copy variables into the new namespace.
        namespace eval $new_win
        foreach var [info vars ${old_win}::*] {
            set ::timebox::${new_win}::[namespace tail $var] [set $var]
        }

        # Create variable traces.
        Create_variable_traces $new_win
    }

    # Delete the old namespace.
    namespace delete $old_win
}

# Separate internal options from options for the spinbox.
proc ::timebox::Scan_options {args} {
    # Set some defaults.
    dict set options timebox -base 0
    dict set options timebox -timezone ""
    dict set options timebox -command ::timebox::Noop
    dict set options spinbox -width 0
    dict set options spinbox -font Courier

    # Separate time-specific options from generic spinbox options.
    foreach {option value} $args {
        if {$option in {-variable -textvariable -format -value
                        -base -timezone -command -help}} {
            dict set options timebox $option $value
        } else {
            dict set options spinbox $option $value
        }
    }

    # If requested, return a help string.
    if {[dict exists $options timebox -help]} {
        error "timebox-specific options:\
             \n  -variable    : Specify linked integer time variable.\
             \n  -textvariable: Specify linked string time variable.\
             \n  -format      : Set format string.\
             \n  -value       : Set initial value.\
             \n  -base        : Base time when date fields are not used.\
             \n  -timezone    : Time zone.\
             \n  -command     : Script to execute on value change.\
             \n  -help        : Print this message.\
             \nAll other options are passed through to spinbox.\
             \nFormat codes:\
             \n  %Y: four-digit year    (2007)\
             \n  %b: month of year      (Jan-Dec)\
             \n  %m: month of year      (01-12)\
             \n  %a: day of week        (Sun-Sat)\
             \n  %d: day of month       (01-31)\
             \n  %P: half-day indicator (am,pm)\
             \n  %p: half-day indicator (AM,PM)\
             \n  %H: military hour      (00-23)\
             \n  %I: civilian hour      (12-11)\
             \n  %M: minute of hour     (00-59)\
             \n  %S: second of minute   (00-59)\
             \n  %%: literal %"
    }

    # Require -format.
    if {![dict exists $options timebox -format]} {
        error "-format required but not specified"
    }

    # Validate -timezone.
    set timezone [dict get $options timebox -timezone]
    if {[catch {clock format 0 -timezone $timezone} error]} {
        error $error
    }

    # Return the internal and generic spinbox options.
    return $options
}

# Expand the format string.
proc ::timebox::Expand_format {fmt} {
    variable Codes

    # Ensure at least one format code is given.
    if {![regexp {(?:^|[^%])(?:%%)*%([^%])} $fmt]} {
        error "invalid format string \"$fmt\": must contain at least\
               one format code"
    }

    # Iterate through all format codes in the format string.
    set old_end 0
    set index 0
    set seen_ampm 0
    set seen_12hr 0
    foreach {beg end} [concat {*}[regexp -inline -indices -all %. $fmt] x] {
        if {$beg ne "x"} {
            # Get the format character.
            set char [string range $fmt [expr {$beg + 1}] $end]

            # Skip %%.
            if {$char eq "%"} {
                continue
            }

            # Keep track of %p, %P, and %I.
            if {$char in {p P}} {
                set seen_ampm 1
            } elseif {$char eq "I"} {
                set seen_12hr 1
            }
        }

        # If literal text precedes this code or is at the end of the format
        # string, add it to the expanded form.
        if {($beg eq "x" && $old_end < [string length $fmt])
         || ($beg ne "x" && $beg > $old_end)} {
            if {$beg eq "x"} {
                set str [string range $fmt $old_end end]
            } else {
                set str [string range $fmt $old_end [expr {$beg - 1}]]
            }
            set str [string map {%% %} $str]
            set len [string length $str]
            lappend expfmt [list $index [expr {$index + $len - 1}] literal $str]
            incr index $len
        }

        # If not at the end of the string, add this code to the result.
        if {$beg ne "x"} {
            set char [string index $fmt [expr {$beg + 1}]]
            set code [lsearch -exact -index 0 $Codes $char]
            if {$code < 0} {
                foreach code $Codes {
                    lappend valid %[lindex $code 0]
                }
                set valid [join [lsort $valid] ", "]
                error "unsupported format code \"%$char\": must be one of\
                       $valid, or %%"
            }
            set len [lindex $Codes $code 1]
            lappend expfmt [list $index [expr {$index + $len - 1}] field $code]
            incr index $len

            # Track the ending index of this format code in order to detect
            # sequences of literal text.
            set old_end [expr {$end + 1}]
        }
    }

    # It's illegal to have a 12-hour clock without AM/PM.
    if {$seen_12hr && !$seen_ampm} {
        error "invalid format string \"$fmt\": %I cannot be specified\
               without also using %p or %P"
    }

    # Return the expanded format.
    return $expfmt
}

# Return the index of the least significant field within a subrange.
proc ::timebox::Lsig_field {expfmt {beg 0} {end inf}} {
    variable Codes

    # Search through the specified subrange of the expanded format for the
    # highest-numbered (i.e. least significant) format code.
    set lsig_code -1
    set lsig_index -1
    set index 0
    foreach {field_beg field_end type code} [concat {*}$expfmt] {
        if {$type eq "field" && $code > $lsig_code
         && $beg <= $field_end && $field_beg <= $end} {
            set lsig_code $code
            set lsig_index $index
        }
        incr index
    }

    # Return the index of the least significant format code in the expanded
    # format specification.  Return -1 if no format codes appeared in the
    # specified subrange.
    return $lsig_index
}

# timebox validator.  This procedure gives the timebox its clock behavior.
proc ::timebox::Validate {win validate edit current edit_beg action command} {
    variable Codes
    variable ${win}::fmt
    variable ${win}::expfmt
    variable ${win}::numvar
    variable ${win}::textvar

    # Make the action string a little bit more palatable.
    if {$action in {-1 0 1}} {
        set action [lindex {forced delete insert} [expr {$action + 1}]]
    }

    # Forced validation always succeeds.
    if {$action eq "forced"} {
        return 1
    }

    # Handle delete simply by backing up the cursor.
    if {$action eq "delete"} {
        $win icursor $edit_beg
        return 0
    }

    # Determine how many characters are being edited.
    set edit_len [string length $edit]
    set edit_end [expr {$edit_beg + $edit_len - 1}]

    # Identify the current field.  If a selection is present and using the
    # spinners, use the least significant field within the selection.
    # Otherwise, use the nearest time field, if not already inside one.
    if {$action in {up down} && [$win selection present]} {
        # Use the least significant field in the selection, or if that
        # fails, use the least significant field in the whole widget.
        set field_idx [Lsig_field $expfmt [$win index sel.first]\
                                          [$win index sel.last]]
        if {$field_idx == -1} {
            set field_idx [Lsig_field $expfmt]
        }
        set event seek_lsig_field
    } else {
        # Find the time field nearest the cursor.  Skip over literals.  When
        # doing an insert, also skip over fields of type "other".
        set field_idx 0
        set seek_forward 0
        set valid_cond {($type ne "literal" && ($action ne "insert"
                        || [lindex $Codes $code 3] ne "other"))}
        foreach {field_beg field_end type code} [concat {*}$expfmt] {
            # Check to see if this field is valid.
            if $valid_cond {
                # If seeking the first or next valid field, stop now.
                # Otherwise remember that this field is valid so that it
                # later will be possible to rewind to it.
                if {$seek_forward} {
                    break
                } else {
                    set valid_idx $field_idx
                }
            }

            # Check to see if this is the field in which the cursor lies.
            if {$field_beg <= $edit_beg && $edit_beg <= $field_end} {
                # Also check the validity of this field.
                if $valid_cond {
                    # The cursor is inside a valid field.  Stop now.
                    set event inside_field
                    break
                } else {
                    # The cursor is inside an invalid field, so rewind to
                    # the previous valid field, or if this is the first
                    # field, advance to the first valid field.  If
                    # performing an insert, always advance.
                    set event seek_near_field
                    if {$action ne "insert" && [info exists valid_idx]} {
                        set field_idx $valid_idx
                        break
                    } else {
                        set seek_forward 1
                    }
                }
            }
            incr field_idx 1
        }

        # If the cursor is at the end of the string, it won't be inside any
        # time fields, so rewind to the last valid time field.
        if {$field_idx == [llength $expfmt]} {
            for {incr field_idx -1} {$field_idx > 0} {incr field_idx -1} {
                lassign [lindex $expfmt $field_idx] field_beg\
                                                    field_end type code
                if $valid_cond {
                    break
                }
            }
            set event seek_near_field
        }
    }

    # Get information about the current field.
    lassign [lindex $expfmt $field_idx] field_beg field_end _ code
    lassign [lindex $Codes $code] char width unit type valid

    # Adjust the edit beginning and ending positions based on the insertion
    # cursor's relationship to the current field.
    if {$event eq "seek_lsig_field"} {
        # Select entire field.
        set edit_beg $field_beg
        set edit_end $field_end
    } elseif {$event eq "seek_near_field"} {
        # Determine whether it was necessary to seek forward or backward.
        if {$edit_beg < $field_beg} {
            # Advance.
            set edit_beg $field_beg
            set edit_end [expr {$field_beg + $edit_len - 1}]
        } else {
            # Don't allow inserting after the end of the field.
            if {$action eq "insert"} {
                return 0
            }

            # Rewind.
            set edit_beg [expr {$field_end - $edit_len + 1}]
            set edit_end $field_end
        }
    }

    # Figure out the new text after the edit.
    if {$action in {up down}} {
        # Forbid years greater than 9999.  (Y10K bug oh no!)
        if {$action eq "up" && [lindex $Codes $code 0] eq "Y"
         && [string range $current $field_beg $field_end] eq "9999"} {
            return 0
        }

        # Determine the step value.
        if {$unit eq "ampm"} {
            # Special-case AM/PM to get less surprising behavior.
            if {[string index $current $field_beg] in {a A}} {
                set step {12 hour}
            } else {
                set step {-12 hour}
            }
        } else {
            # Use negative step for down and positive step for up.
            set step [list [dict get {down -1 up 1} $action] $unit]
        }

        # Add the step value to the current time.
        set time [Add $win [Scan $win $current] {*}$step]

        # Generate a new time string with the correct format.
        set new [Format $win $time]
    } else {
        # Possibly try repeatedly.
        set chances 1
        set orig $current
        for {set round 0} {$round < $chances} {incr round} {
            # Perform the change.
            set new [string replace $current $edit_beg $edit_end $edit]

            # For string fields, use the first valid string with this
            # prefix.
            if {$type eq "str"} {
                # Get the prefix.
                set pre [string range $new $field_beg $edit_end]
                set len [expr {$edit_end - $field_beg + 1}]
                set found 0

                # Search the valid string list for this prefix.
                foreach str $valid {
                    if {[string equal -nocase -length $len $pre $str]} {
                        set new [string replace $new $field_beg $field_end $str]
                        set found 1
                        break
                    }
                }

                # If no match was found, and if inserting, fail.
                if {!$found} {
                    return 0
                }
            }

            # Canonicalize the time string.
            if {[catch {Scan $win $new} time]} {
                # Abort if the format is bad.
                return 0
            }
            set new [Format $win $time]

            # If this results in the edit itself being mutated, try again
            # but with the other fields zeroed out.
            if {![string equal -nocase\
                    [string range $new $edit_beg $edit_end] $edit]} {
                # If this is the second failure, abort.
                if {$chances == 2} {
                    return 0
                }

                # Zero stuff which may be interfering.
                if {$type eq "int"} {
                    # Replace subsequent digits of this field with zeroes.
                    set current [string replace $orig [expr {$edit_end + 1}]\
                            $field_end [string repeat 0\
                            [expr {$field_end - $edit_end}]]]
                } else {
                    # Replace the day-of-month field(s) with 01.
                    set current $orig
                    foreach {day_beg day_end day_type day_code}\
                            [concat {*}$expfmt] {
                        if {$day_type eq "field"
                         && [lindex $Codes $day_code 0] eq "d"} {
                            set current [string replace $current\
                                    $day_beg $day_end 01]
                        }
                    }
                }

                # Now try again.
                incr chances
            }
        }
    }

    # Write the new time string to the widget.
    $win set $new

    # Sync linked variables.  Temporarily disable variable traces while
    # writing to the linked variables.
    if {$numvar ne "" || $textvar ne ""} {
        Delete_variable_traces $win
        foreach {var value} [list $numvar $time $textvar $new] {
            if {$var ne ""} {
                set $var $value
            }
        }
        Create_variable_traces $win
    }

    # When using insert mode, advance the cursor past the separator.  When
    # using the spinners, highlight the current field.
    if {$action eq "insert"} {
        # Figure out where the cursor should be moved.
        set cursor [expr {$edit_end + 1}]

        # If the cursor moved past the end of the field, move it to the
        # beginning of the next field, skipping literals.
        if {$cursor > $field_end} {
            set found 0
            foreach {field_beg field_end type code} [concat {*}$expfmt] {
                if {$found && $type eq "field"} {
                    set cursor $field_beg
                    break
                }
                if {$field_beg <= $cursor && $cursor <= $field_end} {
                    if {$type eq "field"} {
                        break
                    } else {
                        set found 1
                    }
                }
            }
        }

        # Move the cursor.
        $win selection clear
        $win icursor $cursor
    } elseif {$action in {up down}} {
        # Highlight (select) the current field.
        focus $win
        $win selection range $field_beg [expr {$field_end + 1}]
        $win icursor [expr {$field_end + 1}]
    }

    # Reinstall the validator.
    $win config -validate $validate

    # Invoke the on-update command.
    uplevel #0 $command $time

    # Don't allow Tk to set the widget value; it's already done.
    return 0
}

# timebox widget command.
proc ::timebox::widget {win args} {
    # Get options, divided into timebox and spinbox groups.  Make all
    # spinbox options into local variables.
    set options [Scan_options {*}$args]
    set sbopts [dict get $options spinbox]
    set myopts [dict get $options timebox]

    # Expand the format string.
    set fmt [dict get $myopts -format]
    set expfmt [Expand_format $fmt]

    # Get linked variables.
    foreach {option var} {-variable numvar -textvariable textvar} {
        if {[dict exists $myopts $option]} {
            set $var ::[dict get $myopts $option]
        } else {
            set $var ""
        }
    }

    # Get other options.
    set base [dict get $options timebox -base]
    set timezone [dict get $options timebox -timezone]
    set cmd [dict get $options timebox -command]

    # Create a namespace in which to store widget state.
    namespace eval $win {}
    foreach var {fmt expfmt numvar textvar base timezone} {
        set ::timebox::${win}::$var [set $var]
    }

    # Prepare to delete the namespace if anything bad happens.
    if {[catch {
        # Determine the initial time value.
        if {[dict exists $myopts -value]} {
            set initval [dict get $myopts -value]
        } elseif {$numvar ne "" && [info exists $numvar]} {
            set initval [set $numvar]
        } elseif {$textvar ne "" && [info exists $textvar]} {
            set initval [set $textvar]
        } else {
            set initval 0
        }
        if {![string is digit -strict $initval]} {
            set initval [Scan $win $initval]
        }
        if {$numvar ne ""} {
            set $numvar $initval
        }
        if {$textvar ne ""} {
            set $textvar [Format $win $initval]
        }

        # Create the spinbox widget.
        set validate [string map {% %%} ::timebox::Validate]
        set lcmd [list $cmd]
        spinbox $win {*}$sbopts -validate key -command "[list $validate] %W\
                \[%W cget -validate\] {} %s \[%W index insert\] %d $lcmd"\
                -validatecommand [list $validate %W %v %S %s %i %d $cmd]

        # Set traces on linked variables.
        Create_variable_traces $win

        # Arrange for the traces to be updated or removed when the widget is
        # renamed or deleted.
        trace add command $win {rename delete} ::timebox::Trace_command

        # Set the spinbox's initial text, and position the cursor at the
        # start of the least significant field.
        $win set [Format $win $initval]
        $win icursor [lindex $expfmt [Lsig_field $expfmt] 0]
    } result err_opts]} {
        # On error, delete the namespace and abort.
        namespace delete $win
        return -options $err_opts $result
    }

    # Return the widget path to the caller.
    return $win
}

# Make the timebox widget command available under the name "timebox".
interp alias {} ::timebox {} ::timebox::widget

# Example!
proc p {args} {puts $args}
package require Tk
pack [timebox .t -variable foo -format "%a %b %d %I:%M:%S %p %Y" -timezone :UTC]
pack [timebox .t2 -variable foo -format "%Y-%m-%d %H:%M:%S" -command p] -fill x
pack [entry .e -textvariable foo] -fill x
wm title . timebox
wm resizable . 0 0

# vim: set ts=4 sts=4 sw=4 tw=80 et ft=tcl:

Negative time values

beware I'll let someone else consider if changing string is digit to string is integer breaks any functionality, but it would stop it from rejecting dates before 1970.

AMG: [string is integer] has problems with 32-bit integer overflow. Actually, on Tcl 8.5.8 and 8.6b2, it seems more like 33-bit integer overflow, since it'll return true for any integer whose magnitude fits in a 32-bit integer:

% string is integer 4294967295
1
% string is integer -4294967295
1
% string is integer 4294967296
0
% string is integer -4294967296
0

A little odd. Let's use [regexp {^-?\d+$}]. I've substituted that into the above code. Please test it and let me know if it works for your purposes.

(*) I favor renaming [string is integer] to [string is int], matching the int() mathfunc we already have. Then the new [string is integer] would return true for any integer, whether or not it fits in a machine word. I know, it could be called [string is entier] to match the entier() mathfunc, but I'm not a fan of the name "entier".