"Fossies" - the Fresh Open Source Software Archive

Member "ical-tcl/apptlist.tcl" (15 Apr 2019, 12369 Bytes) of package /linux/privat/ical-3.0.4.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Tcl/Tk source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "apptlist.tcl" see the Fossies "Dox" file reference documentation.

    1 # Copyright (c) 1993 by Sanjay Ghemawat
    2 ##############################################################################
    3 # ApptList
    4 #
    5 #       Maintains list of appointments for a certain date.
    6 #
    7 # Description
    8 # ===========
    9 # An AppointmentList displays appointments for a particular date.
   10 
   11 class ApptList {name view} {
   12     set slot(window) $name
   13     set slot(view) $view
   14     set slot(date) [date today]
   15     set slot(items) ""
   16     set slot(width) 100
   17     set slot(start) 0
   18     set slot(finish) 24
   19     set slot(sel) {}
   20 
   21     frame $name -class ApptList
   22     scrollbar $name.s -orient vertical -command [list $name.c yview]
   23     canvas $name.c -yscrollcommand [list $name.s set]
   24 
   25     # Get font for this window
   26     set slot(font) [option get $name.c itemFont Font]
   27     if ![string compare $slot(font) ""] {
   28         set slot(font) [pref itemFont]
   29     }
   30 
   31     # Get font dimensions
   32     set slot(label_width) [text_width  $slot(font) "00:00AM" [pref itemPad]]
   33     set slot(font_height) [text_height $slot(font) "00:00AM" [pref itemPad]]
   34 
   35     $self background
   36 
   37     pack $name.s -side right -fill y
   38     pack $name.c -side left -expand 1 -fill both
   39 
   40     # Establish bindings
   41     $name.c bind rest <2> [list $name.c scan mark 0 %y]
   42     $name.c bind rest <B2-Motion> [list $name.c scan dragto 0 %y]
   43     $name.c bind rest <Button-1> [list $self new %y]
   44     bind $name.c <Configure> [list $self canvas_resize %w %h]
   45     bindtags $name.c [list IcalUser $name.c IcalItemEditBindings IcalItem IcalCommand]
   46 
   47     # Handle triggers
   48     trigger on add      [list $self change]
   49     trigger on delete   [list $self remove]
   50     trigger on change   [list $self change]
   51     trigger on text     [list $self textchange]
   52     trigger on flush    [list $self rescan]
   53     trigger on midnight [list $self rescan]
   54     trigger on reconfig [list $self reconfig]
   55     trigger on select   [list $self check_selection]
   56 }
   57 
   58 method ApptList set_date {date} {
   59     set slot(date) $date
   60     $self rescan
   61     $self scroll_default
   62 }
   63 
   64 # effects - Cleanup on destruction
   65 method ApptList destructor {} {
   66     # We have to be very careful here about making sure callbacks do
   67     # not occur in the wrong place (i.e. on already deleted objects).
   68 
   69     # Remove triggers as soon as possible
   70     trigger remove add          [list $self change]
   71     trigger remove delete       [list $self remove]
   72     trigger remove change       [list $self change]
   73     trigger remove text         [list $self textchange]
   74     trigger remove flush        [list $self rescan]
   75     trigger remove midnight     [list $self rescan]
   76     trigger remove reconfig     [list $self reconfig]
   77     trigger remove select       [list $self check_selection]
   78 
   79     # Trim item list
   80     set list $slot(items)
   81     set slot(items) {}
   82 
   83     foreach item $list {
   84         catch {class_kill $slot(window.$item)}
   85     }
   86 
   87     destroy $slot(window)
   88 }
   89 
   90 method ApptList line_height {} {
   91     return $slot(font_height)
   92 }
   93 
   94 ##############################################################################
   95 # Internal Procedures
   96 
   97 method ApptList reconfig {} {
   98     $slot(window).c delete rest
   99     $self background
  100     $self scroll_default
  101     $self layout
  102 }
  103 
  104 # effects - Create AppointmentList background
  105 method ApptList background {} {
  106     set c $slot(window).c
  107 
  108     set slot(width) [winfo pixels $c "[cal option ItemWidth]c"]
  109 
  110     set width [expr $slot(label_width) + $slot(width)]
  111     set height [expr 48 * $slot(font_height)]
  112 
  113     set slot(start)  [cal option DayviewTimeStart]
  114     set slot(finish) [cal option DayviewTimeFinish]
  115     set lines [expr ($slot(finish) - $slot(start)) * 2]
  116 
  117     # Set canvas geometry
  118 
  119     $c configure\
  120         -width $width\
  121         -height [expr $lines * $slot(font_height)]\
  122         -confine 1\
  123         -scrollregion [list 0 0 $width $height]             
  124 
  125     # Set scrolling increment and initial position
  126     $c configure -xscrollincrement $slot(font_height)
  127     $c configure -yscrollincrement $slot(font_height)
  128     $c xview moveto 0
  129     $c yview moveto [expr $slot(start)/24]
  130 
  131     # Create background
  132     $c create rectangle 0 0 $width $height\
  133         -fill ""\
  134         -outline ""\
  135         -width 0\
  136         -tags [list bg rest]
  137 
  138     # Draw vertical separator line
  139     $c create line $slot(label_width) 0 $slot(label_width) $height\
  140         -fill [pref apptLineColor]\
  141         -tags rest
  142 
  143     set time 0
  144     for {set i 0} {$i < 48} {incr i} {
  145         set ypos [expr $i * $slot(font_height) - 1]
  146 
  147         if {($i % 2) != 0} {
  148             set stipple gray50
  149             set xpos $slot(label_width)
  150         } else {
  151             set stipple ""
  152             set xpos 0
  153 
  154             $c create text\
  155                 [expr $slot(label_width) - [pref itemPad]]\
  156                 [expr $ypos + $slot(font_height) - [pref itemPad]]\
  157                 -text [time2text $time]\
  158                 -fill [pref apptLineColor]\
  159                 -font $slot(font)\
  160                 -anchor se\
  161                 -tags rest
  162         }
  163 
  164         $c create line $xpos $ypos [expr 3*$width] $ypos -stipple $stipple\
  165             -fill [pref apptLineColor]\
  166             -tags rest
  167         incr time 30
  168     }
  169 
  170     $c lower rest
  171 }
  172 
  173 method ApptList new {y} {
  174     # Check if something already selected on this view
  175     if ![catch {set i [ical_find_selection]}] {
  176         ical_unselect
  177         return
  178     }
  179 
  180     if [cal readonly] {
  181         error_notify [winfo toplevel $slot(window)] "Permission denied"
  182         return
  183     }
  184 
  185     set y [$slot(window).c canvasy $y]
  186     set id [appointment]
  187     $id starttime $slot(date) [expr "([$self time $y]/30)*30"]
  188     $id length 30
  189     $id date $slot(date)
  190     $id earlywarning [cal option DefaultEarlyWarning]
  191     $id own
  192 
  193     cal add $id
  194     ical_with_view $slot(view) {run-hook item-create $id}
  195 
  196     if [info exists slot(window.$id)] {
  197         ical_select $id $slot(date)
  198     }
  199 }
  200 
  201 method ApptList change {item} {
  202     if {[$item is appt] && [$item contains $slot(date)]} {
  203         if [info exists slot(window.$item)] {
  204             $slot(window.$item) read
  205         } else {
  206             # Add item
  207             lappend slot(items) $item
  208             $self make_window $item
  209         }
  210         $self layout
  211         return
  212     }
  213 
  214     $self remove $item
  215 }
  216 
  217 method ApptList textchange {item} {
  218     if [info exists slot(window.$item)] {
  219         $slot(window.$item) read
  220     }
  221 }
  222 
  223 method ApptList remove {item} {
  224     set list $slot(items)
  225     if [lremove list $item] {
  226         set slot(items) $list
  227         $self kill $item
  228         $self layout
  229     }
  230 }
  231 
  232 method ApptList kill {item} {
  233     if ![info exists slot(window.$item)] return
  234 
  235     catch {class_kill $slot(window.$item)}
  236     catch {unset slot(window.$item)}
  237     catch {unset slot(adjust.$item)}
  238 }
  239 
  240 # args are ignored - they just allow trigger to call us directly.
  241 method ApptList rescan {args} {
  242     set list $slot(items)
  243     set slot(items) ""
  244 
  245     foreach appt $list {
  246         $self kill $appt
  247     }
  248 
  249     set list {}
  250     cal query $slot(date) $slot(date) item d {
  251         if [$item is appt] {
  252             lappend list $item
  253             $self make_window $item
  254         }
  255     }
  256     set slot(items) $list
  257     $self layout
  258 }
  259 
  260 method ApptList scroll_default {} {
  261     set min [expr 24*60]
  262     set max 0
  263     foreach a $slot(items) {
  264         set st [$a starttime $slot(date)]
  265         set fi [expr [$a starttime $slot(date)]+[$a length]-1]
  266         if {$st < $min} {set min $st}
  267         if {$fi > $max} {set max $fi}
  268     }
  269 
  270     set minLine [expr $min/30]
  271     set maxLine [expr $max/30]
  272 
  273     set h [lindex [$slot(window).c configure -height] 4]
  274     set windowSize [expr $h / $slot(font_height)]
  275 
  276     # Try to make all appointments visible
  277     set start [expr $slot(start) * 2]
  278     if {($start + $windowSize - 1) < $maxLine} {
  279         set start [expr $maxLine-($slot(finish) - $slot(start))*2+1]
  280     }
  281     if {$start > $minLine} {
  282         set start $minLine
  283     }
  284 
  285     $slot(window).c yview moveto [expr double($start)/48]
  286 }
  287 
  288 method ApptList time {y} {
  289     return [expr int((($y + 1) * 30) / $slot(font_height))]
  290 }
  291 
  292 method ApptList coordinate {time} {
  293     return [expr "($time * $slot(font_height)) / 30 - 1"]
  294 }
  295 
  296 method ApptList check_selection {args} {
  297     # Get newly selected item if it belongs to this window
  298     set newsel {}
  299     if ![string compare [ical_focus] [winfo toplevel $slot(window)]] {
  300         # This window is active, try to get the selected item
  301         catch {set newsel [ical_find_selection]}
  302     }
  303 
  304     if [string compare $newsel $slot(sel)] {
  305         # Selection has changed
  306         set slot(sel) $newsel
  307         $self layout
  308     }
  309 }
  310 
  311 method ApptList layout {} {
  312     $self sortitems
  313 
  314     # Move current appt to end of list so it appears at top
  315     if {$slot(sel) != ""} {
  316         set list $slot(items)
  317         if [lremove list $slot(sel)] {
  318             lappend list $slot(sel)
  319         }
  320         set slot(items) $list
  321     }
  322 
  323     # Compute offset for each child (15 minute units?)
  324 
  325     # offset(i) for slot i keeps track of the current horizontal
  326     # adjustment for slot i
  327     for {set i 0} {$i < 24*4} {incr i} {
  328         set offset($i) 0
  329     }
  330 
  331     foreach a $slot(items) {
  332         set start [expr [$a starttime $slot(date)]/15]
  333         set finish [expr ([$a starttime $slot(date)]+[$a length]-1)/15]
  334         if {$finish >= 24*4} {
  335             set finish [expr 24*4-1]
  336         }
  337 
  338         set adjust 0
  339         for {set i $start} {$i <= $finish} {incr i} {
  340             if {$adjust < $offset($i)} {
  341                 set adjust $offset($i)
  342             }
  343         }
  344         for {set i $start} {$i <= $finish} {incr i} {
  345             set offset($i) [expr $adjust+1]
  346         }
  347 
  348         # Place the child
  349         set slot(adjust.$a) $adjust
  350         $self place $a
  351 
  352         if {$adjust > 0} {
  353             $slot(window.$a) raise
  354         }
  355     }
  356 }
  357 
  358 # effects - Sort item list
  359 method ApptList sortitems {} {
  360     # Construct list of pairs <time,item>
  361     set list ""
  362     foreach item $slot(items) {
  363         lappend list [list [$item starttime $slot(date)] $item]
  364     }
  365 
  366     set items ""
  367     foreach pair [lsort $list] {
  368         lappend items [lindex $pair 1]
  369     }
  370     set slot(items) $items
  371 }
  372 
  373 # effects - Create window for item
  374 method ApptList make_window {item} {
  375     set slot(adjust.$item) 0
  376     set slot(window.$item) [ApptItemWindow\
  377                                 $slot(window).c\
  378                                 $slot(font)\
  379                                 $item $slot(date)\
  380                                 [list $self move]\
  381                                 [list $self resize]]
  382 }
  383 
  384 # effects - Place window for item
  385 method ApptList place {a} {
  386     $self set_geometry $a [$a starttime $slot(date)] [$a length]
  387 }
  388 
  389 # effects - Set item window geometry from "start/length"
  390 method ApptList set_geometry {a start length} {
  391     set adj [expr "$slot(adjust.$a) * $slot(font_height)"]
  392     set finish [expr $start + $length]
  393 
  394     set x [expr "$slot(label_width) + $adj + [pref itemPad]"]
  395     set y [expr "[$self coordinate $start]+1"]
  396     set width [expr "$slot(width)-$adj-2*[pref itemPad]"]
  397     set height [expr "[$self coordinate $finish] - $y"]
  398 
  399     $slot(window.$a) raise
  400     $slot(window.$a) geometry $x $y $width $height
  401 }
  402 
  403 # Callbacks
  404 
  405 method ApptList canvas_resize {w h} {
  406     $slot(window).c coord bg 0 0 $w [expr 48 * $slot(font_height)]
  407 }
  408 
  409 method ApptList move {item y} {
  410     if {$y == "done"} {
  411         $item starttime $slot(date) $slot(itemstart)
  412         unset slot(itemstart)
  413         return
  414     }
  415 
  416     set st [expr "([$self time $y]/15)*15"]
  417     if {$st < 0} {set st 0}
  418     if {($st + [$item length]) > 24*60} {set st [expr 24*60-[$item length]]}
  419 
  420     set slot(itemstart) $st
  421     $self set_geometry $item $st [$item length]
  422 }
  423 
  424 method ApptList resize {item top bot} {
  425     if {$top == "done"} {
  426         # slot(itemstart) or slot(itemlength) may not have been set yet.
  427         if {[info exists slot(itemstart)] && [info exists slot(itemlength)]} {
  428             $item starttime $slot(date) $slot(itemstart)
  429             $item length $slot(itemlength)
  430         }
  431 
  432         catch {unset slot(itemstart)}
  433         catch {unset slot(itemlength)}
  434 
  435         return
  436     }
  437 
  438     set st [expr "([$self time $top]/15)*15"]
  439     if {$st < 0} {set st 0}
  440 
  441     set fi [expr "(([$self time $bot]+14)/15)*15"]
  442     if {$fi > 24*60} {set fi [expr 24*60]}
  443 
  444     set len [expr $fi - $st]
  445     if {$len >= 30} {
  446         set slot(itemstart) $st
  447         set slot(itemlength) $len
  448         $self set_geometry $item $st $len
  449     }
  450 }