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