# copyright (C) 1997-2006 Jean-Luc Fontaine (mailto:jfontain@free.fr)
# this program is free software: please read the COPYRIGHT file enclosed in this package or use the Help Copyright menu

# $Id: dbgui.tcl,v 1.62 2006/01/28 19:16:59 jfontain Exp $


class database {

    # dialog box used to display module instances in database, eventually SQL query that can be used to retrieve data for a
    # specific instance, and is also used as a drag site for database module instances to drop in database instances container

    proc displayAndSelectInstances {} {     ;# invoking code must insure that there is a valid database connection before invocation
        if {[info exists (dialog)]} {                                                                                      ;# exists
            raise $widget::($dialog::($(dialog),dialog),path)                                                     ;# make it visible
        } else {
            set (dialog) [new dialog .]                                                           ;# display instances from database
            dialog::deleteCommand $(dialog) {unset database::(dialog)}
        }
    }

    proc removeInstances {} {                                             ;# instances dialog object can only be deleted via its GUI
        if {![info exists (dialog)]} return
        delete $dialog::($(dialog),dialog)
    }

    proc displayAndSelectRange {} {
        if {[info exists (range)]} {                                                                                       ;# exists
            raise $widget::($rangeDialog::($(range),dialog),path)                                                 ;# make it visible
        } else {
            set (range) [new rangeDialog . {unset database::(range)}]                           ;# display database range dialog box
        }
    }

    proc setRange {from to} {
        if {[info exists (range)]} {
            rangeDialog::update $(range) $from $to
        }
    }

    class dialog {

