;;; gnorb-bbdb.el --- The BBDB-centric functions of gnorb
-;; Copyright (C) 2014 Eric Abrahamsen
+;; Copyright (C) 2014 Free Software Foundation, Inc.
;; Author: Eric Abrahamsen <eric@ericabrahamsen.net>
;; Keywords:
;;; Code:
+(require 'bbdb nil t)
(require 'gnorb-utils)
+(require 'cl-lib)
(defgroup gnorb-bbdb nil
"The BBDB bits of gnorb."
:group 'gnorb-bbdb
:type 'symbol)
-(unless (assoc gnorb-bbdb-org-tag-field bbdb-separator-alist)
- (push `(,gnorb-bbdb-org-tag-field ":" ":") bbdb-separator-alist))
+(when (boundp 'bbdb-separator-alist) ;Allow compilation if BBDB is absent!
+ (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
Defaults to org-link."
:group 'gnorb-bbdb)
-(defstruct gnorb-bbdb-link
+(cl-defstruct gnorb-bbdb-link
subject date group id)
(defcustom gnorb-bbdb-posting-styles nil
An example value might look like:"
:group 'gnorb-bbdb)
+(when (fboundp 'bbdb-record-xfield-string)
+ (fset (intern (format "bbdb-read-xfield-%s"
+ gnorb-bbdb-org-tag-field))
+ (lambda (&optional init)
+ (gnorb-bbdb-read-org-tags init)))
+
+ (fset (intern (format "bbdb-display-%s-multi-line"
+ gnorb-bbdb-org-tag-field))
+ (lambda (record)
+ (gnorb-bbdb-display-org-tags record))))
+
+(defun gnorb-bbdb-read-org-tags (&optional init)
+ "Read Org mode tags, with `completing-read-multiple'."
+ (if (string< "24.3" (substring emacs-version 0 4))
+ (let ((crm-separator
+ (concat "[ \t\n]*"
+ (cadr (assq gnorb-bbdb-org-tag-field
+ bbdb-separator-alist))
+ "[ \t\n]*"))
+ (crm-local-completion-map bbdb-crm-local-completion-map)
+ (table (cl-mapcar #'car
+ (org-global-tags-completion-table
+ (org-agenda-files))))
+ (init (if (consp init)
+ (bbdb-join init
+ (nth 2 (assq gnorb-bbdb-org-tag-field
+ bbdb-separator-alist)))
+ init)))
+ (completing-read-multiple
+ "Tags: " table
+ nil nil init))
+ (bbdb-split gnorb-bbdb-org-tag-field
+ (bbdb-read-string "Tags: " init))))
+
+(defun gnorb-bbdb-display-org-tags (record)
+ "Display the Org tags associated with the record.
+
+Org tags are stored in the `gnorb-bbdb-org-tags-field'."
+ (let ((full-field (assq gnorb-bbdb-org-tag-field
+ (bbdb-record-xfields record)))
+ (val (bbdb-record-xfield
+ record
+ gnorb-bbdb-org-tag-field)))
+ (when val
+ ;; We already know that `fmt' and `indent' are dynamically
+ ;; bound, shut up about it.
+ (with-no-warnings
+ (bbdb-display-text (format fmt gnorb-bbdb-org-tag-field)
+ `(xfields ,full-field field-label)
+ 'bbdb-field-name)
+ (if (consp val)
+ (bbdb-display-list val gnorb-bbdb-org-tag-field "\n")
+ (insert
+ (bbdb-indent-string (concat val "\n") indent)))))))
+
+(defvar message-mode-hook)
+
;;;###autoload
(defun gnorb-bbdb-mail (records &optional subject n verbose)
"\\<bbdb-mode-map>Acts just like `bbdb-mail', except runs
(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)))
+ (when (catch 'match
+ (cond
+ ((eq field 'address)
+ (dolist (a rec-val)
+ (unless (and label
+ (not (string-match label (car a))))
+ (when
+ (string-match-p
+ val
+ (bbdb-format-address-default a))
+ (throw 'match t)))))
+ ((eq field 'phone)
+ (dolist (p rec-val)
+ (unless (and label
+ (not (string-match label (car p))))
+ (when
+ (string-match-p val (bbdb-phone-string p))
+ (throw 'match t)))))
+ ((consp rec-val)
+ (dolist (f rec-val)
+ (when (string-match-p val f)
+ (throw 'match t))))
+ ((fboundp field)
+ (when (string-match-p (funcall field r))
+ (throw 'match t)))
+ ((stringp rec-val)
+ (when (string-match-p val rec-val)
+ (throw 'match t)))))
;; there are matches, run through the field setters in last
;; element of the sexp
(dolist (attribute style)
(mapconcat
'identity
(delete-dups
- (mapcan (lambda (r)
- (bbdb-record-xfield-split r gnorb-bbdb-org-tag-field))
- records))
+ (cl-mapcan
+ (lambda (r)
+ (bbdb-record-xfield-split r gnorb-bbdb-org-tag-field))
+ records))
"|")))
(if tag-string
;; C-u = all headings, not just todos
gnorb-gnus-mail-search-backends)
(error "No search backend specified")))
(search-string
- (funcall (second backend)
+ (funcall (cl-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)))
+ (funcall (cl-third backend) search-string)
+ (delete-other-windows)))
;;;###autoload
(defun gnorb-bbdb-cite-contact (rec)
mail-string)))
;;; Field containing links to recent messages
-
-(add-to-list 'bbdb-xfield-label-list gnorb-bbdb-messages-field nil 'eq)
+(when (boundp 'bbdb-xfield-label-list)
+ (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
(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))
+ (with-no-warnings ; For `fmt'
+ (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))
+ (with-no-warnings ; For `indent'
+ (bbdb-indent-string (concat val "\n") indent)))
((listp val)
+ ;; Why aren't I using `bbdb-display-list' with a
+ ;; preformatted list of messages?
(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)
+ (with-no-warnings ; For `indent' again
+ (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
""))))))
(parse-time-string (mail-header-date heads))))
(subject (mail-header-subject heads))
(id (mail-header-id heads))
- (group gnus-newsgroup-name)
+ (group (gnorb-get-real-group-name
+ gnus-newsgroup-name
+ art-no))
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
(time-less-p
(gnorb-bbdb-link-date b)
(gnorb-bbdb-link-date a))))))
- (setq val (subseq val 0 gnorb-bbdb-collect-N-messages))
+ (setq val (cl-subseq val 0 (min (length val) gnorb-bbdb-collect-N-messages)))
(bbdb-record-set-xfield record
gnorb-bbdb-messages-field
(delq nil val))