package require Tk
package require callib
calwid .test
pack .test

# Now, here are the error msgs
.test configure -foo
.test bar

Other Examples  edit

example

Bezoar 2008-06-02

Documentation  edit

calwid - Create and manipulate calendar widgets

calwid pathName ?options?

nextmonth

Advances the shown calendar by one month

nextyear

Advances the shown calendar by one year. The month shown remains the same

prevmonth

Goes back one month

nextyear

Goes back one year. The month shown remains the same

configure ?option? ?value option value ...?

Without any arguments, dumps the current configuration

-font font

sets the font for the daynumbers in the calendar

-background color

sets the background colour

-activebackground color

sets the color of the day the cursor is hovering over

-dayfont font

sets the font used for the day names

-clickedcolor color

sets the color a day field gets after a mouse click. There is no way yet to get rid of a "clicked" day. A workaround is to jump to the next month and back.

-startsunday val

val=1: Sets the starting day of the week to sunday. val=0: Sets the starting day of the week to monday. "clicked" days revert to the background color.

-balloon val

val=1: enables balloons. val=0: disables balloons. Balloons are shown if the mouse hovers a certain amount of time over a day which has marks. The balloon contains a list of the mark prios and texts in ascending order. The delay is set using -delay (see below). The marks are set using -mark (see below)

-delay val

Delay im ms to wait until a balloon containing the days marks are shown

-callback procname

procname gets called at each mouse click event on a day field. The callback is called and gets 6 arguments: year month day dayname column row

-clicked {elem1 elem2}

sets the day at coordinates column=elem1 and row=elem2 to the "clicked" state. Coordinates start with 0

-progcallback val

enables/disables triggering of the callback if the -clicked option is used. val=1: enabled. val=0: disabled

-mark {day month year prio color text}

sets a mark on the date given by day, month and year. Prio sets the priority of the mark. Color sets the color shown around the marked day, if the associated mark has highest priority. Text is shown in the balloon if balloons are enabled.

-daynames {So Mo Di Mi Do Fr Sa}

sets the daynames shown in the calendar. The list starts with Sunday, the calendar uses the first 2 chars of each list element. The callback gets the whole list element.

-month val

sets the month shown by the calendar

-year val

sets the year shown by the calendar

-relief val

sets the relief the calendar day

Future Feature discussion  edit

Comments  edit

#create the widget
label $parent.$col$row -padx 0 -pady 0 -highlightthickness 2
# bind to mouse-click for the callback rather than using [button] as you do now.
bind $parent.$col$row <Button-1> [list callib::callback $parent $col $row]

Changes  edit

2014-05-24

pyk: reformat/modernize code

Code  edit

#! /bin/env tclsh

package provide callib 0.3

# provides api for creating calendar widgets #
proc calwid args {
    # creation of the widget
    set newWidget [callib::MakecalendarWid {*}$args]

    # create body for the new widget proc
    set newCmd "[
        list [namespace current]::callib::calproc] [list $newWidget] {*}\$args"
    # declare new proc to be called when the widget is accessed
    proc $newWidget args $newCmd

    return $newWidget
} ;# END calwid

namespace eval callib {
    # config data for every calwid widget
    variable calState
  
    set calState(unique) 0
}
  
