code.delx.au - gnu-emacs-elpa/blob - packages/gnorb/gnorb-bbdb.el

   1 ;;; gnorb-bbdb.el --- The BBDB-centric functions of gnorb
   2
   3 ;; Copyright (C) 2014  Free Software Foundation, Inc.
   4
   5 ;; Author: Eric Abrahamsen <eric@ericabrahamsen.net>
   6 ;; Keywords:
   7
   8 ;; This program is free software; you can redistribute it and/or modify
   9 ;; it under the terms of the GNU General Public License as published by
  10 ;; the Free Software Foundation, either version 3 of the License, or
  11 ;; (at your option) any later version.
  12
  13 ;; This program is distributed in the hope that it will be useful,
  14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;; GNU General Public License for more details.
  17
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 ;;; Commentary:
  22
  23 ;;
  24
  25 ;;; Code:
  26
  27 (eval-when-compile
  28   (require 'cl))
  29
  30 (require 'bbdb)
  31 (require 'gnorb-utils)
  32 (require 'cl-lib)
  33
  34 (defgroup gnorb-bbdb nil
  35   "The BBDB bits of gnorb."
  36   :tag "Gnorb BBDB"
  37   :group 'gnorb)
  38
  39 (defcustom gnorb-bbdb-org-tag-field 'org-tags
  40   "The name (as a symbol) of the field to use for org tags."
  41   :group 'gnorb-bbdb
  42   :type 'symbol)
  43
  44 (when (boundp 'bbdb-separator-alist)    ;Allow compilation if BBDB is absent!
  45   (unless (assoc gnorb-bbdb-org-tag-field bbdb-separator-alist)
  46     (push `(,gnorb-bbdb-org-tag-field ":" ":") bbdb-separator-alist)))
  47
  48 (defcustom gnorb-bbdb-messages-field 'messages
  49   "The name (as a symbol) of the field where links to recent gnus
  50 messages from this record are stored.
  51
  52 \\<bbdb-mode-map>Records that do not have this field defined
  53 will not collect links to messages: you have to call
  54 \"\\[gnorb-bbdb-open-link]\" on the record once -- after that,
  55 message links will be collected and updated automatically."
  56   :group 'gnorb-bbdb
  57   :type 'symbol)
  58
  59 (defcustom gnorb-bbdb-collect-N-messages 5
  60   "For records with a `gnorb-bbdb-messages-field' defined,
  61 collect links to a maximum of this many messages."
  62   :group 'gnorb-bbdb
  63   :type 'integer)
  64
  65 (defcustom gnorb-bbdb-define-recent 'seen
  66   "For records with a `gnorb-bbdb-message-tag-field' defined,
  67 this variable controls how gnorb defines a \"recent\" message.
  68 Setting it to the symbol seen will collect the messages most
  69 recently opened and viewed. The symbol received means gnorb will
  70 collect the most recent messages by Date header.
  71
  72 In other words, if this variable is set to 'received, and a
  73 record's messages field is already full of recently-received
  74 messages, opening a five-year-old message (for instance) from
  75 this record will not push a link to the message into the field."
  76   :group 'gnorb-bbdb
  77   :type '(choice (const :tag "Most recently seen" 'seen)
  78                  (const :tag "Most recently received" 'received)))
  79
  80 (defcustom gnorb-bbdb-message-link-format-multi "%:count. %D: %:subject"
  81   "How a single message is formatted in the list of recent messages.
  82 This format string is used in multi-line record display.
  83
  84 Available information for each message includes the subject, the
  85 date, and the message's count in the list, as an integer. You can
  86 access subject and count using the %:subject and %:count escapes.
  87 The message date can be formatted using any of the escapes
  88 mentioned in the docstring of `format-time-string', which see."
  89   :group 'gnorb-bbdb
  90   :type 'string)
  91
  92 (defcustom gnorb-bbdb-message-link-format-one "%:count"
  93   "How a single message is formatted in the list of recent messages.
  94 This format string is used in single-line display -- note that by
  95 default, no user-created xfields are displayed in the 'one-line
  96 layout found in `bbdb-layout-alist'. If you want this field to
  97 appear there, put its name in the \"order\" list of the 'one-line
  98 layout.
  99
 100 Available information for each message includes the subject, the
 101 date, and the message's count in the list, as an integer. You can
 102 access subject and count using the %:subject and %:count escapes.
 103 The message date can be formatted using any of the escapes
 104 mentioned in the docstring of `format-time-string', which see."
 105   :group 'gnorb-bbdb
 106   :type 'string)
 107
 108 (defface gnorb-bbdb-link (org-compatible-face 'org-link nil)
 109   "Custom face for displaying message links in the *BBDB* buffer.
 110   Defaults to org-link."
 111   :group 'gnorb-bbdb)
 112
 113 (cl-defstruct gnorb-bbdb-link
 114   subject date group id)
 115
 116 (defcustom gnorb-bbdb-posting-styles nil
 117   "An alist of styles to use when composing messages to the BBDB
 118 record(s) under point. This is entirely analogous to
 119 `gnus-posting-styles', it simply works by examining record fields
 120 rather than group names.
 121
 122 When composing a message to multiple contacts (using the \"*\"
 123 prefix), the records will be scanned in order, with the record
 124 initially under point (if any) set aside for last. That means
 125 that, in the case of conflicting styles, the record under point
 126 will override the others.
 127
 128 In order not to be too intrusive, this option has no effect on
 129 the usual `bbdb-mail' command. Instead, the wrapper command
 130 `gnorb-bbdb-mail' is provided, which consults this option and
 131 then hands off to `bbdb-compose-mail'. If you'd always like to
 132 use `gnorb-bbdb-mail', you can simply bind it to \"m\" in the
 133 `bbdb-mode-map'.
 134
 135 The value of the option should be a list of sexps, each one
 136 matching a single field. The first element should match a field
 137 name: one of the built-in fields like lastname, or an xfield.
 138 Field names should be given as symbols.
 139
 140 The second element is a regexp used to match against the value of
 141 the field (non-string field values will be cast to strings, if
 142 possible). It can also be a cons of two strings, the first of
 143 which matches the field label, the second the field value.
 144
 145 Alternately, the first element can be the name of a custom
 146 function that is called with the record as its only argument, and
 147 returns either t or nil. In this case, the second element of the
 148 list is disregarded.
 149
 150 All following elements should be field setters for the message to
 151 be composed, just as in `gnus-posting-styles'.
 152
 153 An example value might look like:"
 154   :group 'gnorb-bbdb)
 155
 156 (defvar message-mode-hook)
 157
 158 (when (fboundp 'bbdb-record-xfield-string)
 159   (fset (intern (format "bbdb-read-xfield-%s"
 160                         gnorb-bbdb-org-tag-field))
 161         (lambda (&optional init)
 162           (gnorb-bbdb-read-org-tags init)))
 163
 164   (fset (intern (format "bbdb-display-%s-multi-line"
 165                         gnorb-bbdb-org-tag-field))
 166         (lambda (record)
 167           (gnorb-bbdb-display-org-tags record))))
 168
 169 (defun gnorb-bbdb-read-org-tags (&optional init)
 170   "Read Org mode tags, with `completing-read-multiple'."
 171   (if (string< "24.3" (substring emacs-version 0 4))
 172       (let ((crm-separator
 173              (concat "[ \t\n]*"
 174                      (cadr (assq gnorb-bbdb-org-tag-field
 175                                  bbdb-separator-alist))
 176                      "[ \t\n]*"))
 177             (crm-local-completion-map bbdb-crm-local-completion-map)
 178             (table (cl-mapcar #'car
 179                            (org-global-tags-completion-table
 180                             (org-agenda-files))))
 181             (init (if (consp init)
 182                       (bbdb-join init
 183                                  (nth 2 (assq gnorb-bbdb-org-tag-field
 184                                               bbdb-separator-alist)))
 185                     init)))
 186         (completing-read-multiple
 187          "Tags: " table
 188          nil nil init))
 189     (bbdb-split gnorb-bbdb-org-tag-field
 190                 (bbdb-read-string "Tags: " init))))
 191
 192 (defun gnorb-bbdb-display-org-tags (record)
 193   "Display the Org tags associated with the record.
 194
 195 Org tags are stored in the `gnorb-bbdb-org-tags-field'."
 196   (let ((full-field (assq gnorb-bbdb-org-tag-field
 197                           (bbdb-record-xfields record)))
 198         (val (bbdb-record-xfield
 199               record
 200               gnorb-bbdb-org-tag-field)))
 201     (when val
 202       ;; We already know that `fmt' and `indent' are dynamically
 203       ;; bound, shut up about it.
 204       (with-no-warnings
 205        (bbdb-display-text (format fmt gnorb-bbdb-org-tag-field)
 206                           `(xfields ,full-field field-label)
 207                           'bbdb-field-name)
 208        (if (consp val)
 209            (bbdb-display-list val gnorb-bbdb-org-tag-field "\n")
 210          (insert
 211           (bbdb-indent-string (concat val "\n") indent)))))))
 212
 213 ;;;###autoload
 214 (defun gnorb-bbdb-mail (records &optional subject n verbose)
 215   "\\<bbdb-mode-map>Acts just like `bbdb-mail', except runs
 216 RECORDS through `gnorb-bbdb-posting-styles', allowing
 217 customization of message styles for certain records. From the
 218 `bbdb-mail' docstring:
 219
 220 Compose a mail message to RECORDS (optional: using SUBJECT).
 221 Interactively, use BBDB prefix \\[bbdb-do-all-records], see
 222 `bbdb-do-all-records'. By default, the first mail addresses of
 223 RECORDS are used. If prefix N is a number, use Nth mail address
 224 of RECORDS (starting from 1). If prefix N is C-u (t
 225 noninteractively) use all mail addresses of RECORDS. If VERBOSE
 226 is non-nil (as in interactive calls) be verbose."
 227   ;; see the function `gnus-configure-posting-styles' for tips on how
 228   ;; to actually do this.
 229   (interactive (list (bbdb-do-records) nil
 230                      (or (consp current-prefix-arg)
 231                          current-prefix-arg)
 232                      t))
 233   (setq records (bbdb-record-list records))
 234   (if (not records)
 235       (user-error "No records displayed")
 236     (let ((head (bbdb-current-record))
 237           (to (bbdb-mail-address records n nil verbose))
 238           (message-mode-hook (copy-sequence message-mode-hook)))
 239       (setq records (remove head records))
 240       (when gnorb-bbdb-posting-styles
 241         (add-hook 'message-mode-hook
 242                   `(lambda ()
 243                      (gnorb-bbdb-configure-posting-styles (quote ,records))
 244                      (gnorb-bbdb-configure-posting-styles (list ,head)))))
 245       (bbdb-compose-mail to subject))))
 246
 247 (defun gnorb-bbdb-configure-posting-styles (recs)
 248   ;; My most magnificent work of copy pasta!
 249   (dolist (r recs)
 250     (let (field val label rec-val element filep
 251                 element v value results name address)
 252       (dolist (style gnorb-bbdb-posting-styles)
 253         (setq field (pop style)
 254               val (pop style))
 255         (when (consp val) ;; (label value)
 256           (setq label (pop val)
 257                 val (pop val)))
 258         (unless (fboundp field)
 259           ;; what's the record's existing value for this field?
 260           (setq rec-val (bbdb-record-field r field)))
 261         (when (cond
 262                ((eq field 'address)
 263                 (dolist (a rec-val)
 264                   (unless (and label
 265                                (not (string-match label (car a))))
 266                     (string-match val (bbdb-format-address-default a)))))
 267                ((eq field 'phone)
 268                 (dolist (p rec-val)
 269                   (unless (and label
 270                                (not (string-match label (car p))))
 271                     (string-match val (bbdb-phone-string p)))))
 272                ((consp rec-val)
 273                 (dolist (f rec-val)
 274                   (string-match val f)))
 275                ((fboundp field)
 276                 (funcall field r))
 277                ((stringp rec-val)
 278                 (string-match val rec-val)))
 279           ;; there are matches, run through the field setters in last
 280           ;; element of the sexp
 281           (dolist (attribute style)
 282             (setq element (pop attribute)
 283                   filep nil)
 284             (setq value
 285                   (cond
 286                    ((eq (car attribute) :file)
 287                     (setq filep t)
 288                     (cadr attribute))
 289                    ((eq (car attribute) :value)
 290                     (cadr attribute))
 291                    (t
 292                     (car attribute))))
 293             ;; We get the value.
 294             (setq v
 295                   (cond
 296                    ((stringp value)
 297                     value)
 298                    ((or (symbolp value)
 299                         (functionp value))
 300                     (cond ((functionp value)
 301                            (funcall value))
 302                           ((boundp value)
 303                            (symbol-value value))))
 304                    ((listp value)
 305                     (eval value))))
 306             ;; Post-processing for the signature posting-style:
 307             (and (eq element 'signature) filep
 308                  message-signature-directory
 309                  ;; don't actually use the signature directory
 310                  ;; if message-signature-file contains a path.
 311                  (not (file-name-directory v))
 312                  (setq v (nnheader-concat message-signature-directory v)))
 313             ;; Get the contents of file elems.
 314             (when (and filep v)
 315               (setq v (with-temp-buffer
 316                         (insert-file-contents v)
 317                         (buffer-substring
 318                          (point-min)
 319                          (progn
 320                            (goto-char (point-max))
 321                            (if (zerop (skip-chars-backward "\n"))
 322                                (point)
 323                              (1+ (point))))))))
 324             (setq results (delq (assoc element results) results))
 325             (push (cons element v) results))))
 326       (setq name (assq 'name results)
 327             address (assq 'address results))
 328       (setq results (delq name (delq address results)))
 329       (gnus-make-local-hook 'message-setup-hook)
 330       (setq results (sort results (lambda (x y)
 331                                     (string-lessp (car x) (car y)))))
 332       (dolist (result results)
 333         (add-hook 'message-setup-hook
 334                   (cond
 335                    ((eq 'eval (car result))
 336                     'ignore)
 337                    ((eq 'body (car result))
 338                     `(lambda ()
 339                        (save-excursion
 340                          (message-goto-body)
 341                          (insert ,(cdr result)))))
 342                    ((eq 'signature (car result))
 343                     (set (make-local-variable 'message-signature) nil)
 344                     (set (make-local-variable 'message-signature-file) nil)
 345                     (if (not (cdr result))
 346                         'ignore
 347                       `(lambda ()
 348                          (save-excursion
 349                            (let ((message-signature ,(cdr result)))
 350                              (when message-signature
 351                                (message-insert-signature)))))))
 352                    (t
 353                     (let ((header
 354                            (if (symbolp (car result))
 355                                (capitalize (symbol-name (car result)))
 356                              (car result))))
 357                       `(lambda ()
 358                          (save-excursion
 359                            (message-remove-header ,header)
 360                            (let ((value ,(cdr result)))
 361                              (when value
 362                                (message-goto-eoh)
 363                                (insert ,header ": " value)
 364                                (unless (bolp)
 365                                  (insert "\n")))))))))
 366                   t 'local))
 367       (when (or name address)
 368         (add-hook 'message-setup-hook
 369                   `(lambda ()
 370                      (set (make-local-variable 'user-mail-address)
 371                           ,(or (cdr address) user-mail-address))
 372                      (let ((user-full-name ,(or (cdr name) (user-full-name)))
 373                            (user-mail-address
 374                             ,(or (cdr address) user-mail-address)))
 375                        (save-excursion
 376                          (message-remove-header "From")
 377                          (message-goto-eoh)
 378                          (insert "From: " (message-make-from) "\n"))))
 379                   t 'local)))))
 380
 381 ;;;###autoload
 382 (defun gnorb-bbdb-tag-agenda (records)
 383   "Open an Org agenda tags view from the BBDB buffer, using the
 384 value of the record's org-tags field. This shows only TODOs by
 385 default; a prefix argument shows all tagged headings; a \"*\"
 386 prefix operates on all currently visible records. If you want
 387 both, use \"C-u\" before the \"*\"."
 388   (interactive (list (bbdb-do-records)))
 389   (require 'org-agenda)
 390   (unless (and (eq major-mode 'bbdb-mode)
 391                (equal (buffer-name) bbdb-buffer-name))
 392     (error "Only works in the BBDB buffer"))
 393   (setq records (bbdb-record-list records))
 394   (let ((tag-string
 395          (mapconcat
 396           'identity
 397           (delete-dups
 398            (cl-mapcan (lambda (r)
 399                      (bbdb-record-xfield-split r gnorb-bbdb-org-tag-field))
 400                    records))
 401           "|")))
 402     (if tag-string
 403         ;; C-u = all headings, not just todos
 404         (org-tags-view (not (equal current-prefix-arg '(4)))
 405                        tag-string)
 406       (error "No org-tags field present"))))
 407
 408 ;;;###autoload
 409 (defun gnorb-bbdb-mail-search (records)
 410   "Initiate a mail search from the BBDB buffer.
 411
 412 Use the prefix arg to edit the search string first, and the \"*\"
 413 prefix to search mails from all visible contacts. When using both
 414 a prefix arg and \"*\", the prefix arg must come first."
 415   (interactive (list (bbdb-do-records)))
 416   (unless (and (eq major-mode 'bbdb-mode)
 417                (equal (buffer-name) bbdb-buffer-name))
 418     (error "Only works in the BBDB buffer"))
 419   (setq records (bbdb-record-list records))
 420   (require 'gnorb-gnus)
 421   (let* ((backend (or (assoc gnorb-gnus-mail-search-backend
 422                              gnorb-gnus-mail-search-backends)
 423                       (error "No search backend specified")))
 424          (search-string
 425           (funcall (cl-second backend)
 426                    (cl-mapcan 'bbdb-record-mail records))))
 427     (when (equal current-prefix-arg '(4))
 428       (setq search-string
 429             (read-from-minibuffer
 430              (format "%s search string: " (cl-first backend)) search-string)))
 431     (funcall (cl-third backend) search-string)
 432     (delete-other-windows)))
 433
 434 ;;;###autoload
 435 (defun gnorb-bbdb-cite-contact (rec)
 436   (interactive (list (gnorb-prompt-for-bbdb-record)))
 437   (let ((mail-string (bbdb-dwim-mail rec)))
 438    (if (called-interactively-p 'any)
 439        (insert mail-string)
 440      mail-string)))
 441
 442 ;;; Field containing links to recent messages
 443
 444 (when (boundp 'bbdb-xfield-label-list)
 445   (add-to-list 'bbdb-xfield-label-list gnorb-bbdb-messages-field nil 'eq))
 446
 447 (defun gnorb-bbdb-display-messages (record format)
 448   "Show links to the messages collected in the
 449 `gnorb-bbdb-messages-field' field of a BBDB record. Each link
 450 will be formatted using the format string in
 451 `gnorb-bbdb-message-link-format-multi' or
 452 `gnorb-bbdb-message-link-format-one', depending on the current
 453 layout type."
 454   (let ((full-field (assq gnorb-bbdb-messages-field
 455                           (bbdb-record-xfields record)))
 456         (val (bbdb-record-xfield record gnorb-bbdb-messages-field))
 457         (map (make-sparse-keymap))
 458         (count 1)) ; one-indexed to fit with prefix arg to `gnorb-bbdb-open-link'
 459     (define-key map [mouse-1] 'gnorb-bbdb-mouse-open-link)
 460     (define-key map (kbd "<RET>") 'gnorb-bbdb-RET-open-link)
 461     (when val
 462       (when (eq format 'multi)
 463         (with-no-warnings ; For `fmt'
 464           (bbdb-display-text (format fmt gnorb-bbdb-messages-field)
 465                              `(xfields ,full-field field-label)
 466                              'bbdb-field-name)))
 467       (insert (cond ((and (stringp val)
 468                           (eq format 'multi))
 469                      (with-no-warnings ; For `indent'
 470                        (bbdb-indent-string (concat val "\n") indent)))
 471                     ((listp val)
 472                      ;; Why aren't I using `bbdb-display-list' with a
 473                      ;; preformatted list of messages?
 474                      (concat
 475                       (with-no-warnings ; For `indent' again
 476                         (bbdb-indent-string
 477                          (mapconcat
 478                           (lambda (m)
 479                             (prog1
 480                                 (org-propertize
 481                                  (concat
 482                                   (format-time-string
 483                                    (replace-regexp-in-string
 484                                     "%:subject" (gnorb-bbdb-link-subject m)
 485                                     (replace-regexp-in-string
 486                                      "%:count" (number-to-string count)
 487                                      (if (eq format 'multi)
 488                                          gnorb-bbdb-message-link-format-multi
 489                                        gnorb-bbdb-message-link-format-one)))
 490                                    (gnorb-bbdb-link-date m)))
 491                                  'face 'gnorb-bbdb-link
 492                                  'mouse-face 'highlight
 493                                  'gnorb-bbdb-link-count count
 494                                  'keymap map)
 495                               (incf count)))
 496                           val (if (eq format 'multi)
 497                                   "\n" ", "))
 498                          indent))
 499                       (if (eq format 'multi) "\n" "")))
 500                     (t
 501                      ""))))))
 502
 503 (fset (intern (format "bbdb-display-%s-multi-line"
 504                       gnorb-bbdb-messages-field))
 505       (lambda (record)
 506         (gnorb-bbdb-display-messages record 'multi)))
 507
 508 (fset (intern (format "bbdb-display-%s-one-line"
 509                       gnorb-bbdb-messages-field))
 510       (lambda (record)
 511         (gnorb-bbdb-display-messages record 'one)))
 512
 513 ;; Don't allow direct editing of this field
 514
 515 (fset (intern (format "bbdb-read-xfield-%s"
 516                       gnorb-bbdb-messages-field))
 517       (lambda (&optional init)
 518         (user-error "This field shouldn't be edited manually")))
 519
 520 ;; Open links from the *BBDB* buffer.
 521
 522 ;;;###autoload
 523 (defun gnorb-bbdb-open-link (record arg)
 524   "\\<bbdb-mode-map>Call this on a BBDB record to open one of the
 525 links in the message field. By default, the first link will be
 526 opened. Use a prefix arg to open different links. For instance,
 527 M-3 \\[gnorb-bbdb-open-link] will open the third link in the
 528 list. If the %:count escape is present in the message formatting
 529 string (see `gnorb-bbdb-message-link-format-multi' and
 530 `gnorb-bbdb-message-link-format-one'), that's the number to use.
 531
 532 This function also needs to be called on a contact once before
 533 that contact will start collecting links to messages."
 534   (interactive (list
 535                 (or (bbdb-current-record)
 536                     (user-error "No record under point"))
 537                 current-prefix-arg))
 538   (unless (fboundp 'bbdb-record-xfield-string)
 539     (user-error "This function only works with the git version of BBDB"))
 540   (let* ((record (bbdb-current-record))
 541          msg-list target-msg)
 542     (if (not (memq gnorb-bbdb-messages-field
 543                    (mapcar 'car (bbdb-record-xfields record))))
 544         (when (y-or-n-p
 545                (format "Start collecting message links for %s?"
 546                        (bbdb-record-name record)))
 547           (bbdb-record-set-xfield record gnorb-bbdb-messages-field "no links yet")
 548           (message "Opening messages from %s will add links to the %s field"
 549                    (bbdb-record-name record)
 550                    gnorb-bbdb-messages-field)
 551           (bbdb-change-record record))
 552         (setq msg-list
 553               (bbdb-record-xfield record gnorb-bbdb-messages-field))
 554         (setq target-msg
 555               (or (and arg
 556                        (nth (1- arg) msg-list))
 557                   (car msg-list)))
 558         (when target-msg
 559           (org-gnus-follow-link (gnorb-bbdb-link-group target-msg)
 560                                 (gnorb-bbdb-link-id target-msg))))))
 561
 562 (defun gnorb-bbdb-mouse-open-link (event)
 563   (interactive "e")
 564   (mouse-set-point event)
 565   (let ((rec (bbdb-current-record))
 566         (num (get-text-property (point) 'gnorb-bbdb-link-count)))
 567     (if (not num)
 568         (user-error "No link under point")
 569       (gnorb-bbdb-open-link rec num))))
 570
 571 (defun gnorb-bbdb-RET-open-link ()
 572   (interactive)
 573   (let ((rec (bbdb-current-record))
 574         (num (get-text-property (point) 'gnorb-bbdb-link-count)))
 575     (if (not num)
 576         (user-error "No link under point")
 577       (gnorb-bbdb-open-link rec num))))
 578
 579 (defun gnorb-bbdb-store-message-link (record)
 580   "Used in the `bbdb-notice-record-hook' to possibly save a link
 581 to a message into the record's `gnorb-bbdb-messages-field'."
 582
 583   (when (not (fboundp 'bbdb-record-xfield-string))
 584     (user-error "This function only works with the git version of BBDB"))
 585   (unless (or (not (and (memq gnorb-bbdb-messages-field
 586                               (mapcar 'car (bbdb-record-xfields record)))
 587                         (memq major-mode '(gnus-summary-mode gnus-article-mode))))
 588               (with-current-buffer gnus-article-buffer
 589                 (not ; only store messages if the record is the sender
 590                  (member (nth 1 (car (bbdb-get-address-components 'sender)))
 591                          (bbdb-record-mail record)))))
 592     (with-current-buffer gnus-summary-buffer
 593       (let* ((val (bbdb-record-xfield record gnorb-bbdb-messages-field))
 594              (art-no (gnus-summary-article-number))
 595              (heads (gnus-summary-article-header art-no))
 596              (date (apply 'encode-time
 597                           (parse-time-string (mail-header-date heads))))
 598              (subject (mail-header-subject heads))
 599              (id (mail-header-id heads))
 600              (group gnus-newsgroup-name)
 601              link)
 602         ;; check for both nnvirtual and nnir, and link to the real
 603         ;; group in those cases
 604         (when (eq (car (gnus-find-method-for-group group))
 605                   'nnvirtual)
 606           (setq group (car (nnvirtual-map-article art-no))))
 607         (when (eq (car (gnus-find-method-for-group group))
 608                   'nnir)
 609           (setq group (nnir-article-group art-no)))
 610         (if (not (and date subject id group))
 611             (message "Could not save a link to this message")
 612           (setq link (make-gnorb-bbdb-link :subject subject :date date
 613                                            :group group :id id))
 614           (when (stringp val)
 615             (setq val nil))
 616           (setq val (cons link (delete link val)))
 617           (when (eq gnorb-bbdb-define-recent 'received)
 618             (setq val (sort val
 619                             (lambda (a b)
 620                               (time-less-p
 621                                (gnorb-bbdb-link-date b)
 622                                (gnorb-bbdb-link-date a))))))
 623           (setq val (cl-subseq val 0 gnorb-bbdb-collect-N-messages))
 624           (bbdb-record-set-xfield record
 625                                   gnorb-bbdb-messages-field
 626                                   (delq nil val))
 627           (bbdb-change-record record))))))
 628
 629 (add-hook 'bbdb-notice-record-hook 'gnorb-bbdb-store-message-link)
 630
 631 (provide 'gnorb-bbdb)
 632 ;;; gnorb-bbdb.el ends here