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
)))
392 (defun planner-appt-task-schedule-item-p (string)
393 "Return t if STRING is a schedule item derived from a task."
394 ;; Look for any property in the string since STRING will usually be
395 ;; derived from a buffer substring which may have been edited.
396 (text-property-any 0 (length string
) 'appt-task t string
))
399 ;;; Showing Appointments In Various Ways
401 (defvar planner-appt-methods
'()
402 "Methods used for appointment alerts.
403 Internal variable: to set up appointment methods use one of:
404 `planner-appt-use-tasks'
405 `planner-appt-use-schedule'
406 `planner-appt-use-tasks-and-schedule'.")
408 ;; Copying task appts over to an "Appointments" section.
410 (defun planner-appt-format-appt-section-line (desc)
411 "Format DESC as a line for the appointments section."
412 (let* ((td (planner-appt-task-parse-task
413 ;; Trick the function into parsing:
417 (end-time (if (string-match
418 (format "\\s-*\\(%s\\)\\s-*"
419 planner-appt-time-regexp
)
422 (match-string 1 text
)
423 (setq text
(replace-match "" t t text
)))
425 ;; Format in the style of a tabular schedule.
426 (format "%6s | %5s | %s"
427 ;; Using an @ means the time gets fontified for free.
430 (if (string= planner-appt-task-appointments-section
431 planner-appt-schedule-section
)
432 ;; To avoid confusion, add an indication that this
433 ;; item came from a task.
437 (defun planner-appt-update-appt-section ()
439 (planner-seek-to-first planner-appt-task-appointments-section
)
440 (let ((bound (set-marker
443 (planner-appt-seek-to-end-of-current-section)
445 ;; Insert all task appointments, delete the old ones, then
447 (dolist (appt (append --planner-appt-tasks-added-appts
448 --planner-appt-tasks-earlier-appts
))
450 (insert (funcall planner-appt-format-appt-section-line-function
452 (add-text-properties beg
(point) '(appt-task t
))
454 (while (re-search-forward planner-appt-schedule-appt-regexp bound t
)
455 ;; Remove the line if it was previously added by this
457 (when (planner-appt-task-schedule-item-p (match-string 0))
458 ;; (text-property-any (match-beginning 0) (match-end 0)
461 (when (eq (char-after) ?
\n)
463 (set-marker bound nil
))
464 ;; Use schedule sorting with some changes
465 (let ((planner-appt-schedule-section
466 planner-appt-task-appointments-section
)
467 (planner-appt-schedule-regexp
468 (concat "\\(.*?\\)" ; to shift the match groups
469 planner-appt-schedule-basic-regexp
)))
470 (planner-appt-schedule-sort))))
472 (defun planner-appt-update-appt-section-maybe ()
474 ;; The appointment section is only relevant if the task
476 (memq 'tasks planner-appt-methods
)
477 planner-appt-task-use-appointments-section-flag
)
478 (with-planner-update-setup
481 (planner-appt-update-appt-section)))))
483 (defmacro with-planner-appt-update-section-disabled
(&rest body
)
484 `(let ((planner-appt-task-use-appointments-section-flag nil
))
487 (put 'with-planner-appt-update-section-disabled
'lisp-indent-function
0)
488 (put 'with-planner-appt-update-section-disabled
'edebug-form-spec
'(body))
490 ;; Display Current Appointments
491 (defun planner-appt-show-alerts ()
492 "Display a list of currently active alerts in another window."
494 (let ((buf (get-buffer-create planner-appt-alert-buffer
)))
495 (with-current-buffer buf
497 (insert "Current alerts\n==============")
498 (if appt-time-msg-list
499 (dolist (appt appt-time-msg-list
)
500 (insert "\n" (cadr appt
)))
502 (goto-char (point-min)))
503 (fit-window-to-buffer (display-buffer buf
))))
506 ;; Display/Insert Forthcoming Appointments
508 (defvar planner-appt-forthcoming-regexp
510 planner-appt-schedule-appt-regexp
512 planner-live-task-regexp
513 planner-appt-task-regexp
516 (defvar planner-appt-forthcoming-task-regexp
517 (concat planner-live-task-regexp
518 planner-appt-task-regexp
))
520 (defun planner-appt-forthcoming-format-appt-description (time description
)
522 planner-appt-format-appt-section-line-function
523 (planner-appt-format-time-and-description
525 (planner-appt-format-description description
))))
527 (defun planner-appt-forthcoming-task-data (info)
529 (planner-appt-task-parse-task
530 (planner-task-description info
))))
532 (cons (appt-convert-time (nth 1 task-appt
))
533 (planner-appt-forthcoming-format-appt-description
535 (nth 0 task-appt
))))))
537 (defun planner-appt-forthcoming-get-appts (n &optional include-today
)
538 (planner-save-buffers)
540 (pages (planner-get-day-pages
543 (planner-calculate-date-from-day-offset
545 (planner-calculate-date-from-day-offset
546 (planner-today) (if include-today n
(1+ n
)))))
547 cyclic-data cyclic-task-descriptions
548 line task-info task-data
549 date-absolute date time text
)
550 ;; After scanning pages and [conditionally] cyclic entries, each
551 ;; element of appts has:
554 ;; <time in appt format [minutes from midnight]>
555 ;; <date in planner format>
558 ;; The first two elements are used for sorting/merging; they are
559 ;; removed from the returned list.
560 (when (and (featurep 'planner-cyclic
)
561 planner-appt-forthcoming-look-at-cyclic-flag
)
562 ;; Returns (<appts> . <list of planner-cyclic-ly formatted tasks>)
563 (setq cyclic-data
(planner-appt-forthcoming-get-cyclic n
))
564 (setq appts
(car cyclic-data
)
565 cyclic-task-descriptions
(cdr cyclic-data
)))
569 (when (file-exists-p (cdr page
))
570 (setq date
(car page
))
571 (setq date-absolute
(calendar-absolute-from-gregorian
572 (planner-filename-to-calendar-date
574 (insert-file-contents (cdr page
))
575 (goto-char (point-min))
576 (while (re-search-forward planner-appt-forthcoming-regexp nil t
)
577 (setq line
(match-string 0))
578 (if (and (string-match planner-appt-schedule-appt-regexp line
)
579 (not (planner-appt-task-schedule-item-p line
)))
580 (setq time
(save-match-data
581 (appt-convert-time (match-string 1 line
)))
582 text
(match-string 0 line
))
583 (setq task-info
(planner-current-task-info))
584 (setq task-data
(planner-appt-forthcoming-task-data task-info
))
586 ;; Check for a cyclic task already added.
587 ;; This is a bit messy, since a task id
588 ;; won't have been added [and there might
589 ;; be other special case that I haven't
593 "\\s-+{{Tasks:[0-9]+}}\\s-*"
594 (planner-task-description task-info
))
597 (planner-task-description task-info
))
598 (planner-task-description task-info
))
599 cyclic-task-descriptions
)))
600 (setq time
(car task-data
)
601 text
(cdr task-data
))))
602 (when (and time text
)
603 ;; Add if it is not there already [there may be a
604 ;; duplicate if this is a schedule item derived from a
606 (add-to-list 'appts
(list date-absolute time date text
))
607 (setq time nil text nil
)))
613 (or (< (car a
) (car b
))
614 (and (= (car a
) (car b
))
615 (< (cadr a
) (cadr b
))))))))))
618 (defun planner-appt-forthcoming-get-cyclic (n)
620 (cyclic-task-descriptions '())
621 date line time text task-info task-data
)
622 (dolist (entry (planner-list-diary-entries
623 planner-cyclic-diary-file
624 (planner-filename-to-calendar-date
625 (planner-calculate-date-from-day-offset
628 (setq date
(planner-date-to-filename (car entry
))
630 (if (string-match planner-appt-schedule-appt-regexp line
)
631 (setq time
(save-match-data
632 (appt-convert-time (match-string 1 line
)))
633 text
(match-string 0 line
))
634 (when (string-match planner-appt-forthcoming-task-regexp line
)
635 (setq task-info
(planner-task-info-from-string date line
))
636 (setq task-data
(planner-appt-forthcoming-task-data task-info
))
638 ;; For duplicate checking: remember the description as
639 ;; it would be transformed by planner-cyclic.
640 (push (format planner-cyclic-task-description-format
641 (planner-task-description task-info
) date
)
642 cyclic-task-descriptions
)
643 (setq time
(car task-data
)
644 text
(cdr task-data
)))))
645 (when (and time text
)
648 (list (calendar-absolute-from-gregorian (car entry
))
650 (setq time nil text nil
)))
651 (cons appts cyclic-task-descriptions
)))
653 ;; Format the data into a big string to make it easy either to put
654 ;; into a display buffer or into the day page.
655 (defun planner-appt-forthcoming-format (appt-data)
657 (empty-cell-p (string-match
658 (format "\\`[%s]+\\'" muse-regexp-blank
)
659 planner-appt-forthcoming-repeat-date-string
)))
660 (mapconcat #'(lambda (a)
663 (if (string= (car a
) last-date
)
665 planner-appt-forthcoming-repeat-date-string
668 planner-appt-forthcoming-repeat-date-string
))
669 (planner-make-link (car a
)))
671 ;; Remove @s from times to avoid spurious
673 (muse-replace-regexp-in-string
677 (setq last-date
(car a
))))
681 (defvar planner-appt-forthcoming-display-buffer
682 "*Forthcoming Appointments*"
683 "Buffer to display forthcoming appointments.")
685 (defun planner-appt-forthcoming-display (&optional days
)
687 ;; TODO: I wanted to use (interactive "p"), but that defaults to
688 ;; 1. Is this really the best way of getting nil as the default
689 ;; for a command that takes an optional integer prefix?:
690 (list (cond ((consp current-prefix-arg
)
691 (car current-prefix-arg
))
692 ((integerp current-prefix-arg
)
695 (unless days
(setq days planner-appt-forthcoming-days
))
697 (get-buffer-create planner-appt-forthcoming-display-buffer
)
698 (unless (planner-derived-mode-p 'planner-mode
)
699 (setq muse-current-project
(muse-project planner-project
))
701 (cd (planner-directory)))
702 (delete-region (point-min) (point-max))
703 (insert "* Appointments in the next "
704 (number-to-string days
)
705 (if (= days
1) " day" " days")
707 (planner-appt-forthcoming-format
708 (planner-appt-forthcoming-get-appts
709 (or days planner-appt-forthcoming-days
) t
)))
710 (goto-char (point-min)))
711 (display-buffer planner-appt-forthcoming-display-buffer
)
712 (fit-window-to-buffer
713 (get-buffer-window planner-appt-forthcoming-display-buffer
)))
716 (defun planner-appt-forthcoming-update-section (&optional days
)
718 (list (cond ((consp current-prefix-arg
)
719 (car current-prefix-arg
))
720 ((integerp current-prefix-arg
)
723 (with-planner-update-setup
726 (planner-seek-to-first planner-appt-forthcoming-appt-section
)
727 (delete-region (point)
728 (planner-appt-seek-to-end-of-current-section))
729 (insert (planner-appt-forthcoming-format
730 (planner-appt-forthcoming-get-appts
731 (or days planner-appt-forthcoming-days
)))
735 ;; A function suitable for planner-mode-hook
736 (defun planner-appt-forthcoming-update-section-maybe ()
737 (when (planner-appt-todays-page-p)
738 (planner-appt-forthcoming-update-section)))
741 ;;; Alerts From Task Descriptions
743 ;; Add a bit of [premature] optimization, mainly for updating
744 ;; functions where the same task gets examined often.
745 (defvar --planner-appt-task-cache
(make-hash-table :test
'equal
))
747 (defun planner-appt-task-parse-task (description)
748 "Extract appointment time and text from the DESCRIPTION.
749 Return a list (text time). If the task is not an
750 appointment, time defaults to nil."
751 (or (gethash description --planner-appt-task-cache
)
754 (if (string-match planner-appt-task-regexp description
)
755 (list (substring description
(match-end 0))
756 (substring description
(match-beginning 1) (match-end 1)))
757 (list description nil
))
758 --planner-appt-task-cache
)))
760 (defun planner-appt-task-nagging-p (description)
761 "Return non-nil if task DESCRIPTION is a nagging appointment."
762 (string-match planner-appt-task-nagging-regexp description
))
764 (defun planner-appt-task-member (description time appt-list
)
765 "Return non-nil if DESCRIPTION at TIME in APPT-LIST has been scheduled."
766 (member (planner-appt-make-appt-element time description
) appt-list
))
769 ;; Integration with planner-schedule.el
771 (defvar planner-appt-schedule-task-estimate-regexp
772 (concat "[!@][ \t]*\\(?:" ; "shy" form of planner-appt-task-regexp
773 planner-appt-time-regexp
775 "\\s-*\\([0-9]+[smhdw]\\)")
776 "Regular expression matching a task time estimate.")
778 ;; NB: The following advice could be avoided if the regexp were not
779 ;; hard-coded into the original function.
781 ;; NNB: This is not well tested!
783 (defadvice planner-schedule-task-estimate
(around planner-appt-task disable
)
784 "Modify the regexp matched to take appointments into account."
785 (when (string-match planner-appt-schedule-task-estimate-regexp
786 (planner-task-description info
))
787 (schedule-duration-to-seconds
788 (match-string 2 (planner-task-description info
)))))
791 (defun planner-appt-task-add (&optional info
)
792 "Create an appointment from the current task if this is today's plan.
793 Return t if an appointment was added.
794 If the task is an appointment, it is not cancelled, it is scheduled for
795 later today, and is not already added.
796 Optional argument: use INFO instead of the current task info."
798 (let* ((info (or info
799 ;; Unfortunately, in emacs-lisp there are no
800 ;; defaults for optional arguments, so one can't
801 ;; distinguish between null info in an arg and null
802 ;; info from planner-current-task-info; so the
803 ;; error message might be uninformative here.
804 (planner-current-task-info)
805 (error "There is no task on the current line")))
806 (appt (planner-appt-task-parse-task
807 (planner-task-description info
)))
809 (desc (and time
(planner-appt-format-description (nth 0 appt
)))))
811 (not (string= (planner-task-status info
) "C"))
812 (string= (planner-task-date info
)
813 (planner-date-to-filename
814 (decode-time (current-time))))
815 (not (planner-appt-task-member desc time
816 appt-time-msg-list
)))
817 (if (planner-appt-earlier-than-now-p time
)
819 ;; Remember earlier appts separately [principally for
820 ;; their addition in an appointment section].
821 (unless (planner-appt-task-member
822 desc time --planner-appt-tasks-earlier-appts
)
823 (setq --planner-appt-tasks-earlier-appts
824 (planner-appt-remember-appt
826 --planner-appt-tasks-earlier-appts
)))
827 (planner-appt-update-appt-section-maybe)
828 ;; Make sure nil is returned.
831 ;; Keep track of tasks added by this function.
832 (setq --planner-appt-tasks-added-appts
833 (planner-appt-remember-appt
835 --planner-appt-tasks-added-appts
))
836 (planner-appt-update-appt-section-maybe)
839 (defun planner-appt-task-delete (&optional info
)
840 "Delete the appointment from the current task if this is today's plan.
841 Do not remove the time string.
842 Return any deleted appointments.
843 Optional argument: use INFO instead of the current task info."
845 (let* ((info (or info
846 ;; See planner-appt-task-add for comments about
847 ;; the possibly uninformative error message.
848 (planner-current-task-info)
849 (error "There is no task on the current line")))
850 (appt (planner-appt-task-parse-task
851 (planner-task-description info
)))
853 (desc (and time
(planner-appt-format-description (nth 0 appt
))))
854 (tmp-msg-list appt-time-msg-list
))
856 ;; Method from appt-delete
857 (let ((deleted-appts '())
859 (car (planner-appt-task-member
860 desc time --planner-appt-tasks-earlier-appts
)))
862 ;; NB: Mustn't concat time onto description until earlier-appt
863 ;; has been determined [since planner-appt-task-member does
864 ;; the concat itself [this could be improved somehow]]
865 (setq desc
(concat time
" " desc
))
867 (setq element
(car tmp-msg-list
))
868 (when (string= (car (cdr element
)) desc
)
869 (push element deleted-appts
)
870 (setq appt-time-msg-list
(delq element appt-time-msg-list
))
871 (setq --planner-appt-tasks-added-appts
872 (planner-appt-forget-appt
873 element --planner-appt-tasks-added-appts
)))
874 (setq tmp-msg-list
(cdr tmp-msg-list
)))
875 (when (or deleted-appts earlier-appt
)
876 ;; Forget a deleted appt that was earlier than now.
878 (setq --planner-appt-tasks-earlier-appts
879 (planner-appt-forget-appt
880 earlier-appt --planner-appt-tasks-earlier-appts
)))
881 (planner-appt-update-appt-section-maybe))
884 (defun planner-appt-add-appts-from-tasks ()
885 "Parse all of today's tasks and add appointments automatically."
887 (when (planner-appt-todays-page-p)
888 ;; Clear old appts added by this function.
889 (planner-appt-clear-appts --planner-appt-tasks-added-appts
)
890 (setq --planner-appt-tasks-added-appts
'()
891 --planner-appt-tasks-earlier-appts
'())
892 (let ((case-fold-search nil
))
894 (goto-char (point-min))
895 (with-planner-appt-update-section-disabled
896 (while (re-search-forward
897 (concat planner-live-task-regexp
898 planner-appt-task-regexp
)
900 (planner-appt-task-add))))
901 (when (or --planner-appt-tasks-added-appts
902 --planner-appt-tasks-earlier-appts
)
903 (planner-appt-update-appt-section-maybe)))))
907 ;; for speedy enabling and disabling of advice:
909 (defvar --planner-appt-advice
'()
910 "Internal variable: List of advices added by `planner-appt-defadvice'.
911 Each element is a list of args for `ad-enable-advice' and
912 `ad-disable-advice'.")
915 (defvar planner-appt-advice-common-flags
916 '(preactivate disable
)
917 "Advice flags common to all planner-appt advice."))
919 (defmacro planner-appt-defadvice
(function args doc
&rest body
)
920 "Advise FUNCTION with ARGS, DOC and BODY.
921 Remembers the advice function and args in `--planner-appt-advice'."
924 (,@args
,@planner-appt-advice-common-flags
) ,doc
,@body
)
925 (let ((info '(,function
,(car args
) ,(cadr args
))))
926 (unless (member info --planner-appt-advice
)
927 (push info --planner-appt-advice
)))))
929 (put 'planner-appt-defadvice
932 (name name
&rest sexp
)
935 ("interactive" interactive
)]
938 (put 'planner-appt-defadvice
'lisp-indent-function
'defun
)
940 ;; See what happened with the preactivation.
944 (trace-function-background
945 'ad-cache-id-verification-code
946 "*planner-appt advice trace*")))
948 (defun planner-appt-disable-all-advice ()
949 "Disable all advice added with `planner-appt-defadvice'."
950 (mapcar #'(lambda (args)
951 (apply #'ad-disable-advice args
)
952 (ad-activate (car args
)))
953 --planner-appt-advice
))
955 (defun planner-appt-enable-all-advice ()
956 "Enable all advice added with `planner-appt-defadvice'."
957 (mapcar #'(lambda (args)
958 (apply #'ad-enable-advice args
)
959 (ad-activate (car args
)))
960 --planner-appt-advice
))
963 (defmacro with-planner-appt-task-advice-disabled
(&rest body
)
964 "Evaluate BODY forms with all advice matching \"planner-appt-task\" disabled."
967 (planner-appt-disable-all-advice)
968 (planner-appt-debug-message "all advice disabled")
970 (planner-appt-enable-all-advice)
971 (planner-appt-debug-message "all advice enabled")))
973 (put 'with-planner-appt-task-advice-disabled
'lisp-indent-function
0)
974 (put 'with-planner-appt-task-advice-disabled
'edebug-form-spec
'(body))
976 (planner-appt-defadvice planner-task-cancelled
977 (before planner-appt-task
)
978 "Delete the appointment as well."
979 (planner-appt-debug-message
980 "*** called advice on planner-task-cancelled")
981 (planner-appt-task-delete))
983 (planner-appt-defadvice planner-task-done
984 (before planner-appt-task
)
985 "Delete the appointment as well."
986 (planner-appt-debug-message
987 "*** called advice on planner-task-done")
988 (planner-appt-task-delete))
990 (planner-appt-defadvice planner-delete-task
991 (before planner-appt-task
)
992 "Delete the appointment as well."
993 (planner-appt-debug-message
994 "*** called advice on planner-delete-task")
995 (planner-appt-task-delete))
997 ;; The advice for planner-update-task is quite tricky. A task will
998 ;; need updating [for appointments] if the task is dated today and the
999 ;; description differs from other task lines linked to by the current
1000 ;; task. If this is true, we have to examine all the other links,
1001 ;; delete any appointments, and then add the task after planner-update
1002 ;; has been called. Note that it is only possible for this to happen
1003 ;; if planner-id is loaded since otherwise the "same" task line can't
1004 ;; have different descriptions.
1006 (defun planner-appt-get-diff-links (info)
1007 "Given INFO, return a list of tasks linked to it whose info differs."
1010 ;; Todo: with-planner-update-setup really ought to return the
1011 ;; value of the body.
1012 (with-planner-update-setup
1013 ;; Preserve point as well.
1016 (if (featurep 'planner-multi
)
1017 (planner-multi-link-delete
1018 (planner-task-page info
)
1019 (planner-multi-task-link-as-list info
))
1020 (list (planner-task-link info
))))
1021 (when (and (planner-find-file (planner-link-base link
))
1022 (planner-find-task info
)
1023 (setq linked-info
(planner-current-task-info))
1024 (not (planner-tasks-equal-p info linked-info
)))
1025 (push linked-info diffs
)))))
1028 (planner-appt-defadvice planner-update-task
1029 (around planner-appt-task
)
1030 "Update the appointment as well."
1031 (planner-appt-debug-message
1032 "*** called advice on planner-update-task")
1033 (let* ((info (planner-current-task-info))
1035 (and (featurep 'planner-id
)
1036 (string= (planner-task-date info
) (planner-today))
1037 (planner-appt-get-diff-links info
))))
1038 (with-planner-appt-task-advice-disabled ad-do-it
)
1040 (dolist (i diff-linked
)
1041 (planner-appt-task-delete i
))
1042 (planner-appt-task-add))))
1044 ;; For planner-id-update-tasks-on-page, it is actually much faster to
1045 ;; update today's page after it has done its work rather than using
1046 ;; the update advice above.
1048 (planner-appt-defadvice planner-id-update-tasks-on-page
1049 (around planner-appt-task
)
1050 "Update today's appointments as well."
1051 (planner-appt-debug-message
1052 "*** called advice on planner-id-update-tasks-on-page")
1053 (with-planner-appt-task-advice-disabled ad-do-it
)
1054 (with-planner-update-setup
1056 (planner-goto-today)
1057 ;; Update the appointments section afterwards for efficiency.
1058 (with-planner-appt-update-section-disabled
1059 (planner-appt-update))
1060 (planner-appt-update-appt-section-maybe))))
1062 (defvar --planner-appt-planning nil
1064 Lets planner-appt advice know that it has been called within a call to
1067 (planner-appt-defadvice plan
(around planner-appt-task
)
1068 "Note that plan is in progress."
1069 (planner-appt-debug-message
1070 "*** called advice on plan")
1071 (let ((--planner-appt-planning t
))
1074 (planner-appt-defadvice planner-copy-or-move-task
1075 (around planner-appt-task
)
1076 "Update the appointment as well."
1077 (planner-appt-debug-message
1078 "*** called advice on planner-copy-or-move-task; "
1079 (if --planner-appt-planning
1082 (cond ((not --planner-appt-planning
)
1084 ;; Save the appt information for error cleanup and
1085 ;; appointment adding.
1086 ((deleted-appts (planner-appt-task-delete))
1087 (old-info (planner-current-task-info)))
1090 (with-planner-appt-task-advice-disabled ad-do-it
)
1091 ;; If the task was moved to today, add it.
1092 (when (and date
; Bound in the advised function.
1093 (string= date
(planner-today)))
1094 ;; Fiddle the old info so it looks like
1095 ;; today's. NB: would need changing should
1096 ;; the task-info format ever change.
1098 ;; planner-multi uses the date in the link for
1099 ;; planner-task-date [why?], so that has to be
1100 ;; modified too. This has to be done before the
1101 ;; date element is changed, of course.
1102 (when (and (featurep 'planner-multi
)
1103 (consp (nth 5 old-info
))) ; the link element
1105 (member (nth 8 old-info
)
1107 ;; Silly way of avoiding an error if the
1108 ;; date is not in the list: can the date
1109 ;; not be in the list?
1112 ;; Set the date element.
1113 (setcar (nthcdr 8 old-info
) date
)
1114 (planner-appt-task-add old-info
)))
1116 ;; Catch errors in planner-copy-or-move-task: restore
1118 (dolist (d deleted-appts
)
1119 (push d appt-time-msg-list
))
1120 (error (error-message-string err
))))))
1122 ;; `plan' in progress: only move the task if it is not a
1123 ;; regular (non-nagging) appointment. If it's a nagging
1124 ;; appointment, remove the appointment and then move the
1126 (let* ((info (planner-current-task-info))
1127 (appt (planner-appt-task-parse-task
1128 (planner-task-description info
)))
1129 (time (nth 1 appt
)))
1130 (with-planner-appt-task-advice-disabled
1131 (if (planner-appt-task-nagging-p (planner-task-description info
))
1132 (progn (planner-edit-task-description (nth 0 appt
))
1135 ;; Fri Nov 25 13:59:02 GMT 2005: Fix for new [?]
1136 ;; behaviour of planner-copy-or-move-region.
1139 ;; Return nil, otherwise
1140 ;; planner-copy-or-move-region's count will be
1142 (setq ad-return-value nil
))
1145 ;; NB: this advice leads to two updates of the task appointment
1146 ;; section [when updating it is enabled, of course]: it is hard to see
1147 ;; how to avoid this unless there is yet another global variable
1148 ;; tracking deleted appts.
1149 (planner-appt-defadvice planner-edit-task-description
1150 (around planner-appt-task
)
1151 "Update the appointment as well."
1152 (planner-appt-debug-message
1153 "*** called advice on planner-edit-task-description")
1154 (planner-appt-task-delete)
1155 (with-planner-appt-task-advice-disabled ad-do-it
)
1156 (planner-appt-task-add))
1158 ;; planner-create-task-from-info: The appointment adding needs doing
1159 ;; after all hooks to planner-create-task-from-info have been run so
1160 ;; that planner-appt-task-add has the correct task line; planner-id,
1161 ;; for example, adds a task id so if the planner-appt hook is run
1162 ;; first it won't have the right task description.
1164 ;; Hence these shenanigans:
1166 (defvar --planner-appt-created-task-marker
(make-marker))
1167 (defvar --planner-appt-close-the-buffer-flag nil
)
1170 ;; Hide warning about live-buffers [q.v.].
1171 (defvar live-buffers
))
1173 (defun planner-appt-create-task-hook-func ()
1174 "One half of planner-appt create task handling.
1175 Remembers the position of the added task. The other half of the
1176 handling is in advice to `planner-create-task-from-info'."
1177 (set-marker --planner-appt-created-task-marker
(point))
1178 ;; If planner-tasks-file-behavior is 'close, it won't be possible to
1179 ;; recover the position from a marker, so temporarily defeat closing
1180 ;; this file, and close it if necessary in the
1181 ;; planner-create-task-from-info advice.
1182 (setq --planner-appt-close-the-buffer-flag
1183 (if (and (eq planner-tasks-file-behavior
'close
)
1184 ;; `live-buffers' is defined in
1185 ;; planner-create-task-from-info, but it is not
1186 ;; defined in the planner-multi advice [hmm...].
1187 (boundp 'live-buffers
)
1188 (not (memq (current-buffer) live-buffers
)))
1189 ;; Adding the buffer to `live-buffers' means it won't be
1190 ;; closed automatically.
1191 (progn (push (current-buffer) live-buffers
) t
)
1195 (planner-appt-defadvice planner-create-task-from-info
1196 (around planner-appt-task
)
1197 "Add an appointment alert for the new task if necessary."
1198 (planner-appt-debug-message
1199 "*** called advice on planner-create-task-from-info")
1200 (with-planner-appt-task-advice-disabled ad-do-it
)
1201 (let ((buf (marker-buffer --planner-appt-created-task-marker
))
1202 (pos (marker-position --planner-appt-created-task-marker
)))
1204 (with-current-buffer buf
1207 (planner-appt-task-add)))
1208 (set-marker --planner-appt-created-task-marker nil
)
1209 (when --planner-appt-close-the-buffer-flag
1210 ;; Use planner-save-buffers for consistency; remove the buffer
1211 ;; from buffer-list so that it gets closed.
1212 (planner-save-buffers (delq buf
(buffer-list)))))))
1214 (defun planner-appt-task-insinuate ()
1215 "Do task-specific insinuation into `planner-mode'."
1216 ;; Nothing at the moment!
1219 ;; In case of breakage while developing
1220 ;; NB: remember to remove hooks locally where relevant
1221 (defun planner-appt-task-de-insinuate ()
1222 "Remove task-specific hooks."
1223 ;; Nothing at the moment!
1227 ;;; Alerts From The Schedule
1229 (defvar --planner-appt-schedule-added-appts
'()
1230 "Internal variable: Tracks added schedule-based appointment alerts.")
1232 (defun planner-appt-add-appts-from-schedule ()
1233 "Add appointment reminders from the schedule if this is today's plan."
1235 (when (planner-appt-todays-page-p)
1236 ;; Delete old appts created by this function.
1237 (planner-appt-clear-appts --planner-appt-schedule-added-appts
)
1238 (setq --planner-appt-schedule-added-appts
'())
1240 (planner-seek-to-first planner-appt-schedule-section
)
1241 (let ((bound (save-excursion
1242 (planner-appt-seek-to-end-of-current-section)))
1243 line time text task-item-p
)
1244 ;; There are no entries in the schedule unless bound is
1245 ;; greater than point.
1246 (when (> bound
(point))
1247 (while (re-search-forward
1248 planner-appt-schedule-appt-regexp bound t
)
1249 (setq line
(planner-match-string-no-properties 0)
1250 time
(planner-match-string-no-properties 1)
1251 text
(planner-appt-format-description
1252 (planner-match-string-no-properties 3))
1254 (planner-appt-task-schedule-item-p (match-string 0)))
1255 ;; (text-property-any (match-beginning 0) (match-end 0)
1257 (unless (or task-item-p
1258 (planner-appt-earlier-than-now-p time
))
1259 (appt-add time text
)
1260 ;; Remember tasks added here.
1261 (setq --planner-appt-schedule-added-appts
1262 (planner-appt-remember-appt
1263 time text --planner-appt-schedule-added-appts
)))))))))
1265 (defun planner-appt-schedule-insinuate ()
1266 "Do schedule specific insinuation into `planner-mode'."
1267 ;; Nothing at the moment!
1270 (defun planner-appt-schedule-de-insinuate ()
1271 "Remove schedule-based hooks."
1272 ;; Nothing at the moment!
1275 ;; Make appt-make-list behave.
1277 (defadvice appt-make-list
(after planner-appt activate
)
1278 "Restore appointments added by planner-appt."
1279 (dolist (appt (append --planner-appt-tasks-added-appts
1280 --planner-appt-schedule-added-appts
))
1281 (unless (member appt appt-time-msg-list
)
1282 (push appt appt-time-msg-list
)))
1283 (setq appt-time-msg-list
(appt-sort-list appt-time-msg-list
)))
1285 ;;; Sorting the Schedule
1287 (defun planner-appt-schedule-sort ()
1288 "Sort the schedule in the current page."
1292 (planner-seek-to-first planner-appt-schedule-section
)
1293 (narrow-to-region (point)
1295 (planner-appt-seek-to-end-of-current-section)
1297 (sort-subr nil
'forward-line
'end-of-line
1299 (goto-char (planner-line-beginning-position))
1300 (if (looking-at planner-appt-schedule-regexp
)
1303 ;; 1+ max number of minutes from midnight
1307 ;;; Cyclical Schedule Entries
1309 (require 'diary-lib
)
1312 (defvar planner-cyclic-diary-file
))
1314 ;; Purloined from planner-cyclic.el.
1315 (defun planner-appt-schedule-get-cyclic-tasks (date &optional no-of-days
)
1316 "For DATE, get the cyclic tasks.
1317 Optional argument get tasks for NO-OF-DAYS from DATE, the default is 1
1318 day [i.e., only for DATE]."
1319 (let ((date (if (stringp date
)
1320 (planner-filename-to-calendar-date date
)
1323 (mapcar #'(lambda (item)
1324 (when (string-match planner-appt-schedule-regexp
1326 (match-string 0 (elt item
1))))
1327 (planner-list-diary-entries planner-cyclic-diary-file
1328 date no-of-days
)))))
1330 (defun planner-appt-schedule-add-cyclic ()
1331 "Add cylical tasks to the schedule if the current buffer is a day page."
1332 (when (string-match planner-date-regexp
(planner-page-name))
1334 (planner-appt-schedule-get-cyclic-tasks (planner-page-name))))
1336 (planner-seek-to-first planner-appt-schedule-section
)
1337 (let ((start (point)))
1338 (dolist (entry entries
)
1339 ;; Only insert if the entry is not already there.
1340 (unless (save-excursion
1342 (search-forward entry nil t
))
1343 (insert entry ?
\n))))
1344 ;; Lazy way of putting them in the right place.
1345 (when planner-appt-sort-schedule-on-update-flag
1346 (planner-appt-schedule-sort))))))
1348 (defun planner-appt-schedule-add-cyclic-maybe ()
1349 "Add cylical tasks to the schedule.
1350 Behaviour depends upon `planner-appt-schedule-cyclic-behaviour'."
1351 (when (and (not (string< (planner-page-name) (planner-today)))
1352 (or (eq planner-appt-schedule-cyclic-behaviour
'future
)
1354 (eq planner-appt-schedule-cyclic-behaviour
'today
)
1355 (planner-appt-todays-page-p))))
1356 (planner-appt-schedule-add-cyclic)))
1358 (defun planner-appt-schedule-cyclic-insinuate ()
1359 "Insinuate the adding of cyclical schedule entries."
1360 ;; TODO: Add locally?
1361 (planner-appt-add-hook 'planner-mode-hook
1362 'planner-appt-schedule-add-cyclic-maybe nil t
))
1364 (defun planner-appt-schedule-cyclic-de-insinuate ()
1365 "Remove cyclic schedule adding functionality."
1366 (remove-hook 'planner-mode-hook
1367 'planner-appt-schedule-add-cyclic-maybe
))
1370 ;;; Common Functions
1373 ;; So that one doesn't have to use two separate commands when using
1376 (defvar --planner-appt-updated nil
)
1379 (defun planner-appt-update ()
1380 "Update the appointments on the current page."
1382 ;; NB: Task adding has to be done before the schedule to avoid
1383 ;; duplicates if task appointments are copied to the schedule.
1384 (when (memq 'tasks planner-appt-methods
)
1385 (planner-appt-add-appts-from-tasks))
1386 (when (memq 'schedule planner-appt-methods
)
1387 (planner-appt-add-appts-from-schedule))
1388 (when (and planner-appt-sort-schedule-on-update-flag
1389 (planner-appt-todays-page-p))
1390 (planner-appt-schedule-sort))
1391 (run-hooks 'planner-appt-update-hook
)
1392 ;; TODO: Use a belt and some braces: see comments in
1393 ;; `planner-appt-insinuate-if-today'.
1394 (setq --planner-appt-updated t
))
1396 (defun planner-appt-update-for-write ()
1397 (when planner-appt-update-appts-on-save-flag
1398 (planner-appt-update)
1399 ;; Return nil for local-write-file-hooks.
1402 ;; NB: Something like the above could be done for other hooks as
1406 ;;; General Insinuation
1408 ;; This indirect method is used rather than some variable so that the
1409 ;; function advice can be avoided if it is not necessary [when using
1410 ;; schedule appointments exclusively].
1413 (defun planner-appt-use (source)
1414 "Use SOURCE to derive appointments from plan pages.
1415 Possible values for SOURCE are:
1416 'tasks [use today's task descriptions]
1417 'schedule [use today's schedule]
1418 '(tasks schedule) [use both tasks and schedule]."
1419 (dolist (s (if (listp source
)
1422 (cond ((eq s
'tasks
)
1423 ;; Add task-specific non-insinuating code here.
1424 ;; ;; Only activate advice when necessary.
1425 ;; (ad-enable-regexp "planner-appt-task")
1426 ;; (ad-activate-regexp "planner-appt-task")
1427 ;; An outstanding global hook [planner-appt-task-add tests
1428 ;; for today-ness anyway].
1429 (planner-appt-add-hook 'planner-create-task-hook
1430 'planner-appt-create-task-hook-func nil t
)
1431 (add-to-list 'planner-appt-methods s
))
1433 ;; Add schedule task-specific non-insinuating code here.
1434 (add-to-list 'planner-appt-methods s
))
1436 (error "Invalid appointment source %s" s
))))
1437 ;; Add here any non method-specific code that should be executed
1438 ;; even if planner-appt-insinuate is not called.
1439 (if (memq 'tasks planner-appt-methods
)
1440 (planner-appt-enable-all-advice)
1441 (planner-appt-disable-all-advice))
1442 (planner-appt-add-hook 'planner-mode-hook
1443 'planner-appt-font-setup nil t
)
1444 ;; Might as well return something interesting.
1445 planner-appt-methods
)
1448 (defun planner-appt-insinuate-if-today ()
1449 (when (planner-appt-todays-page-p)
1450 (planner-appt-add-hook 'planner-mode-hook
1451 'planner-appt-update t
)
1452 ;; Add method specific things
1453 (when (memq 'tasks planner-appt-methods
)
1454 (planner-appt-task-insinuate))
1455 (when (memq 'schedule planner-appt-methods
)
1456 (planner-appt-schedule-insinuate))
1457 (planner-appt-add-hook planner-appt-write-file-hook
1458 'planner-appt-update-for-write t
)
1459 ;; TODO: Under some conditions, as yet undetermined, an update is
1460 ;; not done when `plan' is called for the first time. So do an
1461 ;; update, but only if there hasn't been one already.
1463 ;; Fri 15 Apr 2005 16:26:04 BST: this has probably been sorted out
1464 ;; now, but it doesn't do any harm to leave this in for now, just
1466 (unless --planner-appt-updated
1467 (planner-appt-update))))
1470 (defun planner-appt-insinuate ()
1471 "Insinuate appointment alerting into planner mode.
1472 Appointment methods should be set up first using one of:
1473 `planner-appt-use-tasks'
1474 `planner-appt-use-schedule'
1475 `planner-appt-use-tasks-and-schedule'."
1476 (unless planner-appt-methods
1478 "No appointment source methods. Use one of:
1479 `planner-appt-use-tasks'
1480 `planner-appt-use-schedule'
1481 `planner-appt-use-tasks-and-schedule'
1482 before you call this function"))
1483 ;; Initialize the appt system according to emacs type and version.
1484 (cond ((fboundp 'appt-activate
) ; Gnu Emacs >= 22
1486 ((fboundp 'appt-initialize
) ; Xemacs
1487 ;; appt-initialize needs a diary file, so create one if it
1488 ;; doesn't already exist
1489 (unless (file-exists-p diary-file
)
1492 (write-region (point-min) (point-max) diary-file
)))
1495 (t (display-time) ; Gnu Emacs < 22
1496 (add-hook 'diary-hook
'appt-make-list
)))
1497 (planner-appt-add-hook 'planner-mode-hook
1498 'planner-appt-insinuate-if-today t t
))
1500 ;; Remove hooks if there is something not working during testing.
1501 (defun planner-appt-de-insinuate ()
1502 "Remove all hooks associated with planner-appt.
1503 Use in an emergency if breakage in planner-appt interferes with your planning."
1505 (remove-hook 'planner-mode-hook
'planner-appt-insinuate-if-today
)
1506 (remove-hook 'mark-diary-entries-hook
'planner-appt-mark-calendar-maybe
)
1507 (when (get-buffer (planner-today))
1508 (with-current-buffer (get-buffer (planner-today))
1509 ;; NB: Remember to remove locally where appropriate.
1510 (remove-hook 'planner-goto-hook
1511 'planner-appt-update t
)
1512 (remove-hook 'planner-mode-hook
1513 'planner-appt-update t
)
1514 (remove-hook planner-appt-write-file-hook
1515 'planner-appt-update-for-write t
)
1516 (remove-hook 'planner-create-task-hook
1517 'planner-appt-create-task-hook-func
)
1518 (planner-appt-task-de-insinuate)
1519 (planner-appt-schedule-de-insinuate)
1520 (planner-appt-schedule-cyclic-de-insinuate)))
1521 (planner-appt-disable-all-advice)
1522 (message "Planner-appt de-insinuated."))
1525 ;;; Convenient Functions For Users' Configuration.
1528 (defun planner-appt-use-tasks ()
1529 "Use tasks to derive appointment alerts."
1530 (planner-appt-use 'tasks
))
1533 (defun planner-appt-use-schedule ()
1534 "Use the schedule to derive appointment alerts."
1535 (planner-appt-use 'schedule
))
1538 (defun planner-appt-use-tasks-and-schedule ()
1539 "Use both tasks and the schedule to derive appointment alerts."
1540 (planner-appt-use '(tasks schedule
)))
1542 ;;; Font Highlighting
1544 (defface planner-appt-face
'((t (:foreground
"green")))
1545 "Face for scheduled time."
1546 :group
'planner-appt
)
1548 (defface planner-appt-overdue-face
'((t (:foreground
"red")))
1549 "Face for scheduled, but overdue time."
1550 :group
'planner-appt
)
1552 (defun planner-appt-task-highlight-face (time)
1553 "Return appropriate face, depending on TIME.
1554 If TIME is earlier than now, return `planner-appt-face', else
1555 return `planner-appt-overdue-face'."
1556 (if (planner-appt-earlier-than-now-p time
)
1557 'planner-appt-overdue-face
1558 'planner-appt-face
))
1560 (defun planner-appt-task-highlight (beg end
&optional verbose
)
1561 "Highlight appointment times in tasks from BEG to END.
1562 VERBOSE is ignored."
1563 (when planner-appt-font-lock-appointments-flag
1565 (while (re-search-forward planner-appt-task-regexp end t
)
1566 (when (or (not planner-appt-limit-highlighting-flag
)
1568 (goto-char (planner-line-beginning-position))
1570 (or (and (looking-at planner-live-task-regexp
)
1571 (string= (planner-task-date
1572 (planner-current-task-info))
1575 (planner-appt-todays-page-p)
1576 (looking-at planner-appt-schedule-appt-regexp
))))))
1577 (planner-highlight-region
1582 (planner-appt-task-highlight-face
1583 (match-string 1))))))))
1585 (defun planner-appt-font-setup ()
1586 "Hook into `planner-mode'."
1587 (planner-appt-add-hook 'muse-colors-buffer-hook
1588 'planner-appt-task-highlight t
))
1590 ;;; Calendar Marking
1592 ;; This is not strictly part of appointment handling, but if the
1593 ;; diary is to be by-passed for appointments, it makes sense to mark
1594 ;; the calendar using day pages.
1598 ;; Use a different face from the diary-entry-marker so we can
1599 ;; see where the different marks come from.
1600 (defface planner-appt-entry-marker
1601 '((t (:foreground
"indianred")))
1602 "Face for planner day page mark in the calendar."
1603 :group
'planner-appt
)
1606 (defun planner-appt-mark-calendar (&optional from to
)
1607 "Mark dates in the calendar that have day pages.
1608 Optional args: mark dates from FROM to TO.
1609 FROM and to are lists: (month day year)."
1610 (with-current-buffer calendar-buffer
; Needed to get displayed date
1612 (let* ((displayed-month-last
1613 (1+ (cdr (assq 'displayed-month
1614 (buffer-local-variables)))))
1616 (cdr (assq 'displayed-year
1617 (buffer-local-variables))))
1618 (today-filename (planner-today))
1619 (today (planner-filename-to-calendar-date today-filename
)))
1620 ;; Do nothing if the calendar is currently showing all months
1621 ;; earlier than today.
1622 (when (and (>= (elt today
2) ; year
1624 (>= displayed-month-last
1625 (elt today
0))) ; month
1626 (let ((diary-entry-marker 'planner-appt-entry-marker
)
1628 (planner-get-day-pages
1630 (planner-date-to-filename from
)
1633 (planner-date-to-filename to
)
1634 ;; The default is last day visible
1636 (planner-date-to-filename
1637 (list displayed-month-last
31 displayed-year
))))))
1638 (dolist (day-page day-pages
)
1639 (apply #'mark-calendar-date-pattern
1640 (planner-filename-to-calendar-date (car day-page
)))))))))
1642 (defun planner-appt-calendar-insinuate ()
1643 (add-hook 'mark-diary-entries-hook
'planner-appt-mark-calendar
))
1645 (provide 'planner-appt
)
1646 ;;; planner-appt.el ends here
1649 ;; indent-tabs-mode: t