# procedure to create a calendar #
proc callib::MakecalendarWid args {
    variable calState

    #make unique name per default
    set holder .calwid_$calState(unique)
    incr calState(unique)
    #if a window name was given on the command line then use it
    #overwriting the already computed name
    if {[string first . [lindex $args 0]] == 0} {
        # put the wanted name in holder
        set holder [lindex $args 0] 
        # remove the name from args
        set args [lreplace $args 0 0]
      };# END window path given

    #make defaults for the command line args

    #year
    set calState($holder.year) [clock format [clock scan now] -format %Y]

    #month
    set mon_num [clock format [clock scan now] -format %m]

    #month starts with 0, can be interpreted as octal ->remove leading 0
    set mon_num [string trimleft $mon_num 0]
    set calState($holder.month) $mon_num 

    #week starts on sunday in the us and on monday in germany
    set calState($holder.startsunday) 0

    #font defaults
    set calState($holder.font) {Lucidatypewriter 12 normal}

    #day names, change the defaults to the language needed
    set calState($holder.daynames) {So Mo Di Mi Do Fr Sa}

    #day font
    set calState($holder.dayfont) {Lucidatypewriter 12 bold}

    #command registered as callback
    set calState($holder.callback) {} 

    # marking list for days, a mark is a list containing a date
    # a mark priority and a mark color, if one day has multiple marks
    # the color of the highest priority is shown, if balloons are enabled
    # then all the marks texts in descending prio order are shown.
    # the list is {day month year prio color label}
    set calState($holder.mark) {}

    # this list contains the marks for the shown month
    set calState($holder.shownmarks) {}

    # last clicked gets row col address of the last clicked button
    set calState($holder.clicked) {}

    # last clicked gets the color of clicked
    set calState($holder.clickedcolor) "yellow"

    # default background goes here, as a default rootwindows background
    # is used
    set calState($holder.background) [. cget -background]

    # the default active background goes here, white
    set calState($holder.activebackground) "white"

    # progcallback: if set to 1, setting clicked will invoke callback
    #               if set to 0, setting clicked will not invoke callback
    # defaults to 1
    set calState($holder.progcallback) 1

    # balloons containing the mark texts, 1 enabled, 0 disables
    set calState($holder.balloon)      1

    # set the delay for the balloon here
    set calState($holder.delay)     1000

    # set the relief 
    set calState($holder.relief)    groove

    # set the relief 
    set calState($holder.foreground)    black

    # check whether options are valid
    foreach {opt val} $args {
        # get rid of leading -
        set option [string range $opt 1 end] 
        if {![info exists calState($holder.$option)]} {
            # create oklist containing the possible commands
            regsub -all $holder. [
                array names calState $holder.*] {} oklist
            error "Bad Option, '$option'\n Valid options are $oklist"
        };# END: if option not in the calendar state array
        set calState($holder.$option) $val  
    };# END: foreach option value pair

    # make a frame to hold it all. Declare the class as being Calendar
    frame $holder -class Calendar 
    # make the frames innards
    Draw $holder
    # rename the frame to give the widget the name $holder
    uplevel #0 [list rename $holder $holder.fr]
    #call the update procedure to use configuration options given at start
    update_cal  $holder
    # clean up after destruction of the widget
    # TODO unset the associated array elements 
    # TODO implement a cleanup proc to take care of cleaning up
    bind $holder <Destroy> +[list rename $holder {}]
    # return the name of the new widget
    return $holder
};# END MakecalendarWid

# this proc takes care of drawing and packing the widgets #      
proc callib::Draw parent {
    variable calState

    # make the weekday list
    set weekdays $calState($parent.daynames)
    if {$calState($parent.startsunday) != 1} {
        set weekdays [roll_left $weekdays]
    };# END if not start on sunday -> start on monday 
    # make labels for the days header
    set colcount 0
    foreach day $weekdays {
        set daylabel $parent.$colcount
        label $daylabel 
        grid  $daylabel  -row 1 -column $colcount -ipadx 0 -ipady 0
        incr colcount
    };#END: foreach day in weekday 
    # get monthlist according to startsunday variable
    set month $calState($parent.month)
    set year  $calState($parent.year)
    set monthlist [cal_list_month $month \
                                  $year  \
                                  $calState($parent.startsunday) ]
    # make the buttons for the calendar, buttons needed 
    # as there will be commands associated with them
    # was button, switched to labels bacause buttons look 
    # ugly under Aqua, callbacks & activebackground implemented 
    # via bind
    for {set row 0} {$row < 6} {incr row} {
        for {set col 0} {$col<7} {incr col} {
            label $parent.$col$row -highlightthickness 2  
            grid $parent.$col$row -padx 0 -pady 0 -ipadx 0 -ipady 0 \
                                  -row [expr {$row+2}] -column $col 
        };#END: col
    };#END: row
};# END: draw the widgets

