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 not part of GNU Emacs.
15 ;; This is free software; you can redistribute it and/or modify it under
16 ;; the terms of the GNU General Public License as published by the Free
17 ;; Software Foundation; either version 2, or (at your option) any later
20 ;; This is distributed in the hope that it will be useful, but WITHOUT
21 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
22 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
25 ;; You should have received a copy of the GNU General Public License
26 ;; along with GNU Emacs; 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.
41 ;; * Seth Falcon supplied the idea and the code that is the basis of
42 ;; the forthcoming appointments display functionality.
46 ;; * Correct sorting of task appointments
48 ;; * Consider changing "insinuate" into "install". I don't like the
49 ;; word "insinuate" very much! Or a minor mode perhaps:
50 ;; planner-appt-minor-mode
52 ;; * A lot of the code properly belongs elsewhere: schedule sorting,
53 ;; schedule cyclical entries, calendar marking...
64 (defgroup planner-appt nil
65 "Appointment integration for planner.el."
66 :prefix
"planner-appt-"
69 (defcustom planner-appt-schedule-section
"Schedule"
70 "The name of the section where the schedule is to be found."
74 (defcustom planner-appt-font-lock-appointments-flag t
75 "Non-nil means use font-locking for appointments."
77 :type
'(choice (const :tag
"Use font-locking" t
)
78 (const :tag
"Don't use font-locking" nil
)))
80 (defcustom planner-appt-update-appts-on-save-flag nil
81 "Non-nil means update appointment alerts on saving today's plan."
83 :type
'(choice (const :tag
"Update on save" t
)
84 (const :tag
"Don't update on save" nil
)))
86 (defcustom planner-appt-sort-schedule-on-update-flag nil
87 "Non-nil means sort the schedule when updating appointments."
89 :type
'(choice (const :tag
"Sort on update" t
)
90 (const :tag
"Don't sort on update" nil
)))
93 (defcustom planner-appt-update-hook
'()
94 "Hook run after appointments have been updated."
98 (defcustom planner-appt-schedule-cyclic-behaviour
'today
99 "Determines the behaviour of cyclical schedule insertion.
100 Used after `planner-appt-schedule-cyclic-insinuate' has been called.
101 'today means only add cylical schedule entries for today
102 'future means add cyclical entries for all future day pages visited."
104 :type
'(choice (const :tag
"For today only" today
)
105 (const :tag
"For all future pages." future
)))
107 (defcustom planner-appt-alert-buffer
"*Alerts*"
108 "Name of the buffer for displaying active alerts.
109 Used by `planner-appt-show-alerts'."
114 (defcustom planner-appt-task-use-appointments-section-flag nil
115 "When non-nil, task appointments will be copied to an appoinments section.
116 The section name is supplied by
117 `planner-appt-task-appointments-section'."
121 (defcustom planner-appt-task-appointments-section
"Schedule"
122 "Name of the section where task appointments are copied.
123 The copying is contingent upon
124 `planner-appt-task-use-appointments-section-flag'."
128 (defcustom planner-appt-format-appt-section-line-function
129 #'planner-appt-format-appt-section-line
130 "The function used when formatting an appointment section line.
132 This function should take one argument: an appointment description.
133 The description is in the form used when an appointment alert is
134 signalled: a string with the time of the appointment and some text
135 such as \"12:00 Do something\". Look at the default function
136 `planner-appt-format-appt-section-line' for inspiration if you want to
137 make a different format."
141 (defcustom planner-appt-limit-highlighting-flag t
142 "When non-nil, only highlight appointment times in tasks and the schedule.
143 When nil, all appointment times are highlighted, wherever they may be
148 (defcustom planner-appt-forthcoming-days
7
149 "Number of days to look ahead for appointments."
153 (defcustom planner-appt-forthcoming-appt-section
"Forthcoming Appointments"
154 "Title of the section for forthcoming appointments."
158 (defcustom planner-appt-forthcoming-repeat-date-string
" "
159 "String to insert for repeated dates.
160 When there are multiple appointments for a date, the date is inserted
161 in the first appointment and the others have this string in their date
164 If the string consists of anything other than whitespace, then a link
165 to the day page for the appoinment is created."
169 (defcustom planner-appt-forthcoming-look-at-cyclic-flag nil
170 "When non nil, add cyclic entries to the forthcoming appointments section."
175 ;; Regular Expressions
177 ;; TODO: Should these really be customizable anyway?
179 ;; TODO: Dynamically changing dependent customizations; i.e., if this
180 ;; is changed, all the other time-based regexps should change too [I
181 ;; don't understand customize well enough to do this].
183 (defcustom planner-appt-time-regexp
184 "[0-9]?[0-9]:[0-5][0-9]\\(?:am\\|pm\\)?"
185 "Regular expression matching times."
189 (defcustom planner-appt-task-regexp
190 (concat "[@!][ \t]*\\(" planner-appt-time-regexp
"\\)[ \t]*")
191 "If a task description matches this regexp, it's an appointment.
192 Match group 1 is the time of the appointment.
193 Used with the task-based method. If you use schedules, look at
194 `planner-appt-schedule-appt-regexp'."
198 (defcustom planner-appt-task-nagging-regexp
199 (concat "![ \t]*\\(" planner-appt-time-regexp
"\\)[ \t]*")
200 "If a task description matches this regexp, it's a nagging
201 appointment. Used with the task-based method. If you use schedules,
202 look at `planner-appt-schedule-appt-regexp'."
206 (defcustom planner-appt-schedule-basic-regexp
209 ;; the appointment time (match group 1)
210 planner-appt-time-regexp
212 ;; possibly some space, possibly a |, and any amount of space
214 ;; perhaps another time [the end time] (match group 2)
216 planner-appt-time-regexp
218 ;; possibly some space or some ?' chars, possibly a |, and any
221 ;; the appointment text (match group 3)
223 "Basic regular expression to match a schedule.
224 Match group 1 should yield the start time, match group 2 the stop
225 time, and match group 3 the schedule text."
226 :group
'planner-appt
)
228 ;; NB: The groups are shifted in this regexp.
229 (defcustom planner-appt-schedule-regexp
231 ;; any amount of whitespace possibly followed by @ and any amount
233 "^[ \t]*\\(@?\\)[ \t]*"
234 ;; followed by the basic regexp
235 planner-appt-schedule-basic-regexp
)
236 "Regexp matching schedule entries.
237 Match group 1 should match at most one leading instance of the
238 appointment marker, Match group 2 should yield the start time, match
239 group 3 the stop time, and match group 4 the schedule text."
243 (defcustom planner-appt-schedule-appt-regexp
245 ;; any amount of whitespace followed by @ and any amount of
248 ;; followed by the basic regexp
249 planner-appt-schedule-basic-regexp
)
250 "Regexp matching appointments in the schedule requiring alerts.
251 Used with the schedule-based method. If you use tasks for appointments,
252 look at `planner-appt-task-regexp.'
253 Match group 1 should yield the start time, match group 2 the stop
254 time, and match group 3 the alert text."
259 ;;; Planner Miscellany
261 ;; Could be useful elsewhere in planner?
263 (defun planner-appt-todays-page-p ()
264 "Return t if the current page is today's, otherwise nil."
265 (string= (planner-page-name) (planner-today)))
267 (defun planner-appt-seek-to-end-of-current-section ()
268 "Go to the end of the current section."
270 (or (and (re-search-forward "^\\*[^*]" nil t
)
271 (1- (planner-line-beginning-position)))
274 (defvar planner-appt-write-file-hook
275 (if (and (boundp 'write-file-functions
)
276 (not (featurep 'xemacs
)))
277 'write-file-functions
279 "The write file hook to use.")
281 ;;; Planner-Appt Miscellany
283 (defvar planner-appt-debug-buffer
"*planner-appt debug messages*"
284 "The buffer to put debugging messages from planner-appt.")
286 (defvar planner-appt-debug-flag nil
287 "Non-nil means turn on planner-appt debugging.")
289 (defmacro planner-appt-debug
(form &rest body
)
290 "Evaluate FORM if `planner-appt-debug-flag' is non-nil.
291 Optional BODY is evaluated otherwise."
292 `(if planner-appt-debug-flag
296 (defun planner-appt-debug-message (&rest args
)
297 "Insert ARGS into `planner-appt-debug-buffer'.
298 This code runs only if `planner-appt-debug-flag' is non-nil."
301 (get-buffer-create planner-appt-debug-buffer
)
302 (goto-char (point-max))
303 (apply #'insert args
)
306 (defun planner-appt-earlier-than-now-p (time)
307 "Return t if TIME is earlier than the current time.
308 Time formats are those used by the appt appointment system."
310 (let* ((now (decode-time))
311 (cur-hour (nth 2 now
))
312 (cur-min (nth 1 now
))
313 (cur-time (+ (* cur-hour
60) cur-min
)))
314 (> cur-time
(appt-convert-time time
))))
316 ;; Not used in this file, but added for completeness.
317 (defun planner-appt-later-than-now-p (time)
318 "Return t if TIME is later than the current time.
319 Time formats are those used by the appt appointment system."
321 (let* ((now (decode-time))
322 (cur-hour (nth 2 now
))
323 (cur-min (nth 1 now
))
324 (cur-time (+ (* cur-hour
60) cur-min
)))
325 (< cur-time
(appt-convert-time time
))))
328 (defvar --planner-appt-tasks-added-appts
'()
329 "Internal variable: Tracks added task-based appointment alerts.")
331 (defvar --planner-appt-tasks-earlier-appts
'()
333 Tracks appointments ignored because they were too early.")
335 (defun planner-appt-clear-appts (appt-list)
337 (setq appt-time-msg-list
338 (delete (pop appt-list
) appt-time-msg-list
))))
340 (defun planner-appt-format-time-and-description (time description
)
341 "Format TIME [a string] and DESCRIPTION as an appointment."
342 (concat time
" " description
))
345 (if (> emacs-major-version
21)
346 (defun planner-appt-make-appt-element (time text
)
348 (list (appt-convert-time time
))
349 (planner-appt-format-time-and-description time text
)
351 (defun planner-appt-make-appt-element (time text
)
353 (list (appt-convert-time time
))
354 (planner-appt-format-time-and-description time text
)))))
356 (defun planner-appt-remember-appt (time text list
)
357 "Store details of an appointment with TIME and TEXT in LIST.
358 Return the new list."
359 (push (planner-appt-make-appt-element time text
) list
))
361 (defun planner-appt-forget-appt (appt appt-list
)
362 "Remove APPT from APPT-LIST and return the new list.
363 APPT is in the appt format."
364 (delete (car (member appt appt-list
)) appt-list
))
366 (defun planner-appt-add-hook (hook function
&optional append global
)
367 "Add to the value of HOOK the function FUNCTION.
368 This is `add-hook' with local and global switched.
369 FUNCTION is not added if already present.
370 FUNCTION is added (if necessary) at the beginning of the hook list
371 unless the optional argument APPEND is non-nil, in which case
372 FUNCTION is added at the end.
373 The optional fourth argument, GLOBAL, if non-nil, says to modify
374 the hook's global value rather than its local value."
375 (add-hook hook function append
(not global
)))
378 (defun planner-appt-remove-task-id (description)
381 (if (boundp 'planner-id-regexp
)
382 "{{\\([^:]+\\):\\([0-9]+\\)}}"))
384 (replace-match "" t t description
)
388 (defun planner-appt-format-description (description)
389 (planner-appt-remove-task-id
390 (planner-remove-links description
)))
393 ;;; Showing Appointments In Various Ways
395 (defvar planner-appt-methods
'()
396 "Methods used for appointment alerts.
397 Internal variable: to set up appointment methods use one of:
398 `planner-appt-use-tasks'
399 `planner-appt-use-schedule'
400 `planner-appt-use-tasks-and-schedule'.")
402 ;; Copying task appts over to an "Appointments" section.
404 (defun planner-appt-format-appt-section-line (desc)
405 "Format DESC as a line for the appointments section."
406 (let* ((td (planner-appt-task-parse-task
407 ;; Trick the function into parsing:
411 (end-time (if (string-match
412 (format "\\s-*\\(%s\\)\\s-*"
413 planner-appt-time-regexp
)
416 (match-string 1 text
)
417 (setq text
(replace-match "" t t text
)))
419 ;; Format in the style of a tabular schedule.
420 (format "%6s | %5s | %s"
421 ;; Using an @ means the time gets fontified for free.
424 (if (string= planner-appt-task-appointments-section
425 planner-appt-schedule-section
)
426 ;; To avoid confusion, add an indication that this
427 ;; item came from a task.
431 (defvar --planner-appt-lines-added-to-section
'()
433 Remembers lines added by `planner-appt-update-appt-section' the last
434 time it was called.")
436 (defun planner-appt-task-schedule-item-p (string)
437 "Return t if STRING is a schedule item derived from a task."
438 (member string --planner-appt-lines-added-to-section
))
439 ;; ;; Look for any property in the string since STRING will usually be
440 ;; ;; derived from a buffer substring which may have been edited.
441 ;; (text-property-any 0 (length string) 'appt-task t string))
443 (defun planner-appt-update-appt-section ()
445 (planner-seek-to-first planner-appt-task-appointments-section
)
446 (let ((bound (make-marker))
448 (copy-sequence --planner-appt-lines-added-to-section
))
451 (planner-appt-seek-to-end-of-current-section)
452 (set-marker bound
(point)))
453 (dolist (appt (append --planner-appt-tasks-added-appts
454 --planner-appt-tasks-earlier-appts
))
455 (setq line
(funcall planner-appt-format-appt-section-line-function
457 (setq lines-to-delete
(delete line lines-to-delete
))
459 (unless (search-forward line bound t
)
461 ;; Remember the line even if it was already there
462 (push line --planner-appt-lines-added-to-section
))
463 ;; Remove lines of deleted tasks
464 (dolist (del-line lines-to-delete
)
465 (setq --planner-appt-lines-added-to-section
466 (delete del-line --planner-appt-lines-added-to-section
))
468 (when (search-forward del-line bound t
)
470 (when (eq (char-after) ?
\n)
472 (set-marker bound nil
))
473 ;; Use schedule sorting with some changes
474 (let ((planner-appt-schedule-section
475 planner-appt-task-appointments-section
)
476 (planner-appt-schedule-regexp
477 (concat "\\(.*?\\)" ; to shift the match groups
478 planner-appt-schedule-basic-regexp
)))
479 (planner-appt-schedule-sort))))
481 (defun planner-appt-update-appt-section-maybe ()
483 ;; The appointment section is only relevant if the task
485 (memq 'tasks planner-appt-methods
)
486 planner-appt-task-use-appointments-section-flag
)
487 (with-planner-update-setup
490 (planner-appt-update-appt-section)))))
492 (defmacro with-planner-appt-update-section-disabled
(&rest body
)
493 `(let ((planner-appt-task-use-appointments-section-flag nil
))
496 (put 'with-planner-appt-update-section-disabled
'lisp-indent-function
0)
497 (put 'with-planner-appt-update-section-disabled
'edebug-form-spec
'(body))
499 ;; Compatibility fix for Xemacs [and for Emacs <21?]
500 (if (fboundp 'fit-window-to-buffer
)
501 (defalias 'planner-fit-window-to-buffer
'fit-window-to-buffer
)
502 (defalias 'planner-fit-window-to-buffer
'shrink-window-if-larger-than-buffer
))
504 ;; Display Current Appointments
505 (defun planner-appt-show-alerts ()
506 "Display a list of currently active alerts in another window."
508 (let ((buf (get-buffer-create planner-appt-alert-buffer
)))
509 (with-current-buffer buf
511 (insert "Current alerts\n==============")
512 (if appt-time-msg-list
513 (dolist (appt appt-time-msg-list
)
514 (insert "\n" (cadr appt
)))
516 (goto-char (point-min)))
517 (planner-fit-window-to-buffer (display-buffer buf
))))
520 ;; Display/Insert Forthcoming Appointments
522 (defvar planner-appt-forthcoming-regexp
524 planner-appt-schedule-appt-regexp
526 planner-live-task-regexp
527 planner-appt-task-regexp
530 (defvar planner-appt-forthcoming-task-regexp
531 (concat planner-live-task-regexp
532 planner-appt-task-regexp
))
534 (defun planner-appt-forthcoming-format-appt-description (time description
)
536 planner-appt-format-appt-section-line-function
537 (planner-appt-format-time-and-description
539 (planner-appt-format-description description
))))
541 (defun planner-appt-forthcoming-task-data (info)
543 (planner-appt-task-parse-task
544 (planner-task-description info
))))
546 (cons (appt-convert-time (nth 1 task-appt
))
547 (planner-appt-forthcoming-format-appt-description
549 (nth 0 task-appt
))))))
551 (defun planner-appt-forthcoming-get-appts (n &optional include-today
)
552 (planner-save-buffers)
554 (pages (planner-get-day-pages
557 (planner-calculate-date-from-day-offset
559 (planner-calculate-date-from-day-offset
560 (planner-today) (if include-today n
(1+ n
)))))
561 cyclic-data cyclic-task-descriptions
562 line task-info task-data
563 date-absolute date time text
)
564 ;; After scanning pages and [conditionally] cyclic entries, each
565 ;; element of appts has:
568 ;; <time in appt format [minutes from midnight]>
569 ;; <date in planner format>
572 ;; The first two elements are used for sorting/merging; they are
573 ;; removed from the returned list.
574 (when (and (featurep 'planner-cyclic
)
575 planner-appt-forthcoming-look-at-cyclic-flag
)
576 ;; Returns (<appts> . <list of planner-cyclic-ly formatted tasks>)
577 (setq cyclic-data
(planner-appt-forthcoming-get-cyclic n
))
578 (setq appts
(car cyclic-data
)
579 cyclic-task-descriptions
(cdr cyclic-data
)))
583 (when (file-exists-p (cdr page
))
584 (setq date
(car page
))
585 (setq date-absolute
(calendar-absolute-from-gregorian
586 (planner-filename-to-calendar-date
588 (insert-file-contents (cdr page
))
589 (goto-char (point-min))
590 (while (re-search-forward planner-appt-forthcoming-regexp nil t
)
591 (setq line
(match-string 0))
592 (if (string-match planner-appt-schedule-appt-regexp line
)
593 (unless (planner-appt-task-schedule-item-p line
)
594 (setq time
(save-match-data
595 (appt-convert-time (match-string 1 line
)))
596 text
(match-string 0 line
)))
597 (setq task-info
(planner-current-task-info))
598 (setq task-data
(planner-appt-forthcoming-task-data task-info
))
600 ;; Check for a cyclic task already added.
601 ;; This is a bit messy, since a task id
602 ;; won't have been added [and there might
603 ;; be other special case that I haven't
607 "\\s-+{{Tasks:[0-9]+}}\\s-*"
608 (planner-task-description task-info
))
611 (planner-task-description task-info
))
612 (planner-task-description task-info
))
613 cyclic-task-descriptions
)))
614 (setq time
(car task-data
)
615 text
(cdr task-data
))))
616 (when (and time text
)
617 ;; Add if it is not there already [there may be a
618 ;; duplicate if this is a schedule item derived from a
620 (add-to-list 'appts
(list date-absolute time date text
))
621 (setq time nil text nil
)))
627 (or (< (car a
) (car b
))
628 (and (= (car a
) (car b
))
629 (< (cadr a
) (cadr b
))))))))))
632 (defun planner-appt-forthcoming-get-cyclic (n)
634 (cyclic-task-descriptions '())
635 date line time text task-info task-data
)
636 (dolist (entry (planner-list-diary-entries
637 planner-cyclic-diary-file
638 (planner-filename-to-calendar-date
639 (planner-calculate-date-from-day-offset
642 (setq date
(planner-date-to-filename (car entry
))
644 (if (string-match planner-appt-schedule-appt-regexp line
)
645 (setq time
(save-match-data
646 (appt-convert-time (match-string 1 line
)))
647 text
(match-string 0 line
))
648 (when (string-match planner-appt-forthcoming-task-regexp line
)
649 (setq task-info
(planner-task-info-from-string date line
))
650 (setq task-data
(planner-appt-forthcoming-task-data task-info
))
652 ;; For duplicate checking: remember the description as
653 ;; it would be transformed by planner-cyclic.
654 (push (format planner-cyclic-task-description-format
655 (planner-task-description task-info
) date
)
656 cyclic-task-descriptions
)
657 (setq time
(car task-data
)
658 text
(cdr task-data
)))))
659 (when (and time text
)
662 (list (calendar-absolute-from-gregorian (car entry
))
664 (setq time nil text nil
)))
665 (cons appts cyclic-task-descriptions
)))
667 ;; Format the data into a big string to make it easy either to put
668 ;; into a display buffer or into the day page.
669 (defun planner-appt-forthcoming-format (appt-data)
671 (empty-cell-p (string-match
672 (format "\\`[%s]+\\'" muse-regexp-blank
)
673 planner-appt-forthcoming-repeat-date-string
)))
674 (mapconcat #'(lambda (a)
677 (if (string= (car a
) last-date
)
679 planner-appt-forthcoming-repeat-date-string
682 planner-appt-forthcoming-repeat-date-string
))
683 (planner-make-link (car a
)))
685 ;; Remove @s from times to avoid spurious
687 (muse-replace-regexp-in-string
691 (setq last-date
(car a
))))
695 (defvar planner-appt-forthcoming-display-buffer
696 "*Forthcoming Appointments*"
697 "Buffer to display forthcoming appointments.")
699 (defun planner-appt-forthcoming-display (&optional days
)
701 ;; TODO: I wanted to use (interactive "p"), but that defaults to
702 ;; 1. Is this really the best way of getting nil as the default
703 ;; for a command that takes an optional integer prefix?:
704 (list (cond ((consp current-prefix-arg
)
705 (car current-prefix-arg
))
706 ((integerp current-prefix-arg
)
709 (unless days
(setq days planner-appt-forthcoming-days
))
711 (get-buffer-create planner-appt-forthcoming-display-buffer
)
712 (unless (planner-derived-mode-p 'planner-mode
)
713 (setq muse-current-project
(muse-project planner-project
))
715 (cd (planner-directory)))
716 (delete-region (point-min) (point-max))
717 (insert "* Appointments in the next "
718 (number-to-string days
)
719 (if (= days
1) " day" " days")
721 (planner-appt-forthcoming-format
722 (planner-appt-forthcoming-get-appts
723 (or days planner-appt-forthcoming-days
) t
)))
724 (goto-char (point-min)))
725 (display-buffer planner-appt-forthcoming-display-buffer
)
726 (planner-fit-window-to-buffer
727 (get-buffer-window planner-appt-forthcoming-display-buffer
)))
730 (defun planner-appt-forthcoming-update-section (&optional days
)
732 (list (cond ((consp current-prefix-arg
)
733 (car current-prefix-arg
))
734 ((integerp current-prefix-arg
)
737 (with-planner-update-setup
740 (planner-seek-to-first planner-appt-forthcoming-appt-section
)
741 (delete-region (point)
742 (planner-appt-seek-to-end-of-current-section))
743 (insert (planner-appt-forthcoming-format
744 (planner-appt-forthcoming-get-appts
745 (or days planner-appt-forthcoming-days
)))
749 ;; A function suitable for planner-mode-hook
750 (defun planner-appt-forthcoming-update-section-maybe ()
751 (when (planner-appt-todays-page-p)
752 (planner-appt-forthcoming-update-section)))
755 ;;; Alerts From Task Descriptions
757 ;; Add a bit of [premature] optimization, mainly for updating
758 ;; functions where the same task gets examined often.
759 (defvar --planner-appt-task-cache
(make-hash-table :test
'equal
))
761 (defun planner-appt-task-parse-task (description)
762 "Extract appointment time and text from the DESCRIPTION.
763 Return a list (text time). If the task is not an
764 appointment, time defaults to nil."
765 (or (gethash description --planner-appt-task-cache
)
768 (if (string-match planner-appt-task-regexp description
)
769 (list (substring description
(match-end 0))
770 (substring description
(match-beginning 1) (match-end 1)))
771 (list description nil
))
772 --planner-appt-task-cache
)))
774 (defun planner-appt-task-nagging-p (description)
775 "Return non-nil if task DESCRIPTION is a nagging appointment."
776 (string-match planner-appt-task-nagging-regexp description
))
778 (defun planner-appt-task-member (description time appt-list
)
779 "Return non-nil if DESCRIPTION at TIME in APPT-LIST has been scheduled."
780 (member (planner-appt-make-appt-element time description
) appt-list
))
783 ;; Integration with planner-schedule.el
785 (defvar planner-appt-schedule-task-estimate-regexp
786 (concat "[!@][ \t]*\\(?:" ; "shy" form of planner-appt-task-regexp
787 planner-appt-time-regexp
789 "\\s-*\\([0-9]+[smhdw]\\)")
790 "Regular expression matching a task time estimate.")
792 ;; NB: The following advice could be avoided if the regexp were not
793 ;; hard-coded into the original function.
795 ;; NNB: This is not well tested!
797 (defadvice planner-schedule-task-estimate
(around planner-appt-task disable
)
798 "Modify the regexp matched to take appointments into account."
799 (when (string-match planner-appt-schedule-task-estimate-regexp
800 (planner-task-description info
))
801 (schedule-duration-to-seconds
802 (match-string 2 (planner-task-description info
)))))
805 (defun planner-appt-task-add (&optional info
)
806 "Create an appointment from the current task if this is today's plan.
807 Return t if an appointment was added.
808 If the task is an appointment, it is not cancelled, it is scheduled for
809 later today, and is not already added.
810 Optional argument: use INFO instead of the current task info."
812 (let* ((info (or info
813 ;; Unfortunately, in emacs-lisp there are no
814 ;; defaults for optional arguments, so one can't
815 ;; distinguish between null info in an arg and null
816 ;; info from planner-current-task-info; so the
817 ;; error message might be uninformative here.
818 (planner-current-task-info)
819 (error "There is no task on the current line")))
820 (appt (planner-appt-task-parse-task
821 (planner-task-description info
)))
823 (desc (and time
(planner-appt-format-description (nth 0 appt
)))))
825 (not (string= (planner-task-status info
) "C"))
826 (string= (planner-task-date info
)
827 (planner-date-to-filename
828 (decode-time (current-time))))
829 (not (planner-appt-task-member desc time
830 appt-time-msg-list
)))
831 (if (planner-appt-earlier-than-now-p time
)
833 ;; Remember earlier appts separately [principally for
834 ;; their addition in an appointment section].
835 (unless (planner-appt-task-member
836 desc time --planner-appt-tasks-earlier-appts
)
837 (setq --planner-appt-tasks-earlier-appts
838 (planner-appt-remember-appt
840 --planner-appt-tasks-earlier-appts
)))
841 (planner-appt-update-appt-section-maybe)
842 ;; Make sure nil is returned.
845 ;; Keep track of tasks added by this function.
846 (setq --planner-appt-tasks-added-appts
847 (planner-appt-remember-appt
849 --planner-appt-tasks-added-appts
))
850 (planner-appt-update-appt-section-maybe)
853 (defun planner-appt-task-delete (&optional info
)
854 "Delete the appointment from the current task if this is today's plan.
855 Do not remove the time string.
856 Return any deleted appointments.
857 Optional argument: use INFO instead of the current task info."
859 (let* ((info (or info
860 ;; See planner-appt-task-add for comments about
861 ;; the possibly uninformative error message.
862 (planner-current-task-info)
863 (error "There is no task on the current line")))
864 (appt (planner-appt-task-parse-task
865 (planner-task-description info
)))
867 (desc (and time
(planner-appt-format-description (nth 0 appt
))))
868 (tmp-msg-list appt-time-msg-list
))
870 ;; Method from appt-delete
871 (let ((deleted-appts '())
873 (car (planner-appt-task-member
874 desc time --planner-appt-tasks-earlier-appts
)))
876 ;; NB: Mustn't concat time onto description until earlier-appt
877 ;; has been determined [since planner-appt-task-member does
878 ;; the concat itself [this could be improved somehow]]
879 (setq desc
(concat time
" " desc
))
881 (setq element
(car tmp-msg-list
))
882 (when (string= (car (cdr element
)) desc
)
883 (push element deleted-appts
)
884 (setq appt-time-msg-list
(delq element appt-time-msg-list
))
885 (setq --planner-appt-tasks-added-appts
886 (planner-appt-forget-appt
887 element --planner-appt-tasks-added-appts
)))
888 (setq tmp-msg-list
(cdr tmp-msg-list
)))
889 (when (or deleted-appts earlier-appt
)
890 ;; Forget a deleted appt that was earlier than now.
892 (setq --planner-appt-tasks-earlier-appts
893 (planner-appt-forget-appt
894 earlier-appt --planner-appt-tasks-earlier-appts
)))
895 (planner-appt-update-appt-section-maybe))
898 (defun planner-appt-add-appts-from-tasks ()
899 "Parse all of today's tasks and add appointments automatically."
901 (when (planner-appt-todays-page-p)
902 ;; Clear old appts added by this function.
903 (planner-appt-clear-appts --planner-appt-tasks-added-appts
)
904 (setq --planner-appt-tasks-added-appts
'()
905 --planner-appt-tasks-earlier-appts
'())
906 (let ((case-fold-search nil
))
908 (goto-char (point-min))
909 (with-planner-appt-update-section-disabled
910 (while (re-search-forward
911 (concat planner-live-task-regexp
912 planner-appt-task-regexp
)
914 (planner-appt-task-add))))
915 (when (or --planner-appt-tasks-added-appts
916 --planner-appt-tasks-earlier-appts
)
917 (planner-appt-update-appt-section-maybe)))))
921 ;; for speedy enabling and disabling of advice:
923 (defvar --planner-appt-advice
'()
924 "Internal variable: List of advices added by `planner-appt-defadvice'.
925 Each element is a list of args for `ad-enable-advice' and
926 `ad-disable-advice'.")
929 (defvar planner-appt-advice-common-flags
930 '(preactivate disable
)
931 "Advice flags common to all planner-appt advice."))
933 (defmacro planner-appt-defadvice
(function args doc
&rest body
)
934 "Advise FUNCTION with ARGS, DOC and BODY.
935 Remembers the advice function and args in `--planner-appt-advice'."
938 (,@args
,@planner-appt-advice-common-flags
) ,doc
,@body
)
939 (let ((info '(,function
,(car args
) ,(cadr args
))))
940 (unless (member info --planner-appt-advice
)
941 (push info --planner-appt-advice
)))))
943 (put 'planner-appt-defadvice
946 (name name
&rest sexp
)
949 ("interactive" interactive
)]
952 (put 'planner-appt-defadvice
'lisp-indent-function
'defun
)
954 ;; See what happened with the preactivation.
958 (trace-function-background
959 'ad-cache-id-verification-code
960 "*planner-appt advice trace*")))
962 (defun planner-appt-disable-all-advice ()
963 "Disable all advice added with `planner-appt-defadvice'."
964 (mapcar #'(lambda (args)
965 (apply #'ad-disable-advice args
)
966 (ad-activate (car args
)))
967 --planner-appt-advice
))
969 (defun planner-appt-enable-all-advice ()
970 "Enable all advice added with `planner-appt-defadvice'."
971 (mapcar #'(lambda (args)
972 (apply #'ad-enable-advice args
)
973 (ad-activate (car args
)))
974 --planner-appt-advice
))
977 (defmacro with-planner-appt-task-advice-disabled
(&rest body
)
978 "Evaluate BODY forms with all advice matching \"planner-appt-task\" disabled."
981 (planner-appt-disable-all-advice)
982 (planner-appt-debug-message "all advice disabled")
984 (planner-appt-enable-all-advice)
985 (planner-appt-debug-message "all advice enabled")))
987 (put 'with-planner-appt-task-advice-disabled
'lisp-indent-function
0)
988 (put 'with-planner-appt-task-advice-disabled
'edebug-form-spec
'(body))
990 (planner-appt-defadvice planner-task-cancelled
991 (before planner-appt-task
)
992 "Delete the appointment as well."
993 (planner-appt-debug-message
994 "*** called advice on planner-task-cancelled")
995 (planner-appt-task-delete))
997 (planner-appt-defadvice planner-task-done
998 (before planner-appt-task
)
999 "Delete the appointment as well."
1000 (planner-appt-debug-message
1001 "*** called advice on planner-task-done")
1002 (planner-appt-task-delete))
1004 (planner-appt-defadvice planner-delete-task
1005 (before planner-appt-task
)
1006 "Delete the appointment as well."
1007 (planner-appt-debug-message
1008 "*** called advice on planner-delete-task")
1009 (planner-appt-task-delete))
1011 ;; The advice for planner-update-task is quite tricky. A task will
1012 ;; need updating [for appointments] if the task is dated today and the
1013 ;; description differs from other task lines linked to by the current
1014 ;; task. If this is true, we have to examine all the other links,
1015 ;; delete any appointments, and then add the task after planner-update
1016 ;; has been called. Note that it is only possible for this to happen
1017 ;; if planner-id is loaded since otherwise the "same" task line can't
1018 ;; have different descriptions.
1020 (defun planner-appt-get-diff-links (info)
1021 "Given INFO, return a list of tasks linked to it whose info differs."
1024 ;; Todo: with-planner-update-setup really ought to return the
1025 ;; value of the body.
1026 (with-planner-update-setup
1027 ;; Preserve point as well.
1030 (if (featurep 'planner-multi
)
1031 (planner-multi-link-delete
1032 (planner-task-page info
)
1033 (planner-multi-task-link-as-list info
))
1034 (list (planner-task-link info
))))
1035 (when (and (planner-find-file (planner-link-base link
))
1036 (planner-find-task info
)
1037 (setq linked-info
(planner-current-task-info))
1038 (not (planner-tasks-equal-p info linked-info
)))
1039 (push linked-info diffs
)))))
1042 (planner-appt-defadvice planner-update-task
1043 (around planner-appt-task
)
1044 "Update the appointment as well."
1045 (planner-appt-debug-message
1046 "*** called advice on planner-update-task")
1047 (let* ((info (planner-current-task-info))
1049 (and (featurep 'planner-id
)
1050 (string= (planner-task-date info
) (planner-today))
1051 (planner-appt-get-diff-links info
))))
1052 (with-planner-appt-task-advice-disabled ad-do-it
)
1054 (dolist (i diff-linked
)
1055 (planner-appt-task-delete i
))
1056 (planner-appt-task-add))))
1058 ;; For planner-id-update-tasks-on-page, it is actually much faster to
1059 ;; update today's page after it has done its work rather than using
1060 ;; the update advice above.
1062 (planner-appt-defadvice planner-id-update-tasks-on-page
1063 (around planner-appt-task
)
1064 "Update today's appointments as well."
1065 (planner-appt-debug-message
1066 "*** called advice on planner-id-update-tasks-on-page")
1067 (with-planner-appt-task-advice-disabled ad-do-it
)
1068 (with-planner-update-setup
1070 (planner-goto-today)
1071 ;; Update the appointments section afterwards for efficiency.
1072 (with-planner-appt-update-section-disabled
1073 (planner-appt-update))
1074 (planner-appt-update-appt-section-maybe))))
1076 (defvar --planner-appt-planning nil
1078 Lets planner-appt advice know that it has been called within a call to
1081 (planner-appt-defadvice plan
(around planner-appt-task
)
1082 "Note that plan is in progress."
1083 (planner-appt-debug-message
1084 "*** called advice on plan")
1085 (let ((--planner-appt-planning t
))
1088 (planner-appt-defadvice planner-copy-or-move-task
1089 (around planner-appt-task
)
1090 "Update the appointment as well."
1091 (planner-appt-debug-message
1092 "*** called advice on planner-copy-or-move-task; "
1093 (if --planner-appt-planning
1096 (cond ((not --planner-appt-planning
)
1098 ;; Save the appt information for error cleanup and
1099 ;; appointment adding.
1100 ((deleted-appts (planner-appt-task-delete))
1101 (old-info (planner-current-task-info)))
1104 (with-planner-appt-task-advice-disabled ad-do-it
)
1105 ;; If the task was moved to today, add it.
1106 (when (and date
; Bound in the advised function.
1107 (string= date
(planner-today)))
1108 ;; Fiddle the old info so it looks like
1109 ;; today's. NB: would need changing should
1110 ;; the task-info format ever change.
1112 ;; planner-multi uses the date in the link for
1113 ;; planner-task-date [why?], so that has to be
1114 ;; modified too. This has to be done before the
1115 ;; date element is changed, of course.
1116 (when (and (featurep 'planner-multi
)
1117 (consp (nth 5 old-info
))) ; the link element
1119 (member (nth 8 old-info
)
1121 ;; Silly way of avoiding an error if the
1122 ;; date is not in the list: can the date
1123 ;; not be in the list?
1126 ;; Set the date element.
1127 (setcar (nthcdr 8 old-info
) date
)
1128 (planner-appt-task-add old-info
)))
1130 ;; Catch errors in planner-copy-or-move-task: restore
1132 (dolist (d deleted-appts
)
1133 (push d appt-time-msg-list
))
1134 (error (error-message-string err
))))))
1136 ;; `plan' in progress: only move the task if it is not a
1137 ;; regular (non-nagging) appointment. If it's a nagging
1138 ;; appointment, remove the appointment and then move the
1140 (let* ((info (planner-current-task-info))
1141 (appt (planner-appt-task-parse-task
1142 (planner-task-description info
)))
1143 (time (nth 1 appt
)))
1144 (with-planner-appt-task-advice-disabled
1145 (if (planner-appt-task-nagging-p (planner-task-description info
))
1146 (progn (planner-edit-task-description (nth 0 appt
))
1149 ;; Fri Nov 25 13:59:02 GMT 2005: Fix for new [?]
1150 ;; behaviour of planner-copy-or-move-region.
1153 ;; Return nil, otherwise
1154 ;; planner-copy-or-move-region's count will be
1156 (setq ad-return-value nil
))
1159 ;; NB: this advice leads to two updates of the task appointment
1160 ;; section [when updating it is enabled, of course]: it is hard to see
1161 ;; how to avoid this unless there is yet another global variable
1162 ;; tracking deleted appts.
1163 (planner-appt-defadvice planner-edit-task-description
1164 (around planner-appt-task
)
1165 "Update the appointment as well."
1166 (planner-appt-debug-message
1167 "*** called advice on planner-edit-task-description")
1168 (planner-appt-task-delete)
1169 (with-planner-appt-task-advice-disabled ad-do-it
)
1170 (planner-appt-task-add))
1172 ;; planner-create-task-from-info: The appointment adding needs doing
1173 ;; after all hooks to planner-create-task-from-info have been run so
1174 ;; that planner-appt-task-add has the correct task line; planner-id,
1175 ;; for example, adds a task id so if the planner-appt hook is run
1176 ;; first it won't have the right task description.
1178 ;; Hence these shenanigans:
1180 (defvar --planner-appt-created-task-marker
(make-marker))
1181 (defvar --planner-appt-close-the-buffer-flag nil
)
1184 ;; Hide warning about live-buffers [q.v.].
1185 (defvar live-buffers
))
1187 (defun planner-appt-create-task-hook-func ()
1188 "One half of planner-appt create task handling.
1189 Remembers the position of the added task. The other half of the
1190 handling is in advice to `planner-create-task-from-info'."
1191 (set-marker --planner-appt-created-task-marker
(point))
1192 ;; If planner-tasks-file-behavior is 'close, it won't be possible to
1193 ;; recover the position from a marker, so temporarily defeat closing
1194 ;; this file, and close it if necessary in the
1195 ;; planner-create-task-from-info advice.
1196 (setq --planner-appt-close-the-buffer-flag
1197 (if (and (eq planner-tasks-file-behavior
'close
)
1198 ;; `live-buffers' is defined in
1199 ;; planner-create-task-from-info, but it is not
1200 ;; defined in the planner-multi advice [hmm...].
1201 (boundp 'live-buffers
)
1202 (not (memq (current-buffer) live-buffers
)))
1203 ;; Adding the buffer to `live-buffers' means it won't be
1204 ;; closed automatically.
1205 (progn (push (current-buffer) live-buffers
) t
)
1209 (planner-appt-defadvice planner-create-task-from-info
1210 (around planner-appt-task
)
1211 "Add an appointment alert for the new task if necessary."
1212 (planner-appt-debug-message
1213 "*** called advice on planner-create-task-from-info")
1214 (with-planner-appt-task-advice-disabled ad-do-it
)
1215 (let ((buf (marker-buffer --planner-appt-created-task-marker
))
1216 (pos (marker-position --planner-appt-created-task-marker
)))
1218 (with-current-buffer buf
1221 (planner-appt-task-add)))
1222 (set-marker --planner-appt-created-task-marker nil
)
1223 (when --planner-appt-close-the-buffer-flag
1224 ;; Use planner-save-buffers for consistency; remove the buffer
1225 ;; from buffer-list so that it gets closed.
1226 (planner-save-buffers (delq buf
(buffer-list)))))))
1228 (defun planner-appt-task-insinuate ()
1229 "Do task-specific insinuation into `planner-mode'."
1230 ;; Nothing at the moment!
1233 ;; In case of breakage while developing
1234 ;; NB: remember to remove hooks locally where relevant
1235 (defun planner-appt-task-de-insinuate ()
1236 "Remove task-specific hooks."
1237 ;; Nothing at the moment!
1241 ;;; Alerts From The Schedule
1243 (defvar --planner-appt-schedule-added-appts
'()
1244 "Internal variable: Tracks added schedule-based appointment alerts.")
1246 (defun planner-appt-add-appts-from-schedule ()
1247 "Add appointment reminders from the schedule if this is today's plan."
1249 (when (planner-appt-todays-page-p)
1250 ;; Delete old appts created by this function.
1251 (planner-appt-clear-appts --planner-appt-schedule-added-appts
)
1252 (setq --planner-appt-schedule-added-appts
'())
1254 (planner-seek-to-first planner-appt-schedule-section
)
1255 (let ((bound (save-excursion
1256 (planner-appt-seek-to-end-of-current-section)))
1257 line time text task-item-p
)
1258 ;; There are no entries in the schedule unless bound is
1259 ;; greater than point.
1260 (when (> bound
(point))
1261 (while (re-search-forward
1262 planner-appt-schedule-appt-regexp bound t
)
1263 (setq line
(planner-match-string-no-properties 0)
1264 time
(planner-match-string-no-properties 1)
1265 text
(planner-appt-format-description
1266 (planner-match-string-no-properties 3))
1268 (planner-appt-task-schedule-item-p (match-string 0)))
1269 ;; (text-property-any (match-beginning 0) (match-end 0)
1271 (unless (or task-item-p
1272 (planner-appt-earlier-than-now-p time
))
1273 (appt-add time text
)
1274 ;; Remember tasks added here.
1275 (setq --planner-appt-schedule-added-appts
1276 (planner-appt-remember-appt
1277 time text --planner-appt-schedule-added-appts
)))))))))
1279 (defun planner-appt-schedule-insinuate ()
1280 "Do schedule specific insinuation into `planner-mode'."
1281 ;; Nothing at the moment!
1284 (defun planner-appt-schedule-de-insinuate ()
1285 "Remove schedule-based hooks."
1286 ;; Nothing at the moment!
1289 ;; Make appt-make-list behave.
1291 (defadvice appt-make-list
(after planner-appt activate
)
1292 "Restore appointments added by planner-appt."
1293 (dolist (appt (append --planner-appt-tasks-added-appts
1294 --planner-appt-schedule-added-appts
))
1295 (unless (member appt appt-time-msg-list
)
1296 (push appt appt-time-msg-list
)))
1297 (setq appt-time-msg-list
(appt-sort-list appt-time-msg-list
)))
1299 ;;; Sorting the Schedule
1301 (defun planner-appt-schedule-sort ()
1302 "Sort the schedule in the current page."
1306 (planner-seek-to-first planner-appt-schedule-section
)
1307 (narrow-to-region (point)
1309 (planner-appt-seek-to-end-of-current-section)
1311 (sort-subr nil
'forward-line
'end-of-line
1313 (goto-char (planner-line-beginning-position))
1314 (if (looking-at planner-appt-schedule-regexp
)
1317 ;; 1+ max number of minutes from midnight
1321 ;;; Cyclical Schedule Entries
1323 (require 'diary-lib
)
1326 (defvar planner-cyclic-diary-file
))
1328 ;; Purloined from planner-cyclic.el.
1329 (defun planner-appt-schedule-get-cyclic-tasks (date &optional no-of-days
)
1330 "For DATE, get the cyclic tasks.
1331 Optional argument get tasks for NO-OF-DAYS from DATE, the default is 1
1332 day [i.e., only for DATE]."
1333 (let ((date (if (stringp date
)
1334 (planner-filename-to-calendar-date date
)
1337 (mapcar #'(lambda (item)
1338 (when (string-match planner-appt-schedule-regexp
1340 (match-string 0 (elt item
1))))
1341 (planner-list-diary-entries planner-cyclic-diary-file
1342 date no-of-days
)))))
1344 (defun planner-appt-schedule-add-cyclic ()
1345 "Add cylical tasks to the schedule if the current buffer is a day page."
1346 (when (string-match planner-date-regexp
(planner-page-name))
1348 (planner-appt-schedule-get-cyclic-tasks (planner-page-name))))
1350 (planner-seek-to-first planner-appt-schedule-section
)
1351 (let ((start (point)))
1352 (dolist (entry entries
)
1353 ;; Only insert if the entry is not already there.
1354 (unless (save-excursion
1356 (search-forward entry nil t
))
1357 (insert entry ?
\n))))
1358 ;; Lazy way of putting them in the right place.
1359 (when planner-appt-sort-schedule-on-update-flag
1360 (planner-appt-schedule-sort))))))
1362 (defun planner-appt-schedule-add-cyclic-maybe ()
1363 "Add cylical tasks to the schedule.
1364 Behaviour depends upon `planner-appt-schedule-cyclic-behaviour'."
1365 (when (and (not (string< (planner-page-name) (planner-today)))
1366 (or (eq planner-appt-schedule-cyclic-behaviour
'future
)
1368 (eq planner-appt-schedule-cyclic-behaviour
'today
)
1369 (planner-appt-todays-page-p))))
1370 (planner-appt-schedule-add-cyclic)))
1372 (defun planner-appt-schedule-cyclic-insinuate ()
1373 "Insinuate the adding of cyclical schedule entries."
1374 ;; TODO: Add locally?
1375 (planner-appt-add-hook 'planner-mode-hook
1376 'planner-appt-schedule-add-cyclic-maybe nil t
))
1378 (defun planner-appt-schedule-cyclic-de-insinuate ()
1379 "Remove cyclic schedule adding functionality."
1380 (remove-hook 'planner-mode-hook
1381 'planner-appt-schedule-add-cyclic-maybe
))
1384 ;;; Common Functions
1387 ;; So that one doesn't have to use two separate commands when using
1390 (defvar --planner-appt-updated nil
)
1393 (defun planner-appt-update ()
1394 "Update the appointments on the current page."
1396 ;; NB: Task adding has to be done before the schedule to avoid
1397 ;; duplicates if task appointments are copied to the schedule.
1398 (when (memq 'tasks planner-appt-methods
)
1399 (planner-appt-add-appts-from-tasks))
1400 (when (memq 'schedule planner-appt-methods
)
1401 (planner-appt-add-appts-from-schedule))
1402 (when (and planner-appt-sort-schedule-on-update-flag
1403 (planner-appt-todays-page-p))
1404 (planner-appt-schedule-sort))
1405 (run-hooks 'planner-appt-update-hook
)
1406 ;; TODO: Use a belt and some braces: see comments in
1407 ;; `planner-appt-insinuate-if-today'.
1408 (setq --planner-appt-updated t
))
1410 (defun planner-appt-update-for-write ()
1411 (when planner-appt-update-appts-on-save-flag
1412 (planner-appt-update)
1413 ;; Return nil for local-write-file-hooks.
1416 ;; NB: Something like the above could be done for other hooks as
1420 ;;; General Insinuation
1422 ;; This indirect method is used rather than some variable so that the
1423 ;; function advice can be avoided if it is not necessary [when using
1424 ;; schedule appointments exclusively].
1427 (defun planner-appt-use (source)
1428 "Use SOURCE to derive appointments from plan pages.
1429 Possible values for SOURCE are:
1430 'tasks [use today's task descriptions]
1431 'schedule [use today's schedule]
1432 '(tasks schedule) [use both tasks and schedule]."
1433 (dolist (s (if (listp source
)
1436 (cond ((eq s
'tasks
)
1437 ;; Add task-specific non-insinuating code here.
1438 ;; ;; Only activate advice when necessary.
1439 ;; (ad-enable-regexp "planner-appt-task")
1440 ;; (ad-activate-regexp "planner-appt-task")
1441 ;; An outstanding global hook [planner-appt-task-add tests
1442 ;; for today-ness anyway].
1443 (planner-appt-add-hook 'planner-create-task-hook
1444 'planner-appt-create-task-hook-func nil t
)
1445 (add-to-list 'planner-appt-methods s
))
1447 ;; Add schedule task-specific non-insinuating code here.
1448 (add-to-list 'planner-appt-methods s
))
1450 (error "Invalid appointment source %s" s
))))
1451 ;; Add here any non method-specific code that should be executed
1452 ;; even if planner-appt-insinuate is not called.
1453 (if (memq 'tasks planner-appt-methods
)
1454 (planner-appt-enable-all-advice)
1455 (planner-appt-disable-all-advice))
1456 (planner-appt-add-hook 'planner-mode-hook
1457 'planner-appt-font-setup nil t
)
1458 ;; Might as well return something interesting.
1459 planner-appt-methods
)
1462 (defun planner-appt-insinuate-if-today ()
1463 (when (planner-appt-todays-page-p)
1464 (planner-appt-add-hook 'planner-mode-hook
1465 'planner-appt-update t
)
1466 ;; Add method specific things
1467 (when (memq 'tasks planner-appt-methods
)
1468 (planner-appt-task-insinuate))
1469 (when (memq 'schedule planner-appt-methods
)
1470 (planner-appt-schedule-insinuate))
1471 (planner-appt-add-hook planner-appt-write-file-hook
1472 'planner-appt-update-for-write t
)
1473 ;; TODO: Under some conditions, as yet undetermined, an update is
1474 ;; not done when `plan' is called for the first time. So do an
1475 ;; update, but only if there hasn't been one already.
1477 ;; Fri 15 Apr 2005 16:26:04 BST: this has probably been sorted out
1478 ;; now, but it doesn't do any harm to leave this in for now, just
1480 (unless --planner-appt-updated
1481 (planner-appt-update))))
1484 (defun planner-appt-insinuate ()
1485 "Insinuate appointment alerting into planner mode.
1486 Appointment methods should be set up first using one of:
1487 `planner-appt-use-tasks'
1488 `planner-appt-use-schedule'
1489 `planner-appt-use-tasks-and-schedule'."
1490 (unless planner-appt-methods
1492 "No appointment source methods. Use one of:
1493 `planner-appt-use-tasks'
1494 `planner-appt-use-schedule'
1495 `planner-appt-use-tasks-and-schedule'
1496 before you call this function"))
1497 ;; Initialize the appt system according to emacs type and version.
1498 (cond ((fboundp 'appt-activate
) ; Gnu Emacs >= 22
1500 ((fboundp 'appt-initialize
) ; Xemacs
1501 ;; appt-initialize needs a diary file, so create one if it
1502 ;; doesn't already exist
1503 (unless (file-exists-p diary-file
)
1506 (write-region (point-min) (point-max) diary-file
)))
1509 (t (display-time) ; Gnu Emacs < 22
1510 (add-hook 'diary-hook
'appt-make-list
)))
1511 (planner-appt-add-hook 'planner-mode-hook
1512 'planner-appt-insinuate-if-today t t
))
1514 ;; Remove hooks if there is something not working during testing.
1515 (defun planner-appt-de-insinuate ()
1516 "Remove all hooks associated with planner-appt.
1517 Use in an emergency if breakage in planner-appt interferes with your planning."
1519 (remove-hook 'planner-mode-hook
'planner-appt-insinuate-if-today
)
1520 (remove-hook 'mark-diary-entries-hook
'planner-appt-mark-calendar-maybe
)
1521 (when (get-buffer (planner-today))
1522 (with-current-buffer (get-buffer (planner-today))
1523 ;; NB: Remember to remove locally where appropriate.
1524 (remove-hook 'planner-goto-hook
1525 'planner-appt-update t
)
1526 (remove-hook 'planner-mode-hook
1527 'planner-appt-update t
)
1528 (remove-hook planner-appt-write-file-hook
1529 'planner-appt-update-for-write t
)
1530 (remove-hook 'planner-create-task-hook
1531 'planner-appt-create-task-hook-func
)
1532 (planner-appt-task-de-insinuate)
1533 (planner-appt-schedule-de-insinuate)
1534 (planner-appt-schedule-cyclic-de-insinuate)))
1535 (planner-appt-disable-all-advice)
1536 (message "Planner-appt de-insinuated."))
1539 ;;; Convenient Functions For Users' Configuration.
1542 (defun planner-appt-use-tasks ()
1543 "Use tasks to derive appointment alerts."
1544 (planner-appt-use 'tasks
))
1547 (defun planner-appt-use-schedule ()
1548 "Use the schedule to derive appointment alerts."
1549 (planner-appt-use 'schedule
))
1552 (defun planner-appt-use-tasks-and-schedule ()
1553 "Use both tasks and the schedule to derive appointment alerts."
1554 (planner-appt-use '(tasks schedule
)))
1556 ;;; Font Highlighting
1558 (defface planner-appt-face
'((t (:foreground
"green")))
1559 "Face for scheduled time."
1560 :group
'planner-appt
)
1562 (defface planner-appt-overdue-face
'((t (:foreground
"red")))
1563 "Face for scheduled, but overdue time."
1564 :group
'planner-appt
)
1566 (defun planner-appt-task-highlight-face (time)
1567 "Return appropriate face, depending on TIME.
1568 If TIME is earlier than now, return `planner-appt-face', else
1569 return `planner-appt-overdue-face'."
1570 (if (planner-appt-earlier-than-now-p time
)
1571 'planner-appt-overdue-face
1572 'planner-appt-face
))
1574 (defun planner-appt-task-highlight (beg end
&optional verbose
)
1575 "Highlight appointment times in tasks from BEG to END.
1576 VERBOSE is ignored."
1577 (when planner-appt-font-lock-appointments-flag
1579 (while (re-search-forward planner-appt-task-regexp end t
)
1580 (when (or (not planner-appt-limit-highlighting-flag
)
1582 (goto-char (planner-line-beginning-position))
1584 (or (and (looking-at planner-live-task-regexp
)
1585 (string= (planner-task-date
1586 (planner-current-task-info))
1589 (planner-appt-todays-page-p)
1590 (looking-at planner-appt-schedule-appt-regexp
))))))
1591 (planner-highlight-region
1596 (planner-appt-task-highlight-face
1597 (match-string 1))))))))
1599 (defun planner-appt-font-setup ()
1600 "Hook into `planner-mode'."
1601 (planner-appt-add-hook 'muse-colors-buffer-hook
1602 'planner-appt-task-highlight t
))
1604 ;;; Calendar Marking
1606 ;; This is not strictly part of appointment handling, but if the
1607 ;; diary is to be by-passed for appointments, it makes sense to mark
1608 ;; the calendar using day pages.
1612 ;; Use a different face from the diary-entry-marker so we can
1613 ;; see where the different marks come from.
1614 (defface planner-appt-entry-marker
1615 '((t (:foreground
"indianred")))
1616 "Face for planner day page mark in the calendar."
1617 :group
'planner-appt
)
1620 (defun planner-appt-mark-calendar (&optional from to
)
1621 "Mark dates in the calendar that have day pages.
1622 Optional args: mark dates from FROM to TO.
1623 FROM and to are lists: (month day year)."
1624 (with-current-buffer calendar-buffer
; Needed to get displayed date
1626 (let* ((displayed-month-last
1627 (1+ (cdr (assq 'displayed-month
1628 (buffer-local-variables)))))
1630 (cdr (assq 'displayed-year
1631 (buffer-local-variables))))
1632 (today-filename (planner-today))
1633 (today (planner-filename-to-calendar-date today-filename
)))
1634 ;; Do nothing if the calendar is currently showing all months
1635 ;; earlier than today.
1636 (when (and (>= (elt today
2) ; year
1638 (>= displayed-month-last
1639 (elt today
0))) ; month
1640 (let ((diary-entry-marker 'planner-appt-entry-marker
)
1642 (planner-get-day-pages
1644 (planner-date-to-filename from
)
1647 (planner-date-to-filename to
)
1648 ;; The default is last day visible
1650 (planner-date-to-filename
1651 (list displayed-month-last
31 displayed-year
))))))
1652 (dolist (day-page day-pages
)
1653 (apply #'mark-calendar-date-pattern
1654 (planner-filename-to-calendar-date (car day-page
)))))))))
1656 (defun planner-appt-calendar-insinuate ()
1657 (add-hook 'mark-diary-entries-hook
'planner-appt-mark-calendar
))
1659 (provide 'planner-appt
)
1660 ;;; planner-appt.el ends here
1663 ;; indent-tabs-mode: t