mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2024-11-30 08:09:04 +00:00
221 lines
7.7 KiB
EmacsLisp
221 lines
7.7 KiB
EmacsLisp
;;; eudc-export.el --- functions to export EUDC query results
|
|
|
|
;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
|
|
;; 2005, 2006, 2007 Free Software Foundation, Inc.
|
|
|
|
;; Author: Oscar Figueiredo <oscar@cpe.fr>
|
|
;; Maintainer: Pavel Janík <Pavel@Janik.cz>
|
|
;; Keywords: comm
|
|
|
|
;; 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 2, 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; see the file COPYING. If not, write to the
|
|
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
|
;; Boston, MA 02110-1301, USA.
|
|
|
|
;;; Commentary:
|
|
|
|
;;; Usage:
|
|
;; See the corresponding info file
|
|
|
|
;;; Code:
|
|
|
|
(require 'eudc)
|
|
|
|
(if (not (featurep 'bbdb))
|
|
(load-library "bbdb"))
|
|
(if (not (featurep 'bbdb-com))
|
|
(load-library "bbdb-com"))
|
|
|
|
(defun eudc-create-bbdb-record (record &optional silent)
|
|
"Create a BBDB record using the RECORD alist.
|
|
RECORD is an alist of (KEY . VALUE) where KEY is a directory attribute name
|
|
symbol and VALUE is the corresponding value for the record.
|
|
If SILENT is non-nil then the created BBDB record is not displayed."
|
|
;; This function runs in a special context where lisp symbols corresponding
|
|
;; to field names in record are bound to the corresponding values
|
|
(eval
|
|
`(let* (,@(mapcar '(lambda (c)
|
|
(list (car c) (if (listp (cdr c))
|
|
(list 'quote (cdr c))
|
|
(cdr c))))
|
|
record)
|
|
bbdb-name
|
|
bbdb-company
|
|
bbdb-net
|
|
bbdb-address
|
|
bbdb-phones
|
|
bbdb-notes
|
|
spec
|
|
bbdb-record
|
|
value
|
|
(conversion-alist (symbol-value eudc-bbdb-conversion-alist)))
|
|
|
|
;; BBDB standard fields
|
|
(setq bbdb-name (eudc-parse-spec (cdr (assq 'name conversion-alist)) record nil)
|
|
bbdb-company (eudc-parse-spec (cdr (assq 'company conversion-alist)) record nil)
|
|
bbdb-net (eudc-parse-spec (cdr (assq 'net conversion-alist)) record nil)
|
|
bbdb-notes (eudc-parse-spec (cdr (assq 'notes conversion-alist)) record nil))
|
|
(setq spec (cdr (assq 'address conversion-alist)))
|
|
(setq bbdb-address (delq nil (eudc-parse-spec (if (listp (car spec))
|
|
spec
|
|
(list spec))
|
|
record t)))
|
|
(setq spec (cdr (assq 'phone conversion-alist)))
|
|
(setq bbdb-phones (delq nil (eudc-parse-spec (if (listp (car spec))
|
|
spec
|
|
(list spec))
|
|
record t)))
|
|
;; BBDB custom fields
|
|
(setq bbdb-notes (append (list (and bbdb-notes (cons 'notes bbdb-notes)))
|
|
(mapcar (function
|
|
(lambda (mapping)
|
|
(if (and (not (memq (car mapping)
|
|
'(name company net address phone notes)))
|
|
(setq value (eudc-parse-spec (cdr mapping) record nil)))
|
|
(cons (car mapping) value))))
|
|
conversion-alist)))
|
|
(setq bbdb-notes (delq nil bbdb-notes))
|
|
(setq bbdb-record (bbdb-create-internal bbdb-name
|
|
bbdb-company
|
|
bbdb-net
|
|
bbdb-address
|
|
bbdb-phones
|
|
bbdb-notes))
|
|
(or silent
|
|
(bbdb-display-records (list bbdb-record))))))
|
|
|
|
(defun eudc-parse-spec (spec record recurse)
|
|
"Parse the conversion SPEC using RECORD.
|
|
If RECURSE is non-nil then SPEC may be a list of atomic specs."
|
|
(cond
|
|
((or (stringp spec)
|
|
(symbolp spec)
|
|
(and (listp spec)
|
|
(symbolp (car spec))
|
|
(fboundp (car spec))))
|
|
(condition-case nil
|
|
(eval spec)
|
|
(void-variable nil)))
|
|
((and recurse
|
|
(listp spec))
|
|
(mapcar '(lambda (spec-elem)
|
|
(eudc-parse-spec spec-elem record nil))
|
|
spec))
|
|
(t
|
|
(error "Invalid specification for `%s' in `eudc-bbdb-conversion-alist'" spec))))
|
|
|
|
(defun eudc-bbdbify-address (addr location)
|
|
"Parse ADDR into a vector compatible with BBDB.
|
|
ADDR should be an address string of no more than four lines or a
|
|
list of lines.
|
|
The last two lines are searched for the zip code, city and state name.
|
|
LOCATION is used as the address location for bbdb."
|
|
(let* ((addr-components (if (listp addr)
|
|
(reverse addr)
|
|
(reverse (split-string addr "\n"))))
|
|
(last1 (pop addr-components))
|
|
(last2 (pop addr-components))
|
|
zip city state)
|
|
(setq addr-components (nreverse addr-components))
|
|
;; If not containing the zip code the last line is supposed to contain a
|
|
;; country name and the addres is supposed to be in european style
|
|
(if (not (string-match "[0-9][0-9][0-9]" last1))
|
|
(progn
|
|
(setq state last1)
|
|
(if (string-match "\\([0-9]+\\)[ \t]+\\(.*\\)" last2)
|
|
(setq city (match-string 2 last2)
|
|
zip (string-to-number (match-string 1 last2)))
|
|
(error "Cannot parse the address")))
|
|
(cond
|
|
;; American style
|
|
((string-match "\\(\\w+\\)\\W*\\([A-Z][A-Z]\\)\\W*\\([0-9]+\\)" last1)
|
|
(setq city (match-string 1 last1)
|
|
state (match-string 2 last1)
|
|
zip (string-to-number (match-string 3 last1))))
|
|
;; European style
|
|
((string-match "\\([0-9]+\\)[ \t]+\\(.*\\)" last1)
|
|
(setq city (match-string 2 last1)
|
|
zip (string-to-number (match-string 1 last1))))
|
|
(t
|
|
(error "Cannot parse the address"))))
|
|
(vector location
|
|
(or (nth 0 addr-components) "")
|
|
(or (nth 1 addr-components) "")
|
|
(or (nth 2 addr-components) "")
|
|
(or city "")
|
|
(or state "")
|
|
zip)))
|
|
|
|
(defun eudc-bbdbify-phone (phone location)
|
|
"Parse PHONE into a vector compatible with BBDB.
|
|
PHONE is either a string supposedly containing a phone number or
|
|
a list of such strings which are concatenated.
|
|
LOCATION is used as the phone location for BBDB."
|
|
(cond
|
|
((stringp phone)
|
|
(let (phone-list)
|
|
(condition-case err
|
|
(setq phone-list (bbdb-parse-phone-number phone))
|
|
(error
|
|
(if (string= "phone number unparsable." (eudc-cadr err))
|
|
(if (not (y-or-n-p (format "BBDB claims %S to be unparsable--insert anyway? " phone)))
|
|
(error "Phone number unparsable")
|
|
(setq phone-list (list (bbdb-string-trim phone))))
|
|
(signal (car err) (cdr err)))))
|
|
(if (= 3 (length phone-list))
|
|
(setq phone-list (append phone-list '(nil))))
|
|
(apply 'vector location phone-list)))
|
|
((listp phone)
|
|
(vector location (mapconcat 'identity phone ", ")))
|
|
(t
|
|
(error "Invalid phone specification"))))
|
|
|
|
(defun eudc-batch-export-records-to-bbdb ()
|
|
"Insert all the records returned by a directory query into BBDB."
|
|
(interactive)
|
|
(goto-char (point-min))
|
|
(let ((nbrec 0)
|
|
record)
|
|
(while (eudc-move-to-next-record)
|
|
(and (overlays-at (point))
|
|
(setq record (overlay-get (car (overlays-at (point))) 'eudc-record))
|
|
(1+ nbrec)
|
|
(eudc-create-bbdb-record record t)))
|
|
(message "%d records imported into BBDB" nbrec)))
|
|
|
|
;;;###autoload
|
|
(defun eudc-insert-record-at-point-into-bbdb ()
|
|
"Insert record at point into the BBDB database.
|
|
This function can only be called from a directory query result buffer."
|
|
(interactive)
|
|
(let ((record (and (overlays-at (point))
|
|
(overlay-get (car (overlays-at (point))) 'eudc-record))))
|
|
(if (null record)
|
|
(error "Point is not over a record")
|
|
(eudc-create-bbdb-record record))))
|
|
|
|
;;;###autoload
|
|
(defun eudc-try-bbdb-insert ()
|
|
"Call `eudc-insert-record-at-point-into-bbdb' if on a record."
|
|
(interactive)
|
|
(and (or (featurep 'bbdb)
|
|
(prog1 (locate-library "bbdb") (message "")))
|
|
(overlays-at (point))
|
|
(overlay-get (car (overlays-at (point))) 'eudc-record)
|
|
(eudc-insert-record-at-point-into-bbdb)))
|
|
|
|
;;; arch-tag: 8cbda7dc-3163-47e6-921c-6ec5083df2d7
|
|
;;; eudc-export.el ends here
|