1 ;;; planner-appt.el --- appointment alerts from planner
4 ;; Copyright (C) 2005 Jim Ottaway <j.ottaway@lse.ac.uk>
5 ;; Copyright (C) 2005 Henrik S. Hansen <hsh@freecode.dk>
6 ;; Parts copyright (C) 2005, 2006 Free Software Foundation, Inc.
7 ;; Parts copyright (C) 2005 Seth Falcon <sethfalcon AT gmail.com>
10 ;; Keywords: hypermedia
13 ;; This file is part of Planner. It is not part of GNU Emacs.
15 ;; Planner is free software; you can redistribute it and/or modify it
16 ;; under the terms of the GNU General Public License as published by
17 ;; the Free Software Foundation; either version 2, or (at your option)
20 ;; Planner is distributed in the hope that it will be useful, but
21 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
22 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
23 ;; General Public License for more details.
25 ;; You should have received a copy of the GNU General Public License
26 ;; along with Planner; see the file COPYING. If not, write to the
27 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
28 ;; Boston, MA 02110-1301, USA.
31 ;; Please report any bugs that you come across to the authors at the
32 ;; addresses given above.
36 ;; Add "(planner-appt-insinuate)" to your configuration to make
37 ;; Planner work with appt.
39 ;; See the Appointments section of the Planner manual for further
44 ;; * Seth Falcon supplied the idea and the code that is the basis of
45 ;; the forthcoming appointments display functionality.
49 ;; * Correct sorting of task appointments
51 ;; * Consider changing "insinuate" into "install". I don't like the
52 ;; word "insinuate" very much! Or a minor mode perhaps:
53 ;; planner-appt-minor-mode
55 ;; * A lot of the code properly belongs elsewhere: schedule sorting,
56 ;; schedule cyclical entries, calendar marking...
67 (defgroup planner-appt nil
68 "Appointment integration for planner.el."
69 :prefix
"planner-appt-"
72 (defcustom planner-appt-schedule-section
"Schedule"
73 "The name of the section where the schedule is to be found."
77 (defcustom planner-appt-font-lock-appointments-flag t
78 "Non-nil means use font-locking for appointments."
80 :type
'(choice (const :tag
"Use font-locking" t
)
81 (const :tag
"Don't use font-locking" nil
)))
83 (defcustom planner-appt-update-appts-on-save-flag nil
84 "Non-nil means update appointment alerts on saving today's plan."
86 :type
'(choice (const :tag
"Update on save" t
)
87 (const :tag
"Don't update on save" nil
)))
89 (defcustom planner-appt-sort-schedule-on-update-flag nil
90 "Non-nil means sort the schedule when updating appointments."
92 :type
'(choice (const :tag
"Sort on update" t
)
93 (const :tag
"Don't sort on update" nil
)))
96 (defcustom planner-appt-update-hook
'()
97 "Hook run after appointments have been updated."
101 (defcustom planner-appt-schedule-cyclic-behaviour
'today
102 "Determines the behaviour of cyclical schedule insertion.
103 Used after `planner-appt-schedule-cyclic-insinuate' has been called.
104 'today means only add cylical schedule entries for today
105 'future means add cyclical entries for all future day pages visited."
107 :type
'(choice (const :tag
"For today only" today
)
108 (const :tag
"For all future pages." future
)))
110 (defcustom planner-appt-alert-buffer
"*Alerts*"
111 "Name of the buffer for displaying active alerts.
112 Used by `planner-appt-show-alerts'."
117 (defcustom planner-appt-task-use-appointments-section-flag nil
118 "When non-nil, task appointments will be copied to an appoinments section.
119 The section name is supplied by
120 `planner-appt-task-appointments-section'."
124 (defcustom planner-appt-task-appointments-section
"Schedule"
125 "Name of the section where task appointments are copied.
126 The copying is contingent upon
127 `planner-appt-task-use-appointments-section-flag'."
131 (defcustom planner-appt-format-appt-section-line-function
132 #'planner-appt-format-appt-section-line
133 "The function used when formatting an appointment section line.
135 This function should take one argument: an appointment description.
136 The description is in the form used when an appointment alert is
137 signalled: a string with the time of the appointment and some text
138 such as \"12:00 Do something\". Look at the default function
139 `planner-appt-format-appt-section-line' for inspiration if you want to
140 make a different format."
144 (defcustom planner-appt-limit-highlighting-flag t
145 "When non-nil, only highlight appointment times in tasks and the schedule.
146 When nil, all appointment times are highlighted, wherever they may be
151 (defcustom planner-appt-forthcoming-days
7
152 "Number of days to look ahead for appointments."
156 (defcustom planner-appt-forthcoming-appt-section
"Forthcoming Appointments"
157 "Title of the section for forthcoming appointments."
161 (defcustom planner-appt-forthcoming-repeat-date-string
" "
162 "String to insert for repeated dates.
163 When there are multiple appointments for a date, the date is inserted
164 in the first appointment and the others have this string in their date
167 If the string consists of anything other than whitespace, then a link
168 to the day page for the appoinment is created."
172 (defcustom planner-appt-forthcoming-look-at-cyclic-flag nil
173 "When non nil, add cyclic entries to the forthcoming appointments section."
178 ;; Regular Expressions
180 ;; TODO: Should these really be customizable anyway?
182 ;; TODO: Dynamically changing dependent customizations; i.e., if this
183 ;; is changed, all the other time-based regexps should change too [I
184 ;; don't understand customize well enough to do this].
186 (defcustom planner-appt-time-regexp
187 "[0-9]?[0-9]:[0-5][0-9]\\(?:am\\|pm\\)?"
188 "Regular expression matching times."
192 (defcustom planner-appt-task-regexp
193 (concat "[@!][ \t]*\\(" planner-appt-time-regexp
"\\)[ \t]*")
194 "If a task description matches this regexp, it's an appointment.
195 Match group 1 is the time of the appointment.
196 Used with the task-based method. If you use schedules, look at
197 `planner-appt-schedule-appt-regexp'."
201 (defcustom planner-appt-task-nagging-regexp
202 (concat "![ \t]*\\(" planner-appt-time-regexp
"\\)[ \t]*")
203 "If a task description matches this regexp, it's a nagging
204 appointment. Used with the task-based method. If you use schedules,
205 look at `planner-appt-schedule-appt-regexp'."
209 (defcustom planner-appt-schedule-basic-regexp
212 ;; the appointment time (match group 1)
213 planner-appt-time-regexp
215 ;; possibly some space, possibly a |, and any amount of space
217 ;; perhaps another time [the end time] (match group 2)
219 planner-appt-time-regexp
221 ;; possibly some space or some ?' chars, possibly a |, and any
224 ;; the appointment text (match group 3)
226 "Basic regular expression to match a schedule.
227 Match group 1 should yield the start time, match group 2 the stop
228 time, and match group 3 the schedule text."
229 :group
'planner-appt
)
231 ;; NB: The groups are shifted in this regexp.
232 (defcustom planner-appt-schedule-regexp
234 ;; any amount of whitespace possibly followed by @ and any amount
236 "^[ \t]*\\(@?\\)[ \t]*"
237 ;; followed by the basic regexp
238 planner-appt-schedule-basic-regexp
)
239 "Regexp matching schedule entries.
240 Match group 1 should match at most one leading instance of the
241 appointment marker, Match group 2 should yield the start time, match
242 group 3 the stop time, and match group 4 the schedule text."
246 (defcustom planner-appt-schedule-appt-regexp
248 ;; any amount of whitespace followed by @ and any amount of
251 ;; followed by the basic regexp
252 planner-appt-schedule-basic-regexp
)
253 "Regexp matching appointments in the schedule requiring alerts.
254 Used with the schedule-based method. If you use tasks for appointments,
255 look at `planner-appt-task-regexp.'
256 Match group 1 should yield the start time, match group 2 the stop
257 time, and match group 3 the alert text."
262 ;;; Planner Miscellany
264 ;; Could be useful elsewhere in planner?
266 (defun planner-appt-todays-page-p ()
267 "Return t if the current page is today's, otherwise nil."
268 (string= (planner-page-name) (planner-today)))
270 (defun planner-appt-seek-to-end-of-current-section ()
271 "Go to the end of the current section."
273 (or (and (re-search-forward "^\\*[^*]" nil t
)
274 (1- (planner-line-beginning-position)))
277 (defvar planner-appt-write-file-hook
278 (if (and (boundp 'write-file-functions
)
279 (not (featurep 'xemacs
)))
280 'write-file-functions
282 "The write file hook to use.")
284 ;;; Planner-Appt Miscellany
286 (defvar planner-appt-debug-buffer
"*planner-appt debug messages*"
287 "The buffer to put debugging messages from planner-appt.")
289 (defvar planner-appt-debug-flag nil
290 "Non-nil means turn on planner-appt debugging.")
292 (defmacro planner-appt-debug
(form &rest body
)
293 "Evaluate FORM if `planner-appt-debug-flag' is non-nil.
294 Optional BODY is evaluated otherwise."
295 `(if planner-appt-debug-flag
299 (defun planner-appt-debug-message (&rest args
)
300 "Insert ARGS into `planner-appt-debug-buffer'.
301 This code runs only if `planner-appt-debug-flag' is non-nil."
304 (get-buffer-create planner-appt-debug-buffer
)
305 (goto-char (point-max))
306 (apply #'insert args
)
309 (defun planner-appt-earlier-than-now-p (time)
310 "Return t if TIME is earlier than the current time.
311 Time formats are those used by the appt appointment system."
313 (let* ((now (decode-time))
314 (cur-hour (nth 2 now
))
315 (cur-min (nth 1 now
))
316 (cur-time (+ (* cur-hour
60) cur-min
)))
317 (> cur-time
(appt-convert-time time
))))
319 ;; Not used in this file, but added for completeness.
320 (defun planner-appt-later-than-now-p (time)
321 "Return t if TIME is later than the current time.
322 Time formats are those used by the appt appointment system."
324 (let* ((now (decode-time))
325 (cur-hour (nth 2 now
))
326 (cur-min (nth 1 now
))
327 (cur-time (+ (* cur-hour
60) cur-min
)))
328 (< cur-time
(appt-convert-time time
))))
331 (defvar --planner-appt-tasks-added-appts
'()
332 "Internal variable: Tracks added task-based appointment alerts.")
334 (defvar --planner-appt-tasks-earlier-appts
'()
336 Tracks appointments ignored because they were too early.")
338 (defun planner-appt-clear-appts (appt-list)
340 (setq appt-time-msg-list
341 (delete (pop appt-list
) appt-time-msg-list
))))
343 (defun planner-appt-format-time-and-description (time description
)
344 "Format TIME [a string] and DESCRIPTION as an appointment."
345 (concat time
" " description
))
348 (if (> emacs-major-version
21)
349 (defun planner-appt-make-appt-element (time text
)
351 (list (appt-convert-time time
))
352 (planner-appt-format-time-and-description time text
)
354 (defun planner-appt-make-appt-element (time text
)
356 (list (appt-convert-time time
))
357 (planner-appt-format-time-and-description time text
)))))
359 (defun planner-appt-remember-appt (time text list
)
360 "Store details of an appointment with TIME and TEXT in LIST.
361 Return the new list."
362 (push (planner-appt-make-appt-element time text
) list
))
364 (defun planner-appt-forget-appt (appt appt-list
)
365 "Remove APPT from APPT-LIST and return the new list.
366 APPT is in the appt format."
367 (delete (car (member appt appt-list
)) appt-list
))
369 (defun planner-appt-add-hook (hook function
&optional append global
)
370 "Add to the value of HOOK the function FUNCTION.
371 This is `add-hook' with local and global switched.
372 FUNCTION is not added if already present.
373 FUNCTION is added (if necessary) at the beginning of the hook list
374 unless the optional argument APPEND is non-nil, in which case
375 FUNCTION is added at the end.
376 The optional fourth argument, GLOBAL, if non-nil, says to modify
377 the hook's global value rather than its local value."
378 (add-hook hook function append
(not global
)))
381 (defun planner-appt-remove-task-id (description)
384 (if (boundp 'planner-id-regexp
)
385 "{{\\([^:]+\\):\\([0-9]+\\)}}"))
387 (replace-match "" t t description
)
391 (defun planner-appt-format-description (description)
392 (planner-appt-remove-task-id
393 (planner-remove-links description
)))
396 ;;; Showing Appointments In Various Ways
398 (defvar planner-appt-methods
'()
399 "Methods used for appointment alerts.
400 Internal variable: to set up appointment methods use one of:
401 `planner-appt-use-tasks'
402 `planner-appt-use-schedule'
403 `planner-appt-use-tasks-and-schedule'.")
405 ;; Copying task appts over to an "Appointments" section.
407 (defun planner-appt-format-appt-section-line (desc)
408 "Format DESC as a line for the appointments section."
409 (let* ((td (planner-appt-task-parse-task
410 ;; Trick the function into parsing:
414 (end-time (if (string-match
415 (format "\\s-*\\(%s\\)\\s-*"
416 planner-appt-time-regexp
)
419 (match-string 1 text
)
420 (setq text
(replace-match "" t t text
)))
422 ;; Format in the style of a tabular schedule.
423 (format "%6s | %5s | %s"
424 ;; Using an @ means the time gets fontified for free.
427 (if (string= planner-appt-task-appointments-section
428 planner-appt-schedule-section
)
429 ;; To avoid confusion, add an indication that this
430 ;; item came from a task.
434 (defvar --planner-appt-lines-added-to-section
'()
436 Remembers lines added by `planner-appt-update-appt-section' the last
437 time it was called.")
439 (defun planner-appt-task-schedule-item-p (string)
440 "Return t if STRING is a schedule item derived from a task."
441 (member string --planner-appt-lines-added-to-section
))
442 ;; ;; Look for any property in the string since STRING will usually be
443 ;; ;; derived from a buffer substring which may have been edited.
444 ;; (text-property-any 0 (length string) 'appt-task t string))
446 (defun planner-appt-update-appt-section ()
448 (planner-seek-to-first planner-appt-task-appointments-section
)
449 (let ((bound (make-marker))
451 (copy-sequence --planner-appt-lines-added-to-section
))
454 (planner-appt-seek-to-end-of-current-section)
455 (set-marker bound
(point)))
456 (dolist (appt (append --planner-appt-tasks-added-appts
457 --planner-appt-tasks-earlier-appts
))
458 (setq line
(funcall planner-appt-format-appt-section-line-function
460 (setq lines-to-delete
(delete line lines-to-delete
))
462 (unless (search-forward line bound t
)
464 ;; Remember the line even if it was already there
465 (push line --planner-appt-lines-added-to-section
))
466 ;; Remove lines of deleted tasks
467 (dolist (del-line lines-to-delete
)
468 (setq --planner-appt-lines-added-to-section
469 (delete del-line --planner-appt-lines-added-to-section
))
471 (when (search-forward del-line bound t
)
473 (when (eq (char-after) ?
\n)
475 (set-marker bound nil
))
476 ;; Use schedule sorting with some changes
477 (let ((planner-appt-schedule-section
478 planner-appt-task-appointments-section
)
479 (planner-appt-schedule-regexp
480 (concat "\\(.*?\\)" ; to shift the match groups
481 planner-appt-schedule-basic-regexp
)))
482 (planner-appt-schedule-sort))))
484 (defun planner-appt-update-appt-section-maybe ()
486 ;; The appointment section is only relevant if the task
488 (memq 'tasks planner-appt-methods
)
489 planner-appt-task-use-appointments-section-flag
)
490 (with-planner-update-setup
493 (planner-appt-update-appt-section)))))
495 (defmacro with-planner-appt-update-section-disabled
(&rest body
)
496 `(let ((planner-appt-task-use-appointments-section-flag nil
))
499 (put 'with-planner-appt-update-section-disabled
'lisp-indent-function
0)
500 (put 'with-planner-appt-update-section-disabled
'edebug-form-spec
'(body))
502 ;; Compatibility fix for Xemacs [and for Emacs <21?]
503 (if (fboundp 'fit-window-to-buffer
)
504 (defalias 'planner-fit-window-to-buffer
'fit-window-to-buffer
)
505 (defalias 'planner-fit-window-to-buffer
'shrink-window-if-larger-than-buffer
))
507 ;; Display Current Appointments
508 (defun planner-appt-show-alerts ()
509 "Display a list of currently active alerts in another window."
511 (let ((buf (get-buffer-create planner-appt-alert-buffer
)))
512 (with-current-buffer buf
514 (insert "Current alerts\n==============")
515 (if appt-time-msg-list
516 (dolist (appt appt-time-msg-list
)
517 (insert "\n" (cadr appt
)))
519 (goto-char (point-min)))
520 (planner-fit-window-to-buffer (display-buffer buf
))))
523 ;; Display/Insert Forthcoming Appointments
525 (defvar planner-appt-forthcoming-regexp
527 planner-appt-schedule-appt-regexp
529 planner-live-task-regexp
530 planner-appt-task-regexp
533 (defvar planner-appt-forthcoming-task-regexp
534 (concat planner-live-task-regexp
535 planner-appt-task-regexp
))
537 (defun planner-appt-forthcoming-format-appt-description (time description
)
539 planner-appt-format-appt-section-line-function
540 (planner-appt-format-time-and-description
542 (planner-appt-format-description description
))))
544 (defun planner-appt-forthcoming-task-data (info)
546 (planner-appt-task-parse-task
547 (planner-task-description info
))))
549 (cons (appt-convert-time (nth 1 task-appt
))
550 (planner-appt-forthcoming-format-appt-description
552 (nth 0 task-appt
))))))
554 (defun planner-appt-forthcoming-get-appts (n &optional include-today
)
555 (planner-save-buffers)
557 (pages (planner-get-day-pages
560 (planner-calculate-date-from-day-offset
562 (planner-calculate-date-from-day-offset
563 (planner-today) (if include-today n
(1+ n
)))))
564 cyclic-data cyclic-task-descriptions
565 line task-info task-data
566 date-absolute date time text
)
567 ;; After scanning pages and [conditionally] cyclic entries, each
568 ;; element of appts has:
571 ;; <time in appt format [minutes from midnight]>
572 ;; <date in planner format>
575 ;; The first two elements are used for sorting/merging; they are
576 ;; removed from the returned list.
577 (when (and (featurep 'planner-cyclic
)
578 planner-appt-forthcoming-look-at-cyclic-flag
)
579 ;; Returns (<appts> . <list of planner-cyclic-ly formatted tasks>)
580 (setq cyclic-data
(planner-appt-forthcoming-get-cyclic n
))
581 (setq appts
(car cyclic-data
)
582 cyclic-task-descriptions
(cdr cyclic-data
)))
586 (when (file-exists-p (cdr page
))
587 (setq date
(car page
))
588 (setq date-absolute
(calendar-absolute-from-gregorian
589 (planner-filename-to-calendar-date
591 (insert-file-contents (cdr page
))
592 (goto-char (point-min))
593 (while (re-search-forward planner-appt-forthcoming-regexp nil t
)
594 (setq line
(match-string 0))
595 (if (string-match planner-appt-schedule-appt-regexp line
)
596 (unless (planner-appt-task-schedule-item-p line
)
597 (setq time
(save-match-data
598 (appt-convert-time (match-string 1 line
)))
599 text
(match-string 0 line
)))
600 (setq task-info
(planner-current-task-info))
601 (setq task-data
(planner-appt-forthcoming-task-data task-info
))
603 ;; Check for a cyclic task already added.
604 ;; This is a bit messy, since a task id
605 ;; won't have been added [and there might
606 ;; be other special case that I haven't
610 "\\s-+{{Tasks:[0-9]+}}\\s-*"
611 (planner-task-description task-info
))
614 (planner-task-description task-info
))
615 (planner-task-description task-info
))
616 cyclic-task-descriptions
)))
617 (setq time
(car task-data
)
618 text
(cdr task-data
))))
619 (when (and time text
)
620 ;; Add if it is not there already [there may be a
621 ;; duplicate if this is a schedule item derived from a
623 (add-to-list 'appts
(list date-absolute time date text
))
624 (setq time nil text nil
)))
630 (or (< (car a
) (car b
))
631 (and (= (car a
) (car b
))
632 (< (cadr a
) (cadr b
))))))))))
635 (defun planner-appt-forthcoming-get-cyclic (n)
637 (cyclic-task-descriptions '())
638 date line time text task-info task-data
)
639 (dolist (entry (planner-list-diary-entries
640 planner-cyclic-diary-file
641 (planner-filename-to-calendar-date
642 (planner-calculate-date-from-day-offset
645 (setq date
(planner-date-to-filename (car entry
))
647 (if (string-match planner-appt-schedule-appt-regexp line
)
648 (setq time
(save-match-data
649 (appt-convert-time (match-string 1 line
)))
650 text
(match-string 0 line
))
651 (when (string-match planner-appt-forthcoming-task-regexp line
)
652 (setq task-info
(planner-task-info-from-string date line
))
653 (setq task-data
(planner-appt-forthcoming-task-data task-info
))
655 ;; For duplicate checking: remember the description as
656 ;; it would be transformed by planner-cyclic.
657 (push (format planner-cyclic-task-description-format
658 (planner-task-description task-info
) date
)
659 cyclic-task-descriptions
)
660 (setq time
(car task-data
)
661 text
(cdr task-data
)))))
662 (when (and time text
)
665 (list (calendar-absolute-from-gregorian (car entry
))
667 (setq time nil text nil
)))
668 (cons appts cyclic-task-descriptions
)))
670 ;; Format the data into a big string to make it easy either to put
671 ;; into a display buffer or into the day page.
672 (defun planner-appt-forthcoming-format (appt-data)
674 (empty-cell-p (string-match
675 (format "\\`[%s]+\\'" muse-regexp-blank
)
676 planner-appt-forthcoming-repeat-date-string
)))
677 (mapconcat #'(lambda (a)
680 (if (string= (car a
) last-date
)
682 planner-appt-forthcoming-repeat-date-string
685 planner-appt-forthcoming-repeat-date-string
))
686 (planner-make-link (car a
)))
688 ;; Remove @s from times to avoid spurious
690 (muse-replace-regexp-in-string
694 (setq last-date
(car a
))))
698 (defvar planner-appt-forthcoming-display-buffer
699 "*Forthcoming Appointments*"
700 "Buffer to display forthcoming appointments.")
702 (defun planner-appt-forthcoming-display (&optional days
)
704 ;; TODO: I wanted to use (interactive "p"), but that defaults to
705 ;; 1. Is this really the best way of getting nil as the default
706 ;; for a command that takes an optional integer prefix?:
707 (list (cond ((consp current-prefix-arg
)
708 (car current-prefix-arg
))
709 ((integerp current-prefix-arg
)
712 (unless days
(setq days planner-appt-forthcoming-days
))
714 (get-buffer-create planner-appt-forthcoming-display-buffer
)
715 (unless (planner-derived-mode-p 'planner-mode
)
716 (setq muse-current-project
(muse-project planner-project
))
718 (cd (planner-directory)))
719 (delete-region (point-min) (point-max))
720 (insert "* Appointments in the next "
721 (number-to-string days
)
722 (if (= days
1) " day" " days")
724 (planner-appt-forthcoming-format
725 (planner-appt-forthcoming-get-appts
726 (or days planner-appt-forthcoming-days
) t
)))
727 (goto-char (point-min)))
728 (display-buffer planner-appt-forthcoming-display-buffer
)
729 (planner-fit-window-to-buffer
730 (get-buffer-window planner-appt-forthcoming-display-buffer
)))
733 (defun planner-appt-forthcoming-update-section (&optional days
)
735 (list (cond ((consp current-prefix-arg
)
736 (car current-prefix-arg
))
737 ((integerp current-prefix-arg
)
740 (with-planner-update-setup
743 (planner-seek-to-first planner-appt-forthcoming-appt-section
)
744 (delete-region (point)
745 (planner-appt-seek-to-end-of-current-section))
746 (insert (planner-appt-forthcoming-format
747 (planner-appt-forthcoming-get-appts
748 (or days planner-appt-forthcoming-days
)))
752 ;; A function suitable for planner-mode-hook
753 (defun planner-appt-forthcoming-update-section-maybe ()
754 (when (planner-appt-todays-page-p)
755 (planner-appt-forthcoming-update-section)))
758 ;;; Alerts From Task Descriptions
760 ;; Add a bit of [premature] optimization, mainly for updating
761 ;; functions where the same task gets examined often.
762 (defvar --planner-appt-task-cache
(make-hash-table :test
'equal
))
764 (defun planner-appt-task-parse-task (description)
765 "Extract appointment time and text from the DESCRIPTION.
766 Return a list (text time). If the task is not an
767 appointment, time defaults to nil."
768 (or (gethash description --planner-appt-task-cache
)
771 (if (string-match planner-appt-task-regexp description
)
772 (list (substring description
(match-end 0))
773 (substring description
(match-beginning 1) (match-end 1)))
774 (list description nil
))
775 --planner-appt-task-cache
)))
777 (defun planner-appt-task-nagging-p (description)
778 "Return non-nil if task DESCRIPTION is a nagging appointment."
779 (string-match planner-appt-task-nagging-regexp description
))
781 (defun planner-appt-task-member (description time appt-list
)
782 "Return non-nil if DESCRIPTION at TIME in APPT-LIST has been scheduled."
783 (member (planner-appt-make-appt-element time description
) appt-list
))
786 ;; Integration with planner-schedule.el
788 (defvar planner-appt-schedule-task-estimate-regexp
789 (concat "[!@][ \t]*\\(?:" ; "shy" form of planner-appt-task-regexp
790 planner-appt-time-regexp
792 "\\s-*\\([0-9]+[smhdw]\\)")
793 "Regular expression matching a task time estimate.")
795 ;; NB: The following advice could be avoided if the regexp were not
796 ;; hard-coded into the original function.
798 ;; NNB: This is not well tested!
800 (defadvice planner-schedule-task-estimate
(around planner-appt-task disable
)
801 "Modify the regexp matched to take appointments into account."
802 (when (string-match planner-appt-schedule-task-estimate-regexp
803 (planner-task-description info
))
804 (schedule-duration-to-seconds
805 (match-string 2 (planner-task-description info
)))))
808 (defun planner-appt-task-add (&optional info
)
809 "Create an appointment from the current task if this is today's plan.
810 Return t if an appointment was added.
811 If the task is an appointment, it is not cancelled, it is scheduled for
812 later today, and is not already added.
813 Optional argument: use INFO instead of the current task info."
815 (let* ((info (or info
816 ;; Unfortunately, in emacs-lisp there are no
817 ;; defaults for optional arguments, so one can't
818 ;; distinguish between null info in an arg and null
819 ;; info from planner-current-task-info; so the
820 ;; error message might be uninformative here.
821 (planner-current-task-info)
822 (error "There is no task on the current line")))
823 (appt (planner-appt-task-parse-task
824 (planner-task-description info
)))
826 (desc (and time
(planner-appt-format-description (nth 0 appt
)))))
828 (not (string= (planner-task-status info
) "C"))
829 (string= (planner-task-date info
)
830 (planner-date-to-filename
831 (decode-time (current-time))))
832 (not (planner-appt-task-member desc time
833 appt-time-msg-list
)))
834 (if (planner-appt-earlier-than-now-p time
)
836 ;; Remember earlier appts separately [principally for
837 ;; their addition in an appointment section].
838 (unless (planner-appt-task-member
839 desc time --planner-appt-tasks-earlier-appts
)
840 (setq --planner-appt-tasks-earlier-appts
841 (planner-appt-remember-appt
843 --planner-appt-tasks-earlier-appts
)))
844 (planner-appt-update-appt-section-maybe)
845 ;; Make sure nil is returned.
848 ;; Keep track of tasks added by this function.
849 (setq --planner-appt-tasks-added-appts
850 (planner-appt-remember-appt
852 --planner-appt-tasks-added-appts
))
853 (planner-appt-update-appt-section-maybe)
856 (defun planner-appt-task-delete (&optional info
)
857 "Delete the appointment from the current task if this is today's plan.
858 Do not remove the time string.
859 Return any deleted appointments.
860 Optional argument: use INFO instead of the current task info."
862 (let* ((info (or info
863 ;; See planner-appt-task-add for comments about
864 ;; the possibly uninformative error message.
865 (planner-current-task-info)
866 (error "There is no task on the current line")))
867 (appt (planner-appt-task-parse-task
868 (planner-task-description info
)))
870 (desc (and time
(planner-appt-format-description (nth 0 appt
))))
871 (tmp-msg-list appt-time-msg-list
))
873 ;; Method from appt-delete
874 (let ((deleted-appts '())
876 (car (planner-appt-task-member
877 desc time --planner-appt-tasks-earlier-appts
)))
879 ;; NB: Mustn't concat time onto description until earlier-appt
880 ;; has been determined [since planner-appt-task-member does
881 ;; the concat itself [this could be improved somehow]]
882 (setq desc
(concat time
" " desc
))
884 (setq element
(car tmp-msg-list
))
885 (when (string= (car (cdr element
)) desc
)
886 (push element deleted-appts
)
887 (setq appt-time-msg-list
(delq element appt-time-msg-list
))
888 (setq --planner-appt-tasks-added-appts
889 (planner-appt-forget-appt
890 element --planner-appt-tasks-added-appts
)))
891 (setq tmp-msg-list
(cdr tmp-msg-list
)))
892 (when (or deleted-appts earlier-appt
)
893 ;; Forget a deleted appt that was earlier than now.
895 (setq --planner-appt-tasks-earlier-appts
896 (planner-appt-forget-appt
897 earlier-appt --planner-appt-tasks-earlier-appts
)))
898 (planner-appt-update-appt-section-maybe))
901 (defun planner-appt-add-appts-from-tasks ()
902 "Parse all of today's tasks and add appointments automatically."
904 (when (planner-appt-todays-page-p)
905 ;; Clear old appts added by this function.
906 (planner-appt-clear-appts --planner-appt-tasks-added-appts
)
907 (setq --planner-appt-tasks-added-appts
'()
908 --planner-appt-tasks-earlier-appts
'())
909 (let ((case-fold-search nil
))
911 (goto-char (point-min))
912 (with-planner-appt-update-section-disabled
913 (while (re-search-forward
914 (concat planner-live-task-regexp
915 planner-appt-task-regexp
)
917 (planner-appt-task-add))))
918 (when (or --planner-appt-tasks-added-appts
919 --planner-appt-tasks-earlier-appts
)
920 (planner-appt-update-appt-section-maybe)))))
924 ;; for speedy enabling and disabling of advice:
926 (defvar --planner-appt-advice
'()
927 "Internal variable: List of advices added by `planner-appt-defadvice'.
928 Each element is a list of args for `ad-enable-advice' and
929 `ad-disable-advice'.")
932 (defvar planner-appt-advice-common-flags
933 '(preactivate disable
)
934 "Advice flags common to all planner-appt advice."))
936 (defmacro planner-appt-defadvice
(function args doc
&rest body
)
937 "Advise FUNCTION with ARGS, DOC and BODY.
938 Remembers the advice function and args in `--planner-appt-advice'."
941 (,@args
,@planner-appt-advice-common-flags
) ,doc
,@body
)
942 (let ((info '(,function
,(car args
) ,(cadr args
))))
943 (unless (member info --planner-appt-advice
)
944 (push info --planner-appt-advice
)))))
946 (put 'planner-appt-defadvice
949 (name name
&rest sexp
)
952 ("interactive" interactive
)]
955 (put 'planner-appt-defadvice
'lisp-indent-function
'defun
)
957 ;; See what happened with the preactivation.
961 (trace-function-background
962 'ad-cache-id-verification-code
963 "*planner-appt advice trace*")))
965 (defun planner-appt-disable-all-advice ()
966 "Disable all advice added with `planner-appt-defadvice'."
967 (mapcar #'(lambda (args)
968 (apply #'ad-disable-advice args
)
969 (ad-activate (car args
)))
970 --planner-appt-advice
))
972 (defun planner-appt-enable-all-advice ()
973 "Enable all advice added with `planner-appt-defadvice'."
974 (mapcar #'(lambda (args)
975 (apply #'ad-enable-advice args
)
976 (ad-activate (car args
)))
977 --planner-appt-advice
))
980 (defmacro with-planner-appt-task-advice-disabled
(&rest body
)
981 "Evaluate BODY forms with all advice matching \"planner-appt-task\" disabled."
984 (planner-appt-disable-all-advice)
985 (planner-appt-debug-message "all advice disabled")
987 (planner-appt-enable-all-advice)
988 (planner-appt-debug-message "all advice enabled")))
990 (put 'with-planner-appt-task-advice-disabled
'lisp-indent-function
0)
991 (put 'with-planner-appt-task-advice-disabled
'edebug-form-spec
'(body))
993 (planner-appt-defadvice planner-task-cancelled
994 (before planner-appt-task
)
995 "Delete the appointment as well."
996 (planner-appt-debug-message
997 "*** called advice on planner-task-cancelled")
998 (planner-appt-task-delete))
1000 (planner-appt-defadvice planner-task-done
1001 (before planner-appt-task
)
1002 "Delete the appointment as well."
1003 (planner-appt-debug-message
1004 "*** called advice on planner-task-done")
1005 (planner-appt-task-delete))
1007 (planner-appt-defadvice planner-delete-task
1008 (before planner-appt-task
)
1009 "Delete the appointment as well."
1010 (planner-appt-debug-message
1011 "*** called advice on planner-delete-task")
1012 (planner-appt-task-delete))
1014 ;; The advice for planner-update-task is quite tricky. A task will
1015 ;; need updating [for appointments] if the task is dated today and the
1016 ;; description differs from other task lines linked to by the current
1017 ;; task. If this is true, we have to examine all the other links,
1018 ;; delete any appointments, and then add the task after planner-update
1019 ;; has been called. Note that it is only possible for this to happen
1020 ;; if planner-id is loaded since otherwise the "same" task line can't
1021 ;; have different descriptions.
1023 (defun planner-appt-get-diff-links (info)
1024 "Given INFO, return a list of tasks linked to it whose info differs."
1027 ;; Todo: with-planner-update-setup really ought to return the
1028 ;; value of the body.
1029 (with-planner-update-setup
1030 ;; Preserve point as well.
1033 (if (featurep 'planner-multi
)
1034 (planner-multi-link-delete
1035 (planner-task-page info
)
1036 (planner-multi-task-link-as-list info
))
1037 (list (planner-task-link info
))))
1038 (when (and (planner-find-file (planner-link-base link
))
1039 (planner-find-task info
)
1040 (setq linked-info
(planner-current-task-info))
1041 (not (planner-tasks-equal-p info linked-info
)))
1042 (push linked-info diffs
)))))
1045 (planner-appt-defadvice planner-update-task
1046 (around planner-appt-task
)
1047 "Update the appointment as well."
1048 (planner-appt-debug-message
1049 "*** called advice on planner-update-task")
1050 (let* ((info (planner-current-task-info))
1052 (and (featurep 'planner-id
)
1053 (string= (planner-task-date info
) (planner-today))
1054 (planner-appt-get-diff-links info
))))
1055 (with-planner-appt-task-advice-disabled ad-do-it
)
1057 (dolist (i diff-linked
)
1058 (planner-appt-task-delete i
))
1059 (planner-appt-task-add))))
1061 ;; For planner-id-update-tasks-on-page, it is actually much faster to
1062 ;; update today's page after it has done its work rather than using
1063 ;; the update advice above.
1065 (planner-appt-defadvice planner-id-update-tasks-on-page
1066 (around planner-appt-task
)
1067 "Update today's appointments as well."
1068 (planner-appt-debug-message
1069 "*** called advice on planner-id-update-tasks-on-page")
1070 (with-planner-appt-task-advice-disabled ad-do-it
)
1071 (with-planner-update-setup
1073 (planner-goto-today)
1074 ;; Update the appointments section afterwards for efficiency.
1075 (with-planner-appt-update-section-disabled
1076 (planner-appt-update))
1077 (planner-appt-update-appt-section-maybe))))
1079 (defvar --planner-appt-planning nil
1081 Lets planner-appt advice know that it has been called within a call to
1084 (planner-appt-defadvice plan
(around planner-appt-task
)
1085 "Note that plan is in progress."
1086 (planner-appt-debug-message
1087 "*** called advice on plan")
1088 (let ((--planner-appt-planning t
))
1091 (planner-appt-defadvice planner-copy-or-move-task
1092 (around planner-appt-task
)
1093 "Update the appointment as well."
1094 (planner-appt-debug-message
1095 "*** called advice on planner-copy-or-move-task; "
1096 (if --planner-appt-planning
1099 (cond ((not --planner-appt-planning
)
1101 ;; Save the appt information for error cleanup and
1102 ;; appointment adding.
1103 ((deleted-appts (planner-appt-task-delete))
1104 (old-info (planner-current-task-info)))
1107 (with-planner-appt-task-advice-disabled ad-do-it
)
1108 ;; If the task was moved to today, add it.
1109 (when (and date
; Bound in the advised function.
1110 (string= date
(planner-today)))
1111 ;; Fiddle the old info so it looks like
1112 ;; today's. NB: would need changing should
1113 ;; the task-info format ever change.
1115 ;; planner-multi uses the date in the link for
1116 ;; planner-task-date [why?], so that has to be
1117 ;; modified too. This has to be done before the
1118 ;; date element is changed, of course.
1119 (when (and (featurep 'planner-multi
)
1120 (consp (nth 5 old-info
))) ; the link element
1122 (member (nth 8 old-info
)
1124 ;; Silly way of avoiding an error if the
1125 ;; date is not in the list: can the date
1126 ;; not be in the list?
1129 ;; Set the date element.
1130 (setcar (nthcdr 8 old-info
) date
)
1131 (planner-appt-task-add old-info
)))
1133 ;; Catch errors in planner-copy-or-move-task: restore
1135 (dolist (d deleted-appts
)
1136 (push d appt-time-msg-list
))
1137 (error (error-message-string err
))))))
1139 ;; `plan' in progress: only move the task if it is not a
1140 ;; regular (non-nagging) appointment. If it's a nagging
1141 ;; appointment, remove the appointment and then move the
1143 (let* ((info (planner-current-task-info))
1144 (appt (planner-appt-task-parse-task
1145 (planner-task-description info
)))
1146 (time (nth 1 appt
)))
1147 (with-planner-appt-task-advice-disabled
1148 (if (planner-appt-task-nagging-p (planner-task-description info
))
1149 (progn (planner-edit-task-description (nth 0 appt
))
1152 ;; Fri Nov 25 13:59:02 GMT 2005: Fix for new [?]
1153 ;; behaviour of planner-copy-or-move-region.
1156 ;; Return nil, otherwise
1157 ;; planner-copy-or-move-region's count will be
1159 (setq ad-return-value nil
))
1162 ;; NB: this advice leads to two updates of the task appointment
1163 ;; section [when updating it is enabled, of course]: it is hard to see
1164 ;; how to avoid this unless there is yet another global variable
1165 ;; tracking deleted appts.
1166 (planner-appt-defadvice planner-edit-task-description
1167 (around planner-appt-task
)
1168 "Update the appointment as well."
1169 (planner-appt-debug-message
1170 "*** called advice on planner-edit-task-description")
1171 (planner-appt-task-delete)
1172 (with-planner-appt-task-advice-disabled ad-do-it
)
1173 (planner-appt-task-add))
1175 ;; planner-create-task-from-info: The appointment adding needs doing
1176 ;; after all hooks to planner-create-task-from-info have been run so
1177 ;; that planner-appt-task-add has the correct task line; planner-id,
1178 ;; for example, adds a task id so if the planner-appt hook is run
1179 ;; first it won't have the right task description.
1181 ;; Hence these shenanigans:
1183 (defvar --planner-appt-created-task-marker
(make-marker))
1184 (defvar --planner-appt-close-the-buffer-flag nil
)
1187 ;; Hide warning about live-buffers [q.v.].
1188 (defvar live-buffers
))
1190 (defun planner-appt-create-task-hook-func ()
1191 "One half of planner-appt create task handling.
1192 Remembers the position of the added task. The other half of the
1193 handling is in advice to `planner-create-task-from-info'."
1194 (set-marker --planner-appt-created-task-marker
(point))
1195 ;; If planner-tasks-file-behavior is 'close, it won't be possible to
1196 ;; recover the position from a marker, so temporarily defeat closing
1197 ;; this file, and close it if necessary in the
1198 ;; planner-create-task-from-info advice.
1199 (setq --planner-appt-close-the-buffer-flag
1200 (if (and (eq planner-tasks-file-behavior
'close
)
1201 ;; `live-buffers' is defined in
1202 ;; planner-create-task-from-info, but it is not
1203 ;; defined in the planner-multi advice [hmm...].
1204 (boundp 'live-buffers
)
1205 (not (memq (current-buffer) live-buffers
)))
1206 ;; Adding the buffer to `live-buffers' means it won't be
1207 ;; closed automatically.
1208 (progn (push (current-buffer) live-buffers
) t
)
1212 (planner-appt-defadvice planner-create-task-from-info
1213 (around planner-appt-task
)
1214 "Add an appointment alert for the new task if necessary."
1215 (planner-appt-debug-message
1216 "*** called advice on planner-create-task-from-info")
1217 (with-planner-appt-task-advice-disabled ad-do-it
)
1218 (let ((buf (marker-buffer --planner-appt-created-task-marker
))
1219 (pos (marker-position --planner-appt-created-task-marker
)))
1221 (with-current-buffer buf
1224 (planner-appt-task-add)))
1225 (set-marker --planner-appt-created-task-marker nil
)
1226 (when --planner-appt-close-the-buffer-flag
1227 ;; Use planner-save-buffers for consistency; remove the buffer
1228 ;; from buffer-list so that it gets closed.
1229 (planner-save-buffers (delq buf
(buffer-list)))))))
1231 (defun planner-appt-task-insinuate ()
1232 "Do task-specific insinuation into `planner-mode'."
1233 ;; Nothing at the moment!
1236 ;; In case of breakage while developing
1237 ;; NB: remember to remove hooks locally where relevant
1238 (defun planner-appt-task-de-insinuate ()
1239 "Remove task-specific hooks."
1240 ;; Nothing at the moment!
1244 ;;; Alerts From The Schedule
1246 (defvar --planner-appt-schedule-added-appts
'()
1247 "Internal variable: Tracks added schedule-based appointment alerts.")
1249 (defun planner-appt-add-appts-from-schedule ()
1250 "Add appointment reminders from the schedule if this is today's plan."
1252 (when (planner-appt-todays-page-p)
1253 ;; Delete old appts created by this function.
1254 (planner-appt-clear-appts --planner-appt-schedule-added-appts
)
1255 (setq --planner-appt-schedule-added-appts
'())
1257 (planner-seek-to-first planner-appt-schedule-section
)
1258 (let ((bound (save-excursion
1259 (planner-appt-seek-to-end-of-current-section)))
1260 line time text task-item-p
)
1261 ;; There are no entries in the schedule unless bound is
1262 ;; greater than point.
1263 (when (> bound
(point))
1264 (while (re-search-forward
1265 planner-appt-schedule-appt-regexp bound t
)
1266 (setq line
(planner-match-string-no-properties 0)
1267 time
(planner-match-string-no-properties 1)
1268 text
(planner-appt-format-description
1269 (planner-match-string-no-properties 3))
1271 (planner-appt-task-schedule-item-p (match-string 0)))
1272 ;; (text-property-any (match-beginning 0) (match-end 0)
1274 (unless (or task-item-p
1275 (planner-appt-earlier-than-now-p time
))
1276 (appt-add time text
)
1277 ;; Remember tasks added here.
1278 (setq --planner-appt-schedule-added-appts
1279 (planner-appt-remember-appt
1280 time text --planner-appt-schedule-added-appts
)))))))))
1282 (defun planner-appt-schedule-insinuate ()
1283 "Do schedule specific insinuation into `planner-mode'."
1284 ;; Nothing at the moment!
1287 (defun planner-appt-schedule-de-insinuate ()
1288 "Remove schedule-based hooks."
1289 ;; Nothing at the moment!
1292 ;; Make appt-make-list behave.
1294 (defadvice appt-make-list
(after planner-appt activate
)
1295 "Restore appointments added by planner-appt."
1296 (dolist (appt (append --planner-appt-tasks-added-appts
1297 --planner-appt-schedule-added-appts
))
1298 (unless (member appt appt-time-msg-list
)
1299 (push appt appt-time-msg-list
)))
1300 (setq appt-time-msg-list
(appt-sort-list appt-time-msg-list
)))
1302 ;;; Sorting the Schedule
1304 (defun planner-appt-schedule-sort ()
1305 "Sort the schedule in the current page."
1309 (planner-seek-to-first planner-appt-schedule-section
)
1310 (narrow-to-region (point)
1312 (planner-appt-seek-to-end-of-current-section)
1314 (sort-subr nil
'forward-line
'end-of-line
1316 (goto-char (planner-line-beginning-position))
1317 (if (looking-at planner-appt-schedule-regexp
)
1320 ;; 1+ max number of minutes from midnight
1324 ;;; Cyclical Schedule Entries
1326 (require 'diary-lib
)
1329 (defvar planner-cyclic-diary-file
))
1331 ;; Purloined from planner-cyclic.el.
1332 (defun planner-appt-schedule-get-cyclic-tasks (date &optional no-of-days
)
1333 "For DATE, get the cyclic tasks.
1334 Optional argument get tasks for NO-OF-DAYS from DATE, the default is 1
1335 day [i.e., only for DATE]."
1336 (let ((date (if (stringp date
)
1337 (planner-filename-to-calendar-date date
)
1340 (mapcar #'(lambda (item)
1341 (when (string-match planner-appt-schedule-regexp
1343 (match-string 0 (elt item
1))))
1344 (planner-list-diary-entries planner-cyclic-diary-file
1345 date no-of-days
)))))
1347 (defun planner-appt-schedule-add-cyclic ()
1348 "Add cylical tasks to the schedule if the current buffer is a day page."
1349 (when (string-match planner-date-regexp
(planner-page-name))
1351 (planner-appt-schedule-get-cyclic-tasks (planner-page-name))))
1353 (planner-seek-to-first planner-appt-schedule-section
)
1354 (let ((start (point)))
1355 (dolist (entry entries
)
1356 ;; Only insert if the entry is not already there.
1357 (unless (save-excursion
1359 (search-forward entry nil t
))
1360 (insert entry ?
\n))))
1361 ;; Lazy way of putting them in the right place.
1362 (when planner-appt-sort-schedule-on-update-flag
1363 (planner-appt-schedule-sort))))))
1365 (defun planner-appt-schedule-add-cyclic-maybe ()
1366 "Add cylical tasks to the schedule.
1367 Behaviour depends upon `planner-appt-schedule-cyclic-behaviour'."
1368 (when (and (not (string< (planner-page-name) (planner-today)))
1369 (or (eq planner-appt-schedule-cyclic-behaviour
'future
)
1371 (eq planner-appt-schedule-cyclic-behaviour
'today
)
1372 (planner-appt-todays-page-p))))
1373 (planner-appt-schedule-add-cyclic)))
1375 (defun planner-appt-schedule-cyclic-insinuate ()
1376 "Insinuate the adding of cyclical schedule entries."
1377 ;; TODO: Add locally?
1378 (planner-appt-add-hook 'planner-mode-hook
1379 'planner-appt-schedule-add-cyclic-maybe nil t
))
1381 (defun planner-appt-schedule-cyclic-de-insinuate ()
1382 "Remove cyclic schedule adding functionality."
1383 (remove-hook 'planner-mode-hook
1384 'planner-appt-schedule-add-cyclic-maybe
))
1387 ;;; Common Functions
1390 ;; So that one doesn't have to use two separate commands when using
1393 (defvar --planner-appt-updated nil
)
1396 (defun planner-appt-update ()
1397 "Update the appointments on the current page."
1399 ;; NB: Task adding has to be done before the schedule to avoid
1400 ;; duplicates if task appointments are copied to the schedule.
1401 (when (memq 'tasks planner-appt-methods
)
1402 (planner-appt-add-appts-from-tasks))
1403 (when (memq 'schedule planner-appt-methods
)
1404 (planner-appt-add-appts-from-schedule))
1405 (when (and planner-appt-sort-schedule-on-update-flag
1406 (planner-appt-todays-page-p))
1407 (planner-appt-schedule-sort))
1408 (run-hooks 'planner-appt-update-hook
)
1409 ;; TODO: Use a belt and some braces: see comments in
1410 ;; `planner-appt-insinuate-if-today'.
1411 (setq --planner-appt-updated t
))
1413 (defun planner-appt-update-for-write ()
1414 (when planner-appt-update-appts-on-save-flag
1415 (planner-appt-update)
1416 ;; Return nil for local-write-file-hooks.
1419 ;; NB: Something like the above could be done for other hooks as
1423 ;;; General Insinuation
1425 ;; This indirect method is used rather than some variable so that the
1426 ;; function advice can be avoided if it is not necessary [when using
1427 ;; schedule appointments exclusively].
1430 (defun planner-appt-use (source)
1431 "Use SOURCE to derive appointments from plan pages.
1432 Possible values for SOURCE are:
1433 'tasks [use today's task descriptions]
1434 'schedule [use today's schedule]
1435 '(tasks schedule) [use both tasks and schedule]."
1436 (dolist (s (if (listp source
)
1439 (cond ((eq s
'tasks
)
1440 ;; Add task-specific non-insinuating code here.
1441 ;; ;; Only activate advice when necessary.
1442 ;; (ad-enable-regexp "planner-appt-task")
1443 ;; (ad-activate-regexp "planner-appt-task")
1444 ;; An outstanding global hook [planner-appt-task-add tests
1445 ;; for today-ness anyway].
1446 (planner-appt-add-hook 'planner-create-task-hook
1447 'planner-appt-create-task-hook-func nil t
)
1448 (add-to-list 'planner-appt-methods s
))
1450 ;; Add schedule task-specific non-insinuating code here.
1451 (add-to-list 'planner-appt-methods s
))
1453 (error "Invalid appointment source %s" s
))))
1454 ;; Add here any non method-specific code that should be executed
1455 ;; even if planner-appt-insinuate is not called.
1456 (if (memq 'tasks planner-appt-methods
)
1457 (planner-appt-enable-all-advice)
1458 (planner-appt-disable-all-advice))
1459 (planner-appt-add-hook 'planner-mode-hook
1460 'planner-appt-font-setup nil t
)
1461 ;; Might as well return something interesting.
1462 planner-appt-methods
)
1465 (defun planner-appt-insinuate-if-today ()
1466 (when (planner-appt-todays-page-p)
1467 (planner-appt-add-hook 'planner-mode-hook
1468 'planner-appt-update t
)
1469 ;; Add method specific things
1470 (when (memq 'tasks planner-appt-methods
)
1471 (planner-appt-task-insinuate))
1472 (when (memq 'schedule planner-appt-methods
)
1473 (planner-appt-schedule-insinuate))
1474 (planner-appt-add-hook planner-appt-write-file-hook
1475 'planner-appt-update-for-write t
)
1476 ;; TODO: Under some conditions, as yet undetermined, an update is
1477 ;; not done when `plan' is called for the first time. So do an
1478 ;; update, but only if there hasn't been one already.
1480 ;; Fri 15 Apr 2005 16:26:04 BST: this has probably been sorted out
1481 ;; now, but it doesn't do any harm to leave this in for now, just
1483 (unless --planner-appt-updated
1484 (planner-appt-update))))
1487 (defun planner-appt-insinuate ()
1488 "Insinuate appointment alerting into planner mode.
1489 Appointment methods should be set up first using one of:
1490 `planner-appt-use-tasks'
1491 `planner-appt-use-schedule'
1492 `planner-appt-use-tasks-and-schedule'."
1493 (unless planner-appt-methods
1495 "No appointment source methods. Use one of:
1496 `planner-appt-use-tasks'
1497 `planner-appt-use-schedule'
1498 `planner-appt-use-tasks-and-schedule'
1499 before you call this function"))
1500 ;; Initialize the appt system according to emacs type and version.
1501 (cond ((fboundp 'appt-activate
) ; Gnu Emacs >= 22
1503 ((fboundp 'appt-initialize
) ; Xemacs
1504 ;; appt-initialize needs a diary file, so create one if it
1505 ;; doesn't already exist
1506 (unless (file-exists-p diary-file
)
1509 (write-region (point-min) (point-max) diary-file
)))
1512 (t (display-time) ; Gnu Emacs < 22
1513 (add-hook 'diary-hook
'appt-make-list
)))
1514 (planner-appt-add-hook 'planner-mode-hook
1515 'planner-appt-insinuate-if-today t t
))
1517 ;; Remove hooks if there is something not working during testing.
1518 (defun planner-appt-de-insinuate ()
1519 "Remove all hooks associated with planner-appt.
1520 Use in an emergency if breakage in planner-appt interferes with your planning."
1522 (remove-hook 'planner-mode-hook
'planner-appt-insinuate-if-today
)
1523 (remove-hook 'mark-diary-entries-hook
'planner-appt-mark-calendar-maybe
)
1524 (when (get-buffer (planner-today))
1525 (with-current-buffer (get-buffer (planner-today))
1526 ;; NB: Remember to remove locally where appropriate.
1527 (remove-hook 'planner-goto-hook
1528 'planner-appt-update t
)
1529 (remove-hook 'planner-mode-hook
1530 'planner-appt-update t
)
1531 (remove-hook planner-appt-write-file-hook
1532 'planner-appt-update-for-write t
)
1533 (remove-hook 'planner-create-task-hook
1534 'planner-appt-create-task-hook-func
)
1535 (planner-appt-task-de-insinuate)
1536 (planner-appt-schedule-de-insinuate)
1537 (planner-appt-schedule-cyclic-de-insinuate)))
1538 (planner-appt-disable-all-advice)
1539 (message "Planner-appt de-insinuated."))
1542 ;;; Convenient Functions For Users' Configuration.
1545 (defun planner-appt-use-tasks ()
1546 "Use tasks to derive appointment alerts."
1547 (planner-appt-use 'tasks
))
1550 (defun planner-appt-use-schedule ()
1551 "Use the schedule to derive appointment alerts."
1552 (planner-appt-use 'schedule
))
1555 (defun planner-appt-use-tasks-and-schedule ()
1556 "Use both tasks and the schedule to derive appointment alerts."
1557 (planner-appt-use '(tasks schedule
)))
1559 ;;; Font Highlighting
1561 (defface planner-appt-face
'((t (:foreground
"green")))
1562 "Face for scheduled time."
1563 :group
'planner-appt
)
1565 (defface planner-appt-overdue-face
'((t (:foreground
"red")))
1566 "Face for scheduled, but overdue time."
1567 :group
'planner-appt
)
1569 (defun planner-appt-task-highlight-face (time)
1570 "Return appropriate face, depending on TIME.
1571 If TIME is earlier than now, return `planner-appt-face', else
1572 return `planner-appt-overdue-face'."
1573 (if (planner-appt-earlier-than-now-p time
)
1574 'planner-appt-overdue-face
1575 'planner-appt-face
))
1577 (defun planner-appt-task-highlight (beg end
&optional verbose
)
1578 "Highlight appointment times in tasks from BEG to END.
1579 VERBOSE is ignored."
1580 (when planner-appt-font-lock-appointments-flag
1582 (while (re-search-forward planner-appt-task-regexp end t
)
1583 (when (or (not planner-appt-limit-highlighting-flag
)
1585 (goto-char (planner-line-beginning-position))
1587 (or (and (looking-at planner-live-task-regexp
)
1588 (string= (planner-task-date
1589 (planner-current-task-info))
1592 (planner-appt-todays-page-p)
1593 (looking-at planner-appt-schedule-appt-regexp
))))))
1594 (planner-highlight-region
1599 (planner-appt-task-highlight-face
1600 (match-string 1))))))))
1602 (defun planner-appt-font-setup ()
1603 "Hook into `planner-mode'."
1604 (planner-appt-add-hook 'muse-colors-buffer-hook
1605 'planner-appt-task-highlight t
))
1607 ;;; Calendar Marking
1609 ;; This is not strictly part of appointment handling, but if the
1610 ;; diary is to be by-passed for appointments, it makes sense to mark
1611 ;; the calendar using day pages.
1615 ;; Use a different face from the diary-entry-marker so we can
1616 ;; see where the different marks come from.
1617 (defface planner-appt-entry-marker
1618 '((t (:foreground
"indianred")))
1619 "Face for planner day page mark in the calendar."
1620 :group
'planner-appt
)
1623 (defun planner-appt-mark-calendar (&optional from to
)
1624 "Mark dates in the calendar that have day pages.
1625 Optional args: mark dates from FROM to TO.
1626 FROM and to are lists: (month day year)."
1627 (with-current-buffer calendar-buffer
; Needed to get displayed date
1629 (let* ((displayed-month-last
1630 (1+ (cdr (assq 'displayed-month
1631 (buffer-local-variables)))))
1633 (cdr (assq 'displayed-year
1634 (buffer-local-variables))))
1635 (today-filename (planner-today))
1636 (today (planner-filename-to-calendar-date today-filename
)))
1637 ;; Do nothing if the calendar is currently showing all months
1638 ;; earlier than today.
1639 (when (and (>= (elt today
2) ; year
1641 (>= displayed-month-last
1642 (elt today
0))) ; month
1643 (let ((diary-entry-marker 'planner-appt-entry-marker
)
1645 (planner-get-day-pages
1647 (planner-date-to-filename from
)
1650 (planner-date-to-filename to
)
1651 ;; The default is last day visible
1653 (planner-date-to-filename
1654 (list displayed-month-last
31 displayed-year
))))))
1655 (dolist (day-page day-pages
)
1656 (apply #'mark-calendar-date-pattern
1657 (planner-filename-to-calendar-date (car day-page
)))))))))
1659 (defun planner-appt-calendar-insinuate ()
1660 (add-hook 'mark-diary-entries-hook
'planner-appt-mark-calendar
))
1662 (provide 'planner-appt
)
1663 ;;; planner-appt.el ends here
1666 ;; indent-tabs-mode: t