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

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