lisp/net/eudc-export.el

   1 ;;; eudc-export.el --- functions to export EUDC query results -*- coding: utf-8 -*-
   2
   3 ;; Copyright (C) 1998-2015 Free Software Foundation, Inc.
   4
   5 ;; Author: Oscar Figueiredo <oscar@cpe.fr>
   6 ;;         Pavel Janík <Pavel@Janik.cz>
   7 ;; Maintainer: Thomas Fitzsimmons <fitzsim@fitzsim.org>
   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 ;; NOERROR is so we can compile it.
  36 (require 'bbdb nil t)
  37 (require 'bbdb-com nil t)
  38
  39 (defun eudc-create-bbdb-record (record &optional silent)
  40   "Create a BBDB record using the RECORD alist.
  41 RECORD is an alist of (KEY . VALUE) where KEY is a directory attribute name
  42 symbol and VALUE is the corresponding value for the record.
  43 If SILENT is non-nil then the created BBDB record is not displayed."
  44   (require 'bbdb)
  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 address 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   (require 'bbdb)
 171   (cond
 172    ((stringp phone)
 173     (let (phone-list)
 174       (condition-case err
 175           (setq phone-list (bbdb-parse-phone-number phone))
 176         (error
 177          (if (string= "phone number unparsable." (cadr err))
 178              (if (not (y-or-n-p (format "BBDB claims %S to be unparsable--insert anyway? " phone)))
 179                  (error "Phone number unparsable")
 180                (setq phone-list (list (bbdb-string-trim phone))))
 181            (signal (car err) (cdr err)))))
 182       (if (= 3 (length phone-list))
 183           (setq phone-list (append phone-list '(nil))))
 184       (apply 'vector location phone-list)))
 185    ((listp phone)
 186     (vector location (mapconcat 'identity phone ", ")))
 187    (t
 188     (error "Invalid phone specification"))))
 189
 190 (defun eudc-batch-export-records-to-bbdb ()
 191   "Insert all the records returned by a directory query into BBDB."
 192   (interactive)
 193   (require 'bbdb)
 194   (goto-char (point-min))
 195   (let ((nbrec 0)
 196         record)
 197     (while (eudc-move-to-next-record)
 198       (and (overlays-at (point))
 199            (setq record (overlay-get (car (overlays-at (point))) 'eudc-record))
 200            (1+ nbrec)
 201            (eudc-create-bbdb-record record t)))
 202     (message "%d records imported into BBDB" nbrec)))
 203
 204 ;;;###autoload
 205 (defun eudc-insert-record-at-point-into-bbdb ()
 206   "Insert record at point into the BBDB database.
 207 This function can only be called from a directory query result buffer."
 208   (interactive)
 209   (require 'bbdb)
 210   (let ((record (and (overlays-at (point))
 211                      (overlay-get (car (overlays-at (point))) 'eudc-record))))
 212     (if (null record)
 213         (error "Point is not over a record")
 214       (eudc-create-bbdb-record record))))
 215
 216 ;;;###autoload
 217 (defun eudc-try-bbdb-insert ()
 218   "Call `eudc-insert-record-at-point-into-bbdb' if on a record."
 219   (interactive)
 220   (require 'bbdb)
 221   (and (overlays-at (point))
 222        (overlay-get (car (overlays-at (point))) 'eudc-record)
 223        (eudc-insert-record-at-point-into-bbdb)))
 224
 225 ;;; eudc-export.el ends here