A configurable calendar widget. [Jaf] 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. As for now the only documentation consists of the comments and the code within the big "switch" statement. A crude attempt at user help: 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. Sorry for the inconvenience, ss soon as I have the time I will write a bit of documentation for it. Namespace stuff from [Clif Flynt]'s book. ---- package provide callib 0.1 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 # 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 # 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 "+ 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 -font $calState($parent.dayfont) -width 2 grid $daylabel -row 1 -column $colcount 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 for {set row 0} {$row<6} {incr row} { for {set col 0} {$col<7} {incr col} { #set text [lindex $monthlist [expr 7*$row+$col] ] button $parent.$col$row -padx 0 -pady 0 \ -highlightthickness 2 \ -command "callib::callback $parent \ $col \ $row" grid $parent.$col$row -padx 0 -pady 0 -ipadx 0 -ipady 0 \ -row [expr {$row+2}] -column $col };#END: col };#END: row # now put the days in there update_cal $parent };# 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 -relief groove \ -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 -relief ridge \ -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 to be passed to the 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 # 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) 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 groove set stateval normal bind $parent.$col$row \ [list after $calState($parent.delay) \ [list callib::balloon_show %W]] bind $parent.$col$row \ "callib::balloon_dn %W" if {$text == ""} { set reliefval flat set stateval disabled bind $parent.$col$row {} bind $parent.$col$row {} };# END: if dayfield is empty # reconfigure the button $parent.$col$row configure -relief $reliefval -state $stateval \ -borderwidth 2 \ -width 2 \ -activebackground \ $calState($parent.activebackground)\ -background \ $calState($parent.background) \ -highlightbackground \ $calState($parent.background) \ -font $calState($parent.font) \ -text [format "%2s" $text] \ -anchor center };#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 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 } "-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 } "-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" } } } 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 ---- [[ [Category Widget] ]]