;;; bbdb-anniv.el --- get anniversaries from BBDB -*- lexical-binding: t -*- ;; Copyright (C) 2011-2017 Free Software Foundation, Inc. ;; This file is part of the Insidious Big Brother Database (aka BBDB), ;; BBDB is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; BBDB is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with BBDB. If not, see . ;;; Commentary: ;; Anniversaries are stored in xfields as defined via `bbdb-anniv-alist'. ;; Each such field may contain multiple anniversaries entries with separators ;; defined via `bbdb-separator-alist' (newlines by default). ;; Each anniversary entry is a string DATE followed by optional TEXT. ;; DATE may take the same format as the date of ordinary diary entries. ;; In particular, `calendar-date-style' is obeyed via `diary-date-forms'. ;; If `bbdb-anniv-alist' has a non-nil FORM for this type of anniversary, ;; FORM is used to display the anniversary entry in the diary buffer. ;; If FORM is nil, TEXT is used instead to display the anniversary entry ;; in the diary buffer. ;; ;; To display BBDB anniversaries in the Emacs diary, ;; call `bbdb-initialize' with arg `anniv'. ;; ;; See the BBDB info manual for documentation. ;;; Code: (require 'bbdb) (require 'bbdb-com) (require 'diary-lib) (eval-when-compile (require 'cl-lib)) (defcustom bbdb-anniv-alist '((birthday . "%n's %d%s birthday") (wedding . "%n's %d%s wedding anniversary") (anniversary)) "Alist of rules for formatting anniversaries in the diary buffer. Each element is of the form (LABEL . FORM). LABEL is the xfield where this type of anniversaries is stored. FORM is a format string with the following substitutions: %n name of the record %d number of years %s ordinal suffix (st, nd, rd, th) for the year. %t the optional text following the date string in field LABEL. If FORM is nil, use the text following the date string in field LABEL as format string." :type '(repeat (cons :tag "Rule" (symbol :tag "Label") (choice (string) (const nil)))) :group 'bbdb-utilities-anniv) ;; `bbdb-anniv-diary-entries' becomes a member of `diary-list-entries-hook'. ;; When this hook is run by `diary-list-entries', the variable `original-date' ;; is bound to the value of arg DATE of `diary-list-entries'. ;; Also, `number' is arg NUMBER of `diary-list-entries'. ;; `diary-list-entries' selects the entries for NUMBER days starting with DATE. (defvar original-date) ; defined in diary-lib (with-no-warnings (defvar number)) ; defined in diary-lib ;;;###autoload (defun bbdb-anniv-diary-entries () "Add anniversaries from BBDB records to `diary-list-entries'. This obeys `calendar-date-style' via `diary-date-forms'. To enable this feature, put the following into your .emacs: \(add-hook 'diary-list-entries-hook 'bbdb-anniv-diary-entries)" ;; Loop over NUMBER dates starting from ORGINAL-DATE. (let* ((num-date (1- (calendar-absolute-from-gregorian original-date))) (end-date (+ num-date number))) (while (<= (setq num-date (1+ num-date)) end-date) (let* ((date (calendar-gregorian-from-absolute num-date)) (dd (calendar-extract-day date)) (mm (calendar-extract-month date)) (yy (calendar-extract-year date)) ;; We construct a regexp that only uses shy groups, ;; except for the part of the regexp matching the year. ;; This way we can grab the year from the date string. (year "\\([0-9]+\\)\\|\\*") (dayname (format "%s\\|%s\\.?" (calendar-day-name date) (calendar-day-name date 'abbrev))) (lex-env `((day . ,(format "0*%d" dd)) (month . ,(format "0*%d" mm)) (year . ,year) (dayname . ,dayname) (monthname . ,(format "%s\\|%s" (calendar-month-name mm) (calendar-month-name mm 'abbrev))))) ;; Require that the matched date is at the beginning of the string. (fmt (format "\\`%s?\\(?:%%s\\)" (regexp-quote diary-nonmarking-symbol))) date-forms) (cl-flet ((fun (date-form) (push (cons (format fmt (mapconcat (lambda (form) (eval form lex-env)) (if (eq (car date-form) 'backup) (cdr date-form) date-form) "\\)\\(?:")) (eq (car date-form) 'backup)) date-forms))) (mapc #'fun diary-date-forms) ;; The anniversary of February 29 is considered to be March 1 ;; in non-leap years. So we search for February 29, too. (when (and (= mm 3) (= dd 1) (not (calendar-leap-year-p yy))) (setq lex-env `((day . "0*29") (month . "0*2") (year . ,year) (dayname . ,dayname) (monthname . ,(format "%s\\|%s" (calendar-month-name 2) (calendar-month-name 2 'abbrev))))) (mapc #'fun diary-date-forms))) (dolist (record (bbdb-records)) (dolist (rule bbdb-anniv-alist) (dolist (anniv (bbdb-record-xfield-split record (car rule))) (let ((date-forms date-forms) (anniv-string (concat anniv " X")) ; for backup forms (case-fold-search t) form yr text) (while (setq form (pop date-forms)) (when (string-match (car form) anniv-string) (setq date-forms nil yr (match-string 1 anniv-string) yr (if (and yr (string-match-p "[0-9]+" yr)) (- yy (string-to-number yr)) 100) ; as in `diary-anniversary' ;; For backup forms we should search backward in ;; anniv-string from (match-end 0) for "\\<". ;; That gets too complicated here! ;; Yet for the default value of `diary-date-forms' ;; this would matter only if anniv-string started ;; with a time. That is rather rare for anniversaries. ;; Then we may simply step backward by one character. text (substring anniv-string (if (cdr form) ; backup (1- (match-end 0)) (match-end 0)) -1) text (replace-regexp-in-string "\\`[ \t]+" "" text) text (replace-regexp-in-string "[ \t]+\\'" "" text)) (if (cdr rule) (setq text (replace-regexp-in-string "%t" text (cdr rule)))) ;; Add the anniversaries to `diary-entries-list'. (if (and (numberp yr) (< 0 (length text))) (diary-add-to-list date ;; `diary-add-to-list' expects an arg SPECIFIER for being ;; able to jump to the location of the entry in the diary ;; file. Here we only have BBDB records. So we use ;; an empty string for SPECIFIER, but instead we `propertize' ;; the STRING passed to `diary-add-to-list'. (propertize (format ;; Text substitution similar to `diary-anniversary'. (replace-regexp-in-string "%n" (bbdb-record-name record) text) yr (diary-ordinal-suffix yr)) 'diary-goto-entry (list 'bbdb-display-records (list record))) "")))))))))))) ;; based on `diary-goto-entry' (defun bbdb-anniv-goto-entry (button) "Jump to the diary entry for the BUTTON at point. The character at point may have a text property `diary-goto-entry' which should be a list (FUNCTION ARG1 ARG2 ...). Then call FUNCTION with args ARG1, ARG2, ... to locate the entry. Otherwise follow the rules used by `diary-goto-entry'." (let* ((fun-call (get-text-property (overlay-start button) 'diary-goto-entry)) (locator (button-get button 'locator)) (marker (car locator)) markbuf file) (cond (fun-call (apply (car fun-call) (cdr fun-call))) ;; If marker pointing to diary location is valid, use that. ((and marker (setq markbuf (marker-buffer marker))) (pop-to-buffer markbuf) (goto-char (marker-position marker))) ;; Marker is invalid (eg buffer has been killed). ((and (setq file (cadr locator)) (file-exists-p file) (find-file-other-window file)) (when (eq major-mode (default-value 'major-mode)) (diary-mode)) (goto-char (point-min)) (if (re-search-forward (format "%s.*\\(%s\\)" (regexp-quote (nth 2 locator)) (regexp-quote (nth 3 locator))) nil t) (goto-char (match-beginning 1)))) (t (message "Unable to locate this diary entry"))))) ;; `diary-goto-entry-function' is rather inflexible if multiple packages ;; want to use it for its purposes: this variable can be hijacked ;; only once. Here our function `bbdb-anniv-goto-entry' should work ;; for other packages, too. (setq diary-goto-entry-function 'bbdb-anniv-goto-entry) (provide 'bbdb-anniv) ;;; bbdb-anniv.el ends here