planner-calendar: Fix bug.
[planner-el.git] / planner-appt.el
blobc67c4bcb3229bcaefb498c31a7ed520eb116599d
1 ;;; planner-appt.el --- appointment alerts from planner
2 ;;
3 ;;
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>
8 ;;
9 ;; Author: Jim Ottaway
10 ;; Keywords: hypermedia
13 ;; This file is part of Planner. It is not part of GNU Emacs.
15 ;; Planner is free software; you can redistribute it and/or modify it
16 ;; under the terms of the GNU General Public License as published by
17 ;; the Free Software Foundation; either version 2, or (at your option)
18 ;; any later version.
20 ;; Planner is distributed in the hope that it will be useful, but
21 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
22 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
23 ;; General Public License for more details.
25 ;; You should have received a copy of the GNU General Public License
26 ;; along with Planner; see the file COPYING. If not, write to the
27 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
28 ;; Boston, MA 02110-1301, USA.
31 ;; Please report any bugs that you come across to the authors at the
32 ;; addresses given above.
34 ;; Usage:
36 ;; Add "(planner-appt-insinuate)" to your configuration to make
37 ;; Planner work with appt.
39 ;; See the Appointments section of the Planner manual for further
40 ;; details.
42 ;; Contributors:
44 ;; * Seth Falcon supplied the idea and the code that is the basis of
45 ;; the forthcoming appointments display functionality.
47 ;;; TODO:
49 ;; * Correct sorting of task appointments
51 ;; * Consider changing "insinuate" into "install". I don't like the
52 ;; word "insinuate" very much! Or a minor mode perhaps:
53 ;; planner-appt-minor-mode
55 ;; * A lot of the code properly belongs elsewhere: schedule sorting,
56 ;; schedule cyclical entries, calendar marking...
59 ;;; Code:
62 (require 'planner)
63 (require 'appt)
64 (require 'calendar)
66 ;;; Customization
68 (defgroup planner-appt nil
69 "Appointment integration for planner.el."
70 :prefix "planner-appt-"
71 :group 'planner)
73 (defcustom planner-appt-schedule-section "Schedule"
74 "The name of the section where the schedule is to be found."
75 :group 'planner-appt
76 :type 'string)
78 (defcustom planner-appt-font-lock-appointments-flag t
79 "Non-nil means use font-locking for appointments."
80 :group 'planner-appt
81 :type '(choice (const :tag "Use font-locking" t)
82 (const :tag "Don't use font-locking" nil)))
84 (defcustom planner-appt-update-appts-on-save-flag nil
85 "Non-nil means update appointment alerts on saving today's plan."
86 :group 'planner-appt
87 :type '(choice (const :tag "Update on save" t)
88 (const :tag "Don't update on save" nil)))
90 (defcustom planner-appt-sort-schedule-on-update-flag nil
91 "Non-nil means sort the schedule when updating appointments."
92 :group 'planner-appt
93 :type '(choice (const :tag "Sort on update" t)
94 (const :tag "Don't sort on update" nil)))
97 (defcustom planner-appt-update-hook '()
98 "Hook run after appointments have been updated."
99 :group 'planner-appt
100 :type 'hook)
102 (defcustom planner-appt-schedule-cyclic-behaviour 'today
103 "Determines the behaviour of cyclical schedule insertion.
104 Used after `planner-appt-schedule-cyclic-insinuate' has been called.
105 'today means only add cylical schedule entries for today
106 'future means add cyclical entries for all future day pages visited."
107 :group 'planner-appt
108 :type '(choice (const :tag "For today only" today)
109 (const :tag "For all future pages." future)))
111 (defcustom planner-appt-alert-buffer "*Alerts*"
112 "Name of the buffer for displaying active alerts.
113 Used by `planner-appt-show-alerts'."
114 :group 'planner-appt
115 :type 'string)
118 (defcustom planner-appt-task-use-appointments-section-flag nil
119 "When non-nil, task appointments will be copied to an appoinments section.
120 The section name is supplied by
121 `planner-appt-task-appointments-section'."
122 :group 'planner-appt
123 :type 'boolean)
125 (defcustom planner-appt-task-appointments-section "Schedule"
126 "Name of the section where task appointments are copied.
127 The copying is contingent upon
128 `planner-appt-task-use-appointments-section-flag'."
129 :group 'planner-appt
130 :type 'string)
132 (defcustom planner-appt-format-appt-section-line-function
133 #'planner-appt-format-appt-section-line
134 "The function used when formatting an appointment section line.
136 This function should take one argument: an appointment description.
137 The description is in the form used when an appointment alert is
138 signalled: a string with the time of the appointment and some text
139 such as \"12:00 Do something\". Look at the default function
140 `planner-appt-format-appt-section-line' for inspiration if you want to
141 make a different format."
142 :group 'planner-appt
143 :type 'function)
145 (defcustom planner-appt-limit-highlighting-flag t
146 "When non-nil, only highlight appointment times in tasks and the schedule.
147 When nil, all appointment times are highlighted, wherever they may be
148 in the buffer."
149 :group 'planner-appt
150 :type 'boolean)
152 (defcustom planner-appt-forthcoming-days 7
153 "Number of days to look ahead for appointments."
154 :group 'planner-appt
155 :type 'integer)
157 (defcustom planner-appt-forthcoming-appt-section "Forthcoming Appointments"
158 "Title of the section for forthcoming appointments."
159 :group 'planner-appt
160 :type 'string)
162 (defcustom planner-appt-forthcoming-show-day-names-flag t
163 "When non nil, show day names in forthcoming appointments."
164 :group 'planner-appt
165 :type 'boolean)
167 (defcustom planner-appt-forthcoming-repeat-date-string " "
168 "String to insert for repeated dates.
169 When there are multiple appointments for a date, the date is inserted
170 in the first appointment and the others have this string in their date
171 cell.
173 If the string consists of anything other than whitespace, then a link
174 to the day page for the appoinment is created."
175 :group 'planner-appt
176 :type 'string)
178 (defcustom planner-appt-forthcoming-look-at-cyclic-flag nil
179 "When non nil, add cyclic entries to the forthcoming appointments section."
180 :group 'planner-appt
181 :type 'boolean)
184 ;; Regular Expressions
186 ;; TODO: Should these really be customizable anyway?
188 ;; TODO: Dynamically changing dependent customizations; i.e., if this
189 ;; is changed, all the other time-based regexps should change too [I
190 ;; don't understand customize well enough to do this].
192 (defcustom planner-appt-time-regexp
193 "[0-9]?[0-9]:[0-5][0-9]\\(?:am\\|pm\\)?"
194 "Regular expression matching times."
195 :group 'planner-appt
196 :type 'regexp)
198 (defcustom planner-appt-task-regexp
199 (concat "[@!][ \t]*\\(" planner-appt-time-regexp "\\)[ \t]*")
200 "If a task description matches this regexp, it's an appointment.
201 Match group 1 is the time of the appointment.
202 Used with the task-based method. If you use schedules, look at
203 `planner-appt-schedule-appt-regexp'."
204 :group 'planner-appt
205 :type 'regexp)
207 (defcustom planner-appt-task-nagging-regexp
208 (concat "![ \t]*\\(" planner-appt-time-regexp "\\)[ \t]*")
209 "If a task description matches this regexp, it's a nagging
210 appointment. Used with the task-based method. If you use schedules,
211 look at `planner-appt-schedule-appt-regexp'."
212 :group 'planner-appt
213 :type 'regexp)
215 (defcustom planner-appt-schedule-basic-regexp
216 (concat
217 "\\("
218 ;; the appointment time (match group 1)
219 planner-appt-time-regexp
220 "\\)"
221 ;; possibly some space, possibly a |, and any amount of space
222 "[ \t]*|?[ \t]*"
223 ;; perhaps another time [the end time] (match group 2)
224 "\\("
225 planner-appt-time-regexp
226 "\\)?"
227 ;; possibly some space or some ?' chars, possibly a |, and any
228 ;; amount of space
229 "[' \t]*|?[ \t]*"
230 ;; the appointment text (match group 3)
231 "\\(.+\\)")
232 "Basic regular expression to match a schedule.
233 Match group 1 should yield the start time, match group 2 the stop
234 time, and match group 3 the schedule text."
235 :group 'planner-appt)
237 ;; NB: The groups are shifted in this regexp.
238 (defcustom planner-appt-schedule-regexp
239 (concat
240 ;; any amount of whitespace possibly followed by @ and any amount
241 ;; of whitespace
242 "^[ \t]*\\(@?\\)[ \t]*"
243 ;; followed by the basic regexp
244 planner-appt-schedule-basic-regexp)
245 "Regexp matching schedule entries.
246 Match group 1 should match at most one leading instance of the
247 appointment marker, Match group 2 should yield the start time, match
248 group 3 the stop time, and match group 4 the schedule text."
249 :group 'planner-appt
250 :type 'regexp)
252 (defcustom planner-appt-schedule-appt-regexp
253 (concat
254 ;; any amount of whitespace followed by @ and any amount of
255 ;; whitespace
256 "^[ \t]*@[ \t]*"
257 ;; followed by the basic regexp
258 planner-appt-schedule-basic-regexp)
259 "Regexp matching appointments in the schedule requiring alerts.
260 Used with the schedule-based method. If you use tasks for appointments,
261 look at `planner-appt-task-regexp.'
262 Match group 1 should yield the start time, match group 2 the stop
263 time, and match group 3 the alert text."
264 :group 'planner-appt
265 :type 'regexp)
268 ;;; Planner Miscellany
270 ;; Could be useful elsewhere in planner?
272 (defun planner-appt-todays-page-p ()
273 "Return t if the current page is today's, otherwise nil."
274 (string= (planner-page-name) (planner-today)))
276 (defun planner-appt-seek-to-end-of-current-section ()
277 "Go to the end of the current section."
278 (goto-char
279 (or (and (re-search-forward "^\\*[^*\n]" nil t)
280 (1- (planner-line-beginning-position)))
281 (point-max))))
283 (defvar planner-appt-write-file-hook
284 (if (and (boundp 'write-file-functions)
285 (not (featurep 'xemacs)))
286 'write-file-functions
287 'write-file-hooks)
288 "The write file hook to use.")
290 ;;; Planner-Appt Miscellany
292 (defvar planner-appt-debug-buffer "*planner-appt debug messages*"
293 "The buffer to put debugging messages from planner-appt.")
295 (defvar planner-appt-debug-flag nil
296 "Non-nil means turn on planner-appt debugging.")
298 (defmacro planner-appt-debug (form &rest body)
299 "Evaluate FORM if `planner-appt-debug-flag' is non-nil.
300 Optional BODY is evaluated otherwise."
301 `(if planner-appt-debug-flag
302 ,form
303 ,@body))
305 (defun planner-appt-debug-message (&rest args)
306 "Insert ARGS into `planner-appt-debug-buffer'.
307 This code runs only if `planner-appt-debug-flag' is non-nil."
308 (planner-appt-debug
309 (with-current-buffer
310 (get-buffer-create planner-appt-debug-buffer)
311 (goto-char (point-max))
312 (apply #'insert args)
313 (insert ?\n))))
315 (defun planner-appt-earlier-than-now-p (time)
316 "Return t if TIME is earlier than the current time.
317 Time formats are those used by the appt appointment system."
318 ;; From appt-check
319 (let* ((now (decode-time))
320 (cur-hour (nth 2 now))
321 (cur-min (nth 1 now))
322 (cur-time (+ (* cur-hour 60) cur-min)))
323 (> cur-time (appt-convert-time time))))
325 ;; Not used in this file, but added for completeness.
326 (defun planner-appt-later-than-now-p (time)
327 "Return t if TIME is later than the current time.
328 Time formats are those used by the appt appointment system."
329 ;; From appt-check
330 (let* ((now (decode-time))
331 (cur-hour (nth 2 now))
332 (cur-min (nth 1 now))
333 (cur-time (+ (* cur-hour 60) cur-min)))
334 (< cur-time (appt-convert-time time))))
337 (defvar --planner-appt-tasks-added-appts '()
338 "Internal variable: Tracks added task-based appointment alerts.")
340 (defvar --planner-appt-tasks-earlier-appts '()
341 "Internal variable:
342 Tracks appointments ignored because they were too early.")
344 (defun planner-appt-clear-appts (appt-list)
345 (while appt-list
346 (setq appt-time-msg-list
347 (delete (pop appt-list) appt-time-msg-list))))
349 (defun planner-appt-format-time-and-description (time description)
350 "Format TIME [a string] and DESCRIPTION as an appointment."
351 (concat time " " description))
353 (eval-and-compile
354 (if (> emacs-major-version 21)
355 (defun planner-appt-make-appt-element (time text)
356 (list
357 (list (appt-convert-time time))
358 (planner-appt-format-time-and-description time text)
360 (defun planner-appt-make-appt-element (time text)
361 (list
362 (list (appt-convert-time time))
363 (planner-appt-format-time-and-description time text)))))
365 (defun planner-appt-remember-appt (time text list)
366 "Store details of an appointment with TIME and TEXT in LIST.
367 Return the new list."
368 (push (planner-appt-make-appt-element time text) list))
370 (defun planner-appt-forget-appt (appt appt-list)
371 "Remove APPT from APPT-LIST and return the new list.
372 APPT is in the appt format."
373 (delete (car (member appt appt-list)) appt-list))
375 (defun planner-appt-add-hook (hook function &optional append global)
376 "Add to the value of HOOK the function FUNCTION.
377 This is `add-hook' with local and global switched.
378 FUNCTION is not added if already present.
379 FUNCTION is added (if necessary) at the beginning of the hook list
380 unless the optional argument APPEND is non-nil, in which case
381 FUNCTION is added at the end.
382 The optional fourth argument, GLOBAL, if non-nil, says to modify
383 the hook's global value rather than its local value."
384 (add-hook hook function append (not global)))
387 (defun planner-appt-remove-task-id (description)
388 (if (string-match
389 (concat "\\s-*"
390 (if (boundp 'planner-id-regexp)
391 planner-id-regexp))
392 description)
393 (replace-match "" t t description)
394 description))
397 (defun planner-appt-format-description (description)
398 (planner-appt-remove-task-id
399 (planner-remove-links description)))
402 ;;; Showing Appointments In Various Ways
404 (defvar planner-appt-methods '()
405 "Methods used for appointment alerts.
406 Internal variable: to set up appointment methods use one of:
407 `planner-appt-use-tasks'
408 `planner-appt-use-schedule'
409 `planner-appt-use-tasks-and-schedule'.")
411 ;; Copying task appts over to an "Appointments" section.
413 (defun planner-appt-format-appt-section-line (desc)
414 "Format DESC as a line for the appointments section."
415 (let* ((td (planner-appt-task-parse-task
416 ;; Trick the function into parsing:
417 (concat "@" desc)))
418 (text (car td))
419 (time (cadr td))
420 (end-time (if (string-match
421 (format "\\s-*\\(%s\\)\\s-*"
422 planner-appt-time-regexp)
423 text)
424 (prog1
425 (match-string 1 text)
426 (setq text (replace-match "" t t text)))
427 " ")))
428 ;; Format in the style of a tabular schedule.
429 (format "%6s | %5s | %s"
430 ;; Using an @ means the time gets fontified for free.
431 (concat "@" time)
432 end-time
433 (if (string= planner-appt-task-appointments-section
434 planner-appt-schedule-section)
435 ;; To avoid confusion, add an indication that this
436 ;; item came from a task.
437 (concat "# " text)
438 text))))
440 (defvar --planner-appt-lines-added-to-section '()
441 "Internal variable:
442 Remembers lines added by `planner-appt-update-appt-section' the last
443 time it was called.")
445 (defun planner-appt-task-schedule-item-p (string)
446 "Return t if STRING is a schedule item derived from a task."
447 (member string --planner-appt-lines-added-to-section))
448 ;; ;; Look for any property in the string since STRING will usually be
449 ;; ;; derived from a buffer substring which may have been edited.
450 ;; (text-property-any 0 (length string) 'appt-task t string))
452 (defun planner-appt-update-appt-section ()
453 (save-excursion
454 (planner-seek-to-first planner-appt-task-appointments-section)
455 (let ((bound (make-marker))
456 (lines-to-delete
457 (copy-sequence --planner-appt-lines-added-to-section))
458 line)
459 (save-excursion
460 (planner-appt-seek-to-end-of-current-section)
461 (set-marker bound (point)))
462 (dolist (appt (append --planner-appt-tasks-added-appts
463 --planner-appt-tasks-earlier-appts))
464 (setq line (funcall planner-appt-format-appt-section-line-function
465 (cadr appt)))
466 (setq lines-to-delete (delete line lines-to-delete))
467 (save-excursion
468 (unless (search-forward line bound t)
469 (insert line ?\n)))
470 ;; Remember the line even if it was already there
471 (push line --planner-appt-lines-added-to-section))
472 ;; Remove lines of deleted tasks
473 (dolist (del-line lines-to-delete)
474 (setq --planner-appt-lines-added-to-section
475 (delete del-line --planner-appt-lines-added-to-section))
476 (save-excursion
477 (when (search-forward del-line bound t)
478 (replace-match "")
479 (when (eq (char-after) ?\n)
480 (delete-char 1)))))
481 (set-marker bound nil))
482 ;; Use schedule sorting with some changes
483 (let ((planner-appt-schedule-section
484 planner-appt-task-appointments-section)
485 (planner-appt-schedule-regexp
486 (concat "\\(.*?\\)" ; to shift the match groups
487 planner-appt-schedule-basic-regexp)))
488 (planner-appt-schedule-sort))))
490 (defun planner-appt-update-appt-section-maybe ()
491 (when (and
492 ;; The appointment section is only relevant if the task
493 ;; method is used
494 (memq 'tasks planner-appt-methods)
495 planner-appt-task-use-appointments-section-flag)
496 (with-planner-update-setup
497 (save-excursion
498 (planner-goto-today)
499 (planner-appt-update-appt-section)))))
501 (defmacro with-planner-appt-update-section-disabled (&rest body)
502 `(let ((planner-appt-task-use-appointments-section-flag nil))
503 ,@body))
505 (put 'with-planner-appt-update-section-disabled 'lisp-indent-function 0)
506 (put 'with-planner-appt-update-section-disabled 'edebug-form-spec '(body))
508 ;; Compatibility fix for Xemacs [and for Emacs <21?]
509 (if (fboundp 'fit-window-to-buffer)
510 (defalias 'planner-fit-window-to-buffer 'fit-window-to-buffer)
511 (defalias 'planner-fit-window-to-buffer 'shrink-window-if-larger-than-buffer))
513 ;; Display Current Appointments
514 (defun planner-appt-show-alerts ()
515 "Display a list of currently active alerts in another window."
516 (interactive)
517 (let ((buf (get-buffer-create planner-appt-alert-buffer)))
518 (with-current-buffer buf
519 (erase-buffer)
520 (insert "Current alerts\n==============")
521 (if appt-time-msg-list
522 (dolist (appt appt-time-msg-list)
523 (insert "\n" (cadr appt)))
524 (insert "\nNone"))
525 (goto-char (point-min)))
526 (planner-fit-window-to-buffer (display-buffer buf))))
529 ;; Display/Insert Forthcoming Appointments
531 (defvar planner-appt-forthcoming-regexp
532 (concat "\\("
533 planner-appt-schedule-appt-regexp
534 "\\)\\|\\("
535 planner-live-task-regexp
536 planner-appt-task-regexp
537 "\\)"))
539 (defvar planner-appt-forthcoming-task-regexp
540 (concat planner-live-task-regexp
541 planner-appt-task-regexp))
543 (defun planner-appt-forthcoming-format-appt-description (time description)
544 (funcall
545 planner-appt-format-appt-section-line-function
546 (planner-appt-format-time-and-description
547 time
548 (planner-appt-format-description description))))
550 (defun planner-appt-forthcoming-task-data (info)
551 (let ((task-appt
552 (planner-appt-task-parse-task
553 (planner-task-description info))))
554 (when task-appt
555 (cons (appt-convert-time (nth 1 task-appt))
556 (planner-appt-forthcoming-format-appt-description
557 (nth 1 task-appt)
558 (nth 0 task-appt))))))
560 (defun planner-appt-forthcoming-get-appts (n &optional include-today)
561 (planner-save-buffers)
562 (let ((appts '())
563 (pages (planner-get-day-pages
564 (if include-today
565 (planner-today)
566 (planner-calculate-date-from-day-offset
567 (planner-today) 1))
568 (planner-calculate-date-from-day-offset
569 (planner-today) (if include-today n (1+ n)))))
570 cyclic-data cyclic-task-descriptions
571 line task-info task-data
572 date-absolute date time text)
573 ;; After scanning pages and [conditionally] cyclic entries, each
574 ;; element of appts has:
576 ;; (<absolute date>
577 ;; <time in appt format [minutes from midnight]>
578 ;; <date in planner format>
579 ;; description text)
581 ;; The first two elements are used for sorting/merging; they are
582 ;; removed from the returned list.
583 (when (and (featurep 'planner-cyclic)
584 planner-appt-forthcoming-look-at-cyclic-flag)
585 ;; Returns (<appts> . <list of planner-cyclic-ly formatted tasks>)
586 (setq cyclic-data (planner-appt-forthcoming-get-cyclic n))
587 (setq appts (car cyclic-data)
588 cyclic-task-descriptions (cdr cyclic-data)))
589 (with-temp-buffer
590 (with-planner
591 (dolist (page pages)
592 (when (file-exists-p (cdr page))
593 (setq date (car page))
594 (setq date-absolute (calendar-absolute-from-gregorian
595 (planner-filename-to-calendar-date
596 date)))
597 (insert-file-contents (cdr page))
598 (goto-char (point-min))
599 (while (re-search-forward planner-appt-forthcoming-regexp nil t)
600 (setq line (match-string 0))
601 (if (string-match planner-appt-schedule-appt-regexp line)
602 (unless (planner-appt-task-schedule-item-p line)
603 (setq time (save-match-data
604 (appt-convert-time (match-string 1 line)))
605 text (match-string 0 line)))
606 (setq task-info (planner-current-task-info))
607 (setq task-data (planner-appt-forthcoming-task-data task-info))
608 (when (and task-data
609 ;; Check for a cyclic task already added.
610 ;; This is a bit messy, since a task id
611 ;; won't have been added [and there might
612 ;; be other special case that I haven't
613 ;; anticipated].
614 (not (member
615 (if (string-match
616 "\\s-+{{Tasks:[0-9]+}}\\s-*"
617 (planner-task-description task-info))
618 (replace-match
619 "" nil t
620 (planner-task-description task-info))
621 (planner-task-description task-info))
622 cyclic-task-descriptions)))
623 (setq time (car task-data)
624 text (cdr task-data))))
625 (when (and time text)
626 ;; Add if it is not there already [there may be a
627 ;; duplicate if this is a schedule item derived from a
628 ;; task item]
629 (add-to-list 'appts (list date-absolute time date text))
630 (setq time nil text nil)))
631 (erase-buffer)))))
632 (when appts
633 (mapcar #'cddr
634 (sort appts
635 #'(lambda (a b)
636 (or (< (car a) (car b))
637 (and (= (car a) (car b))
638 (< (cadr a) (cadr b))))))))))
641 (defun planner-appt-forthcoming-get-cyclic (n)
642 (let ((appts '())
643 (cyclic-task-descriptions '())
644 date line time text task-info task-data)
645 (dolist (entry (planner-list-diary-entries
646 planner-cyclic-diary-file
647 (planner-filename-to-calendar-date
648 (planner-calculate-date-from-day-offset
649 (planner-today) 1))
650 (1- n)))
651 (setq date (planner-date-to-filename (car entry))
652 line (cadr entry))
653 (if (string-match planner-appt-schedule-appt-regexp line)
654 (setq time (save-match-data
655 (appt-convert-time (match-string 1 line)))
656 text (match-string 0 line))
657 (when (string-match planner-appt-forthcoming-task-regexp line)
658 (setq task-info (planner-task-info-from-string date line))
659 (setq task-data (planner-appt-forthcoming-task-data task-info))
660 (when task-data
661 ;; For duplicate checking: remember the description as
662 ;; it would be transformed by planner-cyclic.
663 (push (format planner-cyclic-task-description-format
664 (planner-task-description task-info) date)
665 cyclic-task-descriptions)
666 (setq time (car task-data)
667 text (cdr task-data)))))
668 (when (and time text)
669 (add-to-list
670 'appts
671 (list (calendar-absolute-from-gregorian (car entry))
672 time date text))
673 (setq time nil text nil)))
674 (cons appts cyclic-task-descriptions)))
676 ;; Format the data into a big string to make it easy either to put
677 ;; into a display buffer or into the day page.
678 (defun planner-appt-forthcoming-format (appt-data)
679 (let* ((last-date "")
680 (empty-cell-p (string-match
681 (format "\\`[%s]+\\'" muse-regexp-blank)
682 planner-appt-forthcoming-repeat-date-string))
683 (calendar-abbrev-length
684 ;; compatibility fix for Gnu Emacs < 22 and XEmacs
685 (if (boundp 'calendar-abbrev-length)
686 calendar-abbrev-length
688 (day-padding (make-string (1+ calendar-abbrev-length) ?\ )))
689 (mapconcat #'(lambda (a)
690 (prog1
691 (concat
692 (if (string= (car a) last-date)
693 (concat
694 (when planner-appt-forthcoming-show-day-names-flag
695 day-padding)
696 (if empty-cell-p
697 planner-appt-forthcoming-repeat-date-string
698 (planner-make-link
699 (car a)
700 planner-appt-forthcoming-repeat-date-string)))
701 (concat
702 (when planner-appt-forthcoming-show-day-names-flag
703 (concat
704 (calendar-day-name
705 (planner-filename-to-calendar-date (car a))
706 ;; compatibility:
707 calendar-abbrev-length)
708 " "))
709 (planner-make-link (car a))))
710 " | "
711 ;; Remove @s from times to avoid spurious
712 ;; highlighting.
713 (muse-replace-regexp-in-string
714 "@\\([ \t]*[0-9]\\)"
715 " \\1"
716 (cadr a)))
717 (setq last-date (car a))))
718 appt-data "\n")))
721 (defvar planner-appt-forthcoming-display-buffer
722 "*Forthcoming Appointments*"
723 "Buffer to display forthcoming appointments.")
725 (defun planner-appt-forthcoming-display (&optional days)
726 (interactive
727 ;; TODO: I wanted to use (interactive "p"), but that defaults to
728 ;; 1. Is this really the best way of getting nil as the default
729 ;; for a command that takes an optional integer prefix?:
730 (list (cond ((consp current-prefix-arg)
731 (car current-prefix-arg))
732 ((integerp current-prefix-arg)
733 current-prefix-arg)
734 (t nil))))
735 (unless days (setq days planner-appt-forthcoming-days))
736 (with-current-buffer
737 (get-buffer-create planner-appt-forthcoming-display-buffer)
738 (unless (planner-derived-mode-p 'planner-mode)
739 (setq muse-current-project (muse-project planner-project))
740 (planner-mode)
741 (cd (planner-directory)))
742 (delete-region (point-min) (point-max))
743 (insert "* Appointments in the next "
744 (number-to-string days)
745 (if (= days 1) " day" " days")
746 "\n\n"
747 (planner-appt-forthcoming-format
748 (planner-appt-forthcoming-get-appts
749 (or days planner-appt-forthcoming-days) t)))
750 (goto-char (point-min)))
751 (display-buffer planner-appt-forthcoming-display-buffer)
752 (planner-fit-window-to-buffer
753 (get-buffer-window planner-appt-forthcoming-display-buffer)))
756 (defun planner-appt-forthcoming-update-section (&optional days)
757 (interactive
758 (list (cond ((consp current-prefix-arg)
759 (car current-prefix-arg))
760 ((integerp current-prefix-arg)
761 current-prefix-arg)
762 (t nil))))
763 (with-planner-update-setup
764 (save-excursion
765 (planner-goto-today)
766 (planner-seek-to-first planner-appt-forthcoming-appt-section)
767 (delete-region (point)
768 (planner-appt-seek-to-end-of-current-section))
769 (insert (planner-appt-forthcoming-format
770 (planner-appt-forthcoming-get-appts
771 (or days planner-appt-forthcoming-days)))
772 ?\n))))
775 ;; A function suitable for planner-mode-hook
776 (defun planner-appt-forthcoming-update-section-maybe ()
777 (when (planner-appt-todays-page-p)
778 (planner-appt-forthcoming-update-section)))
781 ;;; Alerts From Task Descriptions
783 ;; Add a bit of [premature] optimization, mainly for updating
784 ;; functions where the same task gets examined often.
785 (defvar --planner-appt-task-cache (make-hash-table :test 'equal))
787 (defun planner-appt-task-parse-task (description)
788 "Extract appointment time and text from the DESCRIPTION.
789 Return a list (text time). If the task is not an
790 appointment, time defaults to nil."
791 (or (gethash description --planner-appt-task-cache)
792 (puthash
793 description
794 (if (string-match planner-appt-task-regexp description)
795 (list (substring description (match-end 0))
796 (substring description (match-beginning 1) (match-end 1)))
797 (list description nil))
798 --planner-appt-task-cache)))
800 (defun planner-appt-task-nagging-p (description)
801 "Return non-nil if task DESCRIPTION is a nagging appointment."
802 (string-match planner-appt-task-nagging-regexp description))
804 (defun planner-appt-task-member (description time appt-list)
805 "Return non-nil if DESCRIPTION at TIME in APPT-LIST has been scheduled."
806 (member (planner-appt-make-appt-element time description) appt-list))
809 ;; Integration with planner-schedule.el
811 (defvar planner-appt-schedule-task-estimate-regexp
812 (concat "[!@][ \t]*\\(?:" ; "shy" form of planner-appt-task-regexp
813 planner-appt-time-regexp
814 "\\)[ \t]*"
815 "\\s-*\\([0-9]+[smhdw]\\)")
816 "Regular expression matching a task time estimate.")
818 ;; NB: The following advice could be avoided if the regexp were not
819 ;; hard-coded into the original function.
821 ;; NNB: This is not well tested!
823 (defadvice planner-schedule-task-estimate (around planner-appt-task disable)
824 "Modify the regexp matched to take appointments into account."
825 (when (string-match planner-appt-schedule-task-estimate-regexp
826 (planner-task-description info))
827 (schedule-duration-to-seconds
828 (match-string 2 (planner-task-description info)))))
831 (defun planner-appt-task-add (&optional info)
832 "Create an appointment from the current task if this is today's plan.
833 Return t if an appointment was added.
834 If the task is an appointment, it is not cancelled, it is scheduled for
835 later today, and is not already added.
836 Optional argument: use INFO instead of the current task info."
837 (interactive)
838 (let* ((info (or info
839 ;; Unfortunately, in emacs-lisp there are no
840 ;; defaults for optional arguments, so one can't
841 ;; distinguish between null info in an arg and null
842 ;; info from planner-current-task-info; so the
843 ;; error message might be uninformative here.
844 (planner-current-task-info)
845 (error "There is no task on the current line")))
846 (appt (planner-appt-task-parse-task
847 (planner-task-description info)))
848 (time (nth 1 appt))
849 (desc (and time (planner-appt-format-description (nth 0 appt)))))
850 (when (and time
851 (not (string= (planner-task-status info) "C"))
852 (string= (planner-task-date info)
853 (planner-date-to-filename
854 (decode-time (current-time))))
855 (not (planner-appt-task-member desc time
856 appt-time-msg-list)))
857 (if (planner-appt-earlier-than-now-p time)
858 (progn
859 ;; Remember earlier appts separately [principally for
860 ;; their addition in an appointment section].
861 (unless (planner-appt-task-member
862 desc time --planner-appt-tasks-earlier-appts)
863 (setq --planner-appt-tasks-earlier-appts
864 (planner-appt-remember-appt
865 time desc
866 --planner-appt-tasks-earlier-appts)))
867 (planner-appt-update-appt-section-maybe)
868 ;; Make sure nil is returned.
869 nil)
870 (appt-add time desc)
871 ;; Keep track of tasks added by this function.
872 (setq --planner-appt-tasks-added-appts
873 (planner-appt-remember-appt
874 time desc
875 --planner-appt-tasks-added-appts))
876 (planner-appt-update-appt-section-maybe)
877 t))))
879 (defun planner-appt-task-delete (&optional info)
880 "Delete the appointment from the current task if this is today's plan.
881 Do not remove the time string.
882 Return any deleted appointments.
883 Optional argument: use INFO instead of the current task info."
884 (interactive)
885 (let* ((info (or info
886 ;; See planner-appt-task-add for comments about
887 ;; the possibly uninformative error message.
888 (planner-current-task-info)
889 (error "There is no task on the current line")))
890 (appt (planner-appt-task-parse-task
891 (planner-task-description info)))
892 (time (nth 1 appt))
893 (desc (and time (planner-appt-format-description (nth 0 appt))))
894 (tmp-msg-list appt-time-msg-list))
895 (when time
896 ;; Method from appt-delete
897 (let ((deleted-appts '())
898 (earlier-appt
899 (car (planner-appt-task-member
900 desc time --planner-appt-tasks-earlier-appts)))
901 element)
902 ;; NB: Mustn't concat time onto description until earlier-appt
903 ;; has been determined [since planner-appt-task-member does
904 ;; the concat itself [this could be improved somehow]]
905 (setq desc (concat time " " desc))
906 (while tmp-msg-list
907 (setq element (car tmp-msg-list))
908 (when (string= (car (cdr element)) desc)
909 (push element deleted-appts)
910 (setq appt-time-msg-list (delq element appt-time-msg-list))
911 (setq --planner-appt-tasks-added-appts
912 (planner-appt-forget-appt
913 element --planner-appt-tasks-added-appts)))
914 (setq tmp-msg-list (cdr tmp-msg-list)))
915 (when (or deleted-appts earlier-appt)
916 ;; Forget a deleted appt that was earlier than now.
917 (when earlier-appt
918 (setq --planner-appt-tasks-earlier-appts
919 (planner-appt-forget-appt
920 earlier-appt --planner-appt-tasks-earlier-appts)))
921 (planner-appt-update-appt-section-maybe))
922 deleted-appts))))
924 (defun planner-appt-add-appts-from-tasks ()
925 "Parse all of today's tasks and add appointments automatically."
926 (interactive)
927 (when (planner-appt-todays-page-p)
928 ;; Clear old appts added by this function.
929 (planner-appt-clear-appts --planner-appt-tasks-added-appts)
930 (setq --planner-appt-tasks-added-appts '()
931 --planner-appt-tasks-earlier-appts '())
932 (let ((case-fold-search nil))
933 (save-excursion
934 (goto-char (point-min))
935 (with-planner-appt-update-section-disabled
936 (while (re-search-forward
937 (concat planner-live-task-regexp
938 planner-appt-task-regexp)
939 nil t)
940 (planner-appt-task-add))))
941 (when (or --planner-appt-tasks-added-appts
942 --planner-appt-tasks-earlier-appts)
943 (planner-appt-update-appt-section-maybe)))))
945 ;;; Advice
947 ;; for speedy enabling and disabling of advice:
949 (defvar --planner-appt-advice '()
950 "Internal variable: List of advices added by `planner-appt-defadvice'.
951 Each element is a list of args for `ad-enable-advice' and
952 `ad-disable-advice'.")
954 (eval-and-compile
955 (defvar planner-appt-advice-common-flags
956 '(preactivate disable)
957 "Advice flags common to all planner-appt advice."))
959 (defmacro planner-appt-defadvice (function args doc &rest body)
960 "Advise FUNCTION with ARGS, DOC and BODY.
961 Remembers the advice function and args in `--planner-appt-advice'."
962 `(prog1
963 (defadvice ,function
964 (,@args ,@planner-appt-advice-common-flags) ,doc ,@body)
965 (let ((info '(,function ,(car args) ,(cadr args))))
966 (unless (member info --planner-appt-advice)
967 (push info --planner-appt-advice)))))
969 (put 'planner-appt-defadvice
970 'edebug-form-spec
971 '(&define name
972 (name name &rest sexp)
973 stringp
974 [&optional
975 ("interactive" interactive)]
976 def-body))
978 (put 'planner-appt-defadvice 'lisp-indent-function 'defun)
980 ;; See what happened with the preactivation.
981 (planner-appt-debug
982 (progn
983 (require 'trace)
984 (trace-function-background
985 'ad-cache-id-verification-code
986 "*planner-appt advice trace*")))
988 (defun planner-appt-disable-all-advice ()
989 "Disable all advice added with `planner-appt-defadvice'."
990 (mapcar #'(lambda (args)
991 (apply #'ad-disable-advice args)
992 (ad-activate (car args)))
993 --planner-appt-advice))
995 (defun planner-appt-enable-all-advice ()
996 "Enable all advice added with `planner-appt-defadvice'."
997 (mapcar #'(lambda (args)
998 (apply #'ad-enable-advice args)
999 (ad-activate (car args)))
1000 --planner-appt-advice))
1003 (defmacro with-planner-appt-task-advice-disabled (&rest body)
1004 "Evaluate BODY forms with all advice matching \"planner-appt-task\" disabled."
1005 `(unwind-protect
1006 (progn
1007 (planner-appt-disable-all-advice)
1008 (planner-appt-debug-message "all advice disabled")
1009 ,@body)
1010 (planner-appt-enable-all-advice)
1011 (planner-appt-debug-message "all advice enabled")))
1013 (put 'with-planner-appt-task-advice-disabled 'lisp-indent-function 0)
1014 (put 'with-planner-appt-task-advice-disabled 'edebug-form-spec '(body))
1016 (planner-appt-defadvice planner-task-cancelled
1017 (before planner-appt-task)
1018 "Delete the appointment as well."
1019 (planner-appt-debug-message
1020 "*** called advice on planner-task-cancelled")
1021 (planner-appt-task-delete))
1023 (planner-appt-defadvice planner-task-done
1024 (before planner-appt-task)
1025 "Delete the appointment as well."
1026 (planner-appt-debug-message
1027 "*** called advice on planner-task-done")
1028 (planner-appt-task-delete))
1030 (planner-appt-defadvice planner-delete-task
1031 (before planner-appt-task)
1032 "Delete the appointment as well."
1033 (planner-appt-debug-message
1034 "*** called advice on planner-delete-task")
1035 (planner-appt-task-delete))
1037 ;; The advice for planner-update-task is quite tricky. A task will
1038 ;; need updating [for appointments] if the task is dated today and the
1039 ;; description differs from other task lines linked to by the current
1040 ;; task. If this is true, we have to examine all the other links,
1041 ;; delete any appointments, and then add the task after planner-update
1042 ;; has been called. Note that it is only possible for this to happen
1043 ;; if planner-id is loaded since otherwise the "same" task line can't
1044 ;; have different descriptions.
1046 (defun planner-appt-get-diff-links (info)
1047 "Given INFO, return a list of tasks linked to it whose info differs."
1048 (let ((diffs '())
1049 (linked-info))
1050 ;; Todo: with-planner-update-setup really ought to return the
1051 ;; value of the body.
1052 (with-planner-update-setup
1053 ;; Preserve point as well.
1054 (save-excursion
1055 (dolist (link
1056 (if (featurep 'planner-multi)
1057 (planner-multi-link-delete
1058 (planner-task-page info)
1059 (planner-multi-task-link-as-list info))
1060 (list (planner-task-link info))))
1061 (when (and (planner-find-file (planner-link-base link))
1062 (planner-find-task info)
1063 (setq linked-info (planner-current-task-info))
1064 (not (planner-tasks-equal-p info linked-info)))
1065 (push linked-info diffs)))))
1066 diffs))
1068 (planner-appt-defadvice planner-update-task
1069 (around planner-appt-task)
1070 "Update the appointment as well."
1071 (planner-appt-debug-message
1072 "*** called advice on planner-update-task")
1073 (let* ((info (planner-current-task-info))
1074 (diff-linked
1075 (and (featurep 'planner-id)
1076 (string= (planner-task-date info) (planner-today))
1077 (planner-appt-get-diff-links info))))
1078 (with-planner-appt-task-advice-disabled ad-do-it)
1079 (when diff-linked
1080 (dolist (i diff-linked)
1081 (planner-appt-task-delete i))
1082 (planner-appt-task-add))))
1084 ;; For planner-id-update-tasks-on-page, it is actually much faster to
1085 ;; update today's page after it has done its work rather than using
1086 ;; the update advice above.
1088 (planner-appt-defadvice planner-id-update-tasks-on-page
1089 (around planner-appt-task)
1090 "Update today's appointments as well."
1091 (planner-appt-debug-message
1092 "*** called advice on planner-id-update-tasks-on-page")
1093 (with-planner-appt-task-advice-disabled ad-do-it)
1094 (with-planner-update-setup
1095 (save-excursion
1096 (planner-goto-today)
1097 ;; Update the appointments section afterwards for efficiency.
1098 (with-planner-appt-update-section-disabled
1099 (planner-appt-update))
1100 (planner-appt-update-appt-section-maybe))))
1102 (defvar --planner-appt-planning nil
1103 "Internal flag:
1104 Lets planner-appt advice know that it has been called within a call to
1105 `plan'.")
1107 (planner-appt-defadvice plan (around planner-appt-task)
1108 "Note that plan is in progress."
1109 (planner-appt-debug-message
1110 "*** called advice on plan")
1111 (let ((--planner-appt-planning t))
1112 ad-do-it))
1114 (planner-appt-defadvice planner-copy-or-move-task
1115 (around planner-appt-task)
1116 "Update the appointment as well."
1117 (planner-appt-debug-message
1118 "*** called advice on planner-copy-or-move-task; "
1119 (if --planner-appt-planning
1120 "in plan"
1121 "not in plan"))
1122 (cond ((not --planner-appt-planning)
1123 (let
1124 ;; Save the appt information for error cleanup and
1125 ;; appointment adding.
1126 ((deleted-appts (planner-appt-task-delete))
1127 (old-info (planner-current-task-info)))
1128 (condition-case err
1129 (progn
1130 (with-planner-appt-task-advice-disabled ad-do-it)
1131 ;; If the task was moved to today, add it.
1132 (when (and date ; Bound in the advised function.
1133 (string= date (planner-today)))
1134 ;; Fiddle the old info so it looks like
1135 ;; today's. NB: would need changing should
1136 ;; the task-info format ever change.
1138 ;; planner-multi uses the date in the link for
1139 ;; planner-task-date [why?], so that has to be
1140 ;; modified too. This has to be done before the
1141 ;; date element is changed, of course.
1142 (when (and (featurep 'planner-multi)
1143 (consp (nth 5 old-info))) ; the link element
1144 (setcar (or
1145 (member (nth 8 old-info)
1146 (nth 5 old-info))
1147 ;; Silly way of avoiding an error if the
1148 ;; date is not in the list: can the date
1149 ;; not be in the list?
1150 '(nil))
1151 date))
1152 ;; Set the date element.
1153 (setcar (nthcdr 8 old-info) date)
1154 (planner-appt-task-add old-info)))
1155 ('error
1156 ;; Catch errors in planner-copy-or-move-task: restore
1157 ;; deleted tasks.
1158 (dolist (d deleted-appts)
1159 (push d appt-time-msg-list))
1160 (error (error-message-string err))))))
1162 ;; `plan' in progress: only move the task if it is not a
1163 ;; regular (non-nagging) appointment. If it's a nagging
1164 ;; appointment, remove the appointment and then move the
1165 ;; task.
1166 (let* ((info (planner-current-task-info))
1167 (appt (planner-appt-task-parse-task
1168 (planner-task-description info)))
1169 (time (nth 1 appt)))
1170 (with-planner-appt-task-advice-disabled
1171 (if (planner-appt-task-nagging-p (planner-task-description info))
1172 (progn (planner-edit-task-description (nth 0 appt))
1173 ad-do-it)
1174 (if (and info time)
1175 ;; Fri Nov 25 13:59:02 GMT 2005: Fix for new [?]
1176 ;; behaviour of planner-copy-or-move-region.
1177 (progn
1178 (forward-line -1)
1179 ;; Return nil, otherwise
1180 ;; planner-copy-or-move-region's count will be
1181 ;; wrong.
1182 (setq ad-return-value nil))
1183 ad-do-it)))))))
1185 ;; NB: this advice leads to two updates of the task appointment
1186 ;; section [when updating it is enabled, of course]: it is hard to see
1187 ;; how to avoid this unless there is yet another global variable
1188 ;; tracking deleted appts.
1189 (planner-appt-defadvice planner-edit-task-description
1190 (around planner-appt-task)
1191 "Update the appointment as well."
1192 (planner-appt-debug-message
1193 "*** called advice on planner-edit-task-description")
1194 (planner-appt-task-delete)
1195 (with-planner-appt-task-advice-disabled ad-do-it)
1196 (planner-appt-task-add))
1198 ;; planner-create-task-from-info: The appointment adding needs doing
1199 ;; after all hooks to planner-create-task-from-info have been run so
1200 ;; that planner-appt-task-add has the correct task line; planner-id,
1201 ;; for example, adds a task id so if the planner-appt hook is run
1202 ;; first it won't have the right task description.
1204 ;; Hence these shenanigans:
1206 (defvar --planner-appt-created-task-marker (make-marker))
1207 (defvar --planner-appt-close-the-buffer-flag nil)
1209 (eval-when-compile
1210 ;; Hide warning about live-buffers [q.v.].
1211 (defvar live-buffers))
1213 (defun planner-appt-create-task-hook-func ()
1214 "One half of planner-appt create task handling.
1215 Remembers the position of the added task. The other half of the
1216 handling is in advice to `planner-create-task-from-info'."
1217 (set-marker --planner-appt-created-task-marker (point))
1218 ;; If planner-tasks-file-behavior is 'close, it won't be possible to
1219 ;; recover the position from a marker, so temporarily defeat closing
1220 ;; this file, and close it if necessary in the
1221 ;; planner-create-task-from-info advice.
1222 (setq --planner-appt-close-the-buffer-flag
1223 (if (and (eq planner-tasks-file-behavior 'close)
1224 ;; `live-buffers' is defined in
1225 ;; planner-create-task-from-info, but it is not
1226 ;; defined in the planner-multi advice [hmm...].
1227 (boundp 'live-buffers)
1228 (not (memq (current-buffer) live-buffers)))
1229 ;; Adding the buffer to `live-buffers' means it won't be
1230 ;; closed automatically.
1231 (progn (push (current-buffer) live-buffers) t)
1232 nil)))
1235 (planner-appt-defadvice planner-create-task-from-info
1236 (around planner-appt-task)
1237 "Add an appointment alert for the new task if necessary."
1238 (planner-appt-debug-message
1239 "*** called advice on planner-create-task-from-info")
1240 (with-planner-appt-task-advice-disabled ad-do-it)
1241 (let ((buf (marker-buffer --planner-appt-created-task-marker))
1242 (pos (marker-position --planner-appt-created-task-marker)))
1243 (when buf
1244 (with-current-buffer buf
1245 (save-excursion
1246 (goto-char pos)
1247 (planner-appt-task-add)))
1248 (set-marker --planner-appt-created-task-marker nil)
1249 (when --planner-appt-close-the-buffer-flag
1250 ;; Use planner-save-buffers for consistency; remove the buffer
1251 ;; from buffer-list so that it gets closed.
1252 (planner-save-buffers (delq buf (buffer-list)))))))
1254 (defun planner-appt-task-insinuate ()
1255 "Do task-specific insinuation into `planner-mode'."
1256 ;; Nothing at the moment!
1259 ;; In case of breakage while developing
1260 ;; NB: remember to remove hooks locally where relevant
1261 (defun planner-appt-task-de-insinuate ()
1262 "Remove task-specific hooks."
1263 ;; Nothing at the moment!
1267 ;;; Alerts From The Schedule
1269 (defvar --planner-appt-schedule-added-appts '()
1270 "Internal variable: Tracks added schedule-based appointment alerts.")
1272 (defun planner-appt-add-appts-from-schedule ()
1273 "Add appointment reminders from the schedule if this is today's plan."
1274 (interactive)
1275 (when (planner-appt-todays-page-p)
1276 ;; Delete old appts created by this function.
1277 (planner-appt-clear-appts --planner-appt-schedule-added-appts)
1278 (setq --planner-appt-schedule-added-appts '())
1279 (save-excursion
1280 (planner-seek-to-first planner-appt-schedule-section)
1281 (let ((bound (save-excursion
1282 (planner-appt-seek-to-end-of-current-section)))
1283 line time text task-item-p)
1284 ;; There are no entries in the schedule unless bound is
1285 ;; greater than point.
1286 (when (> bound (point))
1287 (while (re-search-forward
1288 planner-appt-schedule-appt-regexp bound t)
1289 (setq line (planner-match-string-no-properties 0)
1290 time (planner-match-string-no-properties 1)
1291 text (save-match-data
1292 (planner-appt-format-description
1293 (planner-match-string-no-properties 3)))
1294 task-item-p
1295 (planner-appt-task-schedule-item-p (match-string 0)))
1296 (unless (or task-item-p
1297 (planner-appt-earlier-than-now-p time))
1298 (appt-add time text)
1299 ;; Remember tasks added here.
1300 (setq --planner-appt-schedule-added-appts
1301 (planner-appt-remember-appt
1302 time text --planner-appt-schedule-added-appts)))))))))
1304 (defun planner-appt-schedule-insinuate ()
1305 "Do schedule specific insinuation into `planner-mode'."
1306 ;; Nothing at the moment!
1309 (defun planner-appt-schedule-de-insinuate ()
1310 "Remove schedule-based hooks."
1311 ;; Nothing at the moment!
1314 ;; Make appt-make-list behave.
1316 (defadvice appt-make-list (after planner-appt activate)
1317 "Restore appointments added by planner-appt."
1318 (dolist (appt (append --planner-appt-tasks-added-appts
1319 --planner-appt-schedule-added-appts))
1320 (unless (member appt appt-time-msg-list)
1321 (push appt appt-time-msg-list)))
1322 (setq appt-time-msg-list (appt-sort-list appt-time-msg-list)))
1324 ;;; Sorting the Schedule
1326 (defun planner-appt-schedule-sort ()
1327 "Sort the schedule in the current page."
1328 (interactive)
1329 (save-excursion
1330 (save-restriction
1331 (planner-seek-to-first planner-appt-schedule-section)
1332 (narrow-to-region (point)
1333 (save-excursion
1334 (planner-appt-seek-to-end-of-current-section)
1335 (point)))
1336 (sort-subr nil 'forward-line 'end-of-line
1337 #'(lambda ()
1338 (goto-char (planner-line-beginning-position))
1339 (if (looking-at planner-appt-schedule-regexp)
1340 (appt-convert-time
1341 (match-string 2))
1342 ;; 1+ max number of minutes from midnight
1343 1441))
1344 nil))))
1346 ;;; Cyclical Schedule Entries
1348 (require 'diary-lib)
1350 (eval-when-compile
1351 (defvar planner-cyclic-diary-file))
1353 ;; Purloined from planner-cyclic.el.
1354 (defun planner-appt-schedule-get-cyclic-tasks (date &optional no-of-days)
1355 "For DATE, get the cyclic tasks.
1356 Optional argument get tasks for NO-OF-DAYS from DATE, the default is 1
1357 day [i.e., only for DATE]."
1358 (let ((date (if (stringp date)
1359 (planner-filename-to-calendar-date date)
1360 date)))
1361 (delq nil
1362 (mapcar #'(lambda (item)
1363 (when (string-match planner-appt-schedule-regexp
1364 (elt item 1))
1365 (match-string 0 (elt item 1))))
1366 (planner-list-diary-entries planner-cyclic-diary-file
1367 date no-of-days)))))
1369 (defun planner-appt-schedule-add-cyclic ()
1370 "Add cylical tasks to the schedule if the current buffer is a day page."
1371 (when (string-match planner-date-regexp (planner-page-name))
1372 (let ((entries
1373 (planner-appt-schedule-get-cyclic-tasks (planner-page-name))))
1374 (when entries
1375 (planner-seek-to-first planner-appt-schedule-section)
1376 (let ((start (point)))
1377 (dolist (entry entries)
1378 ;; Only insert if the entry is not already there.
1379 (unless (save-excursion
1380 (goto-char start)
1381 (search-forward entry nil t))
1382 (insert entry ?\n))))
1383 ;; Lazy way of putting them in the right place.
1384 (when planner-appt-sort-schedule-on-update-flag
1385 (planner-appt-schedule-sort))))))
1387 (defun planner-appt-schedule-add-cyclic-maybe ()
1388 "Add cylical tasks to the schedule.
1389 Behaviour depends upon `planner-appt-schedule-cyclic-behaviour'."
1390 (when (and (not (string< (planner-page-name) (planner-today)))
1391 (or (eq planner-appt-schedule-cyclic-behaviour 'future)
1392 (and
1393 (eq planner-appt-schedule-cyclic-behaviour 'today)
1394 (planner-appt-todays-page-p))))
1395 (planner-appt-schedule-add-cyclic)))
1397 (defun planner-appt-schedule-cyclic-insinuate ()
1398 "Insinuate the adding of cyclical schedule entries."
1399 ;; TODO: Add locally?
1400 (planner-appt-add-hook 'planner-mode-hook
1401 'planner-appt-schedule-add-cyclic-maybe nil t))
1403 (defun planner-appt-schedule-cyclic-de-insinuate ()
1404 "Remove cyclic schedule adding functionality."
1405 (remove-hook 'planner-mode-hook
1406 'planner-appt-schedule-add-cyclic-maybe))
1409 ;;; Common Functions
1412 ;; So that one doesn't have to use two separate commands when using
1413 ;; both methods:
1415 (defvar --planner-appt-updated nil)
1417 ;;;###autoload
1418 (defun planner-appt-update ()
1419 "Update the appointments on the current page."
1420 (interactive)
1421 ;; NB: Task adding has to be done before the schedule to avoid
1422 ;; duplicates if task appointments are copied to the schedule.
1423 (when (memq 'tasks planner-appt-methods)
1424 (planner-appt-add-appts-from-tasks))
1425 (when (memq 'schedule planner-appt-methods)
1426 (planner-appt-add-appts-from-schedule))
1427 (when (and planner-appt-sort-schedule-on-update-flag
1428 (planner-appt-todays-page-p))
1429 (planner-appt-schedule-sort))
1430 (run-hooks 'planner-appt-update-hook)
1431 ;; TODO: Use a belt and some braces: see comments in
1432 ;; `planner-appt-insinuate-if-today'.
1433 (setq --planner-appt-updated t))
1435 (defun planner-appt-update-for-write ()
1436 (when planner-appt-update-appts-on-save-flag
1437 (planner-appt-update)
1438 ;; Return nil for local-write-file-hooks.
1439 nil))
1441 ;; NB: Something like the above could be done for other hooks as
1442 ;; well...
1445 ;;; General Insinuation
1447 ;; This indirect method is used rather than some variable so that the
1448 ;; function advice can be avoided if it is not necessary [when using
1449 ;; schedule appointments exclusively].
1452 (defun planner-appt-use (source)
1453 "Use SOURCE to derive appointments from plan pages.
1454 Possible values for SOURCE are:
1455 'tasks [use today's task descriptions]
1456 'schedule [use today's schedule]
1457 '(tasks schedule) [use both tasks and schedule]."
1458 (dolist (s (if (listp source)
1459 source
1460 (list source)))
1461 (cond ((eq s 'tasks)
1462 ;; Add task-specific non-insinuating code here.
1463 ;; ;; Only activate advice when necessary.
1464 ;; (ad-enable-regexp "planner-appt-task")
1465 ;; (ad-activate-regexp "planner-appt-task")
1466 ;; An outstanding global hook [planner-appt-task-add tests
1467 ;; for today-ness anyway].
1468 (planner-appt-add-hook 'planner-create-task-hook
1469 'planner-appt-create-task-hook-func nil t)
1470 (add-to-list 'planner-appt-methods s))
1471 ((eq s 'schedule)
1472 ;; Add schedule task-specific non-insinuating code here.
1473 (add-to-list 'planner-appt-methods s))
1475 (error "Invalid appointment source %s" s))))
1476 ;; Add here any non method-specific code that should be executed
1477 ;; even if planner-appt-insinuate is not called.
1478 (if (memq 'tasks planner-appt-methods)
1479 (planner-appt-enable-all-advice)
1480 (planner-appt-disable-all-advice))
1481 (planner-appt-add-hook 'planner-mode-hook
1482 'planner-appt-font-setup nil t)
1483 ;; Might as well return something interesting.
1484 planner-appt-methods)
1486 ;;;###autoload
1487 (defun planner-appt-insinuate-if-today ()
1488 (when (planner-appt-todays-page-p)
1489 (planner-appt-add-hook 'planner-mode-hook
1490 'planner-appt-update t)
1491 ;; Add method specific things
1492 (when (memq 'tasks planner-appt-methods)
1493 (planner-appt-task-insinuate))
1494 (when (memq 'schedule planner-appt-methods)
1495 (planner-appt-schedule-insinuate))
1496 (planner-appt-add-hook planner-appt-write-file-hook
1497 'planner-appt-update-for-write t)
1498 ;; TODO: Under some conditions, as yet undetermined, an update is
1499 ;; not done when `plan' is called for the first time. So do an
1500 ;; update, but only if there hasn't been one already.
1502 ;; Fri 15 Apr 2005 16:26:04 BST: this has probably been sorted out
1503 ;; now, but it doesn't do any harm to leave this in for now, just
1504 ;; in case.
1505 (unless --planner-appt-updated
1506 (planner-appt-update))))
1508 ;;;###autoload
1509 (defun planner-appt-insinuate ()
1510 "Insinuate appointment alerting into planner mode.
1511 Appointment methods should be set up first using one of:
1512 `planner-appt-use-tasks'
1513 `planner-appt-use-schedule'
1514 `planner-appt-use-tasks-and-schedule'."
1515 (unless planner-appt-methods
1516 (error
1517 "No appointment source methods. Use one of:
1518 `planner-appt-use-tasks'
1519 `planner-appt-use-schedule'
1520 `planner-appt-use-tasks-and-schedule'
1521 before you call this function"))
1522 ;; Initialize the appt system according to emacs type and version.
1523 (cond ((fboundp 'appt-activate) ; Gnu Emacs >= 22
1524 (appt-activate 1))
1525 ((fboundp 'appt-initialize) ; Xemacs
1526 ;; appt-initialize needs a diary file, so create one if it
1527 ;; doesn't already exist
1528 (unless (file-exists-p diary-file)
1529 (with-temp-buffer
1530 (insert ?\n)
1531 (write-region (point-min) (point-max) diary-file)))
1532 (display-time)
1533 (appt-initialize))
1534 (t (display-time) ; Gnu Emacs < 22
1535 (add-hook 'diary-hook 'appt-make-list)))
1536 (planner-appt-add-hook 'planner-mode-hook
1537 'planner-appt-insinuate-if-today t t))
1539 ;; Remove hooks if there is something not working during testing.
1540 (defun planner-appt-de-insinuate ()
1541 "Remove all hooks associated with planner-appt.
1542 Use in an emergency if breakage in planner-appt interferes with your planning."
1543 (interactive)
1544 (remove-hook 'planner-mode-hook 'planner-appt-insinuate-if-today)
1545 (remove-hook 'mark-diary-entries-hook 'planner-appt-mark-calendar-maybe)
1546 (when (get-buffer (planner-today))
1547 (with-current-buffer (get-buffer (planner-today))
1548 ;; NB: Remember to remove locally where appropriate.
1549 (remove-hook 'planner-goto-hook
1550 'planner-appt-update t)
1551 (remove-hook 'planner-mode-hook
1552 'planner-appt-update t)
1553 (remove-hook planner-appt-write-file-hook
1554 'planner-appt-update-for-write t)
1555 (remove-hook 'planner-create-task-hook
1556 'planner-appt-create-task-hook-func)
1557 (planner-appt-task-de-insinuate)
1558 (planner-appt-schedule-de-insinuate)
1559 (planner-appt-schedule-cyclic-de-insinuate)))
1560 (planner-appt-disable-all-advice)
1561 (message "Planner-appt de-insinuated."))
1564 ;;; Convenient Functions For Users' Configuration.
1566 ;;;###autoload
1567 (defun planner-appt-use-tasks ()
1568 "Use tasks to derive appointment alerts."
1569 (planner-appt-use 'tasks))
1571 ;;;###autoload
1572 (defun planner-appt-use-schedule ()
1573 "Use the schedule to derive appointment alerts."
1574 (planner-appt-use 'schedule))
1576 ;;;###autoload
1577 (defun planner-appt-use-tasks-and-schedule ()
1578 "Use both tasks and the schedule to derive appointment alerts."
1579 (planner-appt-use '(tasks schedule)))
1581 ;;; Font Highlighting
1583 (defface planner-appt-face '((t (:foreground "green")))
1584 "Face for scheduled time."
1585 :group 'planner-appt)
1587 (defface planner-appt-overdue-face '((t (:foreground "red")))
1588 "Face for scheduled, but overdue time."
1589 :group 'planner-appt)
1591 (defun planner-appt-task-highlight-face (time)
1592 "Return appropriate face, depending on TIME.
1593 If TIME is earlier than now, return `planner-appt-face', else
1594 return `planner-appt-overdue-face'."
1595 (if (planner-appt-earlier-than-now-p time)
1596 'planner-appt-overdue-face
1597 'planner-appt-face))
1599 (defun planner-appt-task-highlight (beg end &optional verbose)
1600 "Highlight appointment times in tasks from BEG to END.
1601 VERBOSE is ignored."
1602 (when planner-appt-font-lock-appointments-flag
1603 (goto-char beg)
1604 (while (re-search-forward planner-appt-task-regexp end t)
1605 (when (or (not planner-appt-limit-highlighting-flag)
1606 (save-excursion
1607 (goto-char (planner-line-beginning-position))
1608 (save-match-data
1609 (or (and (looking-at planner-live-task-regexp)
1610 (string= (planner-task-date
1611 (planner-current-task-info))
1612 (planner-today)))
1613 (and
1614 (planner-appt-todays-page-p)
1615 (looking-at planner-appt-schedule-appt-regexp))))))
1616 (planner-highlight-region
1617 (match-beginning 1)
1618 (match-end 1)
1619 'planner-appt 60
1620 (list 'face
1621 (planner-appt-task-highlight-face
1622 (match-string 1))))))))
1624 (defun planner-appt-font-setup ()
1625 "Hook into `planner-mode'."
1626 (planner-appt-add-hook 'muse-colors-buffer-hook
1627 'planner-appt-task-highlight t))
1629 ;;; Calendar Marking
1631 ;; This is not strictly part of appointment handling, but if the
1632 ;; diary is to be by-passed for appointments, it makes sense to mark
1633 ;; the calendar using day pages.
1636 ;; Use a different face from the diary-entry-marker so we can
1637 ;; see where the different marks come from.
1638 (defface planner-appt-entry-marker
1639 '((t (:foreground "indianred")))
1640 "Face for planner day page mark in the calendar."
1641 :group 'planner-appt)
1644 (defun planner-appt-mark-calendar (&optional from to)
1645 "Mark dates in the calendar that have day pages.
1646 Optional args: mark dates from FROM to TO.
1647 FROM and to are lists: (month day year)."
1648 (with-current-buffer calendar-buffer ; Needed to get displayed date
1649 ; information.
1650 (let* ((displayed-month-last
1651 (1+ (cdr (assq 'displayed-month
1652 (buffer-local-variables)))))
1653 (displayed-year
1654 (cdr (assq 'displayed-year
1655 (buffer-local-variables))))
1656 (today-filename (planner-today))
1657 (today (planner-filename-to-calendar-date today-filename)))
1658 ;; Do nothing if the calendar is currently showing all months
1659 ;; earlier than today.
1660 (when (and (>= (elt today 2) ; year
1661 displayed-year)
1662 (>= displayed-month-last
1663 (elt today 0))) ; month
1664 (let ((diary-entry-marker 'planner-appt-entry-marker)
1665 (day-pages
1666 (planner-get-day-pages
1667 (if from
1668 (planner-date-to-filename from)
1669 today-filename)
1670 (if to
1671 (planner-date-to-filename to)
1672 ;; The default is last day visible
1673 ;; in the calendar.
1674 (planner-date-to-filename
1675 (list displayed-month-last 31 displayed-year))))))
1676 (dolist (day-page day-pages)
1677 (apply #'mark-calendar-date-pattern
1678 (planner-filename-to-calendar-date (car day-page)))))))))
1680 (defun planner-appt-calendar-insinuate ()
1681 (add-hook 'mark-diary-entries-hook 'planner-appt-mark-calendar))
1683 (provide 'planner-appt)
1684 ;;; planner-appt.el ends here
1686 ;; Local Variables:
1687 ;; indent-tabs-mode: t
1688 ;; tab-width: 8
1689 ;; End: