8 Feb. 2005 [Jaf]

A configurable calendar widget.
----
I wanted to configure the start of the week e.g Sunday/Monday in a calendar and ended up writing a 
widget. At least it allowed me to learn about namespaces.
----


For the impatient:
  package require callib
  calwid .test
  .test configure -foo
  .test bar
Calling the widget with wrong arguments makes it complain and spew a bit of
help.


For Documentation: see below

Namespace stuff from [Clif Flynt]'s book.
----
[MAK] Suggests using labels rather than buttons.  Under Aqua, there are no groove/flat button reliefs.


[Jaf], I think I would lose the callback capability. But it is worth looking into. Thanks.


[MG] If you switch to labels, I think you'd just need to do
  label $parent.$col$row -padx 0 -pady 0 -highlightthickness 2 ;# create the widget
  bind $parent.$col$row <Button-1> [list callib::callback $parent $col $row] ;# bind to 
                                                        # mouse-click for the callback
rather than using the [button] as you do now.

[Jaf]: I made a compromise: I just made the ''relief'' a configuration item. I think this should be OK (?) Cheers

[MAK]: Not exactly.  What I meant in the original statement was that, even if you configure a button with -relief flat, under Aqua it still shows up as a normal elongated round 3D button, not flat like a label.  Through some oddity with the minimum size of the buttons and the space alloted them by grid, there are other artifacts that make it just look wrong.

[Jaf] OK, I see the problem. I started reworking the widget. The labels make it a bit more difficult to implement the
activebackground stuff, I'll bind these too to the Enter/Leave events, that should be OK. Cheers.

[Jaf] 24 Feb 2005: changed the buttons to labels, functionality the same. Should be right under Aqua. Cheers.

[Jaf] 03 March 2005: Fixed a bug associated with setting the background color

[RH] 19 Oct 2005: removed additional characters in proc balloon_show that caused a tcl error

Wouldn't it be better to use the tooltip package of tklib instead of reimplementing the wheel, ahem tooltip.
----

 package provide callib 0.3

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

   # create body for the new widget proc
   set newCmd [format {return [namespace eval %s %s %s $args]} \
                                             callib     \
                                             calproc    \
                                             $newWidget ]
   # 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

    proc MakecalendarWid {args} {
    ##################################
    # procedure to create a calendar #
    ##################################
        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) [list Lucidatypewriter 12 normal]
        #day names, change the defaults to the language needed
        set calState($holder.daynames) [list "So" "Mo" "Di" "Mi" "Do" "Fr" "Sa"]
        #day font
        set calState($holder.dayfont) [list 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 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> "+ rename $holder {}"
        # return the name of the new widget
        return $holder
      };# END MakecalendarWid
    
    proc Draw {parent} {
    ###########################################################
    # this proc takes care of drawing and packing the widgets #      
    ###########################################################
        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

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

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

        if {$old_row != ""} {
            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 != ""} {
            $procname $callargs
          }
      }

    proc update_cal {parent} {
    ##################################################################
    # this proc updates the calendar shown according to the contents #
    # of the calState array                                          #
    ##################################################################
        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 == ""} {
                  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 != "") && ($col != "")} {
            $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

    proc enter_proc {wname} {
    ###################################
    # gets called at each enter event #
    ###################################
        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] 
      }

    proc leave_proc {wname} {
    ###################################
    # gets called at each leave event #
    ###################################
        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 != ""} {
            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 
      }

    proc balloon_show {wname} {
    #######################################
    # triggers a balloon help like window #
    #######################################
        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 

    proc balloon_dn {wname} {
    ###############################
    # makes the balloon disappear #
    ###############################
        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

    proc calproc {parent args} {
    ################################################################
    # This proc takes care of all the configuration subcommands of #
    # the calendar widget                                          #
    ################################################################
        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 [list "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 == ""} {
                    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 != "shownmarks"} {
                            lappend returnlist [list $opt $val]
                          }  
                      }
                    return $returnlist  
                  };# END: if no args for configure
                foreach {opt val} $args {
                    switch -- $opt {
                        "-font" {
                            if {$val == ""} {
                                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 == ""} {
                                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\""
                                return
                              }
                            set calState($parent.background) $val
                          }
                        "-foreground" {
                            if {$val == ""} {
                                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\""
                                return
                              }
                            set calState($parent.foreground) $val
                          }
                        "-activebackground" {
                            if {$val == ""} {
                                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\""
                                return
                              }
                            set calState($parent.activebackground) $val
                          }
                        "-dayfont" {
                            if {$val == ""} {
                                return $calState($parent.dayfont)
                              };# END: if no dayfont specified
                            set calState($parent.dayfont) $val
                          }
                        "-clickedcolor" {
                            if {$val == ""} {
                                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\""
                                return
                              }
                            set calState($parent.clickedcolor) $val
                          }
                        "-relief" {
                            if {$val == ""} {
                                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\""
                                return
                              }
                            set calState($parent.relief) $val
                          }
                        "-startsunday" {
                            if {$val == ""} {
                                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 == ""} {
                                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 == ""} {
                                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\""
                                return
                              }
                            if {$val < 0} {
                                error "Problem with negative delay value\n\
                                      given delay is \"$val\""
                                return
                              }
                            set calState($parent.delay) $val 
                          }
                        "-progcallback" {
                            if {$val == ""} {
                                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 == ""} {
                                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"
                                return
                              }
                            # 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"
                                return
                              }
                            # 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\""
                                return
                              }
                            # 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\""
                                return
                              }
                            # all consistency checks went OK
                            # append mark to mark list
                            lappend calState($parent.mark) $val
                          }
                        "-daynames" {
                            if {$val == ""} {
                                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 == ""} {
                                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 == "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 == ""} {
                                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 == ""} {
                                return $calState($parent.year)
                              };# END: if no year specified
                            set calState($parent.year) $val
                            set calState($parent.clicked) {}  
                          }     
                        "-callback" {
                            if {$val == ""} {
                                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
    proc roll_left {listvar {rollby 1}} {
    ##############################################
    # helper function to roll a list to the left #
    ##############################################
        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

    proc cal_start_weekday { month year } {
    ############################################
    # returns the weekday as an ordinal number #
    # sunday is 0                              #
    ############################################
        # 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

    proc cal_month_length { monthvar yearvar } {
    #################################
    # returns the length of a month #
    #################################
        # 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  == ""} {set lastday  "0"}
        # return
        return   $lastday 
      };# END: cal_month_length

    proc cal_build_month { month year } {
    ######################################################
    # returns a list of 35 elements containing the month #
    # start day of week is sunday by default             #
    ######################################################
        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 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

  };# END namespace callib


 
----
See also [An i15d date chooser]


[Jaf] Yes I had a look at it. That gave hints on how to do things, thanks a lot.
----
[Jaf] Here is a bit of documentation:

'''Name'''

''calwid'' - Create and manipulate calendar widgets
 
'''Synopsis'''

''calwid'' pathName ?options?

'''Widget commands:'''

''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 mounth

''nextyear'' Goes back one year. The month shown remains the same

'''configure'''

''Arguments'' see below

Without any arguments, dumps the current configuration


'''Configure options'''

Note: all options return their current value if they are called without arguments

''-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.
''                   '' Note that 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

----
[Jaf]: Does somebody know how to contact a MS exchange server? It would be nice to fill the marks with appointments.
Cheers.

[MAKR]: Via IMAP maybe? At my company the Exchange servers can be queried via IMAP and return an email with a vCalendar MIME part.

[LV] This would be a '''great''' topic to pursue.  If someone could build a cross platform
Tcl extension to interact with the calendaring portion of the MS server environment, it
would be a great ''selling'' point for the language.

[Jaf]: I've been experimenting a bit with the RFC244{5,6,7} sending schedule requests from my sun to my M$ e-mail account. I could get an appointment scheduled but never got an answer to my free/busy requests. Still ongoing though..., Cheers.

[LV] Sure wish this could be a two way bridge. I use Sun's calendaring, but my task leader uses exchange. So we never can see each other's appointments.
 
----
[LV] Have you considered making use of [Tile] so that your widgets look more native?

[LV] A nice addition would be adding the code (from somewhere here on the wiki) so that month and day names and abbreviations are internationalized (or is that localized?), etc.
----
!!!!!!
%| [Category Widget] | [Category Date and Time] |%
!!!!!!