scripts/diary.itk

   1 # vim: foldmarker=<<<,>>>
   2
   3 itk::usual Calendar {
   4         keep -resultformat -monthnames -titlegap -titleheight -titlespacer \
   5                  -weekdayheaders -padx -pady -cellwidth -cellheight -dayheaderheight \
   6                  -validfrom -validto -titlefg -titlefont -fillerbg -weekdayheaderbg \
   7                  -availablebg -invalidbg -weekendbg -specialbg -dayfont \
   8                  -weekdayheaderfont -weekdayheaderfg -availablefg -invalidfg \
   9              -weekendfg -specialfg -borders -background -command -special_cb \
  10                 -onlyweekdays
  11 }
  12
  13 class tlc::Diary {
  14         inherit tlc::Mywidget tlc::Handlers
  15
  16         constructor {args} {}
  17         destructor {}
  18
  19         # Multiplicity of options <<<
  20         itk_option define -resultformat resultFormat ResultFormat "%Y-%m-%d"
  21         itk_option define -monthnames monthNames MonthNames {January February March April May June July August September October November December} eventually_rerender
  22         itk_option define -titlegap titleGap TitleGap 4 eventually_rerender
  23         itk_option define -titleheight titleHeight TitleHeight 20 eventually_rerender
  24         itk_option define -titleskew titleSkew TitleSkew 0 eventually_rerender
  25         itk_option define -titlespacer titleSpacer TitleSpacer 4 eventually_rerender
  26         itk_option define -weekdayheaders weekdayHeaders WeekdayHeaders {Su Mo Tu We Th Fr Sa} eventually_rerender
  27         itk_option define -validhours validHours Validhours {6 7 8 9 10 12 13 14 15 16 17 18 19 20}
  28         itk_option define -padx padX PadX 5     eventually_rerender
  29         itk_option define -pady padY PadY 5     eventually_rerender
  30         itk_option define -cellwidth cellWidth CellWidth 40 eventually_rerender
  31         itk_option define -cellheight cellHeight CellHeight 50 eventually_rerender
  32         itk_option define -hourheight hourHeight HourHeight 20 eventually_rerender
  33         itk_option define -hourwidth hourWidth HourWidth 60 eventually_rerender
  34         itk_option define -dayheaderheight dayHeaderHeight DayHeaderHeight 23 eventually_rerender
  35         itk_option define -validfrom validFrom ValidFrom "" eventually_rerender
  36         itk_option define -validto validTo ValidTo "" eventually_rerender
  37
  38         itk_option define -titlefg titleFg TitleFg "black" configure_tags
  39         itk_option define -titlefont titleFont TitleFont {Helvetica -14 bold} configure_tags
  40         itk_option define -fillerbg fillerBg FillerBg "#999999" configure_tags
  41         itk_option define -weekdayheaderbg weekdayHeaderBg WeekdayHeaderBg "#9cdefc" configure_tags
  42         itk_option define -availablebg availableBg AvailableBg "white" configure_tags
  43         itk_option define -invalidbg invalidBg InvalidBg "#c4c4c4" configure_tags
  44         itk_option define -weekendbg weekendBg WeekendBg "#cefff9" configure_tags
  45         itk_option define -specialbg specialBg SpecialBg "white" configure_tags
  46         itk_option define -dayfont dayFont DayFont {Helvetica -12 bold} configure_tags
  47         itk_option define -weekdayheaderfont weekdayHeaderFont WeekdayHeaderFont {Helvetica -12 bold} configure_tags
  48         itk_option define -weekdayheaderfg weekdayHeaderFg WeekdayHeaderFg "black" configure_tags
  49         itk_option define -availablefg availableFg AvailableFg "black" configure_tags
  50         itk_option define -invalidfg invalidFg InvalidFg "#a0a0a0" configure_tags
  51         itk_option define -weekendfg weekendFg WeekendFg "black" configure_tags
  52         itk_option define -specialfg specialFg SpecialFg "black" configure_tags
  53         itk_option define -todaybg todayBg TodayBg "#f1ff0a" configure_tags
  54         itk_option define -borders borders Borders "black" configure_tags
  55         itk_option define -command command Command {}
  56         itk_option define -onlyweekdays onlyWeekdays OnlyWeekdays 1
  57         itk_option define -textvariable textVariable TextVariable ""
  58         itk_option define -newselection newSelection NewSelection {}
  59         # Multiplicity of options >>>
  60
  61         public {
  62                 variable date           ""      eventually_rerender
  63                 variable day            ""  eventually_rerender
  64                 variable month          ""      eventually_rerender
  65                 variable year           ""      eventually_rerender
  66                 variable today          ""      eventually_rerender
  67                 variable special_cb     {}      eventually_rerender
  68
  69                 method next_month {}
  70                 method last_month {}
  71                 method next_year {}
  72                 method last_year {}
  73                 method scroll_month {delta}
  74                 method scroll_year {delta}
  75                 method force_redraw {}
  76                 method rerender_dom_ref {}
  77                 method get_date {}
  78         }
  79
  80         private {
  81                 common imgs
  82                 variable colstart
  83                 variable rows
  84                 variable days
  85                 variable topleft_x
  86                 variable topleft_y
  87                 variable dayheader_height
  88                 variable cell_w
  89                 variable cell_h
  90                 variable rendered
  91                 variable special
  92                 variable valid_from_day
  93                 variable valid_to_day
  94                 variable eventually_rerender_id ""
  95                 variable constructing
  96                 variable tooltip_txt    ""
  97                 variable rerender_dom
  98                 variable date_sel ""
  99                 variable old_textvariable ""
 100                 variable dat
 101
 102
 103                 method dayheader_xy {dnum}
 104                 method xy {dom}
 105                 method bbox {dom}
 106                 method rc {dom}
 107                 method rerender {}
 108                 method configure_tags {}
 109                 method dom_tags {pref dom}
 110                 method get_special {}
 111                 method enter_day {}
 112                 method leave_day {}
 113                 method enter_dom {dom}
 114                 method leave_dom {dom}
 115                 method available {dom}
 116                 method eventually_rerender {}
 117                 method select_day {}
 118                 method day_rerender {}
 119                 method newvalue {args} {}
 120                 method newselection {newdate}
 121
 122         }
 123 }
 124
 125
 126 body tlc::Diary::constructor {args} { #<<<1
 127         set constructing        1
 128         set rendered            0
 129         array set special       {}
 130
 131         Domino #auto rerender_dom
 132         $rerender_dom attach_output [code $this force_redraw]
 133
 134         if {![info exists imgs(current)]} {
 135                 foreach {name file} {
 136                         day_selected                    day_selected.gif
 137                         special_day                             special_day.gif
 138                         left_arrow                              left_arrow.gif
 139                         right_arrow                             right_arrow.gif
 140                         left_arrow_disabled             left_arrow_disabled.gif
 141                         right_arrow_disabled    right_arrow_disabled.gif
 142                 } {
 143                         set imgs($name) [image create photo \
 144                                         -file [file join $::tlc::library scripts images $file]]
 145                 }
 146         }
 147
 148         Hoverbox $w.tooltip -textvariable [scope tooltip_txt] \
 149                         -background "#ffffe1"
 150
 151         itk_component add canvas {
 152                 canvas $w.cal
 153         } {
 154                 usual
 155                 ignore -borderwidth
 156         }
 157
 158         set today [clock format [clock seconds] -format "%d/%m/%Y"]
 159
 160         set dat(new_date) $today
 161
 162         frame $w.frame -borderwidth 1 -relief groove
 163         Dateentry $w.frame.date -textvariable [scope dat(new_date)]
 164         canvas $w.frame.day
 165
 166         table $w.frame \
 167                         $w.frame.date   1,1 \
 168                         $w.frame.day    2,1 -padx {3 3} -pady {3 3}
 169
 170         table $w \
 171                         $w.cal          1,1 \
 172                         $w.frame        1,2
 173
 174         eval itk_initialize $args
 175         $w.cal bind day_box <Enter> [code $this enter_day]
 176         $w.cal bind day_box <Leave> [code $this leave_day]
 177         $w.cal bind day_box <Button-1> [code $this select_day]
 178
 179         $w.cal bind left_arrow <Button-1> [code $this last_month]
 180         $w.cal bind right_arrow <Button-1> [code $this next_month]
 181
 182         catch {
 183                 $w.cal bind monthname <MouseWheel> \
 184                                 [code $this scroll_month \[expr \{- (%D / 120) * 4\}\]]
 185         }
 186         $w.cal bind monthname <Button-5> [code $this last_month]
 187         $w.cal bind monthname <Button-4> [code $this next_month]
 188         catch {
 189                 $w.cal bind yearname <MouseWheel> \
 190                                 [code $this scroll_year \[expr \{- (%D / 120) * 4\}\]]
 191         }
 192         $w.cal bind yearname <Button-5> [code $this last_year]
 193         $w.cal bind yearname <Button-4> [code $this next_year]
 194
 195         register_handler enter_dom [code $this enter_dom]
 196         register_handler leave_dom [code $this leave_dom]
 197
 198         set constructing        0
 199
 200         rerender
 201         day_rerender
 202 }
 203
 204
 205 body tlc::Diary::destructor {} { #<<<1
 206         after cancel $eventually_rerender_id
 207 }
 208
 209
 210 # get the (double)(x,y) of the center of the cell for the weekday header dnum
 211 body tlc::Diary::dayheader_xy {dnum} { #<<<1
 212         if {$dnum < 0 || $dnum > 6} {
 213 #               log error "Calender::dayheader_xy: dnum ($dnum) out of range (0-6)"
 214                 error "Calender::dayheader_xy: dnum ($dnum) out of range (0-6)"
 215         }
 216
 217         set x           [expr {$topleft_x}]
 218         set y           [expr {$topleft_y + $dayheader_height / 2.0}]
 219
 220         set x           [expr {$x + $dnum * $cell_w + $cell_w / 2.0}]
 221
 222         return [list $x $y]
 223 }
 224
 225
 226 # Get the (double)(x,y) of the center of the cell for day of month
 227 body tlc::Diary::xy {dom} { #<<<1
 228 #       set x           0
 229 #       set y           0
 230         set x           [expr {$topleft_x}]
 231         set y           [expr {$topleft_y + $dayheader_height}]
 232
 233         foreach {r c} [rc $dom] break
 234
 235         set x           [expr {$x + $cell_w * $c + $cell_w / 2.0}]
 236         set y           [expr {$y + $cell_h * $r + $cell_h / 2.0}]
 237
 238         return [list $x $y]
 239 }
 240
 241
 242 # Get the (double)(x1,y1,x2,y2) bounding box of the cell for day of month $dom
 243 body tlc::Diary::bbox {dom} { #<<<1
 244 #       set x           0
 245 #       set y           0
 246         set x           [expr {$topleft_x}]
 247         set y           [expr {$topleft_y + $dayheader_height}]
 248
 249         foreach {r c} [rc $dom] break
 250
 251         set x1          [expr {$x + $cell_w * $c}]
 252         set y1          [expr {$y + $cell_h * $r}]
 253         set x2          [expr {$x + $cell_w * $c + $cell_w}]
 254         set y2          [expr {$y + $cell_h * $r + $cell_h}]
 255
 256         return [list $x1 $y1 $x2 $y2]
 257 }
 258
 259
 260 # Get the (row,column) for day of month
 261 body tlc::Diary::rc {dom} { #<<<1
 262         if {$dom < 1 || $dom > $days} {
 263 #               log error "tlc::Calendar::rc: dom ($dom) is out of range ($days)"
 264                 error "tlc::Calendar::rc: dom ($dom) is out of range ($days)"
 265         }
 266
 267         incr dom        -1
 268
 269         set cell        [expr {$colstart + $dom}]
 270         set row         [expr {$cell / 7}]
 271         set col         [expr {$cell % 7}]
 272
 273         return [list $row $col]
 274 }
 275
 276 body tlc::Diary::day_rerender {} { #<<<1
 277         $w.frame.day delete all
 278         $w.frame.day configure -width 400 -height 400
 279         $w.frame.day yview moveto 0.0
 280         $w.frame.day xview moveto 0.0
 281
 282         set times {
 283                 "06:00"
 284                 "07:00"
 285                 "08:00"
 286                 "09:00"
 287                 "10:00"
 288                 "11:00"
 289                 "12:00"
 290                 "13:00"
 291                 "14:00"
 292                 "15:00"
 293                 "16:00"
 294                 "17:00"
 295                 "18:00"
 296                 "19:00"
 297         }
 298         set day_width 400
 299         set day_height 400
 300
 301 #       puts "Diary::day_rerender: width ($day_width) height ($day_height)"
 302
 303         set hour_width [expr {$day_width / 3}]
 304         set hour_height [expr {$day_height / 14}]
 305
 306
 307         for {set row 0} {$row < 14} {incr row} {
 308                 set y [expr {$row * $hour_height}]
 309                 set y2 [expr {$y + $hour_height}]
 310                 for {set column 0} {$column < 1} {incr column} {
 311                         set x [expr {$column * $hour_width}]
 312                         set x2 [expr {$x + $hour_width}]
 313                         set x3 [expr {$hour_width * 2 + $x2}]
 314 #                       puts "Diary::day_rerender: x ($x) y ($y) w ($x2) h ($y2)"
 315                         $w.frame.day create rectangle $x $y $x2 $y2 -fill yellow
 316                         set tx [expr {$x + 10}]
 317                         set ty [expr {$y + 10}]
 318                         $w.frame.day create text $tx $ty -text "[lindex $times $row]" -anchor w
 319                         $w.frame.day create rectangle $x2 $y $x3 $y2 -fill white
 320                 }
 321         }
 322         set new_date ""
 323         if {$date_sel == ""} {
 324                 set new_date $today
 325         } else {
 326                 set new_date ""
 327                 set new_date $date_sel
 328         }
 329
 330         set dat(new_date) $new_date
 331
 332 }
 333
 334 body tlc::Diary::rerender {} { #<<<1
 335         if {$constructing} return
 336 #       log debug "rerender profile [time \{
 337         after cancel $eventually_rerender_id
 338         set eventually_rerender_id      ""
 339
 340         if {$date == ""} {
 341                 set date        [clock seconds]
 342         }
 343         foreach {d m y} [clock format $date -format "%d %m %Y"] break
 344
 345         if {$day == ""} {
 346                 set day $d
 347         }
 348         if {$month == ""} {
 349                 set month       $m
 350         }
 351         if {$year == ""} {
 352                 set year        $y
 353         }
 354
 355         set month       [string trimleft $month 0]
 356         set year        [string trimleft $year 0]
 357         if {$year == ""} {set year      0}
 358
 359         get_special
 360 #       log debug "tlc::Calendar::rerender: ($w) after get_special"
 361
 362         set colstart    [clock format [clock scan "$year-$month-01"] -format "%w"]
 363
 364         # Determine days in month
 365         set tmp                 [clock format [clock scan "$year-$month-01 + 1 month"] -format "%Y-%m-01"]; # first day of next month
 366         set delta               [expr {[clock scan $tmp] - [clock scan "$year-$month-01"]}]
 367         set days                [expr {$delta / 86400}]
 368
 369         set rows                [expr {int(ceil(($colstart + $days) / 7.0))}]
 370
 371         set topleft_x           $itk_option(-padx)
 372         set topleft_y           [expr {$itk_option(-titleheight) + $itk_option(-pady) + $itk_option(-titlespacer)}]
 373         set dayheader_height    $itk_option(-dayheaderheight)
 374 # 23 x 26 y
 375         set cell_h                              $itk_option(-cellheight)
 376         set cell_w                              $itk_option(-cellwidth)
 377
 378         # Calculate relative valid days <<<
 379         if {$itk_option(-validfrom) != ""} {
 380                 set valid_from  [clock scan \
 381                                 [clock format \
 382                                         [clock scan $itk_option(-validfrom)] \
 383                                 -format "%Y-%m-%d"]]
 384                 set valid_from_day \
 385                                 [expr {($valid_from - [clock scan "$year-$month-01"]) / 86400 + 1}]
 386         } else {
 387                 set valid_from_day      -1000
 388         }
 389
 390         if {$itk_option(-validto) != ""} {
 391                 set valid_to    [clock scan \
 392                                 [clock format \
 393                                         [clock scan $itk_option(-validto)] \
 394                                 -format "%Y-%m-%d"]]
 395                 set valid_to_day \
 396                                 [expr {$days - (([clock scan "$year-$month-$days"] - $valid_to) / 86400)}]
 397         } else {
 398                 set valid_to_day        1000
 399         }
 400         # Calculate relative valid days >>>
 401
 402         # Calculate canvas bounding box <<<
 403         set width               0
 404         set height              0
 405         incr width              [expr {$itk_option(-padx) * 2}]
 406         incr width              [expr {7 * $cell_w}]
 407         incr height             [expr {$itk_option(-pady) * 2}]
 408         incr height             $itk_option(-titleheight)
 409         incr height             $itk_option(-titlespacer)
 410         incr height             $dayheader_height
 411         incr height             [expr {$rows * $cell_h}]
 412         # Calculate canvas bounding box >>>
 413
 414 #       log trivia "tlc::Calendar::rerender: $y-$m-$d\ncolstart: ($colstart)\ndays: ($days)\nrows: ($rows)\nwidth: ($width) height: ($height) rc(1): ([rc 1])\nvalid from, to: ($valid_from_day,$valid_to_day)"
 415
 416         $w.cal configure -width $width -height $height
 417         $w.cal yview moveto 0.0
 418         $w.cal xview moveto 0.0
 419
 420         # draw calendar <<<
 421         $w.cal delete all
 422
 423         # draw day area background
 424         set x1  $topleft_x
 425         set y1  [expr {$topleft_y + $dayheader_height}]
 426         set x2  [expr {$x1 + 7 * $cell_w}]
 427         set y2  [expr {$y1 + $rows * $cell_h}]
 428         $w.cal create rectangle $x1 $y1 $x2 $y2 -tags bg_filler
 429
 430         # draw weekday backgrounds
 431         set y1  $topleft_y
 432         set y2  [expr {$y1 + $dayheader_height}]
 433         for {set d 0} {$d < 7} {incr d} {
 434                 set x1          [expr {$topleft_x + $d * $cell_w}]
 435                 set x2          [expr {$x1 + $cell_w}]
 436                 $w.cal create rectangle $x1 $y1 $x2 $y2 -tags bg_weekday_header
 437         }
 438
 439         # draw day backgrounds
 440         for {set d 1} {$d <= $days} {incr d} {
 441                 foreach {x1 y1 x2 y2} [bbox $d] break
 442                 $w.cal create rectangle $x1 $y1 $x2 $y2 -tags [dom_tags bg $d]
 443         }
 444
 445         # draw month selector
 446         set y   [expr {$itk_option(-pady) + $itk_option(-titleheight) / 2.0}]
 447         set x   [expr {$itk_option(-padx)}]
 448         $w.cal create image $x $y \
 449                         -image $imgs(left_arrow) \
 450                         -disabledimage $imgs(left_arrow_disabled) \
 451                         -anchor w -tags left_arrow \
 452                         -state [lindex {disabled normal} [expr {$valid_from_day < 1}]]
 453         set x   [expr {$width - $itk_option(-padx)}]
 454         $w.cal create image $x $y \
 455                         -image $imgs(right_arrow) \
 456                         -disabledimage $imgs(right_arrow_disabled) \
 457                         -anchor e -tags right_arrow \
 458                         -state [lindex {disabled normal} [expr {$valid_to_day > $days}]]
 459         set x   [expr {$width * 0.55}]
 460         $w.cal create text [expr {$x - $itk_option(-titlegap) / 2.0 + $itk_option(-titleskew)}] $y \
 461                         -anchor e \
 462                         -text [lindex $itk_option(-monthnames) [expr {$month - 1}]] \
 463                         -tags {monthname title}
 464         $w.cal create text [expr {$x + $itk_option(-titlegap) / 2.0 + $itk_option(-titleskew)}] $y \
 465                         -anchor w \
 466                         -text $year \
 467                         -tags {yearname title}
 468
 469         # draw weekday headers
 470         for {set d 0} {$d < 7} {incr d} {
 471                 foreach {x y} [dayheader_xy $d] break
 472                 $w.cal create text $x $y \
 473                                 -text [lindex $itk_option(-weekdayheaders) $d] \
 474                                 -tags fg_weekday_header
 475         }
 476
 477         # draw day numbers
 478         for {set d 1} {$d <= $days} {incr d} {
 479                 foreach {x y} [xy $d] break
 480                 $w.cal create text $x $y -text $d -tags [dom_tags fg $d]
 481                 if {[info exists special($d)]} {
 482                         $w.cal create image $x $y -image $imgs(special_day) -anchor center
 483                 }
 484         }
 485
 486         $w.cal create image -100 -100 -image $imgs(day_selected) -anchor center \
 487                         -tags day_selected
 488
 489         # create binders
 490         for {set d 1} {$d <= $days} {incr d} {
 491                 foreach {x1 y1 x2 y2} [bbox $d] break
 492                 $w.cal create rectangle $x1 $y1 $x2 $y2 -tags [list day_box "dom $d"] -fill "" -outline ""
 493         }
 494         # draw calendar >>>
 495
 496         set rendered    1
 497         configure_tags
 498
 499         day_rerender
 500 #\}]"
 501 }
 502
 503
 504 body tlc::Diary::configure_tags {} { #<<<1
 505         if {!$rendered} rerender
 506         $w.cal itemconfigure bg_filler -fill $itk_option(-fillerbg)
 507         $w.cal itemconfigure bg_weekday_header -fill $itk_option(-weekdayheaderbg)
 508         $w.cal itemconfigure bg_available -fill $itk_option(-availablebg)
 509         $w.cal itemconfigure bg_invalid -fill $itk_option(-invalidbg)
 510         $w.cal itemconfigure bg_weekend -fill $itk_option(-weekendbg)
 511         $w.cal itemconfigure bg_special -fill $itk_option(-specialbg)
 512         $w.cal itemconfigure bg_today -fill $itk_option(-todaybg)
 513
 514         $w.cal itemconfigure fg_day -font $itk_option(-dayfont)
 515         $w.cal itemconfigure fg_weekday_header -font $itk_option(-weekdayheaderfont)
 516
 517         $w.cal itemconfigure fg_weekday_header -fill $itk_option(-weekdayheaderfg)
 518         $w.cal itemconfigure fg_available -fill $itk_option(-availablefg)
 519         $w.cal itemconfigure fg_invalid -fill $itk_option(-invalidfg)
 520         $w.cal itemconfigure fg_weekend -fill $itk_option(-weekendfg)
 521         $w.cal itemconfigure fg_special -fill $itk_option(-specialfg)
 522
 523         $w.cal itemconfigure bg_day -outline $itk_option(-borders)
 524         $w.cal itemconfigure bg_filler -outline $itk_option(-borders)
 525         $w.cal itemconfigure bg_weekday_header -outline $itk_option(-borders)
 526
 527         $w.cal itemconfigure title -fill $itk_option(-titlefg)
 528         $w.cal itemconfigure title -font $itk_option(-titlefont)
 529 }
 530
 531
 532 # Returns a list of tags applicable for day of month $dom
 533 body tlc::Diary::dom_tags {pref dom} { #<<<1
 534         if {$dom < 1 || $dom > $days} {
 535 #               log error "tlc::Calendar::dom_tags: dom ($dom) out of range (0-$days)"
 536                 error "tlc::Calendar::dom_tags: dom ($dom) out of range (0-$days)"
 537         }
 538         set build               {}
 539         lappend build   "${pref}_dom $dom"
 540         lappend build   ${pref}_day
 541
 542         set weekday             [expr {($colstart + $dom - 1) % 7}]
 543         if {$dom < $valid_from_day || $dom > $valid_to_day} {
 544                 lappend build   ${pref}_invalid
 545         } elseif {$weekday == 0 || $weekday == 6} {
 546                 lappend build   ${pref}_weekend
 547         } elseif {[info exists special($dom)]} {
 548                 lappend build   ${pref}_special
 549         }
 550         if {[available $dom]} {
 551                 lappend build   ${pref}_available
 552         }
 553
 554 #       log trivia "tlc::Calendar::dom_tags: ($dom) ($build)"
 555
 556         return $build
 557 }
 558
 559
 560 # Call the special_cb (if any) to get a list of special days
 561 body tlc::Diary::get_special {} { #<<<1
 562         catch {unset special}
 563         array set special {}
 564         if {$special_cb != {}} {
 565                 array set special [uplevel #0 $special_cb [list $year $month]]
 566         }
 567 }
 568
 569
 570 body tlc::Diary::enter_day {} { #<<<1
 571         set dom         ""
 572         foreach tag [$w.cal gettags current] {
 573                 if {[string range $tag 0 3] == "dom "} {
 574                         set dom         [string range $tag 4 end]
 575                 }
 576         }
 577
 578         if {$dom == ""} {
 579                 set tags        [$w.cal gettags current]
 580 #               log error "tlc::Calendar::enter_day: couldn't resolve dom ($tags)"
 581                 error "tlc::Calendar::enter_day: couldn't resolve dom ($tags)"
 582         }
 583
 584         invoke_handlers enter_dom $dom
 585 }
 586
 587
 588 body tlc::Diary::leave_day {} { #<<<1
 589         set dom         ""
 590         foreach tag [$w.cal gettags current] {
 591                 if {[string range $tag 0 3] == "dom "} {
 592                         set dom         [string range $tag 4 end]
 593                 }
 594         }
 595
 596         if {$dom == ""} {
 597                 set tags        [$w.cal gettags current]
 598 #               log error "tlc::Calendar::enter_day: couldn't resolve dom ($tags)"
 599                 error "tlc::Calendar::enter_day: couldn't resolve dom ($tags)"
 600         }
 601
 602         invoke_handlers leave_dom $dom
 603 }
 604
 605
 606 body tlc::Diary::enter_dom {dom} { #<<<1
 607 #       log trivia "tlc::Calendar::enter_dom: ($dom)"
 608
 609         if {[available $dom]} {
 610                 $w.cal coords day_selected [xy $dom]
 611         }
 612         if {[info exists special($dom)]} {
 613                 set tooltip_txt         $special($dom)
 614                 foreach {x y} [xy $dom] break
 615                 set x           [expr {int([winfo rootx $w.cal] + $x - [winfo reqwidth $w.tooltip] / 2.0)}]
 616                 set y           [expr {int([winfo rooty $w.cal] + $y + $itk_option(-cellheight) / 2.0)}]
 617                 $w.tooltip moveto  $x $y
 618                 $w.tooltip show
 619                 $w.tooltip raisewin
 620         }
 621 }
 622
 623
 624 body tlc::Diary::leave_dom {dom} { #<<<1
 625 #       log trivia "tlc::Calendar::leave_dom: ($dom)"
 626
 627         $w.cal coords day_selected -100 -100
 628         $w.tooltip hide
 629 }
 630
 631
 632 body tlc::Diary::available {dom} { #<<<1
 633         set weekday             [expr {($colstart + $dom - 1) % 7}]
 634         if {$dom < $valid_from_day || $dom > $valid_to_day} {
 635                 return 0
 636         } elseif {$itk_option(-onlyweekdays) && ($weekday == 0 || $weekday == 6)} {
 637                 return 0
 638         } elseif {[info exists special($dom)]} {
 639                 return 0
 640         }
 641
 642         return 1
 643 }
 644
 645
 646 body tlc::Diary::last_month {} { #<<<1
 647         if {$valid_from_day < 1} {
 648                 set todate      [clock scan "$year-$month-01 - 1 month"]
 649                 set month       [clock format $todate -format "%m"]
 650                 set year        [clock format $todate -format "%Y"]
 651                 eventually_rerender
 652                 return 1
 653         }
 654         return 0
 655 }
 656
 657
 658 body tlc::Diary::next_month {} { #<<<1
 659         if {$valid_to_day > $days} {
 660                 set todate      [clock scan "$year-$month-01 + 1 month"]
 661                 set month       [clock format $todate -format "%m"]
 662                 set year        [clock format $todate -format "%Y"]
 663                 eventually_rerender
 664                 return 1
 665         }
 666         return 0
 667 }
 668
 669
 670 body tlc::Diary::last_year {} { #<<<1
 671         if {$valid_from_day < 1} {
 672                 set todate      [clock scan "$year-$month-01 - 1 year"]
 673                 set month       [clock format $todate -format "%m"]
 674                 set year        [clock format $todate -format "%Y"]
 675                 eventually_rerender
 676                 return 1
 677         }
 678         return 0
 679 }
 680
 681
 682 body tlc::Diary::next_year {} { #<<<1
 683         if {$valid_to_day > $days} {
 684                 set todate      [clock scan "$year-$month-01 + 1 year"]
 685                 set month       [clock format $todate -format "%m"]
 686                 set year        [clock format $todate -format "%Y"]
 687                 eventually_rerender
 688                 return 1
 689         }
 690         return 0
 691 }
 692
 693
 694 body tlc::Diary::eventually_rerender {} { #<<<1
 695         if {$eventually_rerender_id != ""} return
 696 #       log debug "tlc::Calendar::eventually_rerender: traceback rendered: ($rendered) eventually_rerender_id: ($eventually_rerender_id)\n$::errorInfo"
 697         set eventually_rerender_id      [after idle [code $this rerender]]
 698 }
 699
 700
 701 body tlc::Diary::scroll_month {delta} { #<<<1
 702         if {$delta < 0} {
 703                 while {$delta < 0} {
 704                         last_month
 705                         incr delta
 706                 }
 707         } else {
 708                 while {$delta > 0} {
 709                         next_month
 710                         incr delta -1
 711                 }
 712         }
 713 }
 714
 715
 716 body tlc::Diary::scroll_year {delta} { #<<<1
 717         if {$delta < 0} {
 718                 while {$delta < 0} {
 719                         last_year
 720                         incr delta
 721                 }
 722         } else {
 723                 while {$delta > 0} {
 724                         next_year
 725                         incr delta -1
 726                 }
 727         }
 728 }
 729
 730
 731 body tlc::Diary::select_day {} { #<<<1
 732         set dom         ""
 733         foreach tag [$w.cal gettags current] {
 734                 if {[string range $tag 0 3] == "dom "} {
 735                         set dom         [string range $tag 4 end]
 736                 }
 737         }
 738
 739         if {$dom == ""} {
 740                 set tags        [$w.cal gettags current]
 741                 log error "tlc::Calendar::select_day: couldn't resolve dom ($tags)"
 742                 error "tlc::Calendar::select_day: couldn't resolve dom ($tags)"
 743         }
 744
 745         if {![available $dom]} return
 746
 747         if {$itk_option(-command) != {}} {
 748                 uplevel #0 $itk_option(-command) [list [clock format [clock scan "$year-$month-$dom"] -format $itk_option(-resultformat)]]
 749         }
 750
 751         set date_sel [list [clock format [clock scan "$year-$month-$dom"] -format "%d/%m/%Y"]]
 752         puts "Diary:: date_sel $date_sel"
 753
 754         newselection $date_sel
 755
 756         day_rerender
 757 }
 758
 759
 760 body tlc::Diary::force_redraw {} { #<<<1
 761         eventually_rerender
 762 }
 763
 764
 765 body tlc::Diary::rerender_dom_ref {} { #<<<1
 766         return $rerender_dom
 767 }
 768
 769 body tlc::Diary::newselection {newdate} { #<<<1
 770         set new_date    $newdate
 771         if {$itk_option(-textvariable) != ""} {
 772                 uplevel #0 [list set $itk_option(-textvariable) $date]
 773         }
 774         if {$itk_option(-command) != ""} {
 775                 uplevel #0 $itk_option(-command) [list $newdate]
 776         }
 777         if {$itk_option(-newselection) != {}} {
 778                 uplevel #0 $itk_option(-newselection) [list $newdate]
 779         }
 780
 781         puts "Diary::newselection: date $new_date"
 782
 783         invoke_handlers onselect [list $newdate]
 784 }
 785 body tlc::Diary::newvalue {args} { #<<<1
 786         if {$itk_option(-textvariable) != ""} {
 787                 upvar #0 $itk_option(-textvariable) invar
 788                 if {![info exists invar]} {
 789                         set invar       ""
 790                 }
 791                 set date        $invar
 792                 puts "newvalue: ($invar)"
 793         }
 794 }
 795 body tlc::Diary::get_date {} { #<<<1
 796         return $date_sel
 797
 798         puts "Diary::get_date $date_sel"
 799 }