Jaf 2005-02-08:
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.
Example for the impatient:
package require Tk package require callib calwid .test pack .test # Now, here are the error msgs .test configure -foo .test bar
Calling the widget with wrong arguments makes it complain and spew a bit of help.
Namespace stuff from Clif Flynt's book.
Jaf: Here is a bit of documentation:
Name
Synopsis
Widget commands:
Configure options
All options return their current value if they are called without arguments
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.
Jaf: A bit of light at the end of the tunnel? See Tcom examples for Microsoft Outlook, the idea was to let a server run on the outlook side of things. Cheers.
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
#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]
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 2005-02-24: changed the buttons to labels, functionality the same. Should be right under Aqua. Cheers.
Jaf 2005-03-03: Fixed a bug associated with setting the background color
hae 2005-10-19: removed additional characters in 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.
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.
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.
ofv 2008-05-27: Correction: Calls the callback with 6 arguments, as per the documentation, not with a list of six elements.
#! /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