lisp/net/eudc-export.el

   1 ;;; eudc-export.el --- functions to export EUDC query results
   2
   3 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
   4 ;;   2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
   5
   6 ;; Author: Oscar Figueiredo <oscar@cpe.fr>
   7 ;; Maintainer: Pavel Janík <Pavel@Janik.cz>
   8 ;; Keywords: comm
   9 ;; Package: eudc
  10
  11 ;; This file is part of GNU Emacs.
  12
  13 ;; GNU Emacs is free software: you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation, either version 3 of the License, or
  16 ;; (at your option) any later version.
  17
  18 ;; GNU Emacs is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  25
  26 ;;; Commentary:
  27
  28 ;;; Usage:
  29 ;;    See the corresponding info file
  30
  31 ;;; Code:
  32
  33 (require 'eudc)
  34
  35 (if (not (featurep 'bbdb))
  36     (load-library "bbdb"))
  37 (if (not (featurep 'bbdb-com))
  38     (load-library "bbdb-com"))
  39
  40 (defun eudc-create-bbdb-record (record &optional silent)
  41   "Create a BBDB record using the RECORD alist.
  42 RECORD is an alist of (KEY . VALUE) where KEY is a directory attribute name
  43 symbol and VALUE is the corresponding value for the record.
  44 If SILENT is non-nil then the created BBDB record is not displayed."
  45   ;; This function runs in a special context where lisp symbols corresponding
  46   ;; to field names in record are bound to the corresponding values
  47   (eval
  48    `(let* (,@(mapcar '(lambda (c)
  49                         (list (car c) (if (listp (cdr c))
  50                                           (list 'quote (cdr c))
  51                                         (cdr c))))
  52                      record)
  53              bbdb-name
  54              bbdb-company
  55              bbdb-net
  56              bbdb-address
  57              bbdb-phones
  58              bbdb-notes
  59              spec
  60              bbdb-record
  61              value
  62              (conversion-alist (symbol-value eudc-bbdb-conversion-alist)))
  63
  64       ;; BBDB standard fields
  65       (setq bbdb-name (eudc-parse-spec (cdr (assq 'name conversion-alist)) record nil)
  66             bbdb-company (eudc-parse-spec (cdr (assq 'company conversion-alist)) record nil)
  67             bbdb-net (eudc-parse-spec (cdr (assq 'net conversion-alist)) record nil)
  68             bbdb-notes (eudc-parse-spec (cdr (assq 'notes conversion-alist)) record nil))
  69       (setq spec (cdr (assq 'address conversion-alist)))
  70       (setq bbdb-address (delq nil (eudc-parse-spec (if (listp (car spec))
  71                                                       spec
  72                                                     (list spec))
  73                                                   record t)))
  74       (setq spec (cdr (assq 'phone conversion-alist)))
  75       (setq bbdb-phones (delq nil (eudc-parse-spec (if (listp (car spec))
  76                                                      spec
  77                                                    (list spec))
  78                                                  record t)))
  79       ;; BBDB custom fields
  80       (setq bbdb-notes (append (list (and bbdb-notes (cons 'notes bbdb-notes)))
  81                                (mapcar (function
  82                                         (lambda (mapping)
  83                                           (if (and (not (memq (car mapping)
  84                                                               '(name company net address phone notes)))
  85                                                    (setq value (eudc-parse-spec (cdr mapping) record nil)))
  86                                               (cons (car mapping) value))))
  87                                        conversion-alist)))
  88       (setq bbdb-notes (delq nil bbdb-notes))
  89       (setq bbdb-record (bbdb-create-internal bbdb-name
  90                                               bbdb-company
  91                                               bbdb-net
  92                                               bbdb-address
  93                                               bbdb-phones
  94                                               bbdb-notes))
  95       (or silent
  96           (bbdb-display-records (list bbdb-record))))))
  97
  98 (defun eudc-parse-spec (spec record recurse)
  99   "Parse the conversion SPEC using RECORD.
 100 If RECURSE is non-nil then SPEC may be a list of atomic specs."
 101   (cond
 102    ((or (stringp spec)
 103         (symbolp spec)
 104         (and (listp spec)
 105              (symbolp (car spec))
 106              (fboundp (car spec))))
 107     (condition-case nil
 108         (eval spec)
 109       (void-variable nil)))
 110    ((and recurse
 111          (listp spec))
 112     (mapcar '(lambda (spec-elem)
 113                (eudc-parse-spec spec-elem record nil))
 114             spec))
 115    (t
 116     (error "Invalid specification for `%s' in `eudc-bbdb-conversion-alist'" spec))))
 117
 118 (defun eudc-bbdbify-address (addr location)
 119   "Parse ADDR into a vector compatible with BBDB.
 120 ADDR should be an address string of no more than four lines or a
 121 list of lines.
 122 The last two lines are searched for the zip code, city and state name.
 123 LOCATION is used as the address location for bbdb."
 124   (let* ((addr-components (if (listp addr)
 125                               (reverse addr)
 126                             (reverse (split-string addr "\n"))))
 127          (last1 (pop addr-components))
 128          (last2 (pop addr-components))
 129          zip city state)
 130     (setq addr-components (nreverse addr-components))
 131     ;; If not containing the zip code the last line is supposed to contain a
 132     ;; country name and the addres is supposed to be in european style
 133     (if (not (string-match "[0-9][0-9][0-9]" last1))
 134         (progn
 135           (setq state last1)
 136           (if (string-match "\\([0-9]+\\)[ \t]+\\(.*\\)" last2)
 137               (setq city (match-string 2 last2)
 138                     zip (string-to-number (match-string 1 last2)))
 139             (error "Cannot parse the address")))
 140       (cond
 141        ;; American style
 142        ((string-match "\\(\\w+\\)\\W*\\([A-Z][A-Z]\\)\\W*\\([0-9]+\\)" last1)
 143         (setq city (match-string 1 last1)
 144               state (match-string 2 last1)
 145               zip (string-to-number (match-string 3 last1))))
 146        ;; European style
 147        ((string-match "\\([0-9]+\\)[ \t]+\\(.*\\)" last1)
 148         (setq city (match-string 2 last1)
 149               zip (string-to-number (match-string 1 last1))))
 150        (t
 151         (error "Cannot parse the address"))))
 152     (vector location
 153             (or (nth 0 addr-components) "")
 154             (or (nth 1 addr-components) "")
 155             (or (nth 2 addr-components) "")
 156             (or city "")
 157             (or state "")
 158             zip)))
 159
 160 ;; External.
 161 (declare-function bbdb-parse-phone-number "ext:bbdb-com"
 162                   (string &optional number-type))
 163 (declare-function bbdb-string-trim "ext:bbdb" (string))
 164
 165 (defun eudc-bbdbify-phone (phone location)
 166   "Parse PHONE into a vector compatible with BBDB.
 167 PHONE is either a string supposedly containing a phone number or
 168 a list of such strings which are concatenated.
 169 LOCATION is used as the phone location for BBDB."
 170   (cond
 171    ((stringp phone)
 172     (let (phone-list)
 173       (condition-case err
 174           (setq phone-list (bbdb-parse-phone-number phone))
 175         (error
 176          (if (string= "phone number unparsable." (eudc-cadr err))
 177              (if (not (y-or-n-p (format "BBDB claims %S to be unparsable--insert anyway? " phone)))
 178                  (error "Phone number unparsable")
 179                (setq phone-list (list (bbdb-string-trim phone))))
 180            (signal (car err) (cdr err)))))
 181       (if (= 3 (length phone-list))
 182           (setq phone-list (append phone-list '(nil))))
 183       (apply 'vector location phone-list)))
 184    ((listp phone)
 185     (vector location (mapconcat 'identity phone ", ")))
 186    (t
 187     (error "Invalid phone specification"))))
 188
 189 (defun eudc-batch-export-records-to-bbdb ()
 190   "Insert all the records returned by a directory query into BBDB."
 191   (interactive)
 192   (goto-char (point-min))
 193   (let ((nbrec 0)
 194         record)
 195     (while (eudc-move-to-next-record)
 196       (and (overlays-at (point))
 197            (setq record (overlay-get (car (overlays-at (point))) 'eudc-record))
 198            (1+ nbrec)
 199            (eudc-create-bbdb-record record t)))
 200     (message "%d records imported into BBDB" nbrec)))
 201
 202 ;;;###autoload
 203 (defun eudc-insert-record-at-point-into-bbdb ()
 204   "Insert record at point into the BBDB database.
 205 This function can only be called from a directory query result buffer."
 206   (interactive)
 207   (let ((record (and (overlays-at (point))
 208                      (overlay-get (car (overlays-at (point))) 'eudc-record))))
 209     (if (null record)
 210         (error "Point is not over a record")
 211       (eudc-create-bbdb-record record))))
 212
 213 ;;;###autoload
 214 (defun eudc-try-bbdb-insert ()
 215   "Call `eudc-insert-record-at-point-into-bbdb' if on a record."
 216   (interactive)
 217   (and (or (featurep 'bbdb)
 218            (prog1 (locate-library "bbdb") (message "")))
 219        (overlays-at (point))
 220        (overlay-get (car (overlays-at (point))) 'eudc-record)
 221        (eudc-insert-record-at-point-into-bbdb)))
 222
 223 ;; arch-tag: 8cbda7dc-3163-47e6-921c-6ec5083df2d7
 224 ;;; eudc-export.el ends here