# this procedure gets called whenever a day button is pressed #
proc callib::callback {parent col row} {
    variable calState

    # cleanup previously clicked
    set old_col [lindex $calState($parent.clicked) 0]  
    set old_row [lindex $calState($parent.clicked) 1]  

    if {$old_row ne {}} {
        set button_name $parent.$old_col$old_row
        $button_name configure -background $calState($parent.background)
    };# END: there was a clicked button
    # change the clicked button appropriately
    set calState($parent.clicked) [list $col $row]
    set button_name $parent.$col$row
    $button_name configure -background $calState($parent.clickedcolor)
    $button_name configure -background $calState($parent.clickedcolor)
    # get the daynames from the state array
    set namelist $calState($parent.daynames)
    # if start on monday roll the list 
    if {$calState($parent.startsunday) != 1} {
        set namelist [roll_left $namelist]
    }
    # make the arguments for the user defined callback procedure  
    set callargs [list $calState($parent.year)                         \
                       $calState($parent.month)                        \
                       [string trimleft [$parent.$col$row cget -text]] \
                       [lrange $namelist $col $col]                    \
                       $col                                            \
                       $row]
                       
    # procedure name                   
    set procname $calState($parent.callback)
    # if there is something registered as callback, call it
    if {$procname ne {}} {
        $procname {*}$callargs
    }
}

# this proc updates the calendar shown according to the contents #
# of the calState array                                          #
proc callib::update_cal parent {
    variable calState

    # set the frame color to the background
    $parent.fr configure -background $calState($parent.background)
    # make the weekday list
    set weekdays $calState($parent.daynames)
    if {$calState($parent.startsunday) != 1} {
        set weekdays [roll_left $weekdays]
    };# END if not start on sunday -> start on monday 
    # update labels for the days header
    set colcount 0
    foreach day $weekdays {
        set daylabel $parent.$colcount
        set day [string range $day 0 1]
        $daylabel configure -text $day -width 2                       \
                            -font $calState($parent.dayfont)          \
                            -foreground $calState($parent.foreground) \
                            -background $calState($parent.background)
        incr colcount
    };#END: foreach day in weekday 

    # get monthlist according to startsunday variable
    set month $calState($parent.month)
    set year  $calState($parent.year)
    set monthlist [cal_list_month $month \
                                  $year  \
                                  $calState($parent.startsunday)]
    # make an array with the day as index and the buttons coords as value
    # will be used while processing the marked days
    # first delete the array
    catch {unset index_arr}
    # fill buttons with the stuff
    for {set row 0} {$row < 6} {incr row} {
        for {set col 0} {$col < 7} {incr col} {
            set text  [lindex $monthlist [expr {7*$row+$col}] ]
            set index_arr($text) $col$row
            # set default values, change them if day field is empty
            set reliefval $calState($parent.relief)
            set stateval  normal
            bind $parent.$col$row <Any-Enter> [list callib::enter_proc %W] 
            bind $parent.$col$row <Any-Leave> [list callib::leave_proc %W] 
            bind $parent.$col$row <Button-1>  [list callib::callback \
                                                     $parent         \
                                                     $col            \
                                                     $row]
            if {$text eq {}} {
                set reliefval flat
                set stateval  disabled
                bind $parent.$col$row <Any-Enter> {}
                bind $parent.$col$row <Any-Leave> {}
                bind $parent.$col$row <Button-1>  {}
            };# END: if dayfield is empty
            # reconfigure the button 
            $parent.$col$row configure -relief $reliefval -state $stateval \
                                       -borderwidth 2                      \
                                       -width 2                            \
                                       -background                         \
                                         $calState($parent.background)     \
                                       -highlightbackground                \
                                         $calState($parent.background)     \
                                       -font $calState($parent.font)       \
                                       -text [format "%2s" $text]          \
                                       -justify center                     \
                                       -foreground                         \
                                         $calState($parent.foreground)
        };#END: col
    };#END: row
    # check if there is a clicked day & update the color according to 
    # calstate array
    set col [lindex $calState($parent.clicked) 0]  
    set row [lindex $calState($parent.clicked) 1]  
    if {($row ne {}) && ($col ne {})} {
        $parent.$col$row configure -background \
                                     $calState($parent.clickedcolor)
    }
    # check if there are days in the marked list that are displayed
    # right now and mark them
    # put the needed part of mark list into the shownmarks list
    set calState($parent.shownmarks) {}
    foreach Mlist $calState($parent.mark) {
        foreach {Mday Mmonth Myear Mpri Mcol Mlabel} $Mlist {}
        if {$Myear == $calState($parent.year)} {
            if {$Mmonth == $calState($parent.month)} {
                lappend calState($parent.shownmarks) $Mlist
            }
        }
    }
    # sort the array in ascending order of prio
    # so that highest prio is at the end
    set calState($parent.shownmarks) [
        lsort -index 3 -integer $calState($parent.shownmarks)] 
    # start @ beginnig of array and reconfigure the buttons the 
    # last marks will be of highest prio & will determine the marking color
    # automatically. Not blazingly fast, might tune later
    foreach Mlist $calState($parent.shownmarks) {
        # month & year are matching the shown ones, get the day
        foreach {Mday Mmonth Myear Mpri Mcol Mlabel} $Mlist {}
        $parent.$index_arr($Mday) configure -highlightbackground $Mcol 
    }
    # delete the array  
    catch {unset index_arr}
    # return used here to avoid returning the value of the catch
    return 
};# END update_cal

