code.delx.au - gnu-emacs/blob - lisp/net/eudc-export.el

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