--- /dev/null
+;;; gnorb-bbdb.el --- The BBDB-centric functions of gnorb
+
+;; Copyright (C) 2014 Eric Abrahamsen
+
+;; Author: Eric Abrahamsen <eric@ericabrahamsen.net>
+;; Keywords:
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;
+
+;;; Code:
+
+(require 'gnorb-utils)
+
+(defgroup gnorb-bbdb nil
+ "The BBDB bits of gnorb."
+ :tag "Gnorb BBDB"
+ :group 'gnorb)
+
+(defcustom gnorb-bbdb-org-tag-field 'org-tags
+ "The name (as a symbol) of the field to use for org tags."
+ :group 'gnorb-bbdb
+ :type 'symbol)
+
+(unless (assoc gnorb-bbdb-org-tag-field bbdb-separator-alist)
+ (push `(,gnorb-bbdb-org-tag-field ":" ":") bbdb-separator-alist))
+
+(defcustom gnorb-bbdb-messages-field 'messages
+ "The name (as a symbol) of the field where links to recent gnus
+messages from this record are stored.
+
+\\<bbdb-mode-map>Records that do not have this field defined
+will not collect links to messages: you have to call
+\"\\[gnorb-bbdb-open-link]\" on the record once -- after that,
+message links will be collected and updated automatically."
+ :group 'gnorb-bbdb
+ :type 'symbol)
+
+(defcustom gnorb-bbdb-collect-N-messages 5
+ "For records with a `gnorb-bbdb-messages-field' defined,
+collect links to a maximum of this many messages."
+ :group 'gnorb-bbdb
+ :type 'integer)
+
+(defcustom gnorb-bbdb-define-recent 'seen
+ "For records with a `gnorb-bbdb-message-tag-field' defined,
+this variable controls how gnorb defines a \"recent\" message.
+Setting it to the symbol seen will collect the messages most
+recently opened and viewed. The symbol received means gnorb will
+collect the most recent messages by Date header.
+
+In other words, if this variable is set to 'received, and a
+record's messages field is already full of recently-received
+messages, opening a five-year-old message (for instance) from
+this record will not push a link to the message into the field."
+ :group 'gnorb-bbdb
+ :type '(choice (const :tag "Most recently seen" 'seen)
+ (const :tag "Most recently received" 'received)))
+
+(defcustom gnorb-bbdb-message-link-format-multi "%:count. %D: %:subject"
+ "How a single message is formatted in the list of recent messages.
+This format string is used in multi-line record display.
+
+Available information for each message includes the subject, the
+date, and the message's count in the list, as an integer. You can
+access subject and count using the %:subject and %:count escapes.
+The message date can be formatted using any of the escapes
+mentioned in the docstring of `format-time-string', which see."
+ :group 'gnorb-bbdb
+ :type 'string)
+
+(defcustom gnorb-bbdb-message-link-format-one "%:count"
+ "How a single message is formatted in the list of recent messages.
+This format string is used in single-line display -- note that by
+default, no user-created xfields are displayed in the 'one-line
+layout found in `bbdb-layout-alist'. If you want this field to
+appear there, put its name in the \"order\" list of the 'one-line
+layout.
+
+Available information for each message includes the subject, the
+date, and the message's count in the list, as an integer. You can
+access subject and count using the %:subject and %:count escapes.
+The message date can be formatted using any of the escapes
+mentioned in the docstring of `format-time-string', which see."
+ :group 'gnorb-bbdb
+ :type 'string)
+
+(defface gnorb-bbdb-link (org-compatible-face 'org-link nil)
+ "Custom face for displaying message links in the *BBDB* buffer.
+ Defaults to org-link."
+ :group 'gnorb-bbdb)
+
+(defstruct gnorb-bbdb-link
+ subject date group id)
+
+(defcustom gnorb-bbdb-posting-styles nil
+ "An alist of styles to use when composing messages to the BBDB
+record(s) under point. This is entirely analogous to
+`gnus-posting-styles', it simply works by examining record fields
+rather than group names.
+
+When composing a message to multiple contacts (using the \"*\"
+prefix), the records will be scanned in order, with the record
+initially under point (if any) set aside for last. That means
+that, in the case of conflicting styles, the record under point
+will override the others.
+
+In order not to be too intrusive, this option has no effect on
+the usual `bbdb-mail' command. Instead, the wrapper command
+`gnorb-bbdb-mail' is provided, which consults this option and
+then hands off to `bbdb-compose-mail'. If you'd always like to
+use `gnorb-bbdb-mail', you can simply bind it to \"m\" in the
+`bbdb-mode-map'.
+
+The value of the option should be a list of sexps, each one
+matching a single field. The first element should match a field
+name: one of the built-in fields like lastname, or an xfield.
+Field names should be given as symbols.
+
+The second element is a regexp used to match against the value of
+the field (non-string field values will be cast to strings, if
+possible). It can also be a cons of two strings, the first of
+which matches the field label, the second the field value.
+
+Alternately, the first element can be the name of a custom
+function that is called with the record as its only argument, and
+returns either t or nil. In this case, the second element of the
+list is disregarded.
+
+All following elements should be field setters for the message to
+be composed, just as in `gnus-posting-styles'.
+
+An example value might look like:"
+ :group 'gnorb-bbdb)
+
+;;;###autoload
+(defun gnorb-bbdb-mail (records &optional subject n verbose)
+ "\\<bbdb-mode-map>Acts just like `bbdb-mail', except runs
+RECORDS through `gnorb-bbdb-posting-styles', allowing
+customization of message styles for certain records. From the
+`bbdb-mail' docstring:
+
+Compose a mail message to RECORDS (optional: using SUBJECT).
+Interactively, use BBDB prefix \\[bbdb-do-all-records], see
+`bbdb-do-all-records'. By default, the first mail addresses of
+RECORDS are used. If prefix N is a number, use Nth mail address
+of RECORDS (starting from 1). If prefix N is C-u (t
+noninteractively) use all mail addresses of RECORDS. If VERBOSE
+is non-nil (as in interactive calls) be verbose."
+ ;; see the function `gnus-configure-posting-styles' for tips on how
+ ;; to actually do this.
+ (interactive (list (bbdb-do-records) nil
+ (or (consp current-prefix-arg)
+ current-prefix-arg)
+ t))
+ (setq records (bbdb-record-list records))
+ (if (not records)
+ (user-error "No records displayed")
+ (let ((head (bbdb-current-record))
+ (to (bbdb-mail-address records n nil verbose))
+ (message-mode-hook (copy-sequence message-mode-hook)))
+ (setq records (remove head records))
+ (when gnorb-bbdb-posting-styles
+ (add-hook 'message-mode-hook
+ `(lambda ()
+ (gnorb-bbdb-configure-posting-styles (quote ,records))
+ (gnorb-bbdb-configure-posting-styles (list ,head)))))
+ (bbdb-compose-mail to subject))))
+
+(defun gnorb-bbdb-configure-posting-styles (recs)
+ ;; My most magnificent work of copy pasta!
+ (dolist (r recs)
+ (let (field val label rec-val element filep
+ element v value results name address)
+ (dolist (style gnorb-bbdb-posting-styles)
+ (setq field (pop style)
+ val (pop style))
+ (when (consp val) ;; (label value)
+ (setq label (pop val)
+ val (pop val)))
+ (unless (fboundp field)
+ ;; what's the record's existing value for this field?
+ (setq rec-val (bbdb-record-field r field)))
+ (when (cond
+ ((eq field 'address)
+ (dolist (a rec-val)
+ (unless (and label
+ (not (string-match label (car a))))
+ (string-match val (bbdb-format-address-default a)))))
+ ((eq field 'phone)
+ (dolist (p rec-val)
+ (unless (and label
+ (not (string-match label (car p))))
+ (string-match val (bbdb-phone-string p)))))
+ ((consp rec-val)
+ (dolist (f rec-val)
+ (string-match val f)))
+ ((fboundp field)
+ (funcall field r))
+ ((stringp rec-val)
+ (string-match val rec-val)))
+ ;; there are matches, run through the field setters in last
+ ;; element of the sexp
+ (dolist (attribute style)
+ (setq element (pop attribute)
+ filep nil)
+ (setq value
+ (cond
+ ((eq (car attribute) :file)
+ (setq filep t)
+ (cadr attribute))
+ ((eq (car attribute) :value)
+ (cadr attribute))
+ (t
+ (car attribute))))
+ ;; We get the value.
+ (setq v
+ (cond
+ ((stringp value)
+ value)
+ ((or (symbolp value)
+ (functionp value))
+ (cond ((functionp value)
+ (funcall value))
+ ((boundp value)
+ (symbol-value value))))
+ ((listp value)
+ (eval value))))
+ ;; Post-processing for the signature posting-style:
+ (and (eq element 'signature) filep
+ message-signature-directory
+ ;; don't actually use the signature directory
+ ;; if message-signature-file contains a path.
+ (not (file-name-directory v))
+ (setq v (nnheader-concat message-signature-directory v)))
+ ;; Get the contents of file elems.
+ (when (and filep v)
+ (setq v (with-temp-buffer
+ (insert-file-contents v)
+ (buffer-substring
+ (point-min)
+ (progn
+ (goto-char (point-max))
+ (if (zerop (skip-chars-backward "\n"))
+ (point)
+ (1+ (point))))))))
+ (setq results (delq (assoc element results) results))
+ (push (cons element v) results))))
+ (setq name (assq 'name results)
+ address (assq 'address results))
+ (setq results (delq name (delq address results)))
+ (gnus-make-local-hook 'message-setup-hook)
+ (setq results (sort results (lambda (x y)
+ (string-lessp (car x) (car y)))))
+ (dolist (result results)
+ (add-hook 'message-setup-hook
+ (cond
+ ((eq 'eval (car result))
+ 'ignore)
+ ((eq 'body (car result))
+ `(lambda ()
+ (save-excursion
+ (message-goto-body)
+ (insert ,(cdr result)))))
+ ((eq 'signature (car result))
+ (set (make-local-variable 'message-signature) nil)
+ (set (make-local-variable 'message-signature-file) nil)
+ (if (not (cdr result))
+ 'ignore
+ `(lambda ()
+ (save-excursion
+ (let ((message-signature ,(cdr result)))
+ (when message-signature
+ (message-insert-signature)))))))
+ (t
+ (let ((header
+ (if (symbolp (car result))
+ (capitalize (symbol-name (car result)))
+ (car result))))
+ `(lambda ()
+ (save-excursion
+ (message-remove-header ,header)
+ (let ((value ,(cdr result)))
+ (when value
+ (message-goto-eoh)
+ (insert ,header ": " value)
+ (unless (bolp)
+ (insert "\n")))))))))
+ t 'local))
+ (when (or name address)
+ (add-hook 'message-setup-hook
+ `(lambda ()
+ (set (make-local-variable 'user-mail-address)
+ ,(or (cdr address) user-mail-address))
+ (let ((user-full-name ,(or (cdr name) (user-full-name)))
+ (user-mail-address
+ ,(or (cdr address) user-mail-address)))
+ (save-excursion
+ (message-remove-header "From")
+ (message-goto-eoh)
+ (insert "From: " (message-make-from) "\n"))))
+ t 'local)))))
+
+;;;###autoload
+(defun gnorb-bbdb-tag-agenda (records)
+ "Open an Org agenda tags view from the BBDB buffer, using the
+value of the record's org-tags field. This shows only TODOs by
+default; a prefix argument shows all tagged headings; a \"*\"
+prefix operates on all currently visible records. If you want
+both, use \"C-u\" before the \"*\"."
+ (interactive (list (bbdb-do-records)))
+ (require 'org-agenda)
+ (unless (and (eq major-mode 'bbdb-mode)
+ (equal (buffer-name) bbdb-buffer-name))
+ (error "Only works in the BBDB buffer"))
+ (setq records (bbdb-record-list records))
+ (let ((tag-string
+ (mapconcat
+ 'identity
+ (delete-dups
+ (mapcan (lambda (r)
+ (bbdb-record-xfield-split r gnorb-bbdb-org-tag-field))
+ records))
+ "|")))
+ (if tag-string
+ ;; C-u = all headings, not just todos
+ (if (equal current-prefix-arg '(4))
+ (org-tags-view nil tag-string)
+ (org-tags-view t tag-string))
+ (error "No org-tags field present"))))
+
+;;;###autoload
+(defun gnorb-bbdb-mail-search (records)
+ "Initiate a mail search from the BBDB buffer.
+
+Use the prefix arg to edit the search string first, and the \"*\"
+prefix to search mails from all visible contacts. When using both
+a prefix arg and \"*\", the prefix arg must come first."
+ (interactive (list (bbdb-do-records)))
+ (unless (and (eq major-mode 'bbdb-mode)
+ (equal (buffer-name) bbdb-buffer-name))
+ (error "Only works in the BBDB buffer"))
+ (setq records (bbdb-record-list records))
+ (require 'gnorb-gnus)
+ (let* ((backend (or (assoc gnorb-gnus-mail-search-backend
+ gnorb-gnus-mail-search-backends)
+ (error "No search backend specified")))
+ (search-string
+ (funcall (second backend)
+ (cl-mapcan 'bbdb-record-mail records))))
+ (when (equal current-prefix-arg '(4))
+ (setq search-string
+ (read-from-minibuffer
+ (format "%s search string: " (first backend)) search-string)))
+ (funcall (third backend) search-string)
+ (delete-other-windows)))
+
+;;;###autoload
+(defun gnorb-bbdb-cite-contact (rec)
+ (interactive (list (gnorb-prompt-for-bbdb-record)))
+ (let ((mail-string (bbdb-dwim-mail rec)))
+ (if (called-interactively-p 'any)
+ (insert mail-string)
+ mail-string)))
+
+;;; Field containing links to recent messages
+
+(add-to-list 'bbdb-xfield-label-list gnorb-bbdb-messages-field nil 'eq)
+
+(defun gnorb-bbdb-display-messages (record format)
+ "Show links to the messages collected in the
+`gnorb-bbdb-messages-field' field of a BBDB record. Each link
+will be formatted using the format string in
+`gnorb-bbdb-message-link-format-multi' or
+`gnorb-bbdb-message-link-format-one', depending on the current
+layout type."
+ (let ((full-field (assq gnorb-bbdb-messages-field
+ (bbdb-record-xfields record)))
+ (val (bbdb-record-xfield record gnorb-bbdb-messages-field))
+ (map (make-sparse-keymap))
+ (count 1)) ; one-indexed to fit with prefix arg to `gnorb-bbdb-open-link'
+ (define-key map [mouse-1] 'gnorb-bbdb-mouse-open-link)
+ (define-key map (kbd "<RET>") 'gnorb-bbdb-RET-open-link)
+ (when val
+ ;; indent and fmt are dynamically bound
+ (when (eq format 'multi)
+ (bbdb-display-text (format fmt gnorb-bbdb-messages-field)
+ `(xfields ,full-field field-label)
+ 'bbdb-field-name))
+ (insert (cond ((and (stringp val)
+ (eq format 'multi))
+ (bbdb-indent-string (concat val "\n") indent))
+ ((listp val)
+ (concat
+ (bbdb-indent-string
+ (mapconcat
+ (lambda (m)
+ (prog1
+ (org-propertize
+ (concat
+ (format-time-string
+ (replace-regexp-in-string
+ "%:subject" (gnorb-bbdb-link-subject m)
+ (replace-regexp-in-string
+ "%:count" (number-to-string count)
+ (if (eq format 'multi)
+ gnorb-bbdb-message-link-format-multi
+ gnorb-bbdb-message-link-format-one)))
+ (gnorb-bbdb-link-date m)))
+ 'face 'gnorb-bbdb-link
+ 'mouse-face 'highlight
+ 'gnorb-bbdb-link-count count
+ 'keymap map)
+ (incf count)))
+ val (if (eq format 'multi)
+ "\n" ", "))
+ indent)
+ (if (eq format 'multi) "\n" "")))
+ (t
+ ""))))))
+
+(fset (intern (format "bbdb-display-%s-multi-line"
+ gnorb-bbdb-messages-field))
+ (lambda (record)
+ (gnorb-bbdb-display-messages record 'multi)))
+
+(fset (intern (format "bbdb-display-%s-one-line"
+ gnorb-bbdb-messages-field))
+ (lambda (record)
+ (gnorb-bbdb-display-messages record 'one)))
+
+;; Don't allow direct editing of this field
+
+(fset (intern (format "bbdb-read-xfield-%s"
+ gnorb-bbdb-messages-field))
+ (lambda (&optional init)
+ (user-error "This field shouldn't be edited manually")))
+
+;; Open links from the *BBDB* buffer.
+
+;;;###autoload
+(defun gnorb-bbdb-open-link (record arg)
+ "\\<bbdb-mode-map>Call this on a BBDB record to open one of the
+links in the message field. By default, the first link will be
+opened. Use a prefix arg to open different links. For instance,
+M-3 \\[gnorb-bbdb-open-link] will open the third link in the
+list. If the %:count escape is present in the message formatting
+string (see `gnorb-bbdb-message-link-format-multi' and
+`gnorb-bbdb-message-link-format-one'), that's the number to use.
+
+This function also needs to be called on a contact once before
+that contact will start collecting links to messages."
+ (interactive (list
+ (or (bbdb-current-record)
+ (user-error "No record under point"))
+ current-prefix-arg))
+ (unless (fboundp 'bbdb-record-xfield-string)
+ (user-error "This function only works with the git version of BBDB"))
+ (let* ((record (bbdb-current-record))
+ msg-list target-msg)
+ (if (not (memq gnorb-bbdb-messages-field
+ (mapcar 'car (bbdb-record-xfields record))))
+ (when (y-or-n-p
+ (format "Start collecting message links for %s?"
+ (bbdb-record-name record)))
+ (bbdb-record-set-xfield record gnorb-bbdb-messages-field "no links yet")
+ (message "Opening messages from %s will add links to the %s field"
+ (bbdb-record-name record)
+ gnorb-bbdb-messages-field)
+ (bbdb-change-record record))
+ (setq msg-list
+ (bbdb-record-xfield record gnorb-bbdb-messages-field))
+ (setq target-msg
+ (or (and arg
+ (nth (1- arg) msg-list))
+ (car msg-list)))
+ (when target-msg
+ (org-gnus-follow-link (gnorb-bbdb-link-group target-msg)
+ (gnorb-bbdb-link-id target-msg))))))
+
+(defun gnorb-bbdb-mouse-open-link (event)
+ (interactive "e")
+ (mouse-set-point event)
+ (let ((rec (bbdb-current-record))
+ (num (get-text-property (point) 'gnorb-bbdb-link-count)))
+ (if (not num)
+ (user-error "No link under point")
+ (gnorb-bbdb-open-link rec num))))
+
+(defun gnorb-bbdb-RET-open-link ()
+ (interactive)
+ (let ((rec (bbdb-current-record))
+ (num (get-text-property (point) 'gnorb-bbdb-link-count)))
+ (if (not num)
+ (user-error "No link under point")
+ (gnorb-bbdb-open-link rec num))))
+
+(defun gnorb-bbdb-store-message-link (record)
+ "Used in the `bbdb-notice-record-hook' to possibly save a link
+to a message into the record's `gnorb-bbdb-messages-field'."
+
+ (when (not (fboundp 'bbdb-record-xfield-string))
+ (user-error "This function only works with the git version of BBDB"))
+ (unless (or (not (and (memq gnorb-bbdb-messages-field
+ (mapcar 'car (bbdb-record-xfields record)))
+ (memq major-mode '(gnus-summary-mode gnus-article-mode))))
+ (with-current-buffer gnus-article-buffer
+ (not ; only store messages if the record is the sender
+ (member (nth 1 (car (bbdb-get-address-components 'sender)))
+ (bbdb-record-mail record)))))
+ (with-current-buffer gnus-summary-buffer
+ (let* ((val (bbdb-record-xfield record gnorb-bbdb-messages-field))
+ (art-no (gnus-summary-article-number))
+ (heads (gnus-summary-article-header art-no))
+ (date (apply 'encode-time
+ (parse-time-string (mail-header-date heads))))
+ (subject (mail-header-subject heads))
+ (id (mail-header-id heads))
+ (group gnus-newsgroup-name)
+ link)
+ ;; check for both nnvirtual and nnir, and link to the real
+ ;; group in those cases
+ (when (eq (car (gnus-find-method-for-group group))
+ 'nnvirtual)
+ (setq group (car (nnvirtual-map-article art-no))))
+ (when (eq (car (gnus-find-method-for-group group))
+ 'nnir)
+ (setq group (nnir-article-group art-no)))
+ (if (not (and date subject id group))
+ (message "Could not save a link to this message")
+ (setq link (make-gnorb-bbdb-link :subject subject :date date
+ :group group :id id))
+ (when (stringp val)
+ (setq val nil))
+ (setq val (cons link (delete link val)))
+ (when (eq gnorb-bbdb-define-recent 'received)
+ (setq val (sort val
+ (lambda (a b)
+ (time-less-p
+ (gnorb-bbdb-link-date b)
+ (gnorb-bbdb-link-date a))))))
+ (setq val (subseq val 0 gnorb-bbdb-collect-N-messages))
+ (bbdb-record-set-xfield record
+ gnorb-bbdb-messages-field
+ (delq nil val))
+ (bbdb-change-record record))))))
+
+(add-hook 'bbdb-notice-record-hook 'gnorb-bbdb-store-message-link)
+
+(provide 'gnorb-bbdb)
+;;; gnorb-bbdb.el ends here