git.shemshak.org - ~bandali/configs/blob - lisp/bbdb/bbdb-anniv.el

   1 ;;; bbdb-anniv.el --- get anniversaries from BBDB -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2011-2017  Free Software Foundation, Inc.
   4
   5 ;; This file is part of the Insidious Big Brother Database (aka BBDB),
   6
   7 ;; BBDB is free software: you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published by
   9 ;; the Free Software Foundation, either version 3 of the License, or
  10 ;; (at your option) any later version.
  11
  12 ;; BBDB is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;; GNU General Public License for more details.
  16
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with BBDB.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 ;;; Commentary:
  21 ;; Anniversaries are stored in xfields as defined via `bbdb-anniv-alist'.
  22 ;; Each such field may contain multiple anniversaries entries with separators
  23 ;; defined via `bbdb-separator-alist' (newlines by default).
  24 ;; Each anniversary entry is a string DATE followed by optional TEXT.
  25 ;; DATE may take the same format as the date of ordinary diary entries.
  26 ;; In particular, `calendar-date-style' is obeyed via `diary-date-forms'.
  27 ;; If `bbdb-anniv-alist' has a non-nil FORM for this type of anniversary,
  28 ;; FORM is used to display the anniversary entry in the diary buffer.
  29 ;; If FORM is nil, TEXT is used instead to display the anniversary entry
  30 ;; in the diary buffer.
  31 ;;
  32 ;; To display BBDB anniversaries in the Emacs diary,
  33 ;; call `bbdb-initialize' with arg `anniv'.
  34 ;;
  35 ;; See the BBDB info manual for documentation.
  36
  37 ;;; Code:
  38
  39 (require 'bbdb)
  40 (require 'bbdb-com)
  41 (require 'diary-lib)
  42 (eval-when-compile
  43   (require 'cl-lib))
  44
  45 (defcustom bbdb-anniv-alist
  46   '((birthday . "%n's %d%s birthday")
  47     (wedding  . "%n's %d%s wedding anniversary")
  48     (anniversary))
  49   "Alist of rules for formatting anniversaries in the diary buffer.
  50 Each element is of the form (LABEL . FORM).
  51 LABEL is the xfield where this type of anniversaries is stored.
  52 FORM is a format string with the following substitutions:
  53   %n  name of the record
  54   %d  number of years
  55   %s  ordinal suffix (st, nd, rd, th) for the year.
  56   %t  the optional text following the date string in field LABEL.
  57 If FORM is nil, use the text following the date string in field LABEL
  58 as format string."
  59   :type '(repeat (cons :tag "Rule"
  60                        (symbol :tag "Label")
  61                        (choice (string)
  62                                (const nil))))
  63   :group 'bbdb-utilities-anniv)
  64
  65 ;; `bbdb-anniv-diary-entries' becomes a member of  `diary-list-entries-hook'.
  66 ;; When this hook is run by `diary-list-entries', the variable `original-date'
  67 ;; is bound to the value of arg DATE of `diary-list-entries'.
  68 ;; Also, `number' is arg NUMBER of `diary-list-entries'.
  69 ;; `diary-list-entries' selects the entries for NUMBER days starting with DATE.
  70
  71 (defvar original-date) ; defined in diary-lib
  72 (with-no-warnings (defvar number)) ; defined in diary-lib
  73
  74 ;;;###autoload
  75 (defun bbdb-anniv-diary-entries ()
  76   "Add anniversaries from BBDB records to `diary-list-entries'.
  77 This obeys `calendar-date-style' via `diary-date-forms'.
  78 To enable this feature, put the following into your .emacs:
  79
  80  \(add-hook 'diary-list-entries-hook 'bbdb-anniv-diary-entries)"
  81   ;; Loop over NUMBER dates starting from ORGINAL-DATE.
  82   (let* ((num-date (1- (calendar-absolute-from-gregorian original-date)))
  83          (end-date (+ num-date number)))
  84     (while (<= (setq num-date (1+ num-date)) end-date)
  85       (let* ((date (calendar-gregorian-from-absolute num-date))
  86              (dd (calendar-extract-day date))
  87              (mm (calendar-extract-month date))
  88              (yy (calendar-extract-year date))
  89              ;; We construct a regexp that only uses shy groups,
  90              ;; except for the part of the regexp matching the year.
  91              ;; This way we can grab the year from the date string.
  92              (year "\\([0-9]+\\)\\|\\*")
  93              (dayname (format "%s\\|%s\\.?" (calendar-day-name date)
  94                               (calendar-day-name date 'abbrev)))
  95              (lex-env `((day . ,(format "0*%d" dd))
  96                         (month . ,(format "0*%d" mm)) (year . ,year)
  97                         (dayname . ,dayname)
  98                         (monthname . ,(format "%s\\|%s" (calendar-month-name mm)
  99                                               (calendar-month-name mm 'abbrev)))))
 100              ;; Require that the matched date is at the beginning of the string.
 101              (fmt (format "\\`%s?\\(?:%%s\\)"
 102                           (regexp-quote diary-nonmarking-symbol)))
 103              date-forms)
 104
 105         (cl-flet ((fun (date-form)
 106                        (push (cons (format fmt
 107                                            (mapconcat (lambda (form) (eval form lex-env))
 108                                                       (if (eq (car date-form) 'backup)
 109                                                           (cdr date-form) date-form)
 110                                                       "\\)\\(?:"))
 111                                    (eq (car date-form) 'backup))
 112                              date-forms)))
 113           (mapc #'fun diary-date-forms)
 114
 115           ;; The anniversary of February 29 is considered to be March 1
 116           ;; in non-leap years.  So we search for February 29, too.
 117           (when (and (= mm 3) (= dd 1)
 118                      (not (calendar-leap-year-p yy)))
 119             (setq lex-env `((day . "0*29") (month . "0*2") (year . ,year)
 120                             (dayname . ,dayname)
 121                             (monthname . ,(format "%s\\|%s" (calendar-month-name 2)
 122                                                   (calendar-month-name 2 'abbrev)))))
 123             (mapc #'fun diary-date-forms)))
 124
 125         (dolist (record (bbdb-records))
 126           (dolist (rule bbdb-anniv-alist)
 127             (dolist (anniv (bbdb-record-xfield-split record (car rule)))
 128               (let ((date-forms date-forms)
 129                     (anniv-string (concat anniv " X")) ; for backup forms
 130                     (case-fold-search t)
 131                     form yr text)
 132                 (while (setq form (pop date-forms))
 133                   (when (string-match (car form) anniv-string)
 134                     (setq date-forms nil
 135                           yr (match-string 1 anniv-string)
 136                           yr (if (and yr (string-match-p "[0-9]+" yr))
 137                                  (- yy (string-to-number yr))
 138                                100) ; as in `diary-anniversary'
 139                           ;; For backup forms we should search backward in
 140                           ;; anniv-string from (match-end 0) for "\\<".
 141                           ;; That gets too complicated here!
 142                           ;; Yet for the default value of `diary-date-forms'
 143                           ;; this would matter only if anniv-string started
 144                           ;; with a time. That is rather rare for anniversaries.
 145                           ;; Then we may simply step backward by one character.
 146                           text (substring anniv-string (if (cdr form) ; backup
 147                                                            (1- (match-end 0))
 148                                                          (match-end 0))
 149                                           -1)
 150                           text (replace-regexp-in-string "\\`[ \t]+" "" text)
 151                           text (replace-regexp-in-string "[ \t]+\\'" "" text))
 152                     (if (cdr rule)
 153                         (setq text (replace-regexp-in-string "%t" text (cdr rule))))
 154                     ;; Add the anniversaries to `diary-entries-list'.
 155                     (if (and (numberp yr) (< 0 (length text)))
 156                         (diary-add-to-list
 157                          date
 158                          ;; `diary-add-to-list' expects an arg SPECIFIER for being
 159                          ;; able to jump to the location of the entry in the diary
 160                          ;; file.  Here we only have BBDB records.  So we use
 161                          ;; an empty string for SPECIFIER, but instead we `propertize'
 162                          ;; the STRING passed to `diary-add-to-list'.
 163                          (propertize
 164                           (format
 165                            ;; Text substitution similar to `diary-anniversary'.
 166                            (replace-regexp-in-string "%n" (bbdb-record-name record) text)
 167                            yr (diary-ordinal-suffix yr))
 168                           'diary-goto-entry (list 'bbdb-display-records (list record)))
 169                          ""))))))))))))
 170
 171 ;; based on `diary-goto-entry'
 172 (defun bbdb-anniv-goto-entry (button)
 173   "Jump to the diary entry for the BUTTON at point.
 174 The character at point may have a text property `diary-goto-entry'
 175 which should be a list (FUNCTION ARG1 ARG2 ...).  Then call FUNCTION
 176 with args ARG1, ARG2, ... to locate the entry.  Otherwise follow
 177 the rules used by `diary-goto-entry'."
 178   (let* ((fun-call (get-text-property (overlay-start button)
 179                                       'diary-goto-entry))
 180          (locator (button-get button 'locator))
 181          (marker (car locator))
 182          markbuf file)
 183     (cond (fun-call
 184            (apply (car fun-call) (cdr fun-call)))
 185           ;; If marker pointing to diary location is valid, use that.
 186           ((and marker (setq markbuf (marker-buffer marker)))
 187            (pop-to-buffer markbuf)
 188            (goto-char (marker-position marker)))
 189           ;; Marker is invalid (eg buffer has been killed).
 190           ((and (setq file (cadr locator))
 191                 (file-exists-p file)
 192                 (find-file-other-window file))
 193            (when (eq major-mode (default-value 'major-mode)) (diary-mode))
 194            (goto-char (point-min))
 195            (if (re-search-forward (format "%s.*\\(%s\\)"
 196                                           (regexp-quote (nth 2 locator))
 197                                           (regexp-quote (nth 3 locator)))
 198                                   nil t)
 199                (goto-char (match-beginning 1))))
 200           (t
 201            (message "Unable to locate this diary entry")))))
 202
 203 ;; `diary-goto-entry-function' is rather inflexible if multiple packages
 204 ;; want to use it for its purposes: this variable can be hijacked
 205 ;; only once.  Here our function `bbdb-anniv-goto-entry' should work
 206 ;; for other packages, too.
 207 (setq diary-goto-entry-function 'bbdb-anniv-goto-entry)
 208
 209 (provide 'bbdb-anniv)
 210
 211 ;;; bbdb-anniv.el ends here