# gets called at each enter event #
proc callib::enter_proc wname {
    variable calState

    # get parents name
    set parent [winfo parent $wname]
    # set active color
    $wname configure -background $calState($parent.activebackground)
    # trigger the balloon
    after $calState($parent.delay) [list callib::balloon_show $wname] 
}

# gets called at each leave event #
proc callib::leave_proc wname {
    variable calState

    # get parents name
    set parent [winfo parent $wname]
    # set inactive color
    $wname configure -background $calState($parent.background)
    # check if the label was "clicked" and set the color to clickedcolor
    set col [lindex $calState($parent.clicked) 0]  
    set row [lindex $calState($parent.clicked) 1]  
    if {$row ne {}} {
        set label_name $parent.$col$row
        $label_name configure -background $calState($parent.clickedcolor)
    };# END: there was a clicked button
    # close the balloon
    balloon_dn $wname 
}

# triggers a balloon help like window #
proc callib::balloon_show wname {
    variable calState

    # get parents name
    set parent [winfo parent $wname]
    # in case the balloons  are disabled do nothing
    if {$calState($parent.balloon) == 0} return
    # in case we already left the widget do nothing
    set currentwin [eval winfo containing [winfo pointerxy .]]
    if {![string match $currentwin $wname]} return
    # make a string with the marks of the date shown by the requester
    set day [string trim [$wname cget -text]]
    set message_str {} 
    foreach Mlist $calState($parent.shownmarks) {
        foreach {Mday Mmonth Myear Mpri Mcol Mlabel} $Mlist {}
            if {($Mday == $day)} {append message_str "$Mpri $Mlabel\n"}
    }
    set message_str [string trim $message_str]
    # if there are no marks for requesters widget return
    if {![string length $message_str]} return
    # create a top level window
    set top $parent.balloon
    catch {destroy $top}
    toplevel $top -borderwidth 1 -background black -relief flat
    wm overrideredirect $top 1
    # create the message widget
    message $top.msg -text $message_str  -width 3i\
                     -font $calState($parent.font)\
                     -background yellow -foreground darkblue
    pack $top.msg
    # get the geometry data of the requester
    set wmx [expr [winfo rootx $wname]+[winfo width  $wname]]
    set wmy [expr [winfo rooty $wname]+[winfo height $wname]]
    wm geometry $top [
        winfo reqwidth $top.msg]x[winfo reqheight $top.msg]+$wmx+$wmy
    # raise so that win is really on top
    raise $top
};# end balloon_show 

# makes the balloon disappear #
proc callib::balloon_dn wname {
    variable calState

    # get parents name
    set parent [winfo parent $wname]
    # in case the balloons  are disabled do nothing
    if {$calState($parent.balloon) == 0} return
    # destroy the help balloon
    catch {destroy $parent.balloon}
};# end balloon_dn

# This proc takes care of all the configuration subcommands of #
# the calendar widget                                          #
proc callib::calproc {parent args} {
    variable calState

    # make a list of allowed commands
    # new commands should be dropped here & processed in the switch 
    # statement along with the possible subcommands
    set commList {nextmonth prevmonth nextyear prevyear configure}
    # extract the first word in args, this must be in the commList
    set command [lindex $args 0]
    if {[lsearch -exact $commList $command] == -1} {
        error "unknown command for $parent, possible command(s):\n\
               $commList"
    };# END: check whether command is known to widget

    # remove the parent name from the args list
    set  args [lreplace $args 0 0]

    switch -- $command {
        configure {
            # if there are no arguments to configure
            # then return a list with all the configuration
            if {$args eq {}} {
                set optlist [array get calState $parent.*]
                set returnlist {} 
                foreach {opt val} $optlist {
                    regsub $parent. $opt {} opt
                    # shownmarks is a private field, so leave it out
                    if {$opt ne {shownmarks}} {
                        lappend returnlist [list $opt $val]
                      }  
                }
                return $returnlist  
            };# END: if no args for configure
            foreach {opt val} $args {
                switch -- $opt {
                    -font {
                        if {$val eq {}} {
                            return $calState($parent.font)
                        };# END: if no font specified
                        # might want to check whether font is available  
                        set calState($parent.font) $val
                    }
                    -background {
                        if {$val eq {}} {
                            return $calState($parent.background)
                        };# END: if no color specified
                        set er [catch {label .tmp -background $val} result]
                        destroy .tmp   
                        if {$er} {
                            error "Problem with the color value\n\
                                  color is \"$val\""
                        }
                        set calState($parent.background) $val
                    }
                    -foreground {
                        if {$val eq {}} {
                            return $calState($parent.foreground)
                        };# END: if no color specified
                        set er [catch {label .tmp -foreground $val} result]
                        destroy .tmp   
                        if {$er} {
                            error "Problem with the color value\n\
                                  color is \"$val\""
                        }
                        set calState($parent.foreground) $val
                    }
                    -activebackground {
                        if {$val eq {}} {
                            return $calState($parent.activebackground)
                        };# END: if no color specified
                        set er [catch {label .tmp -background $val} result]
                        destroy .tmp   
                        if {$er} {
                            error "Problem with the color value\n\
                                  color is \"$val\""
                        }
                        set calState($parent.activebackground) $val
                    }
                    -dayfont {
                        if {$val eq {}} {
                            return $calState($parent.dayfont)
                        };# END: if no dayfont specified
                        set calState($parent.dayfont) $val
                    }
                    -clickedcolor {
                        if {$val eq {}} {
                            return $calState($parent.clickedcolor)
                        };# END: if no clicked color specified
                        set er [catch {label .tmp -background $val} result]
                        destroy .tmp   
                        if {$er} {
                            error "Problem with the color value\n\
                                  color is \"$val\""
                        }
                        set calState($parent.clickedcolor) $val
                    }
                    -relief {
                        if {$val eq {}} {
                            return $calState($parent.relief)
                        };# END: if no relief specified
                        set er [catch {label .tmp -relief $val} result]
                        destroy .tmp   
                        if {$er} {
                            error "Problem with the relief value\n\
                                  relief is \"$val\""
                        }
                        set calState($parent.relief) $val
                    }
                    -startsunday {
                        if {$val eq {}} {
                            return $calState($parent.startsunday)
                        };# END:  if no value for start sunday
                        set calState($parent.startsunday) 0  
                        if {$val == 1} {
                            set calState($parent.startsunday) 1
                        } 
                        # get rid of clicked state as calendar is going
                        # to change layout
                        set calState($parent.clicked) {}  
                    }
                    -balloon {
                        if {$val eq {}} {
                            return $calState($parent.balloon)
                        };# END:  if no value for balloon
                        set calState($parent.balloon) 0  
                        if {$val == 1} {
                            set calState($parent.balloon) 1
                        } 
                    }
                    -delay {
                        if {$val eq {}} {
                            return $calState($parent.delay)
                        };# END:  if no value for balloon delay
                        # delay check: must be integer
                        set er [catch {incr val 0}]
                        if {$er} {
                            error "Problem with the delay value\n\
                                  most likely a non integer value \n\
                                  given delay is \"$val\""
                        }
                        if {$val < 0} {
                            error "Problem with negative delay value\n\
                                  given delay is \"$val\""
                        }
                        set calState($parent.delay) $val 
                    }
                    -progcallback {
                        if {$val eq {}} {
                            return $calState($parent.progcallback)
                        };# END:  if no value for progcallback
                        set calState($parent.progcallback) 0  
                        if {$val == 1} {
                            set calState($parent.progcallback) 1
                        } 
                    }
                    -mark {
                        if {$val eq {}} {
                            return $calState($parent.mark)
                        };# END: if no marking list given
                        if {[llength $val] != 6} {
                            error "The mark list must have 6 elements\n\
                                   a mark list should be like this:  \n\
                                   {day month year prio color label}"
                        };# END: if mark list not properly constructed
                        
                        # assign temp_vars  
                        foreach {Mday Mmonth Myear Mpri Mcol Mlabel} $val {}
                        
                        # check the list fields for consistency  
                        # check the month
                        if {($Mmonth < 1) || ($Mmonth > 12)} {
                            error {Month out of range}
                        }
                        # check year and month, compute the number of days
                        # of the given month
                        set er [catch {cal_month_length $Mmonth $Myear} Ml]
                        if {$er} {
                            error "Problem computing month length,\n\
                                  year out of clock's range or erroneous\n\
                                  month value"
                        }
                        # day check
                        if {($Mday < 1) || ($Mday > $Ml)} {
                            error "Day of month out of range"
                            return
                        }
                        # prio check: must be integer
                        set er [catch {incr Mpri 0}]
                        if {$er} {
                            error "Problem with the priority value\n\
                                  most likely a non integer value \n\
                                  prio is \"$Mpri\""
                        }
                        # check that color is acceptable
                        set er [catch {label .tmp -background $Mcol} result]
                        destroy .tmp   
                        if {$er} {
                            error "Problem with the color value\n\
                                  color is \"$Mcol\""
                        }
                        # all consistency checks went OK
                        # append mark to mark list
                        lappend calState($parent.mark) $val
                    }
                    -daynames {
                        if {$val eq {}} {
                            return $calState($parent.daynames)
                        };# END: if no list with daynames specified
                        if {[llength $val] != 7} {
                            error "The list given to -daynames must have\n\
                                   7  elements, [llength $val] elements \n\
                                   were specified in $val"
                        };# END: if list didn't have 7 elements
                        set calState($parent.daynames) $val  
                    }
                    -clicked {
                        if {$val eq {}} {
                            return $calState($parent.clicked)
                        };# END: if no list with  calendar coordinates 
                        if {[llength $val] != 2} {
                            error "The list given to -clicked must have\n\
                                   2  elements, [llength $val] elements \n\
                                   were specified in $val"
                        };# END: if list didn't have 2 elements
                        set tmp_col [lindex $val 0]
                        set tmp_row [lindex $val 1]
                        if {($tmp_col < 0) || ($tmp_col > 6)} {
                            error "column value for clicked cell invalid\n\
                                   0<= col < 7 allowed, given: $tmp_col"
                        };# END: if coord isn't in right range
                        if { ($tmp_row < 0) || ($tmp_row > 5)} {
                            error "row value for clicked cell invalid\n\
                                   0<= col < 5 allowed, given: $tmp_col"
                        };# END: if coord isn't in right range
                        set Cstate [$parent.$tmp_col$tmp_row cget -state]
                        if {$Cstate eq {normal}} {              
                            set calState($parent.clicked) $val  
                            # call the callback as if the appropriate button
                            # was clicked. 
                            if {$calState($parent.progcallback)=="1"} {
                                callback $parent $tmp_col $tmp_row   
                              };# end: if programm callback enabled  
                        };# END: if cell is not disabled
                    }    
                    -month {
                        if {$val eq {}} {
                            return $calState($parent.month)
                        };# END: if no month specified
                        if {($val > 0) && ($val < 13)} {
                            set calState($parent.month) $val
                        } else {
                            error {Month value must be between 1 and 12}
                        }
                        set calState($parent.clicked) {}  
                      }
                    -year {
                        if {$val eq {}} {
                            return $calState($parent.year)
                        };# END: if no year specified
                        set calState($parent.year) $val
                        set calState($parent.clicked) {}  
                    }     
                    -callback {
                        if {$val eq {}} {
                            return $calState($parent.callback)
                        };# END: if no year specified
                        set calState($parent.callback) $val
                    }     
                    default {
                        error "Bad option: $opt\n\
                               allowed option(s) for configure are:    \n\
                               -font -startsunday -daynames -month     \n\
                               -year -dayfont -callback -clickedcolor  \n\
                               -background -clicked -mark -balloon     \n\
                               -progcallback -activebackground -delay  \n\
                               -foreground" 
                    }
                }
            }
            update_cal $parent  
        }
        nextmonth {
            if {[llength $args]} {
                error "nextmonth not allowed to have arguments"
            };# END: check number of arguments error if != 0
            incr calState($parent.month)
            if {$calState($parent.month) == 13} {
                set calState($parent.month) 1
                incr calState($parent.year)
            };# END: if month crossed year boundary to next year
            set calState($parent.clicked) {}  
            update_cal $parent  
            return [list $calState($parent.year) $calState($parent.month)]
        }
        prevmonth {
            if {[llength $args]} {
                error {prevmonth not allowed to have arguments}
            };# END: check number of arguments error if != 0
            incr calState($parent.month) -1
            if {$calState($parent.month) == 0} {
                set calState($parent.month) 12
                incr calState($parent.year) -1
            };# END: if month crossed year boundary to previous year
            set calState($parent.clicked) {}  
            update_cal $parent  
            return [list $calState($parent.year) $calState($parent.month)]
        }
        nextyear {
            if {[llength $args]} {
                error "nextyear not allowed to have arguments"
            };# END: check number of arguments error if != 0
            incr calState($parent.year)
            set calState($parent.clicked) {}  
            update_cal $parent  
            return [list $calState($parent.year) $calState($parent.month)]
        }
        prevyear {
            if {[llength $args]} {
                error {prevyear not allowed to have arguments}
            };# END: check number of arguments error if != 0
            incr calState($parent.year) -1
            set calState($parent.clicked) {}  
            update_cal $parent  
            return [list $calState($parent.year) $calState($parent.month)]
        }   
        default {
            error "You should never have reached this point\n\
                   The state of the widget might be mangled\n\
                   Bailing out, bye\n"
        }
    };# END: switch -- $command
};# END: calproc
  
