lisp/net/eudc-export.el

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