[bpt/emacs.git] / lisp / net / eudcb-bbdb.el

;;; eudcb-bbdb.el --- Emacs Unified Directory Client - BBDB Backend -*- coding: utf-8 -*-

;; Copyright (C) 1998-2014 Free Software Foundation, Inc.

;; Author: Oscar Figueiredo <oscar@cpe.fr>
;; Maintainer: Pavel Janík <Pavel@Janik.cz>
;; Keywords: comm
;; Package: eudc

;; This file is part of GNU Emacs.

;; GNU Emacs 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.

;; GNU Emacs 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 GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:
;;    This library provides an interface to use BBDB as a backend of
;;    the Emacs Unified Directory Client.

;;; Code:

(require 'eudc)

;; Make it loadable on systems without bbdb.
(require 'bbdb nil t)
(require 'bbdb-com nil t)

;;{{{      Internal cooking

;; I don't like this but mapcar does not accept a parameter to the function and
;; I don't want to use mapcar*
(defvar eudc-bbdb-current-query nil)
(defvar eudc-bbdb-current-return-attributes nil)

(defvar eudc-bbdb-attributes-translation-alist
  '((name . lastname)
    (email . net)
    (phone . phones))
  "Alist mapping EUDC attribute names to BBDB names.")

(eudc-protocol-set 'eudc-query-function 'eudc-bbdb-query-internal 'bbdb)
(eudc-protocol-set 'eudc-list-attributes-function nil 'bbdb)
(eudc-protocol-set 'eudc-protocol-attributes-translation-alist
		   'eudc-bbdb-attributes-translation-alist 'bbdb)
(eudc-protocol-set 'eudc-bbdb-conversion-alist nil 'bbdb)
(eudc-protocol-set 'eudc-protocol-has-default-query-attributes nil 'bbdb)

(defun eudc-bbdb-format-query (query)
  "Format a EUDC query alist into a list suitable to `bbdb-search'."
  (let* ((firstname (cdr (assq 'firstname query)))
	 (lastname (cdr (assq 'lastname query)))
	 (name (or (and firstname lastname
			(concat firstname " " lastname))
		   firstname
		   lastname))
	(company (cdr (assq 'company query)))
	(net (cdr (assq 'net query)))
	(notes (cdr (assq 'notes query)))
	(phone (cdr (assq 'phone query))))
    (list name company net notes phone)))


(defun eudc-bbdb-filter-non-matching-record (record)
  "Return RECORD if it matches `eudc-bbdb-current-query', nil otherwise."
  (require 'bbdb)
  (catch 'unmatch
    (progn
      (dolist (condition eudc-bbdb-current-query)
        (let ((attr (car condition))
              (val (cdr condition))
              (case-fold-search t)
              bbdb-val)
          (or (and (memq attr '(firstname lastname aka company phones
                                addresses net))
                   (progn
                     (setq bbdb-val
                           (eval (list (intern (concat "bbdb-record-"
                                                       (symbol-name attr)))
                                       'record)))
                     (if (listp bbdb-val)
                         (if eudc-bbdb-enable-substring-matches
                             (eval `(or ,@(mapcar (lambda (subval)
                                                    (string-match val subval))
                                                  bbdb-val)))
                           (member (downcase val)
                                   (mapcar 'downcase bbdb-val)))
                       (if eudc-bbdb-enable-substring-matches
                           (string-match val bbdb-val)
                         (string-equal (downcase val) (downcase bbdb-val))))))
              (throw 'unmatch nil))))
      record)))

;; External.
(declare-function bbdb-phone-location   "ext:bbdb" t) ; via bbdb-defstruct
(declare-function bbdb-phone-string     "ext:bbdb" (phone))
(declare-function bbdb-record-phones    "ext:bbdb" t) ; via bbdb-defstruct
(declare-function bbdb-address-streets  "ext:bbdb" t) ; via bbdb-defstruct
(declare-function bbdb-address-city     "ext:bbdb" t) ; via bbdb-defstruct
(declare-function bbdb-address-state    "ext:bbdb" t) ; via bbdb-defstruct
(declare-function bbdb-address-zip      "ext:bbdb" t) ; via bbdb-defstruct
(declare-function bbdb-address-location "ext:bbdb" t) ; via bbdb-defstruct
(declare-function bbdb-record-addresses "ext:bbdb" t) ; via bbdb-defstruct
(declare-function bbdb-records          "ext:bbdb"
                  (&optional dont-check-disk already-in-db-buffer))

(defun eudc-bbdb-extract-phones (record)
  (require 'bbdb)
  (mapcar (function
	   (lambda (phone)
	     (if eudc-bbdb-use-locations-as-attribute-names
		 (cons (intern (bbdb-phone-location phone))
		       (bbdb-phone-string phone))
	       (cons 'phones (format "%s: %s"
				     (bbdb-phone-location phone)
				     (bbdb-phone-string phone))))))
	  (bbdb-record-phones record)))

(defun eudc-bbdb-extract-addresses (record)
  (require 'bbdb)
  (let (s c val)
    (mapcar (lambda (address)
              (setq c (bbdb-address-streets address))
              (dotimes (n 3)
                (unless (zerop (length (setq s (nth n c))))
                  (setq val (concat val s "\n"))))
              (setq c (bbdb-address-city address)
                    s (bbdb-address-state address))
              (setq val (concat val
                                (if (and (> (length c) 0) (> (length s) 0))
                                    (concat c ", " s)
                                  c)
                                " "
                                (bbdb-address-zip address)))
              (if eudc-bbdb-use-locations-as-attribute-names
                  (cons (intern (bbdb-address-location address)) val)
                (cons 'addresses (concat (bbdb-address-location address)
                                         "\n" val))))
            (bbdb-record-addresses record))))

(defun eudc-bbdb-format-record-as-result (record)
  "Format the BBDB RECORD as a EUDC query result record.
The record is filtered according to `eudc-bbdb-current-return-attributes'"
  (require 'bbdb)
  (let ((attrs (or eudc-bbdb-current-return-attributes
		   '(firstname lastname aka company phones addresses net notes)))
	attr
	eudc-rec
	val)
    (while (prog1
	       (setq attr (car attrs))
	     (setq attrs (cdr attrs)))
      (cond
       ((eq attr 'phones)
	(setq val (eudc-bbdb-extract-phones record)))
       ((eq attr 'addresses)
	(setq val (eudc-bbdb-extract-addresses record)))
       ((memq attr '(firstname lastname aka company net notes))
	(setq val (eval
		   (list (intern
			  (concat "bbdb-record-"
				  (symbol-name attr)))
			 'record))))
       (t
	(error "Unknown BBDB attribute")))
      (cond
       ((or (not val) (equal val ""))) ; do nothing
       ((memq attr '(phones addresses))
	(setq eudc-rec (append val eudc-rec)))
       ((and (listp val)
	     (= 1 (length val)))
	(setq eudc-rec (cons (cons attr (car val)) eudc-rec)))
       ((> (length val) 0)
	(setq eudc-rec (cons (cons attr val) eudc-rec)))
       (t
	(error "Unexpected attribute value"))))
    (nreverse eudc-rec)))


(defun eudc-bbdb-query-internal (query &optional return-attrs)
  "Query BBDB  with QUERY.
QUERY is a list of cons cells (ATTR . VALUE) where ATTRs should be valid
BBDB attribute names.
RETURN-ATTRS is a list of attributes to return, defaulting to
`eudc-default-return-attributes'."
  (require 'bbdb)
  (let ((eudc-bbdb-current-query query)
	(eudc-bbdb-current-return-attributes return-attrs)
	(query-attrs (eudc-bbdb-format-query query))
	bbdb-attrs
	(records (bbdb-records))
	result
	filtered)
    ;; BBDB ORs its query attributes while EUDC ANDs them, hence we need to
    ;; call bbdb-search iteratively on the returned records for each of the
    ;; requested attributes
    (while (and records (> (length query-attrs) 0))
      (setq bbdb-attrs (append bbdb-attrs (list (car query-attrs))))
      (if (car query-attrs)
	  (setq records (eval `(bbdb-search ,(quote records) ,@bbdb-attrs))))
      (setq query-attrs (cdr query-attrs)))
    (mapc (function
	   (lambda (record)
	     (setq filtered (eudc-filter-duplicate-attributes record))
	     ;; If there were duplicate attributes reverse the order of the
	     ;; record so the unique attributes appear first
	     (if (> (length filtered) 1)
		 (setq filtered (mapcar (function
					 (lambda (rec)
					   (reverse rec)))
					filtered)))
	     (setq result (append result filtered))))
	  (delq nil
		(mapcar 'eudc-bbdb-format-record-as-result
			(delq nil
			      (mapcar 'eudc-bbdb-filter-non-matching-record
				      records)))))
    result))

;;}}}

;;{{{      High-level interfaces (interactive functions)

(defun eudc-bbdb-set-server (dummy)
  "Set the EUDC server to BBDB."
  (interactive)
  (eudc-set-server dummy 'bbdb)
  (message "BBDB server selected"))

;;}}}


(eudc-register-protocol 'bbdb)

(provide 'eudcb-bbdb)

;;; eudcb-bbdb.el ends here
Commit	Line	Data
c38e0c97	1	;;; eudcb-bbdb.el --- Emacs Unified Directory Client - BBDB Backend -- coding: utf-8 --
7970b229	2
ba318903	3	;; Copyright (C) 1998-2014 Free Software Foundation, Inc.
7970b229	4
89d0ce25	5	;; Author: Oscar Figueiredo <oscar@cpe.fr>
c38e0c97	6	;; Maintainer: Pavel Janík <Pavel@Janik.cz>
ab651127	7	;; Keywords: comm
bd78fa1d	8	;; Package: eudc
7970b229 GM	9
	10	;; This file is part of GNU Emacs.
	11
874a927a	12	;; GNU Emacs is free software: you can redistribute it and/or modify
7970b229	13	;; it under the terms of the GNU General Public License as published by
874a927a GM	14	;; the Free Software Foundation, either version 3 of the License, or
874a927a GM	15	;; (at your option) any later version.
7970b229 GM	16
	17	;; GNU Emacs is distributed in the hope that it will be useful,
	18	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	19	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	20	;; GNU General Public License for more details.
	21
	22	;; You should have received a copy of the GNU General Public License
874a927a	23	;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
7970b229 GM	24
7970b229 GM	25	;;; Commentary:
aed3fbc3	26	;; This library provides an interface to use BBDB as a backend of
7970b229 GM	27	;; the Emacs Unified Directory Client.
	28
	29	;;; Code:
	30
	31	(require 'eudc)
445f95e2 GM	32
	33	;; Make it loadable on systems without bbdb.
	34	(require 'bbdb nil t)
	35	(require 'bbdb-com nil t)
7970b229 GM	36
	37	;;{{{ Internal cooking
	38
	39	;; I don't like this but mapcar does not accept a parameter to the function and
	40	;; I don't want to use mapcar*
	41	(defvar eudc-bbdb-current-query nil)
	42	(defvar eudc-bbdb-current-return-attributes nil)
	43
	44	(defvar eudc-bbdb-attributes-translation-alist
	45	'((name . lastname)
	46	(email . net)
	47	(phone . phones))
	48	"Alist mapping EUDC attribute names to BBDB names.")
	49
	50	(eudc-protocol-set 'eudc-query-function 'eudc-bbdb-query-internal 'bbdb)
	51	(eudc-protocol-set 'eudc-list-attributes-function nil 'bbdb)
a1506d29	52	(eudc-protocol-set 'eudc-protocol-attributes-translation-alist
7970b229 GM	53	'eudc-bbdb-attributes-translation-alist 'bbdb)
	54	(eudc-protocol-set 'eudc-bbdb-conversion-alist nil 'bbdb)
	55	(eudc-protocol-set 'eudc-protocol-has-default-query-attributes nil 'bbdb)
	56
	57	(defun eudc-bbdb-format-query (query)
	58	"Format a EUDC query alist into a list suitable to `bbdb-search'."
	59	(let* ((firstname (cdr (assq 'firstname query)))
	60	(lastname (cdr (assq 'lastname query)))
	61	(name (or (and firstname lastname
	62	(concat firstname " " lastname))
	63	firstname
	64	lastname))
	65	(company (cdr (assq 'company query)))
	66	(net (cdr (assq 'net query)))
	67	(notes (cdr (assq 'notes query)))
	68	(phone (cdr (assq 'phone query))))
	69	(list name company net notes phone)))
a1506d29	70
7970b229 GM	71
	72	(defun eudc-bbdb-filter-non-matching-record (record)
	73	"Return RECORD if it matches `eudc-bbdb-current-query', nil otherwise."
445f95e2	74	(require 'bbdb)
7970b229 GM	75	(catch 'unmatch
7970b229 GM	76	(progn
4f91a816 SM	77	(dolist (condition eudc-bbdb-current-query)
	78	(let ((attr (car condition))
	79	(val (cdr condition))
	80	(case-fold-search t)
	81	bbdb-val)
	82	(or (and (memq attr '(firstname lastname aka company phones
	83	addresses net))
	84	(progn
	85	(setq bbdb-val
	86	(eval (list (intern (concat "bbdb-record-"
	87	(symbol-name attr)))
	88	'record)))
	89	(if (listp bbdb-val)
	90	(if eudc-bbdb-enable-substring-matches
	91	(eval `(or ,@(mapcar (lambda (subval)
	92	(string-match val subval))
	93	bbdb-val)))
	94	(member (downcase val)
	95	(mapcar 'downcase bbdb-val)))
	96	(if eudc-bbdb-enable-substring-matches
	97	(string-match val bbdb-val)
	98	(string-equal (downcase val) (downcase bbdb-val))))))
	99	(throw 'unmatch nil))))
7970b229 GM	100	record)))
7970b229 GM	101
15c0d42b	102	;; External.
8fff8988	103	(declare-function bbdb-phone-location "ext:bbdb" t) ; via bbdb-defstruct
15c0d42b	104	(declare-function bbdb-phone-string "ext:bbdb" (phone))
8fff8988	105	(declare-function bbdb-record-phones "ext:bbdb" t) ; via bbdb-defstruct
c52ae2bb	106	(declare-function bbdb-address-streets "ext:bbdb" t) ; via bbdb-defstruct
8fff8988 GM	107	(declare-function bbdb-address-city "ext:bbdb" t) ; via bbdb-defstruct
	108	(declare-function bbdb-address-state "ext:bbdb" t) ; via bbdb-defstruct
	109	(declare-function bbdb-address-zip "ext:bbdb" t) ; via bbdb-defstruct
	110	(declare-function bbdb-address-location "ext:bbdb" t) ; via bbdb-defstruct
	111	(declare-function bbdb-record-addresses "ext:bbdb" t) ; via bbdb-defstruct
15c0d42b GM	112	(declare-function bbdb-records "ext:bbdb"
	113	(&optional dont-check-disk already-in-db-buffer))
	114
7970b229	115	(defun eudc-bbdb-extract-phones (record)
445f95e2	116	(require 'bbdb)
7970b229 GM	117	(mapcar (function
	118	(lambda (phone)
	119	(if eudc-bbdb-use-locations-as-attribute-names
	120	(cons (intern (bbdb-phone-location phone))
	121	(bbdb-phone-string phone))
a1506d29	122	(cons 'phones (format "%s: %s"
7970b229 GM	123	(bbdb-phone-location phone)
	124	(bbdb-phone-string phone))))))
	125	(bbdb-record-phones record)))
	126
	127	(defun eudc-bbdb-extract-addresses (record)
445f95e2	128	(require 'bbdb)
7970b229	129	(let (s c val)
c52ae2bb GM	130	(mapcar (lambda (address)
	131	(setq c (bbdb-address-streets address))
	132	(dotimes (n 3)
	133	(unless (zerop (length (setq s (nth n c))))
	134	(setq val (concat val s "\n"))))
	135	(setq c (bbdb-address-city address)
	136	s (bbdb-address-state address))
	137	(setq val (concat val
	138	(if (and (> (length c) 0) (> (length s) 0))
	139	(concat c ", " s)
	140	c)
	141	" "
	142	(bbdb-address-zip address)))
	143	(if eudc-bbdb-use-locations-as-attribute-names
	144	(cons (intern (bbdb-address-location address)) val)
	145	(cons 'addresses (concat (bbdb-address-location address)
	146	"\n" val))))
	147	(bbdb-record-addresses record))))
7970b229 GM	148
	149	(defun eudc-bbdb-format-record-as-result (record)
	150	"Format the BBDB RECORD as a EUDC query result record.
	151	The record is filtered according to `eudc-bbdb-current-return-attributes'"
445f95e2	152	(require 'bbdb)
7970b229 GM	153	(let ((attrs (or eudc-bbdb-current-return-attributes
	154	'(firstname lastname aka company phones addresses net notes)))
	155	attr
	156	eudc-rec
	157	val)
a1506d29	158	(while (prog1
7970b229 GM	159	(setq attr (car attrs))
	160	(setq attrs (cdr attrs)))
	161	(cond
	162	((eq attr 'phones)
	163	(setq val (eudc-bbdb-extract-phones record)))
	164	((eq attr 'addresses)
	165	(setq val (eudc-bbdb-extract-addresses record)))
	166	((memq attr '(firstname lastname aka company net notes))
a1506d29 JB	167	(setq val (eval
	168	(list (intern
	169	(concat "bbdb-record-"
7970b229 GM	170	(symbol-name attr)))
	171	'record))))
	172	(t
c623f81a SDJ	173	(error "Unknown BBDB attribute")))
	174	(cond
	175	((or (not val) (equal val ""))) ; do nothing
	176	((memq attr '(phones addresses))
	177	(setq eudc-rec (append val eudc-rec)))
	178	((and (listp val)
	179	(= 1 (length val)))
	180	(setq eudc-rec (cons (cons attr (car val)) eudc-rec)))
	181	((> (length val) 0)
	182	(setq eudc-rec (cons (cons attr val) eudc-rec)))
	183	(t
	184	(error "Unexpected attribute value"))))
7970b229	185	(nreverse eudc-rec)))
a1506d29	186
7970b229 GM	187
	188
	189	(defun eudc-bbdb-query-internal (query &optional return-attrs)
	190	"Query BBDB with QUERY.
a1506d29 JB	191	QUERY is a list of cons cells (ATTR . VALUE) where ATTRs should be valid
	192	BBDB attribute names.
	193	RETURN-ATTRS is a list of attributes to return, defaulting to
7970b229	194	`eudc-default-return-attributes'."
445f95e2	195	(require 'bbdb)
7970b229 GM	196	(let ((eudc-bbdb-current-query query)
	197	(eudc-bbdb-current-return-attributes return-attrs)
	198	(query-attrs (eudc-bbdb-format-query query))
	199	bbdb-attrs
	200	(records (bbdb-records))
	201	result
	202	filtered)
	203	;; BBDB ORs its query attributes while EUDC ANDs them, hence we need to
	204	;; call bbdb-search iteratively on the returned records for each of the
	205	;; requested attributes
	206	(while (and records (> (length query-attrs) 0))
	207	(setq bbdb-attrs (append bbdb-attrs (list (car query-attrs))))
	208	(if (car query-attrs)
	209	(setq records (eval `(bbdb-search ,(quote records) ,@bbdb-attrs))))
	210	(setq query-attrs (cdr query-attrs)))
888ca6f5 GM	211	(mapc (function
	212	(lambda (record)
	213	(setq filtered (eudc-filter-duplicate-attributes record))
	214	;; If there were duplicate attributes reverse the order of the
	215	;; record so the unique attributes appear first
	216	(if (> (length filtered) 1)
	217	(setq filtered (mapcar (function
	218	(lambda (rec)
	219	(reverse rec)))
	220	filtered)))
	221	(setq result (append result filtered))))
	222	(delq nil
	223	(mapcar 'eudc-bbdb-format-record-as-result
	224	(delq nil
	225	(mapcar 'eudc-bbdb-filter-non-matching-record
	226	records)))))
7970b229 GM	227	result))
7970b229 GM	228
aed3fbc3	229	;;}}}
7970b229 GM	230
	231	;;{{{ High-level interfaces (interactive functions)
	232
	233	(defun eudc-bbdb-set-server (dummy)
	234	"Set the EUDC server to BBDB."
	235	(interactive)
	236	(eudc-set-server dummy 'bbdb)
	237	(message "BBDB server selected"))
	238
aed3fbc3	239	;;}}}
7970b229 GM	240
	241
	242	(eudc-register-protocol 'bbdb)
	243
	244	(provide 'eudcb-bbdb)
	245
	246	;;; eudcb-bbdb.el ends here