#utilities start here
#anything needing calState does not belong below

# helper function to roll a list to the left #
proc callib::roll_left {listvar {rollby 1}} {
    set newlist $listvar
    for {set counter 0} {$counter < $rollby} {incr counter} {
        set firstelem [lindex $newlist 0]
        set newlist   [lreplace $newlist 0 0]
        set newlist   [lappend newlist $firstelem]
    }
    return $newlist
};# END roll_left
  
# returns the weekday as an ordinal number #
# sunday is 0                              #
proc callib::cal_start_weekday {month year} {
    # obvious, needed as a wrapper for future 
    # sophistication of the proc
    set startday [clock scan $month/1/$year]
    return [clock format $startday -format %w]
};# END: cal_start_weekday
  
# returns the length of a month #
proc callib::cal_month_length {monthvar yearvar} {
    # get clock ticks
    # make sure to stay in same month to stay in same year
    set startdate    [clock scan $monthvar/1/$yearvar]
    set enddate      [clock scan "+1 month" -base $startdate]
    set lastmonthday [clock scan "yesterday"  -base $enddate]

    # get day numbers from ticks
    set lastday      [clock format $lastmonthday -format %d]

    # get rid of leading zeroes as tcl interpret them as octal
    set lastday  [string trimleft $lastday 0]

    # actually not needed (clock ... %d returns min. 01)
    # but keep sane state for the variables
    if {$lastday eq {}} {set lastday 0}
    return $lastday 
};# END: cal_month_length
  
# returns a list of 35 elements containing the month #
# start day of week is sunday by default             #
proc callib::cal_build_month { month year } {
    set startday [cal_start_weekday $month $year]
    set numdays  [cal_month_length  $month $year]

    # put month there
    for {set counter 1} {$counter <= $numdays} {incr counter} {
        set monthlist [lappend monthlist $counter]
    }
    # make empty preceeding days if needed
    if {$startday != 0} {
        for {set counter 0} {$counter < $startday} {incr counter} {
            set prelist [lappend prelist {}]
        }
        return [concat $prelist $monthlist]
    }
    return $monthlist
};# END: cal_build_month
  
# return the monthlist with start either mondays or sundays #
proc callib::cal_list_month {month year {startsunday 1}} {
    # get the default (start sunday) list
    set monthlist [cal_build_month $month $year ]

    if {$startsunday != 1} {
        # start week as in Europe
        set firstday [cal_start_weekday $month $year]
        if {$firstday == 0} {
            set monthlist [linsert $monthlist 0 {} {} {} {} {} {}]
        } else {
            set monthlist [roll_left $monthlist]
        }
    }
    return $monthlist
};# END: cal_list_month

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References