1# -*- tcl -*- 2# 3# calendar.tcl - 4# 5# Calendar widget drawn on a canvas. 6# Adapted from Suchenwirth code on the wiki. 7# 8# Copyright (c) 2008 R�diger H�rtel 9# 10# RCS: @(#) $Id: calendar.tcl,v 1.9 2010/07/16 00:19:57 hobbs Exp $ 11# 12 13# 14# Creation and Options - widget::calendar $path ... 15# -command -default {} 16# -dateformat -default "%m/%d/%Y" 17# -font -default {Helvetica 9} 18# -textvariable -default {} 19# -firstday -default "monday" 20# -highlightcolor -default "#FFCC00" 21# -shadecolor -default "#888888" 22# -language -default en Supported languages: de, en, es, fr, gr, 23# he, it, ja, sv, pt, zh, fi ,tr, nl, ru, 24# crk, crx-nak, crx-lhe 25# 26# All other options to canvas 27# 28# Methods 29# $path get <part> => selected date, part can be 30# day,month,year, all 31# default is all 32# All other methods to canvas 33# 34# Bindings 35# NONE 36# 37 38if 0 { 39 # Samples 40 package require widget::calendar 41 #set db [widget::calendar .db] 42 #pack $sw -fill both -expand 1 43} 44 45### 46 47package require widget 48 49snit::widgetadaptor widget::calendar { 50 delegate option * to hull 51 delegate method * to hull 52 53 option -firstday -default monday -configuremethod C-refresh \ 54 -type [list snit::enum -values [list sunday monday]] 55 option -textvariable -default {} -configuremethod C-textvariable 56 57 option -command -default {} 58 option -dateformat -default "%m/%d/%Y" -configuremethod C-refresh 59 option -font -default {Helvetica 9} -configuremethod C-font 60 option -highlightcolor -default "#FFCC00" -configuremethod C-refresh 61 option -shadecolor -default "#888888" -configuremethod C-refresh 62 option -language -default en -configuremethod C-language 63 option -showpast -default 1 -configuremethod C-refresh \ 64 -type {snit::boolean} 65 66 67 variable fullrefresh 1 68 variable pending "" ; # pending after id for refresh 69 variable data -array { 70 day 01 month 01 year 2007 71 linespace 0 cellspace 0 72 selday {} selmonth {} selyear {} 73 } 74 75 constructor args { 76 installhull using canvas -highlightthickness 0 -borderwidth 0 \ 77 -background white 78 bindtags $win [linsert [bindtags $win] 1 Calendar] 79 80 set now [clock scan "today 00:00:00"] 81 82 foreach {data(day) data(month) data(year)} \ 83 [clock format $now -format "%e %m %Y"] { break } 84 scan $data(month) %d data(month) ; # avoid leading 0 issues 85 86 set data(selday) $data(day) 87 set data(selmonth) $data(month) 88 set data(selyear) $data(year) 89 90 # Binding for the 'day' tagged items 91 $win bind day <1> [mymethod invoke] 92 93 # move days 94 bind $win <Left> [mymethod adjust -1 0 0] 95 bind $win <Right> [mymethod adjust 1 0 0] 96 # move weeks 97 bind $win <Up> [mymethod adjust -7 0 0] 98 bind $win <Down> [mymethod adjust 7 0 0] 99 # move months 100 bind $win <Control-Left> [mymethod adjust 0 -1 0] 101 bind $win <Control-Right> [mymethod adjust 0 1 0] 102 # move years 103 bind $win <Control-Up> [mymethod adjust 0 0 -1] 104 bind $win <Control-Down> [mymethod adjust 0 0 1] 105 106 $self configurelist $args 107 108 $self reconfigure 109 $self refresh 110 } 111 112 destructor { 113 if { $options(-textvariable) ne "" } { 114 trace remove variable $options(-textvariable) write [mymethod DoUpdate] 115 } 116 } 117 118 # 119 # C-font -- 120 # 121 # Configure the font of the widget 122 # 123 ## 124 method C-font {option value} { 125 set options($option) $value 126 $self reconfigure 127 set fullrefresh 1 128 $self refresh 129 } 130 131 # 132 # C-refresh -- 133 # 134 # Place holder for all options that need a refresh after 135 # takeing over the new option. 136 # 137 ## 138 method C-refresh {option value} { 139 set options($option) $value 140 $self refresh 141 } 142 143 # 144 # C-textvariable -- 145 # 146 # Configure the textvariable for the widget. Installs a 147 # trace handler for the variable. 148 # If an empty textvariable is given the trace handler is 149 # uninstalled. 150 # 151 ## 152 method C-textvariable {option value} { 153 154 if { [string match "::widget::dateentry::Snit*" $value] } { 155 return 156 } 157 158 if {![string match ::* $value]} { 159 set value ::$value 160 } 161 set options($option) $value 162 163 if {$value ne "" } { 164 trace remove variable $options(-textvariable) write [mymethod DoUpdate] 165 166 if { ![info exists $options($option)] } { 167 set now [clock seconds] 168 set $options($option) [clock format $now -format $options(-dateformat)] 169 } 170 171 trace add variable ::$value write [mymethod DoUpdate] 172 if { [info exists $value] } { 173 $self DoUpdate 174 } 175 } 176 } 177 178 # 179 # C-language -- 180 # 181 # Configure the language of the calendar. 182 # 183 ## 184 method C-language {option value} { 185 186 set langs [list \ 187 de en es fr gr he it ja sv pt zh fi tr nl ru \ 188 crk \ 189 crx-nak \ 190 crx-lhe \ 191 ] 192 if { $value ni $langs } { 193 return -code error "Unsupported language. Choose one of: $langs" 194 } 195 196 set options($option) $value 197 198 $self refresh 199 } 200 201 # 202 # DoUpdate -- 203 # 204 # Update the internal values of day, month and year when the 205 # textvariable is written to (trace callback). 206 # 207 ## 208 method DoUpdate { args } { 209 210 set value $options(-textvariable) 211 set tmp [set $value] 212 if {$tmp eq ""} { return } 213 if {$::tcl_version < 8.5} { 214 # Prior to 8.4, users must use [clock]-recognized dateformat 215 set date [clock scan $tmp] 216 } else { 217 set date [clock scan $tmp -format $options(-dateformat)] 218 } 219 220 foreach {data(day) data(month) data(year)} \ 221 [clock format $date -format "%e %m %Y"] { break } 222 scan $data(month) %d data(month) ; # avoid leading 0 issues 223 224 set data(selday) $data(day) 225 set data(selmonth) $data(month) 226 set data(selyear) $data(year) 227 228 $self refresh 229 } 230 231 # 232 # get -- 233 # Return parts of the selected date or the complete date. 234 # 235 # Arguments: 236 # what - Selects the part of the date or the complete date. 237 # values <day,month,year, all>, default is all 238 # 239 ## 240 method get {{what all}} { 241 switch -exact -- $what { 242 "day" { return $data(selday) } 243 "month" { return $data(selmonth) } 244 "year" { return $data(selyear) } 245 "all" { 246 if {$data(selday) ne ""} { 247 set date [clock scan $data(selmonth)/$data(selday)/$data(selyear)] 248 set fmtdate [clock format $date -format $options(-dateformat)] 249 return $fmtdate 250 } 251 } 252 default { 253 return -code error "unknown component to retrieve \"$what\",\ 254 must be one of day, month or year" 255 } 256 } 257 } 258 259 # 260 # adjust -- 261 # 262 # Adjust internal values of the calendar and update the contents 263 # of the widget. This function is invoked by pressing the arrows 264 # in the widget and on key bindings. 265 # 266 # Arguments: 267 # dday - Difference in days 268 # dmonth - Difference in months 269 # dyear - Difference in years 270 # 271 ## 272 method adjust {dday dmonth dyear} { 273 incr data(year) $dyear 274 incr data(month) $dmonth 275 276 set maxday [$self numberofdays $data(month) $data(year)] 277 278 if { ($data(day) + $dday) < 1} { 279 incr data(month) -1 280 281 set maxday [$self numberofdays $data(month) $data(year)] 282 set data(day) [expr {($data(day) + $dday) % $maxday}] 283 284 } else { 285 286 if { ($data(day) + $dday) > $maxday } { 287 288 incr data(month) 1 289 set data(day) [expr {($data(day) + $dday) % $maxday}] 290 291 } else { 292 incr data(day) $dday 293 } 294 } 295 296 297 if { $data(month) > 12} { 298 set data(month) 1 299 incr data(year) 300 } 301 302 if { $data(month) < 1} { 303 set data(month) 12 304 incr data(year) -1 305 } 306 307 308 set maxday [$self numberofdays $data(month) $data(year)] 309 if { $maxday < $data(day) } { 310 set data(day) $maxday 311 } 312 set data(selday) $data(day) 313 set data(selmonth) $data(month) 314 set data(selyear) $data(year) 315 316 $self refresh 317 } 318 319 method cbutton {x y w command} { 320 # Draw simple arrowbutton using Tk's line arrows 321 set wd [expr {abs($w)}] 322 set wd2 [expr {$wd/2. - ((abs($w) < 10) ? 1 : 2)}] 323 set poly [$hull create line $x $y [expr {$x+$w}] $y -arrow last \ 324 -arrowshape [list $wd $wd $wd2] \ 325 -tags [list cbutton shadetext]] 326 $hull bind $poly <1> $command 327 } 328 329 method reconfigure {} { 330 set data(cellspace) [expr {[font measure $options(-font) "30"] * 2}] 331 set w [expr {$data(cellspace) * 8}] 332 set data(linespace) [font metrics $options(-font) -linespace] 333 set h [expr {int($data(linespace) * 9.25)}] 334 $hull configure -width $w -height $h 335 } 336 337 method refresh { } { 338 # Idle deferred refresh 339 after cancel $pending 340 set pending [after idle [mymethod Refresh ]] 341 } 342 343 method Refresh { } { 344 # Set up coords based on font spacing 345 set x [expr {$data(cellspace) / 2}]; set x0 $x 346 set dx $data(cellspace) 347 348 set y [expr {int($data(linespace) * 1.75)}] 349 set dy $data(linespace) 350 set pad [expr {$data(linespace) / 2}] 351 352 set xmax [expr {$x0+$dx*6}] 353 set winw [$hull cget -width] 354 set winh [$hull cget -height] 355 356 if {$fullrefresh} { 357 set fullrefresh 0 358 $hull delete all 359 360 # Left and Right buttons 361 set xs [expr {$data(cellspace) / 2}] 362 $self cbutton [expr {$xs+2}] $pad -$xs [mymethod adjust 0 0 -1]; # << 363 $self cbutton [expr {$xs*2}] $pad [expr {-$xs/1.5}] [mymethod adjust 0 -1 0]; # < 364 set lxs [expr {$winw - $xs - 2}] 365 $self cbutton $lxs $pad $xs [mymethod adjust 0 0 1]; # >> 366 incr lxs -$xs 367 $self cbutton $lxs $pad [expr {$xs/1.5}] [mymethod adjust 0 1 0]; # > 368 369 # day (row) and weeknum (col) headers 370 $hull create rect 0 [expr {$y - $pad}] $winw [expr {$y + $pad}] \ 371 -tags shade 372 $hull create rect 0 [expr {$y - $pad}] $dx $winh -tags shade 373 } else { 374 foreach tag {title otherday day highlight week} { 375 $hull delete $tag 376 } 377 } 378 379 # Title "Month Year" 380 set title [$self formatMY $data(month) $data(year)] 381 $hull create text [expr {$winw/2}] $pad -text $title -tag title \ 382 -font $options(-font) -fill blue 383 384 # weekdays - could be drawn on fullrefresh, watch -firstday change 385 set weekdays $LANGS(weekdays,$options(-language)) 386 if {$options(-firstday) eq "monday"} { $self lcycle weekdays } 387 foreach i $weekdays { 388 incr x $dx 389 $hull create text $x $y -text $i -fill white \ 390 -font $options(-font) -tag title 391 } 392 393 # place out the days 394 set first $data(month)/1/$data(year) 395 set weekday [clock format [clock scan $first] -format %w] 396 if {$options(-firstday) eq "monday"} { 397 set weekday [expr {($weekday+6)%7}] 398 } 399 400 # Print days preceding the 1st of the month 401 set x [expr {$x0+$weekday*$dx}] 402 set x1 $x; set offset 0 403 incr y $dy 404 while {$weekday} { 405 set t [clock scan "$first [incr offset] days ago"] 406 set day [clock format $t -format "%e"] ; # %d w/o leading 0 407 $hull create text $x1 $y -text $day \ 408 -font $options(-font) -tags [list otherday shadetext] 409 incr weekday -1 410 incr x1 -$dx 411 } 412 set dmax [$self numberofdays $data(month) $data(year)] 413 414 for {set d 1} {$d <= $dmax} {incr d} { 415 incr x $dx 416 if {($options(-showpast) == 0) 417 && ($d < $data(selday)) 418 && ($data(month) <= $data(selmonth)) 419 && ($data(year) <= $data(selyear))} { 420 # XXX day in the past - above condition currently broken 421 set id [$hull create text $x $y -text $d \ 422 -tags [list otherday shadetext] \ 423 -font $options(-font)] 424 } else { 425 # current month day 426 set id [$hull create text $x $y -text $d -tag day \ 427 -font $options(-font)] 428 } 429 if {$d == $data(selday) && ($data(month) == $data(selmonth))} { 430 # selected day 431 $hull create rect [$hull bbox $id] -tags [list day highlight] 432 } 433 $hull raise $id 434 if {$x > $xmax} { 435 # Week of the year 436 set x $x0 437 set week [$self getweek $d $data(month) $data(year)] 438 $hull create text [expr {$x0}] $y -text $week -tag week \ 439 -font $options(-font) -fill white 440 incr y $dy 441 } 442 } 443 # Week of year (last day) 444 if {$x != $x0} { 445 set week [$self getweek $dmax $data(month) $data(year)] 446 $hull create text [expr {$x0}] $y -text $week -tag week \ 447 -font $options(-font) -fill white 448 for {set d 1} {$x <= $xmax} {incr d} { 449 incr x $dx 450 $hull create text $x $y -text $d \ 451 -tags [list otherday shadetext] \ 452 -font $options(-font) 453 } 454 } 455 456 # Display Today line 457 set now [clock seconds] 458 set today "$LANGS(today,$options(-language)) [clock format $now -format $options(-dateformat)]" 459 $hull create text [expr {$winw/2}] [expr {$winh - $pad}] -text $today \ 460 -tag week -font $options(-font) -fill black 461 462 # Make sure options-based items are set 463 $hull itemconfigure highlight \ 464 -fill $options(-highlightcolor) \ 465 -outline $options(-highlightcolor) 466 $hull itemconfigure shadetext -fill $options(-shadecolor) 467 $hull itemconfigure shade -fill $options(-shadecolor) \ 468 -outline $options(-shadecolor) 469 } 470 471 method getweek {day month year} { 472 set _date [clock scan $month/$day/$year] 473 return [clock format $_date -format %V] 474 } 475 476 method invoke {} { 477 478 catch {focus -force $win} msg 479 if { $msg ne "" } { 480 # puts $msg 481 } 482 set item [$hull find withtag current] 483 set data(day) [$hull itemcget $item -text] 484 485 set data(selday) $data(day) 486 set data(selmonth) $data(month) 487 set data(selyear) $data(year) 488 set date [clock scan $data(month)/$data(day)/$data(year)] 489 set fmtdate [clock format $date -format $options(-dateformat)] 490 491 if {$options(-textvariable) ne {}} { 492 set $options(-textvariable) $fmtdate 493 } 494 495 if {$options(-command) ne {}} { 496 # pass single arg of formatted date chosen 497 uplevel \#0 $options(-command) [list $fmtdate] 498 } 499 500 $self refresh 501 } 502 503 method formatMY {month year} { 504 set lang $options(-language) 505 if {[info exists LANGS(mn,$lang)]} { 506 set month [lindex $LANGS(mn,$lang) $month] 507 } else { 508 set _date [clock scan $month/1/$year] 509 set month [clock format $_date -format %B] ; # full month name 510 } 511 if {[info exists LANGS(format,$lang)]} { 512 set format $LANGS(format,$lang) 513 } else { 514 set format "%m %Y" ;# default 515 } 516 # Replace month/year and do any necessary substs 517 return [subst [string map [list %m $month %Y $year] $format]] 518 } 519 520 method numberofdays {month year} { 521 if {$month == 12} {set month 0; incr year} 522 clock format [clock scan "[incr month]/1/$year 1 day ago"] -format %d 523 } 524 525 method lcycle _list { 526 upvar $_list list 527 set list [concat [lrange $list 1 end] [list [lindex $list 0]]] 528 } 529 530 typevariable LANGS -array { 531 mn,crk { 532 . Kis\u01E3p\u012Bsim Mikisiwip\u012Bsim Niskip\u012Bsim Ay\u012Bkip\u012Bsim 533 S\u0101kipak\u0101wip\u012Bsim 534 P\u0101sk\u0101wihowip\u012Bsim Paskowip\u012Bsim Ohpahowip\u012Bsim 535 N\u014Dcihitowip\u012Bsim Pin\u0101skowip\u012Bsim Ihkopiwip\u012Bsim 536 Paw\u0101cakinas\u012Bsip\u012Bsim 537 } 538 weekdays,crk {P\u01E3 N\u01E3s Nis N\u01E3 Niy Nik Ay} 539 today,crk {} 540 541 mn,crx-nak { 542 . {Sacho Ooza'} {Chuzsul Ooza'} {Chuzcho Ooza'} {Shin Ooza'} {Dugoos Ooza'} {Dang Ooza'}\ 543 {Talo Ooza'} {Gesul Ooza'} {Bit Ooza'} {Lhoh Ooza'} {Banghan Nuts'ukih} {Sacho Din'ai} 544 } 545 weekdays,crx-nak {Ji Jh WN WT WD Ts Sa} 546 today,crx-nak {} 547 548 mn,crx-lhe { 549 . {'Elhdzichonun} {Yussulnun} {Datsannadulhnun} {Dulats'eknun} {Dugoosnun} {Daingnun}\ 550 {Gesnun} {Nadlehcho} {Nadlehyaz} {Lhewhnandelnun} {Benats'ukuihnun} {'Elhdziyaznun} 551 } 552 weekdays,crx-lhe {Ji Jh WN WT WD Ts Sa} 553 today,crx-lhe {} 554 555 mn,de { 556 . Januar Februar M�rz April Mai Juni Juli August 557 September Oktober November Dezember 558 } 559 weekdays,de {So Mo Di Mi Do Fr Sa} 560 today,de {Heute ist der} 561 562 mn,en { 563 . January February March April May June July August 564 September October November December 565 } 566 weekdays,en {Su Mo Tu We Th Fr Sa} 567 today,en {Today is} 568 569 mn,es { 570 . Enero Febrero Marzo Abril Mayo Junio Julio Agosto 571 Septiembre Octubre Noviembre Diciembre 572 } 573 weekdays,es {Do Lu Ma Mi Ju Vi Sa} 574 today,es {} 575 576 mn,fr { 577 . Janvier F�vrier Mars Avril Mai Juin Juillet Ao�t 578 Septembre Octobre Novembre D�cembre 579 } 580 weekdays,fr {Di Lu Ma Me Je Ve Sa} 581 today,fr {} 582 583 mn,gr { 584 . ���???���?���??��� ???���?���?���??��� ���?������??��� ���������????��� ���?���?��� ���?���???��� ���?���???��� ������??���������?��� 585 ??���������??���??��� ���?������??���??��� ���?���??���??��� ���??���??���??��� 586 } 587 weekdays,gr {��������� ���?��� T���? ??��� � ?? � ?��� ???} 588 today,gr {} 589 590 mn,he { 591 . ���� ������? ?���?������? ���?? ���??������ ��������� ������� ��� ������������ ������������?��� ??���������? ������?���������? � ������������? ���?������? 592 } 593 weekdays,he {?���?������ ?� ��� ?������?��� ?������?��� ���������?��� ?���?��� ?���?} 594 today,he {} 595 596 mn,it { 597 . Gennaio Febraio Marte Aprile Maggio Giugno Luglio Agosto 598 Settembre Ottobre Novembre Dicembre 599 } 600 weekdays,it {Do Lu Ma Me Gi Ve Sa} 601 today,it {} 602 603 format,ja {%Y\u5e74 %m\u6708} 604 weekdays,ja {\u65e5 \u6708 \u706b \u6c34 \u6728 \u91d1 \u571f} 605 today,ja {} 606 607 mn,nl { 608 . januari februari maart april mei juni juli augustus 609 september oktober november december 610 } 611 weekdays,nl {Zo Ma Di Wo Do Vr Za} 612 today,nl {} 613 614 mn,ru { 615 . \u042F\u043D\u0432\u0430\u0440\u044C 616 \u0424\u0435\u0432\u0440\u0430\u043B\u044C \u041C\u0430\u0440\u0442 617 \u0410\u043F\u0440\u0435\u043B\u044C \u041C\u0430\u0439 618 \u0418\u044E\u043D\u044C \u0418\u044E\u043B\u044C 619 \u0410\u0432\u0433\u0443\u0441\u0442 620 \u0421\u0435\u043D\u0442\u044F\u0431\u0440\u044C 621 \u041E\u043A\u0442\u044F\u0431\u0440\u044C \u041D\u043E\u044F\u0431\u0440\u044C 622 \u0414\u0435\u043A\u0430\u0431\u0440\u044C 623 } 624 weekdays,ru { 625 \u432\u43e\u441 \u43f\u43e\u43d \u432\u442\u43e \u441\u440\u435 626 \u447\u435\u442 \u43f\u44f\u442 \u441\u443\u431 627 } 628 today,ru {} 629 630 mn,sv { 631 . januari februari mars april maj juni juli augusti 632 september oktober november december 633 } 634 weekdays,sv {s\u00F6n m\u00E5n tis ons tor fre l\u00F6r} 635 today,sv {} 636 637 mn,pt { 638 . Janeiro Fevereiro Mar\u00E7o Abril Maio Junho 639 Julho Agosto Setembro Outubro Novembro Dezembro 640 } 641 weekdays,pt {Dom Seg Ter Qua Qui Sex Sab} 642 today,pt {} 643 644 format,zh {%Y\u5e74 %m\u6708} 645 mn,zh { 646 . \u4e00 \u4e8c \u4e09 \u56db \u4e94 \u516d \u4e03 647 \u516b \u4e5d \u5341 \u5341\u4e00 \u5341\u4e8c 648 } 649 weekdays,zh {\u65e5 \u4e00 \u4e8c \u4e09 \u56db \u4e94 \u516d} 650 today,zh {} 651 652 mn,fi { 653 . Tammikuu Helmikuu Maaliskuu Huhtikuu Toukokuu Kes�kuu 654 Hein�kuu Elokuu Syyskuu Lokakuu Marraskuu Joulukuu 655 } 656 weekdays,fi {Ma Ti Ke To Pe La Su} 657 today,fi {} 658 659 mn,tr { 660 . ocak \u015fubat mart nisan may\u0131s haziran temmuz a\u011fustos eyl\u00FCl ekim kas\u0131m aral\u0131k 661 } 662 weekdays,tr {pa'tesi sa \u00e7a pe cu cu'tesi pa} 663 today,tr {} 664 } 665} 666 667package provide widget::calendar 0.95 668