        proc dialog {this parentPath args} switched {$args} {
            set dialog [new dialogBox .\
                -buttons hoc -default o -title [mc {moodss: Database instances}] -otherbuttons SQL\
                -helpcommand {generalHelpWindow #menus.file.database.load} -x [winfo pointerx .] -y [winfo pointery .]\
                -grab release -command "database::dialog::validated $this" -deletecommand "delete $this"\
            ]
            wm geometry $widget::($dialog,path) 500x400
            composite::configure $dialog ok -state disabled                        ;# OK button disabled until proper cell selection
            lappend ($this,tips) [linkedHelpWidgetTip $composite::($dialog,help,path)]\
                [new widgetTip -path $composite::($dialog,SQL,path)\
                     -text [mc {toggles the display of the SQL query that can be used to retrieve the data cell history}]\
                ]
            set frame [frame $widget::($dialog,path).frame]
            set scroll [new scroll tree $frame]
            set tree $composite::($scroll,scrolled,path)
            $tree bindText <Control-Button-1> {}; $tree bindImage <Control-Button-1> {}               ;# prevent multiple selections
            $tree configure\
                -dragenabled 0 -dropenabled 0 -deltay [expr {[font metrics $font::(mediumNormal) -linespace] + 4}]\
                -background $widget::option(listbox,background) -selectbackground $widget::option(listbox,selectbackground)\
                -selectforeground $widget::option(listbox,selectforeground)\
                -closecmd "database::dialog::stateChange $this 0" -opencmd "database::dialog::stateChange $this 1"\
                -linestipple gray50 -crossopenimage $configuration::minusIcon -crosscloseimage $configuration::plusIcon\
                -selectcommand "database::dialog::processEvent $this"                      ;# to detect instance and cell selections
            set treeScrollPath $widget::($scroll,path)
            grid $treeScrollPath -row 0 -sticky nsew
            grid rowconfigure $frame 0 -weight 1
            lappend ($this,objects) $scroll

            set range [frame $frame.range]
            set label [label $range.fromLabel -font $font::(mediumBold) -text [mc from:]]
            grid $label -row 0 -column 0 -sticky w
            set ($this,from) [label $range.from -font $font::(mediumNormal)]
            grid $($this,from) -row 0 -column 1 -sticky w -padx 2
            set label [label $range.toLabel -font $font::(mediumBold) -text [mc to:]]
            grid $label -row 1 -column 0 -sticky w
            set ($this,to) [label $range.to -font $font::(mediumNormal)]
            grid $($this,to) -row 1 -column 1 -sticky w -padx 2
            lappend ($this,tips) [new widgetTip -path $range -text [mc {selected item database time range}]]
            grid columnconfigure $range 1 -weight 1
            grid $range -row 1 -sticky ew

            grid columnconfigure $frame 0 -weight 1

            set scroll [new scroll text $frame -vertical 0]
            set query $composite::($scroll,scrolled,path)
            $query configure -background white -height 4 -state disabled -wrap none -font $font::(mediumNormal)
            $query tag configure italic -font $font::(mediumItalic)
            # leave enough vertical room so that scrollbar can appear and disappear without changing the tree height:
            composite::configure $scroll\
                -height [expr {[winfo reqheight $query] + [winfo reqheight $composite::($scroll,horizontal,path)]}]
            lappend ($this,objects) $scroll
            composite::configure $dialog SQL\
                -command "database::dialog::toggleSQLDisplay $this $widget::($scroll,path) $treeScrollPath"
            set ($this,scrollPath) $widget::($scroll,path)

            set canvas [$tree getcanvas]
            set ($this,drag) [new dragSite -path $canvas -validcommand "database::dialog::validateDrag $this"]
            # module database instance is a list: database name, instance, start and end instants from instance and history tables
            dragSite::provide $($this,drag) INSTANCES "database::dialog::dragData $this"

            dialogBox::display $dialog $frame
            set ($this,tree) $tree
            set ($this,query) $query
            set ($this,dialog) $dialog
            set ($this,deleteCommand) {}
            set ($this,nodeTips) {}
            switched::complete $this
            refresh $this
        }

        proc ~dialog {this} {                                     ;# note: this object must be deleted by its GUI dialog object only
            eval delete $($this,nodeTips) $($this,objects) $($this,tips) $($this,drag)
            if {[string length $($this,deleteCommand)] > 0} {
                uplevel #0 $($this,deleteCommand)                                           ;# always invoke command at global level
            }
            if {[string length $switched::($this,-deletecommand)] > 0} {
                uplevel #0 $switched::($this,-deletecommand)                                ;# always invoke command at global level
            }
        }

        proc options {this} {
            return [list\
                [list -command {} {}]\
                [list -deletecommand {} {}]\
            ]
        }

        proc set-command {this value} {}           ;# command is invoked with instance data appended only when there is one selected
        proc set-deletecommand {this value} {}

        proc deleteCommand {this command} {                               ;# for internal usage, as opposed to -deletecommand option
            set ($this,deleteCommand) $command
        }

        proc refresh {this} {
            lifoLabel::push $global::messenger [mc {retrieving module instances from database...}]
            busy 1 [list . $widget::($($this,dialog),path)]
            set database $global::database
            set tree $($this,tree)
            set canvas [$tree getcanvas]
            $tree delete [$tree nodes root]                                                                      ;# clear whole tree
            array unset {} $this,*Data,*                                                                         ;# clear nodes data
            eval delete $($this,nodeTips)
            set data(modules) {}
            foreach module [database::modules $database] {                    ;# note: could be no modules in case of database error
                set data(instances,$module) {}
                foreach instance [database::instances $database $module] {  ;# note: could be no instances in case of database error
                    # note: a query result is empty in case of database error:
                    set data(identifier,$instance) [database::identifier $database $instance]
                    if {[string length $database::($database,error)] > 0} break
                    set data(arguments,$instance) [database::arguments $database $instance]
                    if {[string length $database::($database,error)] > 0} break
                    set data(version,$instance) [database::version $database $instance]
                    if {[string length $database::($database,error)] > 0} break
                    set data(cellsData,$instance) [database::cellsData $database $instance]
                    if {[string length $database::($database,error)] > 0} break
                    lappend data(instances,$module) $instance
                }
                if {[string length $database::($database,error)] > 0} break
                lappend data(modules) $module
            }
            if {[string length $database::($database,error)] > 0} {      ;# display nothing in case of any unexpected database error
                set data(modules) {}
            }
            foreach module $data(modules) {
                set node [$tree insert end root #auto -font $font::(mediumBold) -text $module -image $configuration::closedIcon]
                set ($this,moduleData,$node) $module
            }
            foreach node [$tree nodes root] {
                set module [$tree itemcget $node -text]
                foreach instance $data(instances,$module) {
                    set arguments $data(arguments,$instance)
                    set noOption [expr {[string length $arguments] == 0}]
                    if {$noOption} {
                        set arguments {without options}
                    } else {                                                           ;# eliminate empty values for boolean options
                        set string {}
                        foreach {option value} $arguments {
                            if {[string length $string] > 0} {append string { }}
                            append string $option
                            if {[string length $value] > 0} {                                            ;# boolean switch: no value
                                append string { } $value
                            }
                        }
                        set arguments $string
                    }
                    set new [$tree insert end $node #auto -data $instance -text $arguments -image $configuration::closedIcon]
                    if {$noOption} {
                        $tree itemconfigure $new -font $font::(mediumItalic)
                    } else {
                        $tree itemconfigure $new -font $font::(mediumNormal)
                    }
                    set ($this,instanceData,$new) [list $instance $module $data(identifier,$instance) $arguments]
                    lappend ($this,nodeTips) [new widgetTip -path $canvas -itemortag n:$new\
                        -text [format [mc {instance of module %1$s version %2$s}] $module $data(version,$instance)]\
                    ]                                           ;# note: the node name (n:*) comes from the BWidget tree source code
                }
            }
            foreach node [$tree nodes root] {
                foreach node [$tree nodes $node] {
                    set instance [$tree itemcget $node -data]
                    foreach {row entry label comment} $data(cellsData,$instance) {
                        if {[string length $comment] > 0} {
                            append label " ($comment)"
                        }
                        regsub -all {\n} $label { } label                         ;# replace all new lines, which tree cannot handle
                        set new [$tree insert end $node #auto\
                            -data $row,$entry -text $label -font $font::(mediumNormal) -image $configuration::leafIcon\
                        ]
                        set ($this,cellData,$new) [list $instance $row $entry]
                    }
                }
            }
            busy 0 [list . $widget::($($this,dialog),path)]
            lifoLabel::pop $global::messenger
        }

        proc updateQuery {this instance row entry start end} {
            set query $($this,query)
            $query configure -state normal
            $query delete 1.0 end                                                                                           ;# clear
            foreach {start optional end} [database::historyQuery $global::database $instance $row $entry $start $end] {}
            $query insert end $start
            if {[string length $optional] > 0} {
                $query insert end \n$optional
                $query tag add italic 3.0 3.end                                       ;# highlight timestamp selection optional part
            }
            $query insert end \n$end
            $query configure -state disabled
        }

        proc clearQuery {this} {
            set query $($this,query)
            $query configure -state normal
            $query delete 1.0 end
            $query configure -state disabled
        }

        proc toggleSQLDisplay {this queryScrollPath treeScrollPath} {
            if {[llength [grid info $queryScrollPath]] == 0} {                                                        ;# display SQL
                # make sure query remains visible when shrinking window vertically:
                grid $queryScrollPath -row 2 -sticky ew
                set node [$($this,tree) selection get]                                                          ;# node may be empty
                if {[info exists ($this,cellData,$node)]} {                                                    ;# a cell is selected
                    foreach {instance row entry} $($this,cellData,$node) {}
                    set start {}; set end {}                                                 ;# initialize in case of database error
                    foreach {start end} [cellRange $this $instance $row $entry] {}
                    updateQuery $this $instance $row $entry $start $end
                }
            } else {
                grid forget $queryScrollPath
                clearQuery $this
            }
        }

        proc validateDrag {this x y} {
            return [info exists ($this,instanceData)]
        }

        proc dragData {this format} {
            return [list $($this,instanceData)]
        }

        proc validated {this} {
            if {[string length $switched::($this,-command)] == 0} return
            wm withdraw $widget::($($this,dialog),path)       ;# remove dialog box from view so that main window message can be read
            update                                                ;# wait until dialog box is no longer visible (do not always work)
            uplevel #0 $switched::($this,-command) [list $($this,instanceData)]
        }

        proc processEvent {this tree node} {
            set start {}; set end {}                                              ;# initialize in case of error in database queries
            composite::configure $($this,dialog) ok -state disabled
            catch {unset ($this,instanceData)}
            if {![catch {set data $($this,moduleData,$node)}]} {                                             ;# a module is selected
                foreach {start end} [moduleRange $this $data] {}
            }
            if {![catch {set data $($this,cellData,$node)}]} {                                                 ;# a cell is selected
                foreach {instance row entry} $data {}
                foreach {start end} [cellRange $this $instance $row $entry] {}
                if {[llength [grid info $($this,scrollPath)]] > 0} {                                    ;# display corresponding SQL
                    updateQuery $this $instance $row $entry $start $end
                }
            } else {
                clearQuery $this
            }
            if {![catch {set data $($this,instanceData,$node)}] && ([llength [$tree nodes $node]] > 0)} {
                # an instance with data cells history is selected
                foreach {start end} [instanceRange $this [lindex $data 0]] {}
                set ($this,instanceData) $data
                composite::configure $($this,dialog) ok -state normal
            }
            $($this,from) configure -text $start; $($this,to) configure -text $end
        }

        proc moduleRange {this module} {
            if {[info exists ($this,moduleRange,$module)]} {                      ;# cache time limits because retrieval can be slow
                return $($this,moduleRange,$module)
            } else {
                return [set ($this,moduleRange,$module)\
                    [database::moduleRange $global::database $module [list . $widget::($($this,dialog),path)]]\
                ]
            }
        }

        proc instanceRange {this instance} {
            if {[info exists ($this,instanceRange,$instance)]} {                  ;# cache time limits because retrieval can be slow
                return $($this,instanceRange,$instance)
            } else {
                return [set ($this,instanceRange,$instance)\
                    [database::instanceRange $global::database $instance [list . $widget::($($this,dialog),path)]]\
                ]
            }
        }

        proc cellRange {this instance row entry} {
            if {[info exists ($this,cellRange,$instance,$row,$entry)]} {          ;# cache time limits because retrieval can be slow
                return $($this,cellRange,$instance,$row,$entry)
            } else {
                return [set ($this,cellRange,$instance,$row,$entry)\
                    [database::cellRange $global::database $instance $row $entry {} {} [list . $widget::($($this,dialog),path)]]\
                ]
            }
        }

        proc stateChange {this opened node} {
            if {$opened} {
                $($this,tree) itemconfigure $node -image $configuration::openedIcon
            } else {
                $($this,tree) itemconfigure $node -image $configuration::closedIcon
            }
        }

    }

    class rangeDialog {

        proc rangeDialog {this parentPath {deleteCommand {}}} {
            variable singleton

            if {[info exists singleton]} {
                error {only 1 database range dialog object can exist}
            }
            set singleton $this
            set dialog [new dialogBox $parentPath\
                -buttons hoc -default o -title [mc {moodss: Database history range}] -x [winfo pointerx .] -y [winfo pointery .]\
                -helpcommand {generalHelpWindow #menus.view.database.range} -deletecommand "delete $this" -grab release\
                -command "database::rangeDialog::apply $this 1" -die 0 -otherbuttons apply\
            ]
            composite::configure $dialog apply -text [mc Apply] -command "database::rangeDialog::apply $this 0"
            set ($this,tip) [linkedHelpWidgetTip $composite::($dialog,help,path)]
            set frame [frame $widget::($dialog,path).frame]
            set message [message $frame.message\
                -width [winfo screenwidth .] -font $font::(mediumNormal) -justify center\
                -text [mc {Select history range for database views:}]
            ]
            pack $message -pady 5

            set from [frame $frame.from]
            pack $from -fill x -pady 2
            pack [label $from.label -text [mc from:]] -side left -padx 2
            set input [new input $from]
            set ($this,from) $input
            pack $widget::($input,path) -side right
            set to [frame $frame.to]
            pack $to -fill x -pady 2
            pack [label $to.label -text [mc to:]] -side left -padx 2
            set input [new input $to]
            set ($this,to) $input
            pack $widget::($input,path) -side right
            composite::configure $($this,from) -command "database::rangeDialog::updated $this from"
            composite::configure $($this,to) -command "database::rangeDialog::updated $this to"
            set calendar [new calendar $frame -font $font::(mediumNormal)]
            set ($this,calendar) $calendar
            pack $widget::($calendar,path) -fill both -expand 1

            if {[info exists databaseInstances::singleton]} {                             ;# should always be the case at this point
                foreach {minimum maximum} [databaseInstances::cursorsRange] {}
                input::set $($this,from) $minimum
                input::set $($this,to) $maximum
            }

            set ($this,deleteCommand) $deleteCommand
            set ($this,dialog) $dialog
            dialogBox::display $dialog $frame
        }

        proc ~rangeDialog {this} {
            variable singleton

            delete $($this,tip) $($this,from) $($this,to) $($this,calendar)
            if {[string length $($this,deleteCommand)] > 0} {
                uplevel #0 $($this,deleteCommand)                                           ;# always invoke command at global level
            }
            unset singleton
        }

        proc apply {this close} {
            if {![info exists databaseInstances::singleton]} return                        ;# should never be the case at this point
            databaseInstances::setCursors $databaseInstances::singleton [input::get $($this,from)] [input::get $($this,to)]
            if {$close} {
                delete $($this,dialog)                                                    ;# which in turn should delete this object
            }
            after idle ::refresh                                                                ;# update all database related views
        }

        proc updated {this side seconds} {          ;# user changed date or time: check consistency and eventually bring corrections
            if {[string equal $side from]} {
                set value [input::get $($this,to)]
                if {($value >= 0) && ($seconds > $value)} {
                    input::set $($this,to) $seconds
                }
            } else {                                                                                                   ;# side is to
                set value [input::get $($this,from)]
                if {($value >= 0) && ($seconds < $value)} {
                    input::set $($this,from) $seconds
                }
            }
            set from [input::get $($this,from)]; set to [input::get $($this,to)]
            databaseInstances::setCursors $databaseInstances::singleton $from $to   ;# synchronize database instances viewer cursors
            set calendar $($this,calendar)                                                                           ;# and calendar
            composite::configure $calendar -command {}                     ;# avoid infinitie loops as calendar also updates display
            composite::configure $calendar -seconds [list $from $to]
            composite::configure $calendar -command "database::rangeDialog::update $this"
        }

        proc update {this from to} {                                            ;# public procedure for setting from external source
            input::set $($this,from) $from
            input::set $($this,to) $to
        }

        class input {

            variable hours
            for {::set value 0} {$value < 24} {incr value} {
                lappend hours [format %02u $value]
            }
            variable sixties
            for {::set value 0} {$value < 60} {incr value} {
                lappend sixties [format %02u $value]
            }
            unset value
            variable minimum $global::32BitIntegerMinimum
            variable maximum $global::32BitIntegerMaximum

            proc input {this parentPath args} composite {[new frame $parentPath] $args} {
                variable days
                variable daysWidth
                variable months
                variable monthsWidth
                variable hours
                variable sixties
                variable minimum
                variable maximum

                if {![info exists days]} {
                    ::set days [mc {Sunday Monday Tuesday Wednesday Thursday Friday Saturday}]
                    ::set daysWidth 0
                    foreach value $days {
                        ::set value [string length $value]
                        if {$value > $daysWidth} {::set daysWidth $value}
                    }
                }
                if {![info exists months]} {
                    ::set months [mc {January February March April May June July August September October November December}]
                    ::set monthsWidth 0
                    foreach value $months {
                        ::set value [string length $value]
                        if {$value > $monthsWidth} {::set monthsWidth $value}
                    }
                }
                ::set path $widget::($this,path)
                ::set delay $global::spinBoxRepeatMilliseconds
                composite::manage $this\
                    [new spinbox $path\
                        -font $font::(mediumBold) -width $daysWidth -values $days -justify right -state readonly -wrap 1\
                        -repeatinterval $delay -command "database::rangeDialog::input::increment $this %d 86400 %s"\
                    ] dayOfWeek\
                    [new spinbox $path\
                        -font $font::(mediumBold) -width 2 -from 1 -to 31 -increment 1 -justify right -state readonly -wrap 1\
                        -repeatinterval $delay -command "database::rangeDialog::input::increment $this %d 86400 %s"\
                    ] day\
                    [new spinbox $path\
                        -font $font::(mediumBold) -width $monthsWidth -values $months -justify right -state readonly -wrap 1\
                        -repeatinterval $delay -command "database::rangeDialog::input::setMonth $this %d %s"\
                    ] month\
                    [new spinbox $path\
                        -font $font::(mediumBold) -width 4 -justify right -state readonly\
                        -from [clock format $minimum -format %Y] -to [clock format $maximum -format %Y] -increment 1\
                        -repeatinterval $delay -command "database::rangeDialog::input::setYear $this %d %s"\
                    ] year\
                    [new frame $path -width 10] separator1\
                    [new spinbox $path\
                        -font $font::(mediumBold) -width 2 -values $hours -justify right -wrap 1\
                        -repeatinterval $delay -command "database::rangeDialog::input::increment $this %d 3600 %s"\
                    ] hours\
                    [new label $path -font $font::(mediumBold) -text :] separator2\
                    [new spinbox $path\
                        -font $font::(mediumBold) -width 2 -values $sixties -justify right -wrap 1\
                        -repeatinterval $delay -command "database::rangeDialog::input::increment $this %d 60 %s"\
                    ] minutes\
                    [new label $path -font $font::(mediumBold) -text :] separator3\
                    [new spinbox $path\
                        -font $font::(mediumBold) -width 2 -values $sixties -justify right -wrap 1\
                        -repeatinterval $delay -command "database::rangeDialog::input::increment $this %d 1 %s"\
                    ] seconds
                foreach entry {hours minutes seconds} {                                           ;# filter on positive integers
                    setupEntryValidation $composite::($this,$entry,path) {{check31BitUnsignedInteger %P}}
                }
                pack $composite::($this,dayOfWeek,path) $composite::($this,day,path) $composite::($this,month,path)\
                    $composite::($this,year,path) $composite::($this,separator1,path) $composite::($this,hours,path)\
                    $composite::($this,separator2,path) $composite::($this,minutes,path) $composite::($this,separator3,path)\
                    $composite::($this,seconds,path) -side left
                composite::complete $this
                set $this $minimum
            }

            proc ~input {this} {}

            proc options {this} {
                variable minimum
                variable maximum

                return [list\
                    [list -command {} {}]\
                ]
            }

            proc set-command {this value} {}

            proc get {this} {
                variable months

                ::set day [$composite::($this,day,path) get]
                ::set month [expr {[lsearch -exact $months [$composite::($this,month,path) get]] + 1}]
                ::set year [$composite::($this,year,path) get]
                ::set hours [$composite::($this,hours,path) get]
                ::set minutes [$composite::($this,minutes,path) get]
                ::set seconds [$composite::($this,seconds,path) get]
                if {[catch {::set value [clock scan "$year-$month-$day $hours:$minutes:$seconds"]}]} {
                    # year, month and day are always valid since they are drawn from a fixed list
                    if {[catch {clock scan "$hours:00:00"}]} {
                        ::set entry hours
                    } elseif {[catch {clock scan "$hours:$minutes:00"}]} {
                        ::set entry minutes
                    } else {
                        ::set entry seconds
                    }
                    focus $composite::($this,$entry,path)                                       ;# point at the first error location
                    return -1
                }
                return $value
            }

            proc set {this value} {                                                                           ;# value is in seconds
                variable days
                variable months
                variable minimum
                variable maximum

                if {$value < $minimum} {
                    ::set value $minimum
                } elseif {$value > $maximum} {
                    ::set value $maximum
                }
                foreach {dayOfWeek day month year hours minutes seconds} [clock format $value -format {%w %e %m %Y %H %M %S}] {}
                ::set dayOfWeek [lindex $days $dayOfWeek]
                ::set month [string trimleft $month 0]                            ;# avoid problems with octal number interpretation
                ::set month [lindex $months [expr {$month - 1}]]
                $composite::($this,dayOfWeek,path) set $dayOfWeek
                $composite::($this,day,path) set $day
                $composite::($this,month,path) set $month
                $composite::($this,year,path) set $year
                $composite::($this,hours,path) set $hours
                $composite::($this,minutes,path) set $minutes
                $composite::($this,seconds,path) set $seconds
                ::set ($this,seconds) $value
                if {[string length $composite::($this,-command)] > 0} {
                    uplevel #0 $composite::($this,-command) $value                          ;# always invoke command at global level
                }
            }

            proc increment {this direction value ignore} {
                switch $direction {
                    down {set $this [expr {$($this,seconds) - $value}]}
                    up {set $this [expr {$($this,seconds) + $value}]}
                }
            }

            proc setMonth {this direction ignore} {
                foreach {day month year time} [clock format $($this,seconds) -format {%e %m %Y %T}] {}
                ::set month [string trimleft $month 0]                            ;# avoid problems with octal number interpretation
                switch $direction {
                    down {incr month -1}
                    up {incr month}
                    default return
                }
                if {$month <= 0} {
                    incr year -1
                    ::set month 12
                } elseif {$month > 12} {
                    incr year
                    ::set month 1
                }
                while {[catch {::set seconds [clock scan "$year-$month-$day $time"]}]} {
                    incr day -1                                                   ;# handle months with less days than current value
                }
                set $this $seconds
            }

            proc setYear {this direction year} {
                foreach {day month current time} [clock format $($this,seconds) -format {%e %m %Y %T}] {}
                if {$year == $current} return                                                                           ;# no change
                while {[catch {::set seconds [clock scan "$year-$month-$day $time"]} message]} {
                    incr day -1                                                   ;# handle months with less days than current value
                }
                set $this $seconds
            }

        }

    }

}
