# timebox.tcl
#
# Andy Goth <[email protected]>
#
# This code is available under the same license as Tcl/Tk, available online at
# http://www.tcl.tk/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 {![string is digit -strict $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: