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-literally (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
))))
680 (defvar planner-appt-forthcoming-display-buffer
681 "*Forthcoming Appointments*"
682 "Buffer to display forthcoming appointments.")
684 (defun planner-appt-forthcoming-display (&optional days
)
686 ;; TODO: I wanted to use (interactive "p"), but that defaults to
687 ;; 1. Is this really the best way of getting nil as the default
688 ;; for a command that takes an optional integer prefix?:
689 (list (cond ((consp current-prefix-arg
)
690 (car current-prefix-arg
))
691 ((integerp current-prefix-arg
)
694 (unless days
(setq days planner-appt-forthcoming-days
))
696 (get-buffer-create planner-appt-forthcoming-display-buffer
)
697 (unless (planner-derived-mode-p 'planner-mode
)
698 (setq muse-current-project
(muse-project planner-project
))
700 (cd (planner-directory)))
701 (delete-region (point-min) (point-max))
702 (insert "* Appointments in the next "
703 (number-to-string days
)
704 (if (= days
1) " day" " days")
706 (planner-appt-forthcoming-format
707 (planner-appt-forthcoming-get-appts
708 (or days planner-appt-forthcoming-days
) t
)))
709 (goto-char (point-min)))
710 (display-buffer planner-appt-forthcoming-display-buffer
)
711 (fit-window-to-buffer
712 (get-buffer-window planner-appt-forthcoming-display-buffer
)))
715 (defun planner-appt-forthcoming-update-section (&optional days
)
717 (list (cond ((consp current-prefix-arg
)
718 (car current-prefix-arg
))
719 ((integerp current-prefix-arg
)
722 (with-planner-update-setup
725 (planner-seek-to-first planner-appt-forthcoming-appt-section
)
726 (delete-region (point)
727 (planner-appt-seek-to-end-of-current-section))
728 (insert (planner-appt-forthcoming-format
729 (planner-appt-forthcoming-get-appts
730 (or days planner-appt-forthcoming-days
)))
734 ;; A function suitable for planner-mode-hook
735 (defun planner-appt-forthcoming-update-section-maybe ()
736 (when (planner-appt-todays-page-p)
737 (planner-appt-forthcoming-update-section)))
740 ;;; Alerts From Task Descriptions
742 ;; Add a bit of [premature] optimization, mainly for updating
743 ;; functions where the same task gets examined often.
744 (defvar --planner-appt-task-cache
(make-hash-table :test
'equal
))
746 (defun planner-appt-task-parse-task (description)
747 "Extract appointment time and text from the DESCRIPTION.
748 Return a list (text time). If the task is not an
749 appointment, time defaults to nil."
750 (or (gethash description --planner-appt-task-cache
)
753 (if (string-match planner-appt-task-regexp description
)
754 (list (substring description
(match-end 0))
755 (substring description
(match-beginning 1) (match-end 1)))
756 (list description nil
))
757 --planner-appt-task-cache
)))
759 (defun planner-appt-task-nagging-p (description)
760 "Return non-nil if task DESCRIPTION is a nagging appointment."
761 (string-match planner-appt-task-nagging-regexp description
))
763 (defun planner-appt-task-member (description time appt-list
)
764 "Return non-nil if DESCRIPTION at TIME in APPT-LIST has been scheduled."
765 (member (planner-appt-make-appt-element time description
) appt-list
))
768 ;; Integration with planner-schedule.el
770 (defvar planner-appt-schedule-task-estimate-regexp
771 (concat "[!@][ \t]*\\(?:" ; "shy" form of planner-appt-task-regexp
772 planner-appt-time-regexp
774 "\\s-*\\([0-9]+[smhdw]\\)")
775 "Regular expression matching a task time estimate.")
777 ;; NB: The following advice could be avoided if the regexp were not
778 ;; hard-coded into the original function.
780 ;; NNB: This is not well tested!
782 (defadvice planner-schedule-task-estimate
(around planner-appt-task disable
)
783 "Modify the regexp matched to take appointments into account."
784 (when (string-match planner-appt-schedule-task-estimate-regexp
785 (planner-task-description info
))
786 (schedule-duration-to-seconds
787 (match-string 2 (planner-task-description info
)))))
790 (defun planner-appt-task-add (&optional info
)
791 "Create an appointment from the current task if this is today's plan.
792 Return t if an appointment was added.
793 If the task is an appointment, it is not cancelled, it is scheduled for
794 later today, and is not already added.
795 Optional argument: use INFO instead of the current task info."
797 (let* ((info (or info
798 ;; Unfortunately, in emacs-lisp there are no
799 ;; defaults for optional arguments, so one can't
800 ;; distinguish between null info in an arg and null
801 ;; info from planner-current-task-info; so the
802 ;; error message might be uninformative here.
803 (planner-current-task-info)
804 (error "There is no task on the current line")))
805 (appt (planner-appt-task-parse-task
806 (planner-task-description info
)))
808 (desc (and time
(planner-appt-format-description (nth 0 appt
)))))
810 (not (string= (planner-task-status info
) "C"))
811 (string= (planner-task-date info
)
812 (planner-date-to-filename
813 (decode-time (current-time))))
814 (not (planner-appt-task-member desc time
815 appt-time-msg-list
)))
816 (if (planner-appt-earlier-than-now-p time
)
818 ;; Remember earlier appts separately [principally for
819 ;; their addition in an appointment section].
820 (unless (planner-appt-task-member
821 desc time --planner-appt-tasks-earlier-appts
)
822 (setq --planner-appt-tasks-earlier-appts
823 (planner-appt-remember-appt
825 --planner-appt-tasks-earlier-appts
)))
826 (planner-appt-update-appt-section-maybe)
827 ;; Make sure nil is returned.
830 ;; Keep track of tasks added by this function.
831 (setq --planner-appt-tasks-added-appts
832 (planner-appt-remember-appt
834 --planner-appt-tasks-added-appts
))
835 (planner-appt-update-appt-section-maybe)
838 (defun planner-appt-task-delete (&optional info
)
839 "Delete the appointment from the current task if this is today's plan.
840 Do not remove the time string.
841 Return any deleted appointments.
842 Optional argument: use INFO instead of the current task info."
844 (let* ((info (or info
845 ;; See planner-appt-task-add for comments about
846 ;; the possibly uninformative error message.
847 (planner-current-task-info)
848 (error "There is no task on the current line")))
849 (appt (planner-appt-task-parse-task
850 (planner-task-description info
)))
852 (desc (and time
(planner-appt-format-description (nth 0 appt
))))
853 (tmp-msg-list appt-time-msg-list
))
855 ;; Method from appt-delete
856 (let ((deleted-appts '())
858 (car (planner-appt-task-member
859 desc time --planner-appt-tasks-earlier-appts
)))
861 ;; NB: Mustn't concat time onto description until earlier-appt
862 ;; has been determined [since planner-appt-task-member does
863 ;; the concat itself [this could be improved somehow]]
864 (setq desc
(concat time
" " desc
))
866 (setq element
(car tmp-msg-list
))
867 (when (string= (car (cdr element
)) desc
)
868 (push element deleted-appts
)
869 (setq appt-time-msg-list
(delq element appt-time-msg-list
))
870 (setq --planner-appt-tasks-added-appts
871 (planner-appt-forget-appt
872 element --planner-appt-tasks-added-appts
)))
873 (setq tmp-msg-list
(cdr tmp-msg-list
)))
874 (when (or deleted-appts earlier-appt
)
875 ;; Forget a deleted appt that was earlier than now.
877 (setq --planner-appt-tasks-earlier-appts
878 (planner-appt-forget-appt
879 earlier-appt --planner-appt-tasks-earlier-appts
)))
880 (planner-appt-update-appt-section-maybe))
883 (defun planner-appt-add-appts-from-tasks ()
884 "Parse all of today's tasks and add appointments automatically."
886 (when (planner-appt-todays-page-p)
887 ;; Clear old appts added by this function.
888 (planner-appt-clear-appts --planner-appt-tasks-added-appts
)
889 (setq --planner-appt-tasks-added-appts
'()
890 --planner-appt-tasks-earlier-appts
'())
891 (let ((case-fold-search nil
))
893 (goto-char (point-min))
894 (with-planner-appt-update-section-disabled
895 (while (re-search-forward
896 (concat planner-live-task-regexp
897 planner-appt-task-regexp
)
899 (planner-appt-task-add))))
900 (when (or --planner-appt-tasks-added-appts
901 --planner-appt-tasks-earlier-appts
)
902 (planner-appt-update-appt-section-maybe)))))
906 ;; for speedy enabling and disabling of advice:
908 (defvar --planner-appt-advice
'()
909 "Internal variable: List of advices added by `planner-appt-defadvice'.
910 Each element is a list of args for `ad-enable-advice' and
911 `ad-disable-advice'.")
914 (defvar planner-appt-advice-common-flags
915 '(preactivate disable
)
916 "Advice flags common to all planner-appt advice."))
918 (defmacro planner-appt-defadvice
(function args doc
&rest body
)
919 "Advise FUNCTION with ARGS, DOC and BODY.
920 Remembers the advice function and args in `--planner-appt-advice'."
923 (,@args
,@planner-appt-advice-common-flags
) ,doc
,@body
)
924 (let ((info '(,function
,(car args
) ,(cadr args
))))
925 (unless (member info --planner-appt-advice
)
926 (push info --planner-appt-advice
)))))
928 (put 'planner-appt-defadvice
931 (name name
&rest sexp
)
934 ("interactive" interactive
)]
937 (put 'planner-appt-defadvice
'lisp-indent-function
'defun
)
939 ;; See what happened with the preactivation.
943 (trace-function-background
944 'ad-cache-id-verification-code
945 "*planner-appt advice trace*")))
947 (defun planner-appt-disable-all-advice ()
948 "Disable all advice added with `planner-appt-defadvice'."
949 (mapcar #'(lambda (args)
950 (apply #'ad-disable-advice args
)
951 (ad-activate (car args
)))
952 --planner-appt-advice
))
954 (defun planner-appt-enable-all-advice ()
955 "Enable all advice added with `planner-appt-defadvice'."
956 (mapcar #'(lambda (args)
957 (apply #'ad-enable-advice args
)
958 (ad-activate (car args
)))
959 --planner-appt-advice
))
962 (defmacro with-planner-appt-task-advice-disabled
(&rest body
)
963 "Evaluate BODY forms with all advice matching \"planner-appt-task\" disabled."
966 (planner-appt-disable-all-advice)
967 (planner-appt-debug-message "all advice disabled")
969 (planner-appt-enable-all-advice)
970 (planner-appt-debug-message "all advice enabled")))
972 (put 'with-planner-appt-task-advice-disabled
'lisp-indent-function
0)
973 (put 'with-planner-appt-task-advice-disabled
'edebug-form-spec
'(body))
975 (planner-appt-defadvice planner-task-cancelled
976 (before planner-appt-task
)
977 "Delete the appointment as well."
978 (planner-appt-debug-message
979 "*** called advice on planner-task-cancelled")
980 (planner-appt-task-delete))
982 (planner-appt-defadvice planner-task-done
983 (before planner-appt-task
)
984 "Delete the appointment as well."
985 (planner-appt-debug-message
986 "*** called advice on planner-task-done")
987 (planner-appt-task-delete))
989 (planner-appt-defadvice planner-delete-task
990 (before planner-appt-task
)
991 "Delete the appointment as well."
992 (planner-appt-debug-message
993 "*** called advice on planner-delete-task")
994 (planner-appt-task-delete))
996 ;; The advice for planner-update-task is quite tricky. A task will
997 ;; need updating [for appointments] if the task is dated today and the
998 ;; description differs from other task lines linked to by the current
999 ;; task. If this is true, we have to examine all the other links,
1000 ;; delete any appointments, and then add the task after planner-update
1001 ;; has been called. Note that it is only possible for this to happen
1002 ;; if planner-id is loaded since otherwise the "same" task line can't
1003 ;; have different descriptions.
1005 (defun planner-appt-get-diff-links (info)
1006 "Given INFO, return a list of tasks linked to it whose info differs."
1009 ;; Todo: with-planner-update-setup really ought to return the
1010 ;; value of the body.
1011 (with-planner-update-setup
1012 ;; Preserve point as well.
1015 (if (featurep 'planner-multi
)
1016 (planner-multi-link-delete
1017 (planner-task-page info
)
1018 (planner-multi-task-link-as-list info
))
1019 (list (planner-task-link info
))))
1020 (when (and (planner-find-file (planner-link-base link
))
1021 (planner-find-task info
)
1022 (setq linked-info
(planner-current-task-info))
1023 (not (planner-tasks-equal-p info linked-info
)))
1024 (push linked-info diffs
)))))
1027 (planner-appt-defadvice planner-update-task
1028 (around planner-appt-task
)
1029 "Update the appointment as well."
1030 (planner-appt-debug-message
1031 "*** called advice on planner-update-task")
1032 (let* ((info (planner-current-task-info))
1034 (and (featurep 'planner-id
)
1035 (string= (planner-task-date info
) (planner-today))
1036 (planner-appt-get-diff-links info
))))
1037 (with-planner-appt-task-advice-disabled ad-do-it
)
1039 (dolist (i diff-linked
)
1040 (planner-appt-task-delete i
))
1041 (planner-appt-task-add))))
1043 ;; For planner-id-update-tasks-on-page, it is actually much faster to
1044 ;; update today's page after it has done its work rather than using
1045 ;; the update advice above.
1047 (planner-appt-defadvice planner-id-update-tasks-on-page
1048 (around planner-appt-task
)
1049 "Update today's appointments as well."
1050 (planner-appt-debug-message
1051 "*** called advice on planner-id-update-tasks-on-page")
1052 (with-planner-appt-task-advice-disabled ad-do-it
)
1053 (with-planner-update-setup
1055 (planner-goto-today)
1056 ;; Update the appointments section afterwards for efficiency.
1057 (with-planner-appt-update-section-disabled
1058 (planner-appt-update))
1059 (planner-appt-update-appt-section-maybe))))
1061 (defvar --planner-appt-planning nil
1063 Lets planner-appt advice know that it has been called within a call to
1066 (planner-appt-defadvice plan
(around planner-appt-task
)
1067 "Note that plan is in progress."
1068 (planner-appt-debug-message
1069 "*** called advice on plan")
1070 (let ((--planner-appt-planning t
))
1073 (planner-appt-defadvice planner-copy-or-move-task
1074 (around planner-appt-task
)
1075 "Update the appointment as well."
1076 (planner-appt-debug-message
1077 "*** called advice on planner-copy-or-move-task; "
1078 (if --planner-appt-planning
1081 (cond ((not --planner-appt-planning
)
1083 ;; Save the appt information for error cleanup and
1084 ;; appointment adding.
1085 ((deleted-appts (planner-appt-task-delete))
1086 (old-info (planner-current-task-info)))
1089 (with-planner-appt-task-advice-disabled ad-do-it
)
1090 ;; If the task was moved to today, add it.
1091 (when (and date
; Bound in the advised function.
1092 (string= date
(planner-today)))
1093 ;; Fiddle the old info so it looks like
1094 ;; today's. NB: would need changing should
1095 ;; the task-info format ever change.
1097 ;; planner-multi uses the date in the link for
1098 ;; planner-task-date [why?], so that has to be
1099 ;; modified too. This has to be done before the
1100 ;; date element is changed, of course.
1101 (when (and (featurep 'planner-multi
)
1102 (consp (nth 5 old-info
))) ; the link element
1104 (member (nth 8 old-info
)
1106 ;; Silly way of avoiding an error if the
1107 ;; date is not in the list: can the date
1108 ;; not be in the list?
1111 ;; Set the date element.
1112 (setcar (nthcdr 8 old-info
) date
)
1113 (planner-appt-task-add old-info
)))
1115 ;; Catch errors in planner-copy-or-move-task: restore
1117 (dolist (d deleted-appts
)
1118 (push d appt-time-msg-list
))
1119 (error (error-message-string err
))))))
1121 ;; `plan' in progress: only move the task if it is not a
1122 ;; regular (non-nagging) appointment. If it's a nagging
1123 ;; appointment, remove the appointment and then move the
1125 (let* ((info (planner-current-task-info))
1126 (appt (planner-appt-task-parse-task
1127 (planner-task-description info
)))
1128 (time (nth 1 appt
)))
1129 (with-planner-appt-task-advice-disabled
1130 (if (planner-appt-task-nagging-p (planner-task-description info
))
1131 (progn (planner-edit-task-description (nth 0 appt
))
1134 ;; Fri Nov 25 13:59:02 GMT 2005: Fix for new [?]
1135 ;; behaviour of planner-copy-or-move-region.
1138 ;; Return nil, otherwise
1139 ;; planner-copy-or-move-region's count will be
1141 (setq ad-return-value nil
))
1144 ;; NB: this advice leads to two updates of the task appointment
1145 ;; section [when updating it is enabled, of course]: it is hard to see
1146 ;; how to avoid this unless there is yet another global variable
1147 ;; tracking deleted appts.
1148 (planner-appt-defadvice planner-edit-task-description
1149 (around planner-appt-task
)
1150 "Update the appointment as well."
1151 (planner-appt-debug-message
1152 "*** called advice on planner-edit-task-description")
1153 (planner-appt-task-delete)
1154 (with-planner-appt-task-advice-disabled ad-do-it
)
1155 (planner-appt-task-add))
1157 ;; planner-create-task-from-info: The appointment adding needs doing
1158 ;; after all hooks to planner-create-task-from-info have been run so
1159 ;; that planner-appt-task-add has the correct task line; planner-id,
1160 ;; for example, adds a task id so if the planner-appt hook is run
1161 ;; first it won't have the right task description.
1163 ;; Hence these shenanigans:
1165 (defvar --planner-appt-created-task-marker
(make-marker))
1166 (defvar --planner-appt-close-the-buffer-flag nil
)
1169 ;; Hide warning about live-buffers [q.v.].
1170 (defvar live-buffers
))
1172 (defun planner-appt-create-task-hook-func ()
1173 "One half of planner-appt create task handling.
1174 Remembers the position of the added task. The other half of the
1175 handling is in advice to `planner-create-task-from-info'."
1176 (set-marker --planner-appt-created-task-marker
(point))
1177 ;; If planner-tasks-file-behavior is 'close, it won't be possible to
1178 ;; recover the position from a marker, so temporarily defeat closing
1179 ;; this file, and close it if necessary in the
1180 ;; planner-create-task-from-info advice.
1181 (setq --planner-appt-close-the-buffer-flag
1182 (if (and (eq planner-tasks-file-behavior
'close
)
1183 ;; `live-buffers' is defined in
1184 ;; planner-create-task-from-info, but it is not
1185 ;; defined in the planner-multi advice [hmm...].
1186 (boundp 'live-buffers
)
1187 (not (memq (current-buffer) live-buffers
)))
1188 ;; Adding the buffer to `live-buffers' means it won't be
1189 ;; closed automatically.
1190 (progn (push (current-buffer) live-buffers
) t
)
1194 (planner-appt-defadvice planner-create-task-from-info
1195 (around planner-appt-task
)
1196 "Add an appointment alert for the new task if necessary."
1197 (planner-appt-debug-message
1198 "*** called advice on planner-create-task-from-info")
1199 (with-planner-appt-task-advice-disabled ad-do-it
)
1200 (let ((buf (marker-buffer --planner-appt-created-task-marker
))
1201 (pos (marker-position --planner-appt-created-task-marker
)))
1203 (with-current-buffer buf
1206 (planner-appt-task-add)))
1207 (set-marker --planner-appt-created-task-marker nil
)
1208 (when --planner-appt-close-the-buffer-flag
1209 ;; Use planner-save-buffers for consistency; remove the buffer
1210 ;; from buffer-list so that it gets closed.
1211 (planner-save-buffers (delq buf
(buffer-list)))))))
1213 (defun planner-appt-task-insinuate ()
1214 "Do task-specific insinuation into `planner-mode'."
1215 ;; Nothing at the moment!
1218 ;; In case of breakage while developing
1219 ;; NB: remember to remove hooks locally where relevant
1220 (defun planner-appt-task-de-insinuate ()
1221 "Remove task-specific hooks."
1222 ;; Nothing at the moment!
1226 ;;; Alerts From The Schedule
1228 (defvar --planner-appt-schedule-added-appts
'()
1229 "Internal variable: Tracks added schedule-based appointment alerts.")
1231 (defun planner-appt-add-appts-from-schedule ()
1232 "Add appointment reminders from the schedule if this is today's plan."
1234 (when (planner-appt-todays-page-p)
1235 ;; Delete old appts created by this function.
1236 (planner-appt-clear-appts --planner-appt-schedule-added-appts
)
1237 (setq --planner-appt-schedule-added-appts
'())
1239 (planner-seek-to-first planner-appt-schedule-section
)
1240 (let ((bound (save-excursion
1241 (planner-appt-seek-to-end-of-current-section)))
1242 line time text task-item-p
)
1243 ;; There are no entries in the schedule unless bound is
1244 ;; greater than point.
1245 (when (> bound
(point))
1246 (while (re-search-forward
1247 planner-appt-schedule-appt-regexp bound t
)
1248 (setq line
(planner-match-string-no-properties 0)
1249 time
(planner-match-string-no-properties 1)
1250 text
(planner-appt-format-description
1251 (planner-match-string-no-properties 3))
1253 (planner-appt-task-schedule-item-p (match-string 0)))
1254 ;; (text-property-any (match-beginning 0) (match-end 0)
1256 (unless (or task-item-p
1257 (planner-appt-earlier-than-now-p time
))
1258 (appt-add time text
)
1259 ;; Remember tasks added here.
1260 (setq --planner-appt-schedule-added-appts
1261 (planner-appt-remember-appt
1262 time text --planner-appt-schedule-added-appts
)))))))))
1264 (defun planner-appt-schedule-insinuate ()
1265 "Do schedule specific insinuation into `planner-mode'."
1266 ;; Nothing at the moment!
1269 (defun planner-appt-schedule-de-insinuate ()
1270 "Remove schedule-based hooks."
1271 ;; Nothing at the moment!
1274 ;; Make appt-make-list behave.
1276 (defadvice appt-make-list
(after planner-appt activate
)
1277 "Restore appointments added by planner-appt."
1278 (dolist (appt (append --planner-appt-tasks-added-appts
1279 --planner-appt-schedule-added-appts
))
1280 (unless (member appt appt-time-msg-list
)
1281 (push appt appt-time-msg-list
)))
1282 (setq appt-time-msg-list
(appt-sort-list appt-time-msg-list
)))
1284 ;;; Sorting the Schedule
1286 (defun planner-appt-schedule-sort ()
1287 "Sort the schedule in the current page."
1291 (planner-seek-to-first planner-appt-schedule-section
)
1292 (narrow-to-region (point)
1294 (planner-appt-seek-to-end-of-current-section)
1296 (sort-subr nil
'forward-line
'end-of-line
1298 (goto-char (planner-line-beginning-position))
1299 (if (looking-at planner-appt-schedule-regexp
)
1302 ;; 1+ max number of minutes from midnight
1306 ;;; Cyclical Schedule Entries
1308 (require 'diary-lib
)
1311 (defvar planner-cyclic-diary-file
))
1313 ;; Purloined from planner-cyclic.el.
1314 (defun planner-appt-schedule-get-cyclic-tasks (date &optional no-of-days
)
1315 "For DATE, get the cyclic tasks.
1316 Optional argument get tasks for NO-OF-DAYS from DATE, the default is 1
1317 day [i.e., only for DATE]."
1318 (let ((date (if (stringp date
)
1319 (planner-filename-to-calendar-date date
)
1322 (mapcar #'(lambda (item)
1323 (when (string-match planner-appt-schedule-regexp
1325 (match-string 0 (elt item
1))))
1326 (planner-list-diary-entries planner-cyclic-diary-file
1327 date no-of-days
)))))
1329 (defun planner-appt-schedule-add-cyclic ()
1330 "Add cylical tasks to the schedule if the current buffer is a day page."
1331 (when (string-match planner-date-regexp
(planner-page-name))
1333 (planner-appt-schedule-get-cyclic-tasks (planner-page-name))))
1335 (planner-seek-to-first planner-appt-schedule-section
)
1336 (let ((start (point)))
1337 (dolist (entry entries
)
1338 ;; Only insert if the entry is not already there.
1339 (unless (save-excursion
1341 (search-forward entry nil t
))
1342 (insert entry ?
\n))))
1343 ;; Lazy way of putting them in the right place.
1344 (when planner-appt-sort-schedule-on-update-flag
1345 (planner-appt-schedule-sort))))))
1347 (defun planner-appt-schedule-add-cyclic-maybe ()
1348 "Add cylical tasks to the schedule.
1349 Behaviour depends upon `planner-appt-schedule-cyclic-behaviour'."
1350 (when (and (not (string< (planner-page-name) (planner-today)))
1351 (or (eq planner-appt-schedule-cyclic-behaviour
'future
)
1353 (eq planner-appt-schedule-cyclic-behaviour
'today
)
1354 (planner-appt-todays-page-p))))
1355 (planner-appt-schedule-add-cyclic)))
1357 (defun planner-appt-schedule-cyclic-insinuate ()
1358 "Insinuate the adding of cyclical schedule entries."
1359 ;; TODO: Add locally?
1360 (planner-appt-add-hook 'planner-mode-hook
1361 'planner-appt-schedule-add-cyclic-maybe nil t
))
1363 (defun planner-appt-schedule-cyclic-de-insinuate ()
1364 "Remove cyclic schedule adding functionality."
1365 (remove-hook 'planner-mode-hook
1366 'planner-appt-schedule-add-cyclic-maybe
))
1369 ;;; Common Functions
1372 ;; So that one doesn't have to use two separate commands when using
1375 (defvar --planner-appt-updated nil
)
1378 (defun planner-appt-update ()
1379 "Update the appointments on the current page."
1381 ;; NB: Task adding has to be done before the schedule to avoid
1382 ;; duplicates if task appointments are copied to the schedule.
1383 (when (memq 'tasks planner-appt-methods
)
1384 (planner-appt-add-appts-from-tasks))
1385 (when (memq 'schedule planner-appt-methods
)
1386 (planner-appt-add-appts-from-schedule))
1387 (when (and planner-appt-sort-schedule-on-update-flag
1388 (planner-appt-todays-page-p))
1389 (planner-appt-schedule-sort))
1390 (run-hooks 'planner-appt-update-hook
)
1391 ;; TODO: Use a belt and some braces: see comments in
1392 ;; `planner-appt-insinuate-if-today'.
1393 (setq --planner-appt-updated t
))
1395 (defun planner-appt-update-for-write ()
1396 (when planner-appt-update-appts-on-save-flag
1397 (planner-appt-update)
1398 ;; Return nil for local-write-file-hooks.
1401 ;; NB: Something like the above could be done for other hooks as
1405 ;;; General Insinuation
1407 ;; This indirect method is used rather than some variable so that the
1408 ;; function advice can be avoided if it is not necessary [when using
1409 ;; schedule appointments exclusively].
1412 (defun planner-appt-use (source)
1413 "Use SOURCE to derive appointments from plan pages.
1414 Possible values for SOURCE are:
1415 'tasks [use today's task descriptions]
1416 'schedule [use today's schedule]
1417 '(tasks schedule) [use both tasks and schedule]."
1418 (dolist (s (if (listp source
)
1421 (cond ((eq s
'tasks
)
1422 ;; Add task-specific non-insinuating code here.
1423 ;; ;; Only activate advice when necessary.
1424 ;; (ad-enable-regexp "planner-appt-task")
1425 ;; (ad-activate-regexp "planner-appt-task")
1426 ;; An outstanding global hook [planner-appt-task-add tests
1427 ;; for today-ness anyway].
1428 (planner-appt-add-hook 'planner-create-task-hook
1429 'planner-appt-create-task-hook-func nil t
)
1430 (add-to-list 'planner-appt-methods s
))
1432 ;; Add schedule task-specific non-insinuating code here.
1433 (add-to-list 'planner-appt-methods s
))
1435 (error "Invalid appointment source %s" s
))))
1436 ;; Add here any non method-specific code that should be executed
1437 ;; even if planner-appt-insinuate is not called.
1438 (if (memq 'tasks planner-appt-methods
)
1439 (planner-appt-enable-all-advice)
1440 (planner-appt-disable-all-advice))
1441 (planner-appt-add-hook 'planner-mode-hook
1442 'planner-appt-font-setup nil t
)
1443 ;; Might as well return something interesting.
1444 planner-appt-methods
)
1447 (defun planner-appt-insinuate-if-today ()
1448 (when (planner-appt-todays-page-p)
1449 (planner-appt-add-hook 'planner-mode-hook
1450 'planner-appt-update t
)
1451 ;; Add method specific things
1452 (when (memq 'tasks planner-appt-methods
)
1453 (planner-appt-task-insinuate))
1454 (when (memq 'schedule planner-appt-methods
)
1455 (planner-appt-schedule-insinuate))
1456 (planner-appt-add-hook planner-appt-write-file-hook
1457 'planner-appt-update-for-write t
)
1458 ;; TODO: Under some conditions, as yet undetermined, an update is
1459 ;; not done when `plan' is called for the first time. So do an
1460 ;; update, but only if there hasn't been one already.
1462 ;; Fri 15 Apr 2005 16:26:04 BST: this has probably been sorted out
1463 ;; now, but it doesn't do any harm to leave this in for now, just
1465 (unless --planner-appt-updated
1466 (planner-appt-update))))
1469 (defun planner-appt-insinuate ()
1470 "Insinuate appointment alerting into planner mode.
1471 Appointment methods should be set up first using one of:
1472 `planner-appt-use-tasks'
1473 `planner-appt-use-schedule'
1474 `planner-appt-use-tasks-and-schedule'."
1475 (unless planner-appt-methods
1477 "No appointment source methods. Use one of:
1478 `planner-appt-use-tasks'
1479 `planner-appt-use-schedule'
1480 `planner-appt-use-tasks-and-schedule'
1481 before you call this function"))
1482 ;; Initialize the appt system according to emacs type and version.
1483 (cond ((fboundp 'appt-activate
) ; Gnu Emacs >= 22
1485 ((fboundp 'appt-initialize
) ; Xemacs
1486 ;; appt-initialize needs a diary file, so create one if it
1487 ;; doesn't already exist
1488 (unless (file-exists-p diary-file
)
1491 (write-region (point-min) (point-max) diary-file
)))
1494 (t (display-time) ; Gnu Emacs < 22
1495 (add-hook 'diary-hook
'appt-make-list
)))
1496 (planner-appt-add-hook 'planner-mode-hook
1497 'planner-appt-insinuate-if-today t t
))
1499 ;; Remove hooks if there is something not working during testing.
1500 (defun planner-appt-de-insinuate ()
1501 "Remove all hooks associated with planner-appt.
1502 Use in an emergency if breakage in planner-appt interferes with your planning."
1504 (remove-hook 'planner-mode-hook
'planner-appt-insinuate-if-today
)
1505 (remove-hook 'mark-diary-entries-hook
'planner-appt-mark-calendar-maybe
)
1506 (when (get-buffer (planner-today))
1507 (with-current-buffer (get-buffer (planner-today))
1508 ;; NB: Remember to remove locally where appropriate.
1509 (remove-hook 'planner-goto-hook
1510 'planner-appt-update t
)
1511 (remove-hook 'planner-mode-hook
1512 'planner-appt-update t
)
1513 (remove-hook planner-appt-write-file-hook
1514 'planner-appt-update-for-write t
)
1515 (remove-hook 'planner-create-task-hook
1516 'planner-appt-create-task-hook-func
)
1517 (planner-appt-task-de-insinuate)
1518 (planner-appt-schedule-de-insinuate)
1519 (planner-appt-schedule-cyclic-de-insinuate)))
1520 (planner-appt-disable-all-advice)
1521 (message "Planner-appt de-insinuated."))
1524 ;;; Convenient Functions For Users' Configuration.
1527 (defun planner-appt-use-tasks ()
1528 "Use tasks to derive appointment alerts."
1529 (planner-appt-use 'tasks
))
1532 (defun planner-appt-use-schedule ()
1533 "Use the schedule to derive appointment alerts."
1534 (planner-appt-use 'schedule
))
1537 (defun planner-appt-use-tasks-and-schedule ()
1538 "Use both tasks and the schedule to derive appointment alerts."
1539 (planner-appt-use '(tasks schedule
)))
1541 ;;; Font Highlighting
1543 (defface planner-appt-face
'((t (:foreground
"green")))
1544 "Face for scheduled time."
1545 :group
'planner-appt
)
1547 (defface planner-appt-overdue-face
'((t (:foreground
"red")))
1548 "Face for scheduled, but overdue time."
1549 :group
'planner-appt
)
1551 (defun planner-appt-task-highlight-face (time)
1552 "Return appropriate face, depending on TIME.
1553 If TIME is earlier than now, return `planner-appt-face', else
1554 return `planner-appt-overdue-face'."
1555 (if (planner-appt-earlier-than-now-p time
)
1556 'planner-appt-overdue-face
1557 'planner-appt-face
))
1559 (defun planner-appt-task-highlight (beg end
&optional verbose
)
1560 "Highlight appointment times in tasks from BEG to END.
1561 VERBOSE is ignored."
1562 (when planner-appt-font-lock-appointments-flag
1564 (while (re-search-forward planner-appt-task-regexp end t
)
1565 (when (or (not planner-appt-limit-highlighting-flag
)
1567 (goto-char (planner-line-beginning-position))
1569 (or (and (looking-at planner-live-task-regexp
)
1570 (string= (planner-task-date
1571 (planner-current-task-info))
1574 (planner-appt-todays-page-p)
1575 (looking-at planner-appt-schedule-appt-regexp
))))))
1576 (planner-highlight-region
1581 (planner-appt-task-highlight-face
1582 (match-string 1))))))))
1584 (defun planner-appt-font-setup ()
1585 "Hook into `planner-mode'."
1586 (planner-appt-add-hook 'muse-colors-buffer-hook
1587 'planner-appt-task-highlight t
))
1589 ;;; Calendar Marking
1591 ;; This is not strictly part of appointment handling, but if the
1592 ;; diary is to be by-passed for appointments, it makes sense to mark
1593 ;; the calendar using day pages.
1597 ;; Use a different face from the diary-entry-marker so we can
1598 ;; see where the different marks come from.
1599 (defface planner-appt-entry-marker
1600 '((t (:foreground
"indianred")))
1601 "Face for planner day page mark in the calendar."
1602 :group
'planner-appt
)
1605 (defun planner-appt-mark-calendar (&optional from to
)
1606 "Mark dates in the calendar that have day pages.
1607 Optional args: mark dates from FROM to TO.
1608 FROM and to are lists: (month day year)."
1609 (with-current-buffer calendar-buffer
; Needed to get displayed date
1611 (let* ((displayed-month-last
1612 (1+ (cdr (assq 'displayed-month
1613 (buffer-local-variables)))))
1615 (cdr (assq 'displayed-year
1616 (buffer-local-variables))))
1617 (today-filename (planner-today))
1618 (today (planner-filename-to-calendar-date today-filename
)))
1619 ;; Do nothing if the calendar is currently showing all months
1620 ;; earlier than today.
1621 (when (and (>= (elt today
2) ; year
1623 (>= displayed-month-last
1624 (elt today
0))) ; month
1625 (let ((diary-entry-marker 'planner-appt-entry-marker
)
1627 (planner-get-day-pages
1629 (planner-date-to-filename from
)
1632 (planner-date-to-filename to
)
1633 ;; The default is last day visible
1635 (planner-date-to-filename
1636 (list displayed-month-last
31 displayed-year
))))))
1637 (dolist (day-page day-pages
)
1638 (apply #'mark-calendar-date-pattern
1639 (planner-filename-to-calendar-date (car day-page
)))))))))
1641 (defun planner-appt-calendar-insinuate ()
1642 (add-hook 'mark-diary-entries-hook
'planner-appt-mark-calendar
))
1644 (provide 'planner-appt
)
1645 ;;; planner-appt.el ends here
1648 ;; indent-tabs-mode: t